(FILECREATED "10-Aug-84 19:39:36" {ERIS}<SPEECH>LEXICON>SYLLABLE.;2
 11991  

      changes to:  (VARS A)

      previous date: " 8-Aug-84 12:03:02" {ERIS}<SPEECH>HALVORSEN>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
 (ANAPEST-FOOT ANTEPENULTSYLLABLE CATEGORIZE EDGEMARKER FIND-1-STRESS FOOT-PARSER 
		       LASTSYLLABLE LOADFOOT MAINSTRESS ONSET PACKFEET PARSE-TEST FOOT.DOMAINS 
		       PENULTRULE PENULTSYLLABLE PRETTYFOOT PRINTFOOT LEFT.WEAK.BRACKET 
		       RIGHT.STRONG.BRACKET LEFT.STRONG.BRACKET RIGHT.WEAK.BRACKET PRINTSTRONGFOOT 
		       PRUNE PRUNE1 REAL-LONG-VOWEL? RUNFEET SECONDARY-STRESS STRESS STRESS&STRIP 
		       STRESS-SYLLABLE STRESS-VOWEL MAINSTRESS.FOOT STRIPFOOT SYLLABLE-STACKER 
		       TERTIARY-STRESS TEST-FUNCTION TEST-STRESSER TRANSFORMFOOT))

(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 (2192 11706 (2-S-CLUSTER? 2202 . 2347) (3-S-CLUSTER? 2349 . 2494) (ALL-PARSE 2496 . 3874
) (DIPTHONG? 3876 . 4015) (FINISHFN 4017 . 4270) (NEW-SYLLABLE-PARSER 4272 . 4950) (NG-RULE 4952 . 
5432) (S-CLUSTER-RULE 5434 . 6460) (S-CLUSTER-V-RULE 6462 . 7524) (CO-RULE 7526 . 8756) (ALLCSYLL 8758
 . 9115) (SO-RULE 9117 . 10053) (SO? 10055 . 10177) (SYLLABLE-PARSER 10179 . 10682) (TEST 10684 . 
10974) (TEST-SYLLABIFICATION 10976 . 11182) (VV-RULE 11184 . 11704)))))
STOP