home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: Multimed / Multimed.zip / fest-141.zip / festival / lib / tokenpos.scm < prev    next >
Lisp/Scheme  |  1999-05-30  |  10KB  |  263 lines
  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. ;;;
  34. ;;;  Functions used in identifying token types.
  35. ;;;
  36.  
  37. (defvar token_most_common
  38. '(
  39. sym numeric month to day in the of on and writes a years from
  40. for jst at million by is was gmt page he that than more since as when
  41. with but after about or his i has it date no died number bst who miles
  42. university some people an only w year have ago were are pages up days
  43. months hours minutes through out had which least hi last now ft this
  44. all one its there between cents until over will before past they
  45. nearly times tim message so lbs just if age we during she billion then
  46. other be time new her first states not you members under would many
  47. says degrees two next fax week while bush been around including back
  48. campaign american within publisher flight points even early later
  49. world countries every edt can president most could their what them
  50. former began women killed another also received long americans pounds
  51. do dear said km made into did dead war tel still old x took total men
  52. like f am less c well late down weeks end chapter among place house
  53. away him election death almost students state soviet where version
  54. summer man s nation because washington top though m id est these spent
  55. seats gnu estimated those lost ian high each copies children acres
  56. tons son per my found won off seconds power nations federal born
  57. presidential much city begin p name different whose three home hello)
  58.  
  59. "token_most_common
  60. A list of (English) words which were found to be most common in 
  61. an text database and are used as discriminators in token analysis.")
  62.  
  63. (define (token_pos_guess sc)
  64. "(tok_pos sc)
  65. Returns a general pos for sc's name. 
  66.   numeric   All digits
  67.   number    float or comma'd numeric
  68.   sym       Contains at least one non alphanumeric
  69.   month     has month name (or abbrev)
  70.   day       has day name (or abbrev)
  71.   rootname  else downcased alphabetic.
  72. Note this can be used to find token_pos but isn't used directly as
  73. its not disciminatory enough."
  74.   (let ((name (downcase (item.name sc))))
  75.     (cond
  76.      ((string-matches name "[0-9]+")
  77.       'numeric)
  78.      ((or (string-matches name "[0-9]+\\.[0-9]+")
  79.       (string-matches name 
  80.          "[0-9][0-9]?[0-9]?,\\([0-9][0-9][0-9],\\)*[0-9][0-9][0-9]"))
  81.       'number)
  82.      ((string-matches name ".*[^A-Za-z0-9].*")
  83.       'sym)
  84.      ((member_string name '(jan january feb february mar march 
  85.                    apr april may jun june
  86.                 jul july aug august sep sept september
  87.                 oct october nov november dec december))
  88.       'month)
  89.      ((member_string name '(sun sunday mon monday tue tues tuesday 
  90.                 wed wednesday thu thurs thursday 
  91.                 fri friday sat saturday))
  92.       'day)
  93.      ((member_string name token_most_common)
  94.       name)
  95.      (t
  96.       '_other_))))
  97.  
  98. (define (token_no_starting_quote token)
  99.   "(token_no_starting_quote TOKEN)
  100. Check to see if a single quote (or backquote) appears as prepunctuation
  101. in this token or any previous one in this utterance.  This is used to
  102. disambiguate ending single quote as possessive or end quote."
  103.   (cond
  104.    ((null token)
  105.     t)
  106.    ((string-matches (item.feat token "prepunctuation") "[`']")
  107.     nil)
  108.    (t
  109.     (token_no_starting_quote (item.relation.prev token "Token")))))
  110.  
  111. (define (token_zerostart sc)
  112. "(zerostart sc)
  113. Returns, 1 if first char of sc's name is 0, 0 otherwise."
  114.   (if (string-matches (item.name sc) "^0.*")
  115.       "1"
  116.       "0"))
  117.  
  118. (define (tok_roman_to_numstring roman)
  119.   "(tok_roman_to_numstring ROMAN)
  120. Takes a string of roman numerals and converts it to a number and
  121. then returns the printed string of that.  Only deals with numbers up to 50."
  122.   (let ((val 0) (chars (symbolexplode roman)))
  123.     (while chars
  124.      (cond
  125.       ((equal? (car chars) 'X)
  126.        (set! val (+ 10 val)))
  127.       ((equal? (car chars) 'V)
  128.        (set! val (+ 5 val)))
  129.       ((equal? (car chars) 'I)
  130.        (cond
  131.     ((equal? (car (cdr chars)) 'V)
  132.      (set! val (+ 4 val))
  133.      (set! chars (cdr chars)))
  134.     ((equal? (car (cdr chars)) 'X)
  135.      (set! val (+ 9 val))
  136.      (set! chars (cdr chars)))
  137.     (t
  138.      (set! val (+ 1 val))))))
  139.      (set! chars (cdr chars)))
  140.     (format nil "%d" val)))
  141.  
  142. (define (num_digits sc)
  143. "(num_digits SC)
  144. Returns number of digits (actually chars) is SC's name."
  145.   (string-length (format nil "%s" (item.name sc))))
  146.  
  147. (define (month_range sc)
  148. "(month_range SC)
  149. 1 if SC's name is > 0 and < 32, 0 otherwise."
  150.   (let ((val (parse-number (item.name sc))))
  151.     (if (and (> val 0) (< val 32))
  152.     "1"
  153.     "0")))
  154.  
  155. (define (remove_leading_zeros name)
  156.   "(remove_leading_zeros name)
  157. Remove leading zeros from given string."
  158.   (let ((nname name))
  159.     (while (string-matches nname "^0..*")
  160.        (set! nname (string-after nname "0")))
  161.     nname))
  162.  
  163. (define (token_money_expand type)
  164. "(token_money_expand type)
  165. Convert shortened form of money identifier to words if of a known type."
  166.   (cond
  167.    ((string-equal type "HK")
  168.     (list "Hong" "Kong"))
  169.    ((string-equal type "C")
  170.     (list "Canadian"))
  171.    ((string-equal type "A")
  172.     (list "Australian"))
  173.    ((< (length type) 4)
  174.     (mapcar
  175.      (lambda (letter)
  176.        (list (list 'name letter)
  177.          (list 'pos token.letter_pos)))
  178.      (symbolexplode type)))
  179.    (t
  180.     (list type))))
  181.  
  182. (define (find_month_from_number token string-number)
  183.   "(find_month_from_number token string-number)
  184. Find the textual representation of the month from the given string number"
  185.   (let ((nnum (parse-number string-number)))
  186.     (cond
  187.      ((equal? 1 nnum) (list "January"))
  188.      ((equal? 2 nnum) (list "February"))
  189.      ((equal? 3 nnum) (list "March"))
  190.      ((equal? 4 nnum) (list "April"))
  191.      ((equal? 5 nnum) (list "May"))
  192.      ((equal? 6 nnum) (list "June"))
  193.      ((equal? 7 nnum) (list "July"))
  194.      ((equal? 8 nnum) (list "August"))
  195.      ((equal? 9 nnum) (list "September"))
  196.      ((equal? 10 nnum) (list "October"))
  197.      ((equal? 11 nnum) (list "November"))
  198.      ((equal? 12 nnum) (list "December"))
  199.      (t
  200.       (cons "month"
  201.         (builtin_english_token_to_words token string-number))))))
  202.       
  203. (define (tok_allcaps sc)
  204.   "(tok_allcaps sc)
  205. Returns 1 if sc's name is all capitals, 0 otherwise"
  206.   (if (string-matches (item.name sc) "[A-Z]+")
  207.       "1"
  208.       "0"))
  209.  
  210. (define (tok_section_name sc)
  211.   "(tok_section_name sc)
  212. Returns 1 if sc's name is in list of things that are section/chapter
  213. like."
  214.   (if (member_string
  215.        (downcase (item.name sc))
  216.        '(chapter section part article phrase verse scene act book 
  217.          volume chap sect art vol war fortran saturn
  218.          trek))
  219.       "1"
  220.       "0"))
  221.  
  222. (define (tok_string_as_letters name)
  223.   "(tok_string_as_letters NAME)
  224. Return list of letters marked as letter part of speech made
  225. by exploding NAME."
  226.   (mapcar
  227.    (lambda (letter)
  228.      (list (list 'name letter)
  229.        (list 'pos token.letter_pos)))
  230.    (symbolexplode name)))
  231.  
  232. (define (tok_rex sc)
  233.   "(tok_rex sc)
  234. Returns 1 if King like title is within 3 tokens before or 2 after."
  235.   (let ((kings '(king queen pope duke tsar emperor shah ceasar
  236.               duchess tsarina empress baron baroness
  237.               count countess)))
  238.     (if (or (member_string 
  239.          (downcase (item.feat sc "R:Token.pp.name"))
  240.          kings)
  241.         (member_string 
  242.          (downcase (item.feat sc "R:Token.pp.p.name"))
  243.          kings)
  244.         (member_string 
  245.          (downcase (item.feat sc "R:Token.n.name"))
  246.          kings))
  247.     "1"
  248.     "0")))
  249.  
  250. (define (tok_rex_names sc)
  251.   "(tok_rex sc)
  252. Returns 1 if this is a King-like name."
  253.   (if (member_string
  254.        (downcase (item.name sc))
  255.        '(louis henry charles philip george edward pius william richard
  256.            ptolemy john paul peter nicholas
  257.            alexander frederick james alfonso ivan napolean leo 
  258.            gregory catherine alexandria pierre elizabeth mary))
  259.       "1"
  260.       "0"))
  261.  
  262. (provide 'tokenpos)
  263.