lib/tobi_rules.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                       ;;
   3 ;;;                Centre for Speech Technology Research                  ;;
   4 ;;;                     University of Edinburgh, UK                       ;;
   5 ;;;                       Copyright (c) 1996,1997                         ;;
   6 ;;;                        All Rights Reserved.                           ;;
   7 ;;;                                                                       ;;
   8 ;;;  Permission is hereby granted, free of charge, to use and distribute  ;;
   9 ;;;  this software and its documentation without restriction, including   ;;
  10 ;;;  without limitation the rights to use, copy, modify, merge, publish,  ;;
  11 ;;;  distribute, sublicense, and/or sell copies of this work, and to      ;;
  12 ;;;  permit persons to whom this work is furnished to do so, subject to   ;;
  13 ;;;  the following conditions:                                            ;;
  14 ;;;   1. The code must retain the above copyright notice, this list of    ;;
  15 ;;;      conditions and the following disclaimer.                         ;;
  16 ;;;   2. Any modifications must be clearly marked as such.                ;;
  17 ;;;   3. Original authors' names are not deleted.                         ;;
  18 ;;;   4. The authors' names are not used to endorse or promote products   ;;
  19 ;;;      derived from this software without specific prior written        ;;
  20 ;;;      permission.                                                      ;;
  21 ;;;                                                                       ;;
  22 ;;;  THE UNIVERSITY OF EDINBURGH AND THE CONTRIBUTORS TO THIS WORK        ;;
  23 ;;;  DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING      ;;
  24 ;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT   ;;
  25 ;;;  SHALL THE UNIVERSITY OF EDINBURGH NOR THE CONTRIBUTORS BE LIABLE     ;;
  26 ;;;  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES    ;;
  27 ;;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN   ;;
  28 ;;;  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,          ;;
  29 ;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF       ;;
  30 ;;;  THIS SOFTWARE.                                                       ;;
  31 ;;;                                                                       ;;
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 ;;;                Authors: Robert A. J. Clark and Alan W Black
  34 ;;;                Modifications and Checking:
  35 ;;;                         Gregor Moehler (moehler@ims.uni-stuttgart.de)
  36 ;;;                         Matthew Stone (mdstone@cs.rutgers.edu)
  37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38 ;;;
  39 ;;; Generate F0 points from tobi labels using rules given in:
  40 ;;; Jilka, Moehler & Dogil (forthcomming in Speech Communications)
  41 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42 ;;;
  43 ;;;  *** Converted to new Relation architecture -- but not checked yet -- awb
  44 ;;;      -> crude (beta) checking: gm in Dec. 98
  45 ;;;
  46 ;;;      -> fixed TAKEOVER bug that used time value
  47 ;;;         as pitch target (!) - MDS 1/02
  48 ;;;      -> hacked around bunches of target overlap problems - MDS 1/02
  49 ;;;      -> added primitive pitch range controls
  50 ;;;
  51 ;;;  Known problems and bugs:
  52 ;;;      Can't currently use voicing intervals which cross syllable boundaries,
  53 ;;;      so pre/post-nuclear tones are currently places 0.2s before/after the
  54 ;;;      nuclear tone even if no voicing occurs. Failing this they default a
  55 ;;;      percentage of the voicing for that syllable.
  56 ;;;
  57 ;;;      Don't know about target points ahead of the current syllable.
  58 ;;;      (As you need to know what comes before them to calculate them)
  59 ;;;      So: post accent tones are placed 0.2 ahead if following syllable exists
  60 ;;;          ends before 0.2 from starred target and is not accented
  61 ;;;      The H-target of the H+!H* is 0.2 sec instead of 0.15 sec before
  62 ;;;      starred tone.
  63 ;;;
  64 ;;;      Multi-utterance input has not been tested.
  65 ;;;
  66 ;;;      !H- does not generate any targets
  67 ;;;
  68 ;;;      Unfortunaltely some other modules may decide to put pauses in the
  69 ;;;      middle of a phrase
  70 ;;;
  71 ;;;      valleys are not tested yet
  72 ;;;
  73 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74 ;;;
  75 ;;;  To use this in a voice
  76 ;;;     (require 'tobi_rules)
  77 ;;;  And in the voice call
  78 ;;;     (setup_tobi_f0_method)
  79 ;;;  Set the following for your speaker's F0 range
  80 ;;;  (Parameter.set 'Default_Topline 146)
  81 ;;;  (Parameter.set 'Default_Start_Baseline 61)
  82 ;;;  (Parameter.set 'Valley_Dip 75)
  83
  84 ;; level of debug printout
  85 (set! printdebug 0)
  86
  87 (define (setup_tobi_f0_method)
  88   "(setup_tobi_f0_method)
  89 Set up parameters for current voice to use the implementaion
  90 of ToBI labels to F0 targets by rule."
  91   (Parameter.set 'Int_Method Intonation_Tree)
  92   (Parameter.set 'Int_Target_Method Int_Targets_General)
  93   (set! int_accent_cart_tree no_int_cart_tree) ; NONE always
  94   (set! int_tone_cart_tree   no_int_cart_tree) ; NONE always
  95   (set! int_general_params
  96         (list
  97          (list 'targ_func tobi_f0_targets)))   ; we will return a list of f0 targets here
  98
  99   (Parameter.set 'Phrase_Method 'cart_tree)
 100   (set! phrase_cart_tree tobi_label_phrase_cart_tree) ; redefines the phrasebreak tree
 101   t)
 102
 103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 104 ;;;;;;
 105 ;;;;;; Define and set the new f0 rules
 106 ;;;;;;
 107 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 108
 109 ;;; Set global parameters
 110 ;;; You may want to reset these for different speakers
 111
 112 (Parameter.set 'Default_Topline 146) ;146
 113 (Parameter.set 'Default_Start_Baseline 61) ;61
 114 (Parameter.set 'Current_Topline        (Parameter.get 'Default_Topline))
 115 (Parameter.set 'Current_Start_Baseline (Parameter.get 'Default_Start_Baseline))
 116 (Parameter.set 'Current_End_Baseline   (Parameter.get 'Current_Start_Baseline))
 117 (Parameter.set 'Downstep_Factor 0.70)
 118 (Parameter.set 'Valley_Dip 75)
 119 ;;; function to add target points on a given syllable and fill in
 120 ;;; targets where necessary
 121
 122 (define (tobi_f0_targets utt syl)
 123   "(tobi_f0_targets UTT ITEM)
 124    Returns a list of targets for the given syllable."
 125   (if (and (>= printdebug  1)
 126            (not(equal? 0 (item.feat syl "R:Intonation.daughter1.name"))))
 127       (format t "### %l (%.2f %.2f) %l ptarg: %l ###\n" (item.name syl)
 128               (item.feat syl "syllable_start")(item.feat syl "syllable_end")
 129               (item.feat syl "R:Intonation.daughter1.name") (ttt_last_target_time syl)))
 130
 131   ;; only continue if there is a Word related to this syllable
 132   ;; I know there always should be, but there might be a bug elsewhere
 133   (cond
 134    ((not(equal? 0 (item.feat syl "R:SylStructure.parent.name")))
 135
 136     ; get current label. This assumes that there is only one accent and
 137     ; one endtone on a syllable. Although there can be one of each.
 138     (let ((voicing  (ttt_get_voice_times syl))                ; voicing interval
 139           (pvoicing (ttt_get_voice_times                      ; previous voicing
 140                      (item.relation.prev syl 'Syllable)))
 141           (nvoicing (ttt_get_voice_times                      ; next voicing
 142                      (item.relation.next syl 'Syllable))))
 143
 144     ; if first syl of phrase set Phrase_Start and Phrase_End parameters
 145     ; and reset downstep (currently does so on big and little breaks.)
 146     ; only assignes Default values at this stage
 147     ; maybe trained from CART later - first steps now - MDS
 148     ; following Moehler and Mayer, SSW 2001
 149     (if   (eq 0 (item.feat syl 'syl_in)) ;; GM maybe something better needed here?
 150         (progn
 151          (Parameter.set 'Phrase_Start (item.feat syl 'R:SylStructure.parent.R:Phrase.last.word_start))
 152          (Parameter.set 'Phrase_End (item.feat syl 'R:SylStructure.parent.R:Phrase.last.word_end))
 153          (Parameter.set 'Current_Topline
 154                         (/ (* (wagon syl ttt_topline_tree)
 155                               (Parameter.get 'Default_Topline)) 100))
 156          (Parameter.set 'Current_Start_Baseline
 157                         (/ (* (wagon syl ttt_baseline_tree)
 158                               (Parameter.get 'Default_Start_Baseline)) 100))
 159          (Parameter.set 'Current_End_Baseline
 160                         (Parameter.get 'Current_Start_Baseline))
 161          (if (>= printdebug  3)
 162              (begin
 163                (print (format nil "new range: %f %f %f"
 164                               (Parameter.get 'Current_Topline)
 165                               (Parameter.get 'Current_Start_Baseline)
 166                               (Parameter.get 'Current_End_Baseline) ))))  ))
 167
 168     ; do stuff (should go only if there is an accent/boundary?)
 169     (let ((new_targets
 170            (ttt_to_targets syl (wagon syl ttt_starttone_tree)
 171                            voicing
 172                            pvoicing
 173                            nvoicing
 174                            'Starttones)))
 175
 176     (set! new_targets (append new_targets
 177            (ttt_to_targets syl (wagon syl ttt_accent_tree)
 178                            voicing
 179                            pvoicing
 180                            nvoicing
 181                            'Accents)))
 182
 183     (set! new_targets (append new_targets
 184            (ttt_to_targets syl (wagon syl ttt_endtone_tree)
 185                            voicing
 186                            pvoicing
 187                            nvoicing
 188                            'Endtones)))
 189
 190     (if (and(not(equal? new_targets nil))
 191             (>= printdebug  2))
 192         (begin
 193           (format t ">> Targets: %l\n" new_targets)
 194           (format t ">> LastTarget: %l\n" (last new_targets))
 195           ))
 196
 197       new_targets)))))
 198
 199
 200 ;;; CART tree to specify no accents
 201
 202 (set! no_int_cart_tree
 203 '
 204 ((NONE)))
 205
 206 ;;;
 207 ;;; Relate phrasing to boundary tones.
 208 ;;;   Added downstepped tones - MDS
 209
 210 (set! tobi_label_phrase_cart_tree
 211 '
 212 ((tone in ("L-" "H-" "!H-"))
 213  ((B))
 214  ((tone in ("H-H%" "H-L%" "!H-L%" "L-L%" "L-H%"))
 215   ((BB))
 216   ((NB)))))
 217
 218 ;;;
 219 ;;;  The other functions
 220 ;;;
 221
 222 ;;; process a list of relative targets and convert to actual targets
 223
 224 (define (ttt_to_targets syl rlist voicing pvoicing nvoicing type)
 225   "Takes a list of target sets and returns a list of targets."
 226   (if (or (and (>= printdebug  2)
 227                rlist (atom (caar rlist))
 228                (not (equal? 'NONE (caar rlist))) (not (equal? '(NONE) (caar rlist))))
 229           (>= printdebug  3))
 230        (begin (print "Entering ttt_to_targets with:")
 231         (print (format nil "rlist: %l vc: %l pvc: %l nvc: %l type: %s" rlist voicing pvoicing nvoicing type))))
 232 (cond
 233  ;; nowt
 234  ((eq (length rlist) 0) ())
 235  ;; a single target set
 236  ((atom (car (car rlist)))
 237   (cond
 238    ((eq type 'Accents)
 239     (ttt_accent_set_to_targets syl rlist voicing pvoicing nvoicing))
 240    ((eq type 'Starttones)
 241     (ttt_bound_set_to_targets syl rlist voicing pvoicing))
 242    ((eq type 'Endtones)
 243     (ttt_bound_set_to_targets syl rlist voicing pvoicing))
 244    (t (error "unknown target set encountered in ttt_to_targets"))))
 245  ;; list of target sets
 246  ((atom (car (car (car rlist))))
 247   (append (ttt_to_targets syl (cdr rlist) voicing pvoicing nvoicing type)
 248           (ttt_to_targets syl (car rlist) voicing pvoicing nvoicing type)))
 249  ;; error
 250  (t (error "something strange has happened in ttt_to_targets"))))
 251
 252
 253 ;; process a starttone/endtone target set.
 254
 255 (define (ttt_bound_set_to_targets syl tset voicing pvoicing)
 256   "takes a start/endtone target set and returns a list of target points."
 257   (if (>= printdebug  3) (begin
 258       (print "Entering ttt_bound_set_to_targets with:")
 259       (pprintf (format nil "tset: %l vc: %l pvc: %l" tset voicing pvoicing))))
 260   (cond
 261    ;; usually target given is NONE. (also ignore unknown!)
 262    ((or (eq (car (car tset)) 'NONE)
 263         (eq (car (car tset)) 'UNKNOWN))
 264     nil)
 265    ;; a pair of target pairs
 266    ((eq (length tset) 2)
 267     (list (ttt_get_target (car tset) voicing)
 268           (ttt_get_target (car (cdr tset)) voicing)))
 269    ;; single target pair
 270    ((eq (length tset) 1)
 271     (cond
 272      ;; an actual target pair
 273      ((not (null (cdr (car tset))))
 274       (list (ttt_get_target (car tset) voicing)))
 275      ;; a TAKEOVER marker
 276      ((eq (car (car tset)) 'TAKEOVER)
 277       (list (list (ttt_interval_percent voicing 0)
 278                   (ttt_last_target_value syl))))
 279      (t (error "unknown target pair in ttt_bound_set_to_targets"))))
 280    (t (error "unknown target set type in ttt_bound_set_to_targets"))))
 281
 282
 283 ;; process an accent target set.
 284
 285 (define (ttt_accent_set_to_targets syl tset voicing pvoicing nvoicing)
 286   "takes a accent target set and returns a list of target points."
 287   (if (>= printdebug  3) (begin
 288       (print "Entering ttt_accent_set_to_targets with:")
 289       (pprintf (format nil "tset: %l vc: %l pvc: %l nvc: %l" tset voicing pvoicing nvoicing))))
 290   (cond
 291    ;; single target in set
 292    ((null (cdr tset))
 293     (cond
 294      ; target given is NONE.
 295      ((or (eq (car (car tset)) 'NONE)
 296           (eq (car (car tset)) 'UNKNOWN)) nil)
 297      ; V1 marker
 298      ((eq (car (car tset)) 'V1)
 299       (let ((target_time (+ (/ (- (next_accent_start syl)
 300                                   (ttt_last_target_time syl))
 301                                2.0)
 302                             (ttt_last_target_time syl))))
 303         (list (list target_time (ttt_accent_pitch (Parameter.get 'Valley_Dip) target_time)))))
 304      ; V2 marker
 305      ((eq (car (car tset)) 'V2)
 306       (let ((target_time (+ (ttt_last_target_time syl) 0.25)))
 307         (list (list target_time (ttt_accent_pitch (Parameter.get 'Valley_Dip) target_time)))))
 308      ; V3 marker
 309      ((eq (car (car tset)) 'V3)
 310       (let ((target_time (- (next_accent_start syl) 0.25)))
 311         (list (list target_time (ttt_accent_pitch (Parameter.get 'Valley_Dip) target_time)))))
 312      ; single target pair
 313      (t (list (ttt_get_target (car tset) voicing)))))
 314    ;; a pair of targets
 315    ((length tset 2)
 316     (cond
 317      ;; a *ed tone with PRE type tone (as in L+H*)
 318      ((eq (car (car tset)) 'PRE)
 319       (let ((star_target (ttt_get_target (car (cdr tset)) voicing))
 320             (last_target (parse-number(ttt_last_target_time syl))))
 321         (cond
 322          ; normal 0.2s case (currently doesn't check for voicing)
 323          ((and (eqv? 0 (ip_initial syl))
 324                (> (- (car star_target) 0.2) last_target))
 325           (list  (list (- (car star_target) 0.2)
 326                        (ttt_accent_pitch (car (cdr (car tset)))
 327                                          (- (car star_target) 0.2))) ; the time
 328                  star_target))
 329
 330          ; 90% prev voiced if not before last target - Added back in MDS,
 331          ; with parse-number added and new check for ip_initial
 332          ((and (eqv? 0 (ip_initial syl))
 333                (> (parse-number (ttt_interval_percent pvoicing 90))
 334                   (parse-number (ttt_last_target_time syl))))
 335           (list (list (ttt_interval_percent pvoicing 90)
 336                       (ttt_accent_pitch (car (cdr (car tset)))
 337                                         (ttt_interval_percent pvoicing 90)))
 338                 star_target))
 339
 340          ;  otherwise (UNTESTED) [NOTE: Voicing for this syllable only]
 341          (t
 342           (list (list (ttt_interval_percent voicing 20)
 343                         (ttt_accent_pitch (car (cdr (car tset)))
 344                                           (ttt_interval_percent voicing 20)))
 345                   star_target)))))
 346      ; a *ed tone with POST type tone (as L*+H)
 347      ((eq (car(car(cdr tset))) 'POST)
 348       (let ((star_target (ttt_get_target (car tset) voicing))
 349             (next_target nil ) ; interesting problem
 350             (next_syl (item.next syl)))
 351
 352         (cond
 353          ; normal 0.2s case (UNTESTED)
 354          ((and (not (equal? next_syl nil))
 355                (eq 0 (item.feat next_syl "accented")))
 356           (cond
 357            ((< (+ (car star_target) 0.2) (item.feat next_syl "syllable_end"))
 358             (list star_target
 359                   (list (+ (car star_target) 0.2)
 360                         (ttt_accent_pitch (car (cdr (car (cdr tset))))
 361                                           (+ (car star_target) 0.2) ))))
 362            (t
 363
 364             (list star_target
 365                     (list (ttt_interval_percent nvoicing 90)
 366                           (ttt_accent_pitch (car (cdr (car (cdr tset))))
 367                                             (ttt_interval_percent nvoicing 90) ))))))
 368
 369          ; 20% next voiced (BUG: Can't do this as the next target hasn't been
 370          ;                                                     calculated yet!)
 371          (nil nil)
 372          ;otherwise (UNTESTED)
 373          (t (list star_target
 374                   (list (ttt_interval_percent voicing 90)
 375                         (ttt_accent_pitch (car (cdr (car (cdr tset))))
 376                                           (ttt_interval_percent voicing 90) )))))))
 377
 378      (t
 379       ;; This case didn't use to happen, but now must
 380       ;; to avoid +H's clobbering endtones - MDS's hack.
 381       (list (ttt_get_target (car tset) voicing)
 382             (ttt_get_target (cadr tset) voicing)))))
 383
 384
 385    ;; something else...
 386    (t (error (format nil "unknown accent set in ttt_accent_set_to_targets: %l" tset)))))
 387
 388
 389
 390 (define (ttt_get_target pair voicing)
 391   "Returns actual target pair, usually for a stared tone."
 392   (if (>= printdebug  4) (begin
 393       (print "Entering ttt_get_target with:")
 394       (pprintf pair) (pprintf voicing)))
 395   (list (ttt_interval_percent voicing (car pair))
 396         (ttt_accent_pitch (car (cdr pair))
 397                           (ttt_interval_percent voicing (car pair)))))
 398
 399 (define (ttt_accent_pitch value time)
 400   "Converts a accent pitch entry to a pitch value."
 401   (if (>= printdebug  4) (begin
 402       (print "Entering ttt_accent_pitch with:")
 403       (pprintf value)))
 404   (cond
 405    ;; a real value
 406    ((number? value)
 407     (ttt_interval_percent (list (ttt_get_current_baseline time)
 408                                 (Parameter.get 'Current_Topline))
 409                           value))
 410    ;; Downstep then Topline
 411    ((eq value 'DHIGH)
 412     (progn
 413      (Parameter.set 'Current_Topline (+ (ttt_get_current_baseline time)
 414                                         (* (Parameter.get 'Downstep_Factor)
 415                                            (- (Parameter.get 'Current_Topline)
 416                                               (ttt_get_current_baseline time)))))
 417      (ttt_interval_percent (list (ttt_get_current_baseline time)
 418                                  (Parameter.get 'Current_Topline))
 419                            100)))
 420
 421    ;; Unknown
 422    (t  (error "Unknown accent pitch value encountered"))))
 423
 424
 425 (define (ttt_get_current_baseline v)
 426   "Returns the current declined baseline at time v."
 427   (if (>= printdebug  4) (begin
 428       (print "Entering  ttt_get_current_baseline with:")
 429       (pprintf v)))
 430   (let ((h (Parameter.get 'Current_Start_Baseline))
 431         (l (Parameter.get 'Current_End_Baseline))
 432         (e (Parameter.get 'Phrase_End))
 433         (s (Parameter.get 'Phrase_Start)))
 434     (- h (* (/ (- h l) (- e s)) (- v s)))))
 435
 436 ;;; find the time n% through an inteval
 437
 438 (define (ttt_interval_percent pair percent)
 439   "Returns the time that is percent percent thought the pair."
 440   (if (>= printdebug  4) (begin
 441       (print "Entering ttt_interval_percent with:")
 442       (pprintf (format nil "%l, %l" pair percent))))
 443   (cond
 444    ; no pair given: just return nil
 445    ((null pair) nil)
 446    ; otherwise do the calculation
 447    (t (let ((start (car pair))
 448             (end (car(cdr pair))))
 449         (+ start (* (- end start) (/ percent 100)))))))
 450
 451
 452 ;;;  Getting start and end voicing times in a syllable
 453
 454 (define (ttt_get_voice_times syl_item)
 455   "Returns a pair of start time of first voiced phone in syllable and
 456 end of last voiced phone in syllable, or nil if syllable is nil"
 457   (cond
 458    ((null syl_item) nil)
 459    (t (let ((segs (item.relation.daughters syl_item "SylStructure")))
 460         (list
 461          (item.feat (ttt_first_voiced segs) "segment_start")
 462          (item.feat (ttt_first_voiced (reverse segs)) "end"))))))
 463
 464 (define (ttt_first_voiced segs)
 465   "Returns first segment that is voiced (vowel or voiced consonant)
 466 returns last segment if all are unvoiced."
 467   (cond
 468    ((null (cdr segs))
 469     (car segs))  ;; last possibility
 470    ((equal? "+" (item.feat (car segs) "ph_vc"))
 471     (car segs))
 472    ((equal? "+" (item.feat (car segs) "ph_cvox"))
 473     (car segs))
 474    (t
 475     (ttt_first_voiced (cdr segs)))))
 476
 477 ;;; ttt_last_target has bifurcated into
 478 ;;;   ttt_last_target_time and
 479 ;;;   ttt_last_target_value
 480 ;;; to fix a place where f0 was set to last target time!
 481 ;;;   - MDS
 482
 483 (define (ttt_last_target_time syl)
 484   "Returns the end of the most recent previous target
 485 in the utterance or nil if there is not one present
 486 "
 487   (if (>= printdebug  3)
 488       (begin (print "Entering  ttt_last_target_time")
 489              (print syl))
 490       )
 491   (let ((target (ttt_last_target syl)))
 492     (if (null? target)
 493         nil
 494         (item.feat target "R:Target.daughter1.pos"))))
 495
 496 (define (ttt_last_target_value syl)
 497   "Returns the pitch of the most recent previous target
 498 in the utterance or nil if there is not one present
 499 "
 500   (if (>= printdebug  3)
 501       (begin (print "Entering  ttt_last_target_time")
 502              (print syl))
 503       )
 504   (let ((target (ttt_last_target syl)))
 505     (if (null? target)
 506         nil
 507         (item.feat target "R:Target.daughter1.f0"))))
 508
 509 ;; Changed to scan through segments in the segment relation,
 510 ;; to catch (notional) targets on pauses.  - MDS
 511 ;;
 512 ;;; associated segments are:
 513 ;;; - the segments in the word
 514 ;;; - subsequent segments not in the syllable structure
 515 ;;; and on the first word, preceding segments
 516 ;;; not in the syllable structure
 517
 518 (define (ttt_collect_following seg accum)
 519   (if (or (null? seg)
 520           (not (null? (item.relation seg 'SylStructure))))
 521       accum
 522       (ttt_collect_following (item.next seg)
 523                              (cons seg accum))))
 524
 525
 526 (define (ttt_last_target syl)
 527   "Returns the most recent previous target
 528 in the utterance or nil if there is not one present
 529 "
 530 (if (>= printdebug  3)
 531     (begin (print "Entering  ttt_last_target")
 532     (print syl))
 533     )
 534   (let ((prev_syl (item.relation.prev syl 'Syllable)))
 535     (cond
 536 ;     ((symbol-bound? 'new_targets) (last (caar new_targets)))
 537      ((null prev_syl) nil)
 538      ((ttt_last_target_segs
 539        (ttt_collect_following
 540         (item.relation.next
 541          (item.relation.daughtern prev_syl "SylStructure")
 542          "Segment")
 543         (reverse (item.relation.daughters prev_syl "SylStructure")))))
 544                                         ;list of segments of prev. syllable
 545                                         ;in reverse order, with pauses
 546                                         ;prepended.
 547      (t (ttt_last_target prev_syl)))))
 548
 549 (define (ttt_last_target_segs segs)
 550   "Returns the first target no earlier than seg
 551 or nil if there is not one
 552 "
 553 (if (>= printdebug  4)
 554     (begin (print "Entering  ttt_last_target_segs with:")
 555            (pprintf (format nil "%l" segs))
 556 ))
 557   (cond
 558    ((null segs) nil)
 559    ((and  (> (parse-number
 560               (item.feat  (car segs) "R:Target.daughter1.f0")) 0)
 561           (eq 0 (item.feat (car segs) "R:SylStructure.parent.lisp_lh_condition"))
 562           (eq 0 (item.feat (car segs) "R:SylStructure.parent.lisp_hl_condition"))
 563           (eq 0 (item.feat (car segs) "R:SylStructure.parent.lisp_valley_condition")))
 564     (car segs))
 565
 566    (t (ttt_last_target_segs (cdr segs)))))
 567
 568 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 569 ;;;;;;
 570 ;;;;;; CART TREES                           (ttt - tobi to target)
 571 ;;;;;;
 572 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 573
 574 ;;;
 575 ;;; Return a list of target lists. A target list comprises of a list
 576 ;;; of related targets (ie for the L and H in L+H*), just to confuse
 577 ;;; matters each target is also a list! (pos pitch)
 578 ;;;
 579
 580
 581 (set! ttt_endtone_tree  ; BUG: does it check the current syl for last accent?
 582       '
 583       ((tobi_endtone is NONE)        ; ususally none
 584        ((((NONE))))
 585        ((tobi_endtone is "H-H%")     ; H-H%
 586         ((((100 120))))
 587         ((tobi_endtone is "L-L%")    ; L-L%
 588          ((((100 -20))))
 589          ((tobi_endtone is "L-H%")   ; L-H%
 590           ((lisp_last_accent > 2)
 591            ((lisp_last_accent_type is "L*")
 592             ((((0 25) (100 40))))    ; paper says 80 but AWB had 40
 593             ((((0 0) (100 40)))))
 594            ((lisp_last_accent_type is "L*")
 595             ((((100 40))))
 596             ((((50 0) (100 40))))))
 597           ((tobi_endtone is "H-L%")  ; H-L%
 598            ((lisp_last_accent_type is "L*")
 599             ((tobi_accent is"L*")
 600              ((((50 100) (100 100))))
 601              ((((0 100) (100 100)))))
 602             ((((100 100)))))
 603           ((tobi_endtone is "!H-L%")  ; !H-L%
 604            ((lisp_last_accent_type is "L*")
 605             ((tobi_accent is"L*")
 606              ((((50 DHIGH) (100 100))))
 607              ((((0 DHIGH) (100 100)))))
 608             ((((100 DHIGH)))))
 609            ((tobi_endtone is "H-")
 610             ((((100 100))))
 611             ((tobi_endtone is "!H-")
 612              ((((100 DHIGH))))
 613              ((tobi_endtone is "L-")
 614               ((((100 0))))
 615               ((((UNKNOWN))))))))))))))
 616
 617 (set! ttt_starttone_tree
 618       '
 619       ((lisp_ip_initial = 1)
 620        ((tobi_endtone is "%H")
 621         ((((0 100))))
 622         ((p.tobi_endtone in ("H-" "!H-" "L-"))
 623          ((((TAKEOVER))))       ; takeover case
 624          ((tobi_accent is NONE)
 625           ((lisp_next_accent > 2) ; default cases  (dep. on whether next target is low)
 626            ((lisp_next_accent_type in ("L*" "L*+H" "L*+!H" "L+H*" "L+!H*" "L-" "L-H%" "L-L%"))
 627             ((((0 50)(100 25))))
 628             ((((0 50)(100 75)))))
 629            ((lisp_next_accent_type in ("L*" "L*+H" "L*+!H" "L+H*" "L+!H*" "L-" "L-H%" "L-L%"))
 630             ((((0 30))))
 631             ((((0 70))))))
 632           ((tobi_accent in ("L*" "L*+H" "L*+!H" "L+H*" "L+!H*" "L-" "L-H%" "L-L%"))
 633             ((((0 30))))
 634             ((((0 70))))))))
 635        ((((NONE))))))     ; otherwise (and usually) nothing.
 636
 637 ;; Redone after Jilka, Moehler and Dogil
 638 ;; - But treating one-syllable-ip's like
 639 ;; last-syllable-of-ip's in cases of
 640 ;; two tone switches per syllable (e.g. H* L-H%).
 641 ;; - And (hack) a 70% target for the initial
 642 ;; H*'s of phrases when the next accent is L+H*
 643 ;; - MDS
 644
 645 (set! ttt_accent_tree
 646       '
 647       ((tobi_accent is "H*" )    ; H*
 648        ((lisp_ip_final = 1)
 649         ((lisp_ip_one_syllable_case = 1)
 650          ((((50 100))))
 651          ((((25 100)))))
 652         ((lisp_hstar_weak_target = 1)
 653          ((((60 70))))
 654          ((lisp_ip_initial = 1)
 655           ((((85 100))))
 656           ((((60 100)))))))
 657
 658       ((tobi_accent is "!H*" )    ; !H*
 659        ((lisp_ip_final = 1)
 660         ((lisp_ip_one_syllable_case = 1)
 661          ((((50 DHIGH))))
 662          ((((25 DHIGH)))))
 663        ((lisp_ip_initial = 1)
 664         ((((85 DHIGH))))
 665         ((((60 DHIGH))))))
 666
 667         ((tobi_accent is "L*" )    ; L*
 668          ((lisp_ip_final = 1)
 669           ((lisp_ip_one_syllable_case = 1)
 670            ((((50 0))))
 671            ((((25 0)))))
 672           ((lisp_ip_initial = 1)
 673            ((((85 0))))
 674            ((((60 0))))))
 675
 676         ((tobi_accent is "L+H*")   ; L+H*
 677          ((lisp_ip_final = 1)
 678           ((lisp_ip_one_syllable_case = 1)
 679            ((((PRE 20) (50 100))))  ; JMD estimated 70
 680            ((((PRE 20) (25 100)))))
 681           ((lisp_ip_initial = 1)
 682            ((((PRE 20) (90 100))))
 683            ((((PRE 20) (75 100))))))
 684
 685          ((tobi_accent is "L+!H*")   ; L+!H*
 686          ((lisp_ip_final = 1)
 687           ((lisp_ip_one_syllable_case = 1)
 688            ((((PRE 20) (70 DHIGH))))
 689            ((((PRE 20) (25 DHIGH)))))
 690           ((lisp_ip_initial = 1)
 691            ((((PRE 20) (90 DHIGH))))
 692            ((((PRE 20) (75 DHIGH))))))
 693
 694           ((tobi_accent is "L*+H")   ; L*+H
 695            ((lisp_ip_final = 1)
 696             ((lisp_ip_one_syllable_case = 1)
 697              ((((35 0) (80 100))))     ; POST would clobber endtones
 698              ((((15 0) (40 100)))))    ; POST would clobber endtones - MDS
 699             ((lisp_ip_initial = 1)
 700              ((((55 0) (POST 100))))
 701              ((((40 0) (POST 100))))))
 702
 703           ((tobi_accent is "L*+!H")   ; L*+!H
 704            ((lisp_ip_final = 1)
 705             ((lisp_ip_one_syllable_case = 1)
 706              ((((35 0) (80 DHIGH))))    ; POST would clobber endtones - MDS
 707              ((((15 0) (40 DHIGH)))))   ; POST would clobber endtones - MDS
 708             ((lisp_ip_initial = 1)
 709              ((((55 0) (POST DHIGH))))
 710              ((((40 0) (POST DHIGH))))))
 711
 712            ((tobi_accent is "H+!H*")    ; H+!H*
 713             ((lisp_ip_final = 1)
 714              ((lisp_ip_one_syllable_case = 1)
 715               ((((PRE 143) (60 DHIGH)))) ; the 143 is a hack to level out the downstep
 716               ((((PRE 143) (20 DHIGH)))))
 717              ((lisp_ip_initial = 1)
 718               ((((PRE 143) (90 DHIGH))))
 719               ((((PRE 143) (60 DHIGH))))))
 720
 721             ((lisp_lh_condition = 1)
 722              ((((100 75))))
 723              ((lisp_lh_condition = 2)
 724               ((((0 90))))
 725               ((lisp_hl_condition = 1)
 726                ((((100 25))))
 727                ((lisp_valley_condition = 1)
 728                 ((((V1 85))))
 729                 ((lisp_valley_condition = 2)
 730                  ((((V2 70))))
 731                  ((lisp_valley_condition = 3)
 732                   ((((V3 70))))
 733                   ((tobi_accent is NONE)   ; usually we find no accent
 734                    ((((NONE))))
 735                    ((((UNKNOWN))))))))))))))))))))     ; UNKNOWN TARGET FOUND
 736
 737 ;;; Cart tree to "predict" pitch range
 738 ;;; Right now just accesses a feature
 739 ;;; "register" following Moehler & Mayer 2001.
 740 ;;; Register must be one of
 741 ;;;   H    - primary high register (default): 133% lowest, 92% highest
 742 ;;;   H-H  - expanded high register: 134% lowest, 100% highest
 743 ;;;   H-L  - lowered high register: 128% lowest, 87% highest
 744 ;;;   L    - primary low register: 100% lowest, 73% highest
 745 ;;;   L-L  and HL-L - low compressed: 100% lowest, 66% highest
 746 ;;;   HL   - expanded register:   100% lowest, 84% highest
 747 ;;;   HL-H - complete register:   100% lowest, 96% highest
 748 ;;; For their speaker, ,BASELINE was 42% of PEAK
 749
 750 (set! ttt_topline_tree
 751       '
 752       ((R:SylStructure.parent.register is "H")
 753        (92)
 754        ((R:SylStructure.parent.register is "H-H")
 755         (100)
 756         ((R:SylStructure.parent.register is "H-L")
 757          (87)
 758          ((R:SylStructure.parent.register is "L")
 759           (73)
 760           ((R:SylStructure.parent.register is "L-L")
 761            (66)
 762            ((R:SylStructure.parent.register is "HL")
 763             (84)
 764             ((R:SylStructure.parent.register is "HL-H")
 765              (96)
 766              (92)))))))))
 767
 768 (set! ttt_baseline_tree
 769       '
 770       ((R:SylStructure.parent.register is "H")
 771        (133)
 772        ((R:SylStructure.parent.register is "H-H")
 773         (134)
 774         ((R:SylStructure.parent.register is "H-L")
 775          (128)
 776          ((R:SylStructure.parent.register is "L")
 777           (100)
 778           ((R:SylStructure.parent.register is "L-L")
 779            (100)
 780            ((R:SylStructure.parent.register is "HL")
 781             (100)
 782             ((R:SylStructure.parent.register is "HL-H")
 783              (100)
 784              (133)))))))))
 785
 786 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 787 ;;;;;;
 788 ;;;;;;   Lisp Feature functions.
 789 ;;;;;;
 790 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 791
 792 (define (valley_condition syl)
 793 "(valley_condition syl)
 794 Function to determine if a lowered target between two high target points
 795 is needed in this syllable.
 796 Returns:  0 - no target required
 797           1 - the single target case
 798           2 - the first of the two target case
 799           3 - the second of the two target case
 800 "
 801 (if (>= printdebug  4)
 802     (begin (print "Entering valley_condition")))
 803 (cond
 804  ((and (eq 0 (item.feat syl 'accented))
 805        (string-matches (next_accent_type syl)
 806                        "\\(H\\*\\|H\\-\\|H\\-L\\%\\|H\\-H\\%\\|\\!H\\*\\|\\!H\\-\\|\\!H\\-L\\%\\|\\!H\\-H\\%\\)")
 807        (string-matches (last_accent_type syl)
 808                        "\\(H\\*\\|L\\+H\\*\\|L\\*\\+H\\\\|\\!H\\*\\|L\\+\\!H\\*\\|L\\*\\+\\!H\\)"))
 809                        ;GM: excluded %H (returns nil for last target)
 810   (let ((nas (next_accent_start syl))
 811         (syls (item.feat syl 'syllable_start))
 812         (syle (item.feat syl 'syllable_end))
 813         (las (ttt_last_target_time syl)))
 814     (if (>= printdebug  3)
 815         (begin (print (format nil "nas: %l syls: %l syle %l las %l" nas syls syle las))))
 816     (cond
 817      ((and (< (- nas las) 0.5)
 818            (> (- nas las) 0.25)
 819            (< syls (+ (/ (- nas las) 2.0) (ttt_last_target_time syl)))
 820            (> syle (+ (/ (- nas las) 2.0) (ttt_last_target_time syl)))) 1)
 821      ((and (> (- nas las) 0.5)
 822            (< syls (+ (ttt_last_target_time syl) 0.25))
 823            (> syle (+ (ttt_last_target_time syl) 0.25))) 2)
 824      ((and (> (- nas las) 0.5)
 825            (< syls (- nas 0.25))
 826            (> syle (- nas 0.25))) 3)
 827      (t 0))))
 828  (t 0)))
 829
 830
 831
 832 (define (lh_condition syl)
 833 "(lh_condition syl)
 834 Function to determine the need for extra target points between an L and an H
 835 Returns: 1 - first extra target required
 836          2 - second extra target required
 837          0 - no target required.
 838 "
 839 (if (>= printdebug  4)
 840     (begin (print "Entering LH_condition")))
 841 (cond
 842  ((and (eq 0 (item.feat syl 'accented))
 843        (string-matches (last_accent_type syl) "\\(L\\*\\)")
 844        (string-matches (next_accent_type syl)
 845                        "\\(H\\*\\|H\\-\\|H\\-L\\%\\|H\\-H\\%\\)"))
 846   (cond
 847    ((and (eq 1 (last_accent syl))
 848          (< 2 (next_accent syl))) 1)
 849    ((and (< 2 (last_accent syl))
 850          (eq 1 (next_accent syl))) 2)
 851    (t 0)))
 852  (t 0)))
 853
 854 (define (hl_condition syl)
 855 "(lh_condition syl)
 856 Function to determine the need for extra target points between an H and an L
 857 Returns: 1 - extra target required
 858          0 - no target required.
 859 "
 860 (if (>= printdebug  4)
 861     (begin (print "Entering HL_condition")))
 862 (cond
 863  ((and (eq 0 (item.feat syl 'accented))
 864        (string-matches (next_accent_type syl)
 865            "\\(L\\*\\|L\\+H\\*\\|L\\+\\!H\\*\\|L\\*\\+H\\|L\\*\\+!H\\|L\\-\\|L\\-L\\%\\|L-H\\%\\)")
 866        (string-matches (last_accent_type syl)
 867                        "\\(H\\*\\|L\\+H\\*\\|L\\*\\+H\\\\|\\!H\\*\\|L\\+\\!H\\*\\|L\\*\\+\\!H\\|\\%H\\)")
 868                        ;MDS: added !H's
 869        (eq 1 (last_accent syl))
 870
 871        ;; fall faster! -MDS
 872        (<= 2 (next_accent syl))) 1)
 873  (t 0)))
 874
 875 (define (next_accent syl)
 876 "(next_accent syl)
 877 Wrapper for c++ func ff_next_accent.
 878 Returns the number of the syllables to the next accent in the following format.
 879 0 - no next accent
 880 1 - next syllable
 881 2 - next next syllable
 882 etc..."
 883 (if (>= printdebug  4)
 884     (begin (print "Entering next_accent")))
 885 (cond
 886  ((eq 0 (next_accent_type syl)) 0)
 887  (t (+ (item.feat syl 'next_accent) 1))))
 888
 889 ;; Fixed bug that crashed complex phrase tones. - MDS
 890 ;; Not sure how else to get a big number...
 891 (define infinity (/ 1 0))
 892
 893 ;; Modified to include current accent as well -MDS
 894
 895 (define (last_accent syl)
 896 "(last_accent syl)
 897 Wrapper for c++ func ff_last_accent.
 898 Returns the number of the syllables to the previous accent in the following format.
 899 0 - accent on current syllable
 900 1 - prev syllable
 901 2 - prev to prev syllable
 902 etc...
 903 infinity - no previous syllable"
 904 (if (>= printdebug  4)
 905     (begin (print "Entering last_accent")))
 906 (cond
 907  ((not (equal? "NONE" (item.feat syl 'tobi_accent))) 0)
 908  ((equal? 0 (last_accent_type syl)) infinity)
 909  (t (+  (item.feat syl 'last_accent) 1))))
 910
 911 (define (next_accent_type syl)
 912 "(next_accent_type syl)
 913 Returns the type of the next accent."
 914 (cond
 915  ((not (eq 0 (item.feat syl "n.R:Intonation.daughter1.name")))
 916   (item.feat syl "n.R:Intonation.daughter1.name"))
 917  ((eq 0 (item.feat syl 'syl_out)) 0)  ;;GM real ip_final would be better
 918  (t (next_accent_type (item.relation.next syl 'Syllable)))))
 919
 920 (define (last_accent_type syl)
 921 "(last_accent_type syl)
 922 Returns the type of the last (previous)  accent."
 923 (if (>= printdebug  4)
 924     (begin (print "Entering last_accent_type")))
 925 (cond
 926   ((not (equal? "NONE"  (item.feat syl 'p.tobi_endtone)))
 927    (item.feat syl 'R:Syllable.p.tobi_endtone))
 928   ((not (equal? "NONE"  (item.feat syl 'p.tobi_accent)))
 929    (item.feat syl 'R:Syllable.p.tobi_accent))
 930   ((eq 0 (item.feat syl 'syl_in)) 0)  ;;GM real ip_initial would be better
 931   (t (last_accent_type (item.prev syl 'Syllable)))))
 932
 933 (define (next_accent_start syl)
 934 "(next_accent_start syl)
 935 Returns the start time  of the vowel of next accented syllable"
 936 (if (>= printdebug 4)
 937     (begin (print "Entering next_accent_start")))
 938 (cond
 939  ((not (eq 0 (item.feat syl "n.R:Intonation.daughter1.name")))
 940   (item.feat syl "R:Syllable.n.syllable_start")) ;;GM vowel start would be better
 941  ((eq 0 (item.feat syl 'syl_out)) 0)
 942  (t (next_accent_start (item.relation.next syl 'Syllable)))))
 943
 944 ; new features (not used yet)
 945
 946 (define (ip_final syl)
 947   "(ip_final SYL)
 948   returns 1 if the syllable is the final syllable of an
 949   ip (intermediate phrase)"
 950   (cond
 951    ((or (equal? 0 (item.feat syl "syl_out"))
 952        (equal? "L-" (item.feat syl "tobi_endtone"))
 953        (equal? "H-" (item.feat syl "tobi_endtone"))
 954        (equal? "!H-" (item.feat syl "tobi_endtone"))) 1)
 955    (t 0)))
 956
 957 (define (ip_initial syl)
 958   "(ip_initial SYL)
 959   returns 1 if the syllable is the initial syllable of an
 960   ip (intermediate phrase)"
 961   (cond
 962    ((equal? 0 (item.feat syl "syl_in"))
 963     1)
 964    ((equal? 1 (ip_final (item.relation.prev syl 'Syllable)))
 965     1)
 966    (t 0)))
 967
 968 ;; NEXT TWO FUNCTIONS ARE NEW - MDS
 969 (define (ip_one_syllable_case syl)
 970   "(ip_one_syllable_case SYL)
 971   returns true if the syllable is the initial syllable of an
 972   ip (intermediate phrase) and doesn't itself contain a complex
 973   tone that starts opposite this syllable's accent"
 974   (if (eqv? 0 (ip_initial syl))
 975       0
 976       (let ((accent (item.feat syl "tobi_accent"))
 977             (tone (item.feat syl "tobi_endtone")))
 978         (cond
 979           ((and (equal? tone "L-H%")
 980                 (or (equal? accent "H*")
 981                     (equal? accent "!H*")
 982                     (equal? accent "L+H*")
 983                     (equal? accent "L+!H*")
 984                     (equal? accent "L*+H")
 985                     (equal? accent "L*+!H*")
 986                     (equal? accent "H+!H*")))
 987            0)
 988           ((and (or (equal? tone "H-L%")
 989                     (equal? tone "!H-L%"))
 990                 (equal? accent "L*"))
 991            0)
 992           (t
 993            1)))))
 994
 995 (define (hstar_weak_target syl)
 996   (if (and (equal? 0 (item.feat syl 'asyl_in))
 997            (member (next_accent_type syl)
 998                    (list "L*" "L*+H" "L*+!H" "L+H*" "L+!H*")))
 999       1
1000       0))
1001
1002 (provide 'tobi_rules)