(FILECREATED " 8-Aug-84 12:03:02" {ERIS}<SPEECH>HALVORSEN>SYLLABLE.;1
 11470  

      changes to:  (FNS NEW-SYLLABLE-PARSER)
		   (VARS A)

      previous date: " 3-Aug-84 19:20:04" {ERIS}<SPEECH>LEXICON>SYLLABLE.;1)


(* Copyright (c) 1984 by XEROX. All rights reserved.)

(PRETTYCOMPRINT SYLLABLECOMS)

(RPAQQ SYLLABLECOMS
 [(* Syllable parsing functions)
	(VARS 2-S-CLUSTERS 3-S-CLUSTERS A CO DIPTHONGS LONELYCO SO STRESSRULES SYLLABLE-RULES)
	(FNS 2-S-CLUSTER? 3-S-CLUSTER? ALL-PARSE DIPTHONG? FINISHFN NEW-SYLLABLE-PARSER NG-RULE 
	     S-CLUSTER-RULE S-CLUSTER-V-RULE CO-RULE ALLCSYLL SO-RULE SO? SYLLABLE-PARSER TEST 
	     TEST-SYLLABIFICATION VV-RULE)
	(RECORDS SYLLABLE)
	(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
									      (NLAML)
									      (LAMA SYLLABLE-PARSER])



(* Syllable parsing functions)



(RPAQQ 2-S-CLUSTERS
 ((s p)
		     (s m)
		     (s w)
		     (s t)
		     (s n)
		     (s l)
		     (s k)))

(RPAQQ 3-S-CLUSTERS
 ((s t r)
		     (s p r)
		     (s k r)
		     (s p l)))

(RPAQQ A
 (A B C))

(RPAQQ CO
 ((p l)
	   (p r)
	   (b l)
	   (b r)
	   (f l)
	   (f r)
	   (t r)
	   (d r)
	   (T r)
	   (t w)
	   (d w)
	   (k l)
	   (k r)
	   (g l)
	   (g r)
	   (k w)
	   (g w)
	   (S r)))

(RPAQQ DIPTHONGS
 ((B W)
		  (Y)
		  (A)
		  (e Y)
		  (u W)
		  (i Y)
		  (o W)))

(RPAQQ LONELYCO
 ((- p)
		 (- b)
		 (- f)
		 (- t)
		 (- d)
		 (- T)
		 (- k)
		 (- g)
		 (- S)))

(RPAQQ SO
 (p b f t d T k g S s l r w m n C h J v z d Z y))

(RPAQQ STRESSRULES
 (COONRULE PENULTRULE))

(RPAQQ SYLLABLE-RULES
 (S-CLUSTER-RULE S-CLUSTER-V-RULE CO-RULE SO-RULE VV-RULE NG-RULE))
(DEFINEQ

(2-S-CLUSTER?

  [LAMBDA (SEGMENTLIST)                                (* edited: " 9-Apr-82 22:49")

    (MEMBER SEGMENTLIST 2-S-CLUSTERS])

(3-S-CLUSTER?

  [LAMBDA (SEGMENTLIST)                                (* edited: " 9-Apr-82 18:03")

    (MEMBER SEGMENTLIST 3-S-CLUSTERS])

(ALL-PARSE

  [LAMBDA (WORDLIST CATEGORY FILE)                           (* pkh: " 1-Aug-84 20:28")

                                                             (* CATEGORY is a filter on what words to parse)


          (* This is the top level-function of the foot and syllable-parsing system. We first CATEGORIZE the word 

	  (based on the presence of a string ".../CAT" at the end of the word); next%, do a syllable parse 

	  (NEW-SYLLABLE-PARSER); finally do a foot-parse (PARSE-TEST); the global variable DEBUG controls the printout of 

	  information about the parse)



    (RESETLST [COND
		((OPENP FILE 'OUTPUT)
		  (RESETSAVE (OUTPUT FILE)))
		(T (RESETSAVE (OUTFILE FILE)
			      '(PROGN (CLOSEF? (OUTPUT OLDVALUE]
	      (for
 ITEM WREC TEMP in
 WORDLIST
		 do
 (SETQ WREC (create
 WORD
				       INPUT ← ITEM))
		    (CATEGORIZE WREC)
		    (COND
		      ((AND (NOT (EQ (EVALV 'DEBUG)
				     'NOBIND))
			    DEBUG)
			(printout
 NIL T '"Syllabification and foot-parsing of:    "
				  (fetch
 INPUT of
 WREC)
				  T T)))
		    (COND
		      ((OR (NULL CATEGORY)
			   (EQ (U-CASE CATEGORY)
			       (fetch
 CATEGORY of
 WREC)))
			(NEW-SYLLABLE-PARSER
 WREC)
			(PARSE-TEST WREC)
			(printout
 NIL (fetch
 INPUT of
 WREC)
				  .TAB 22 # (PRINTFOOT (fetch
 STRUCTURE of
 WREC))
				  T])

(DIPTHONG?

  [LAMBDA (SEGMENTLIST)                                (* edited: "10-Apr-82 00:23")

    (MEMBER SEGMENTLIST DIPTHONGS])

(FINISHFN

  [LAMBDA (RULE)                                             (* pkh: " 3-Aug-84 16:54")

    (COND
      ((AND (BOUNDP DEBUG)
	    DEBUG)
	(printout
 NIL RULE %, '"==>  " (NCONC FRONT REST)
		  T)
	FRONT)
      (T (NCONC FRONT REST])

(NEW-SYLLABLE-PARSER

  [LAMBDA (WREC)                                             (* pkh: " 8-Aug-84 11:59")

    (PROG [(TEMP (UNPACK (fetch
 TRANSCRIPTION of
 WREC]
          (SETQ TEMP (S-CLUSTER-RULE
 TEMP))
          (SETQ TEMP (S-CLUSTER-V-RULE
 TEMP))
          (SETQ TEMP (CO-RULE
 TEMP))
          (SETQ TEMP (SO-RULE
 TEMP))
          (SETQ TEMP (VV-RULE
 TEMP))
          (SETQ TEMP (NG-RULE
 TEMP))
          (SETQ TEMP (PACK TEMP))                            (* The structure is simply the word with hyphens 

							     indicating the syllabifiction at this point)

          (replace
 STRUCTURE of
 WREC with
 TEMP])

(NG-RULE

  [LAMBDA (SEGMENTLIST)                                      (* kh: "23-MAR-83 21:14")

    (bind
 (FRONT ONSET NG V (REST ← SEGMENTLIST)) while
 REST
       do
 [COND
	    ([AND (EQUAL 'G (SETQ NG (CAR REST)))
		  (VOWEL? (SETQ V (CADR REST]
	      (SETQ FRONT (NCONC FRONT (LIST NG '- V)))
	      (SETQ REST (CDDR REST)))
	    (T [SETQ FRONT (NCONC FRONT (LIST (CAR REST]
	       (SETQ REST (CDR REST]
       finally
 (RETURN (FINISHFN
 'NG-RULE])

(S-CLUSTER-RULE

  [LAMBDA (SEGMENTLIST)                                      (* edited: "11-Apr-82 17:33")

    (for
 SEGMENT in
 old
 SEGMENTLIST bind
 (ONSET FOLLOWING)
       join
 (COND
	      [[AND [3-S-CLUSTER?
 (SETQ ONSET (LIST (CAR SEGMENTLIST)
						    (CADR SEGMENTLIST)
						    (CADDR SEGMENTLIST]
		    (VOWEL? (SETQ FOLLOWING (CADDDR SEGMENTLIST]
		(SETQ SEGMENTLIST (CDDDR SEGMENTLIST))
		(COND
		  ((VOWEL? (LAST $$VAL))
		    (CONS (CAR ONSET)
			  (LIST '- (CADR ONSET)
				FOLLOWING)))
		  (T (CONS '- (APPEND ONSET (LIST FOLLOWING]
	      [[AND [2-S-CLUSTER?
 (SETQ ONSET (LIST (CAR SEGMENTLIST)
						    (CADR SEGMENTLIST]
		    (VOWEL? (SETQ FOLLOWING (CADDR SEGMENTLIST]
		(SETQ SEGMENTLIST (CDDR SEGMENTLIST))
		(COND
		  ((VOWEL? (LAST $$VAL))
		    (CONS (CAR ONSET)
			  (LIST '- (CADR ONSET)
				FOLLOWING)))
		  (T (CONS '- (APPEND ONSET (LIST FOLLOWING]
	      (T (LIST SEGMENT)))
       finally
 (COND
		 ((EQUAL '- (CAR $$VAL))
		   (CDR $$VAL))
		 (T $$VAL])

(S-CLUSTER-V-RULE

  [LAMBDA (SEGMENTLIST)                                      (* edited: "10-Apr-82 02:13")

    (bind
 (VINFRONT V FRONT ONSET (REST ← SEGMENTLIST)) while
 REST
       do
 [COND
	    [[AND FRONT (VOWEL? (SETQ VINFRONT (CAR REST]
	      (COND
		[[AND [3-S-CLUSTER?
 (SETQ ONSET (LIST (CADR REST)
						      (CADDR REST)
						      (CADDDR REST]
		      (VOWEL? (SETQ V (CAR (CDDDDR REST]
		  [SETQ FRONT (NCONC FRONT (CONS VINFRONT (CONS (CAR ONSET)
								(CONS '- (APPEND (CDR ONSET)
										 (LIST V]
		  (SETQ REST (CDR (CDDDDR REST]
		([AND [2-S-CLUSTER?
 (SETQ ONSET (LIST (CADR REST)
						      (CADDR REST]
		      (VOWEL? (SETQ V (CADDDR REST]
		  [SETQ FRONT (NCONC FRONT (CONS VINFRONT (CONS (CAR ONSET)
								(CONS '- (APPEND (CDR ONSET)
										 (LIST V]
		  (SETQ REST (CDDDDR REST)))
		(T [SETQ FRONT (NCONC FRONT (LIST (CAR REST]
		   (SETQ REST (CDR REST]
	    (T [SETQ FRONT (NCONC FRONT (LIST (CAR REST]
	       (SETQ REST (CDR REST]
       finally
 (RETURN (FINISHFN
 'S-CLUSTER-V-RULE])

(CO-RULE

  [LAMBDA (SEGMENTLIST)                                      (* kh: "23-MAR-83 21:15" posted: " 7-Apr-82 22:26")

                                                             (* Puts a syllable mark in front of complex onset plus 

							     V)

                                                             (* Remainder must be at least 3 long;

							     CO+V is 3)

    (bind
 (ONSET PREVIOUSYLL FRONT (REST ← SEGMENTLIST)) while
 REST
       do
 (SETQ ONSET (LIST (CAR REST)
			    (CADR REST)))
	  [SETQ PREVIOUSYLL (LIST (CAR (LAST FRONT))
				  (CAR (NLEFT FRONT 2))
				  (CAR (NLEFT FRONT 3]
	  [COND
	    ((AND FRONT (NOT (ALLCSYLL
 PREVIOUSYLL))
		  (MEMBER ONSET CO)
		  (MEMBER (CADDR REST)
			  VOWELS))                           (* Make sure we don%'t make a syllable that is all 

							     consonants)

                                                             (* No -

							     at the beginning of the word)

	      [SETQ FRONT (APPEND FRONT (CONS '- (APPEND ONSET (LIST (CADDR REST]
	      (SETQ REST (CDDDR REST)))
	    (T [SETQ FRONT (APPEND FRONT (LIST (CAR REST]
	       (SETQ REST (CDR REST]
       finally
 (RETURN (FINISHFN
 'CO-RULE])

(ALLCSYLL

  [LAMBDA (ENDOFFRONT)                                       (* edited: "10-Apr-82 13:23")

                                                             (* T if the list has only consonants and/or syllable 

							     marks)

    (for
 SEGMENT in
 ENDOFFRONT while
 (NOT (EQUAL SEGMENT '-)) always
 (CONSONANT? SEGMENT])

(SO-RULE

  [LAMBDA (SEGMENTLIST)                                      (* kh: "23-MAR-83 21:13")


          (* Puts syllabification mark before a single onset followed by a vowel%, unless this would leave the beginning of 

	  a complex onset alone in the syllable preceding it)



    (bind
 (FRONT PREVIOUSSYLL ONSET V (REST ← SEGMENTLIST)) while
 REST
       do
 [SETQ PREVIOUSSYLL (LIST (CAR (LAST FRONT))
				   (CAR (NLEFT FRONT 2))
				   (CAR (NLEFT FRONT 3]
	  [COND
	    ([AND FRONT (SO?
 (SETQ ONSET (CAR REST)))
		  (AND (NOT (ALLCSYLL
 PREVIOUSSYLL))
		       (NOT (for
 SEGMENT in
 FRONT always
 (CONSONANT? SEGMENT) finally
 $$VAL)))
		  (VOWEL? (SETQ V (CADR REST]
	      (SETQ FRONT (NCONC FRONT (LIST '- ONSET V)))
	      (SETQ REST (CDDR REST)))
	    (T [SETQ FRONT (NCONC FRONT (LIST (CAR REST]
	       (SETQ REST (CDR REST]
       finally
 (RETURN (FINISHFN
 'SO-RULE])

(SO?

  [LAMBDA (SEGMENT)                                    (* edited: " 9-Apr-82 23:56")

    (MEMBER SEGMENT SO])

(SYLLABLE-PARSER

  [LAMBDA WORD                                         (* edited: "14-Apr-82 00:08")

                                                       (* Makes the word into a list of characters and keeps 

						       applying the syllabble-parsing rules to the list modifying 

						       it as we go along)

    (for
 RULE in
 SYLLABLE-RULES bind
 (SEGMENT-LIST ←(UNPACK WORD)) do
 (APPLY RULE SEGMENT-LIST)
       finally
 (TEMP←(PACK TEMP)
		 (RETURN TEMP])

(TEST

  [LAMBDA (WORDS)                                      (* edited: "10-Apr-82 04:05" posted: " 8-Apr-82 00:18")

    (for
 WORD in
 WORDS do
 (if
 (AND (BOUNDP DEBUG)
				   DEBUG)
			      then
 (printout
 NIL WORD , , , , , , (CO-RULE
 WORD)
					     T])

(TEST-SYLLABIFICATION

  [LAMBDA (RULE WORDLIST)                              (* edited: " 9-Apr-82 19:57")

    (for
 WORD in
 WORDLIST do
 (printout
 NIL (APPLY RULE WORD)
				       T])

(VV-RULE

  [LAMBDA (SEGMENTLIST)                                      (* kh: "23-MAR-83 21:14")

    (bind
 (FRONT ONSET V1 V2 (REST ← SEGMENTLIST)) while
 REST
       do
 [COND
	    ([AND (VOWEL? (SETQ V1 (CAR REST)))
		  (VOWEL? (SETQ V2 (CADR REST)))
		  (NOT (DIPTHONG?
 (LIST V1 V2]
	      (SETQ FRONT (NCONC FRONT (LIST V1 '- V2)))
	      (SETQ REST (CDDR REST)))
	    (T [SETQ FRONT (NCONC FRONT (LIST (CAR REST]
	       (SETQ REST (CDR REST]
       finally
 (RETURN (FINISHFN
 'VV-RULE])
)
[DECLARE: EVAL@COMPILE 

(TYPERECORD SYLLABLE
 (SYLLABLE STRESS))
]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 SYLLABLE-PARSER)
)
(PUTPROPS SYLLABLE COPYRIGHT ("XEROX" 1984))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1671 11185 (2-S-CLUSTER? 1681 . 1826) (3-S-CLUSTER? 1828 . 1973) (ALL-PARSE 1975 . 3353
) (DIPTHONG? 3355 . 3494) (FINISHFN 3496 . 3749) (NEW-SYLLABLE-PARSER 3751 . 4429) (NG-RULE 4431 . 
4911) (S-CLUSTER-RULE 4913 . 5939) (S-CLUSTER-V-RULE 5941 . 7003) (CO-RULE 7005 . 8235) (ALLCSYLL 8237
 . 8594) (SO-RULE 8596 . 9532) (SO? 9534 . 9656) (SYLLABLE-PARSER 9658 . 10161) (TEST 10163 . 10453) (
TEST-SYLLABIFICATION 10455 . 10661) (VV-RULE 10663 . 11183)))))
STOP