(FILECREATED " 7-Aug-84 23:47:31" {ERIS}<SPEECH>LEXICON>KEEP>DFOOT.;9 39667
changes to: (FNS PACKWORD)
(VARS DFOOTCOMS)
previous date: " 7-Aug-84 22:39:08" {ERIS}<SPEECH>LEXICON>KEEP>DFOOT.;7)
(* Copyright (c) 1984 by XEROX. All rights reserved.)
(PRETTYCOMPRINT DFOOTCOMS)
(RPAQQ DFOOTCOMS [(FNS ANAPEST-FOOT ANTEPENULTSYLLABLE CATEGORIZE CONSONANT? COUNTTHEM VVAS.RULE
EDGEMARKER FALLING-FOOT FIND-BOUNDARY FIND-1-STRESS FIND-STRESS FOOT-PARSER
FOOT? HEAVY-SYLLABLE-FOOT LAST.BUT.NOT.SEPR HEAVY-SYLLABLE? LASTSYLLABLE
LOADFOOT LONG-VOWEL? MAINSTRESS MAKE-FOOT ONSET PACKFEET PACKWORD PACKFOOT
PARSE PARSE-1-WORD PARSE-TEST FOOT.DOMAINS PENULTRULE PENULTSYLLABLE
PRETTYFOOT PRINTFOOT LEFT.SYLLABLE.INCORPORATION PRUNE1 REAL-LONG-VOWEL?
RUNFEET SECONDARY-FOOT SECONDARY-STRESS SELECTIVE-PARSE STRESS STRESS&STRIP
STRESS-SYLLABLE MAINSTRESS.FOOT STRESS? STRIPFOOT SYLLABLE-STACKER
TERTIARY-STRESS TEST-FUNCTION TEST-STRESSER TRANSFORMFOOT VOWEL?)
(FNS DEBUG SETUP.FOOTWINDOW FOOTFONTS DEFAULT.FOOT)
(* Functions to parse feet)
(VARS CONSONANTS FOOT-RULES FOOTFILES FOOTOUTPUTFILE LONG-CONSONANTS LONG-VOWELS NAMEFILES
VOWELS TEST-WORDS Z)
(INITVARS (FOOTFONT (FONTCREATE (QUOTE GACHA)
10))
(FOOTSUBFONT (FONTCREATE (QUOTE HIPPO)
10))
(FOOTSUBOFFSET 2)
(DEBUG NIL))
(ADDVARS (FOOTFILES SYLLABLE)
(FOOT-RULES (FALLING-FOOT)))
(RECORDS DOMAINS FOOT WORD)
(P (LOAD (QUOTE SYLLABLE.DCOM))
(LOAD? (QUOTE {ERIS}<LISP>LIBRARY>DECL.DCOM])
(DEFINEQ
(ANAPEST-FOOT
[LAMBDA (SYLLABLES) (* kh: " 5-APR-83 14:24")
(for SYLLABLE-TAIL on old SYLLABLES collect (COND
[(AND (NOT (FOOT? (CAR SYLLABLE-TAIL)))
(NOT (FOOT? (CADR SYLLABLE-TAIL)))
(NOT (FOOT? (CADDR SYLLABLE-TAIL)))
(STRESS? (CAR SYLLABLE-TAIL)
1)
(STRESS? (CADR SYLLABLE-TAIL)
0)
(STRESS? (CADDR SYLLABLE-TAIL)
0))
(SETQ SYLLABLES (CDDR SYLLABLES))
(* SYLLABLES will be decremented when we iterate as
well, therefore no ADD1)
(MAKE-FOOT (LIST (CAR SYLLABLE-TAIL)
(CADR SYLLABLE-TAIL)
(CADDR SYLLABLE-TAIL]
(T (CAR SYLLABLE-TAIL)))
finally $$VAL])
(ANTEPENULTSYLLABLE
[LAMBDA (SYLLABLES) (* kh: "29-Mar-82 21:21" posted: "29-Mar-82 21:47")
(* Returns the antepenultimate syllable of a word given
the syllables as input)
(CADDR SYLLABLES])
(CATEGORIZE
[DLAMBDA ((W WORD))
(* kh: " 5-APR-83 11:23" posted: "29-Mar-82 00:22")
(* Finds the / which indicates the morphological info in
a word, and puts it on the porperty list of the word)
(* / Indicates beginning of morphological information.
If WORD has it, POS will be the character-position
following /)
[COND
[(SETQ POS (STRPOS (QUOTE "/")
(fetch INPUT of W)
NIL NIL NIL T))
[replace CATEGORY of W with (MKATOM (U-CASE (SUBSTRING (fetch INPUT of W)
POS]
(* The category is that part of the word which follows
/)
(* The word itself is the substring preceding /)
(replace TRANSCRIPTION of W with (MKATOM (SUBSTRING (fetch INPUT of W)
1
(IDIFFERENCE POS 2]
(T (replace TRANSCRIPTION of W with (fetch INPUT of W]])
(CONSONANT?
[LAMBDA (SEGMENT) (* kh: "30-Mar-82 21:41" posted: "30-Mar-82 21:37")
(* Returns the consonant if a syllable contains one)
(COND
((MEMBER SEGMENT CONSONANTS)
SEGMENT)
(T NIL])
(COUNTTHEM
[LAMBDA (ARRAY) (* pkh: " 7-Aug-84 15:42")
(for X from 1 to (ARRAYSIZE ARRAY) do (printout T X " " (ELT ARRAY X)
T])
(VVAS.RULE
[LAMBDA (SYLLABLE) (* pkh: " 3-Aug-84 21:40" posted: "29-Mar-82 21:33")
(PROG (TEMP)
(COND
((MEMBER (fetch (WORD CATEGORY) of WREC)
(QUOTE (a v))) (* Shouldn't use WREC freely here)
(* Special treatment of verbs and adjectives. They get stressed if the last syllables has a long vowel or if it
has a vowel followed by at least 2 consonants)
(COND
((NULL (LONG-VOWEL? (HEAVY-SYLLABLE? SYLLABLE)))
(* Long vowels that are the final segment don't count as
long)
(RETURN (STRESS-SYLLABLE SYLLABLE 11)))
(T NIL)))
([AND (SETQ TEMP (SOME SYLLABLE (QUOTE LONG-VOWEL?)))
(CDR TEMP)
(NOT (NUMBERP (CADR TEMP]
(* The VVAS.RULE says to stress the last syllable if there is a long-vowel in it, provided this vowel is not the
last segment in the word)
(RETURN (STRESS-SYLLABLE SYLLABLE 11)))
(T NIL])
(EDGEMARKER
[LAMBDA (SYLLABLES) (* edited: " 8-Apr-82 21:21")
(* Stresses the edge of a word with 1 if it isn't
already stressed)
(PROG [(FIRST (CAR SYLLABLES))
(LAST (CAR (LAST SYLLABLES]
(COND
((STRESS? FIRST 0)
(STRESS-SYLLABLE FIRST 1)))
(COND
((STRESS? LAST 0)
(STRESS-SYLLABLE LAST 1])
(FALLING-FOOT
[LAMBDA (SYLLABLES) (* pkh: " 7-Aug-84 16:54")
(for SYLLABLE-TAIL on old SYLLABLES bind AFTER-STRESS-STRETCH MAIN-UPTO-SECONDARY
MAIN-UPTO-BOUNDARY
collect (COND
((AND (STRESS? (CAR SYLLABLE-TAIL)
1)
(SETQ AFTER-STRESS-STRETCH (FIND-STRESS (CDR SYLLABLE-TAIL)
2)))
(* Looking for a main-stress followed by a secondary-stress; makes a foot out of the main-stress syllable and the
unstressed syllables up to the seocndary stress)
[SETQ MAIN-UPTO-SECONDARY (CONS (CAR SYLLABLE-TAIL)
(REVERSE (CDR (REVERSE AFTER-STRESS-STRETCH]
(* Recurse down the syllable-tail until a 3 stress is found, if FIND-1-STRESS can find a 1 stress on the tail then
make this domain of a 3 and 1 stress into a foot pop it off the stack (i.e. remainder))
(SETQ SYLLABLES (NTH SYLLABLES (LENGTH MAIN-UPTO-SECONDARY)))
(MAKE-FOOT MAIN-UPTO-SECONDARY))
([AND (STRESS? (CAR SYLLABLE-TAIL)
1)
(SETQ AFTER-STRESS-TO-BOUNDARY (FIND-BOUNDARY (CDR SYLLABLE-TAIL]
(* Looking for a main-stress followed by a secondary-stress; makes a foot out of the main-stress syllable and the
unstressed syllables up to the seocndary stress)
(SETQ MAIN-UPTO-BOUNDARY (CONS (CAR SYLLABLE-TAIL)
AFTER-STRESS-TO-BOUNDARY))
(* Recurse down the syllable-tail until a 3 stress is found, if FIND-1-STRESS can find a 1 stress on the tail then
make this domain of a 3 and 1 stress into a foot pop it off the stack (i.e. remainder))
(SETQ SYLLABLES (NTH SYLLABLES (LENGTH MAIN-UPTO-BOUNDARY)))
(MAKE-FOOT MAIN-UPTO-BOUNDARY))
((STRESS? (CAR SYLLABLE-TAIL)
1)
(* Make a foot of the domain from the main-stress to the end of the word when there is no secondary stress
following the main-stress)
(PROG1 (MAKE-FOOT SYLLABLE-TAIL)
(SETQ SYLLABLES NIL)))
(T (* If we don't find a foot return the syllable at top of
the stack unchanged)
(CAR SYLLABLE-TAIL)))
finally (RETURN $$VAL])
(FIND-BOUNDARY
[LAMBDA (SYLLABLES) (* pkh: " 7-Aug-84 16:20")
(for SYLLABLE in old SYLLABLES while (NOT (SETQ FOOTFLG (type? FOOT SYLLABLE))) collect SYLLABLE
finally (RETURN (COND
(FOOTFLG $$VAL)
(T $$VAL])
(FIND-1-STRESS
[LAMBDA (SYLLABLES) (* edited: "10-Apr-82 18:15")
(* Walks down a list of with 0 stress syllables until a 1 stress is found. Returns the list of the unstressed
syllables and the 1 stress, if failure NIL is returned)
(for SYLLABLE in old SYLLABLES while (STRESS? SYLLABLE 0) collect SYLLABLE
finally (COND
[(STRESS? SYLLABLE 1)
(RETURN (APPEND $$VAL (LIST SYLLABLE]
(T (RETURN NIL])
(FIND-STRESS
[LAMBDA (SYLLABLES STRESS) (* pkh: " 7-Aug-84 16:55")
(* Walks down a list of with 0 stress syllables until a stress is found. Returns the list of the unstressed
syllables and the stressed syllable if failure NIL is returned)
(* If you want to find the first stressed syllable regardless of whether it has primary or secondary stress use
NIL for the STRESS parameter)
(for SYLLABLE FOOTFLG in old SYLLABLES while (AND (NOT (SETQ FOOTFLG (type? FOOT SYLLABLE)))
(STRESS? SYLLABLE 0))
collect SYLLABLE finally (RETURN (COND
(FOOTFLG (RETURN NIL))
((NULL SYLLABLES)
NIL)
[(NULL STRESS)
(COND
((OR (STRESS? SYLLABLE 2)
(STRESS? SYLLABLE 1))
(RETURN (APPEND $$VAL (LIST SYLLABLE]
[(STRESS? SYLLABLE STRESS)
(RETURN (APPEND $$VAL (LIST SYLLABLE]
(T NIL])
(FOOT-PARSER
[LAMBDA (WREC) (* pkh: " 7-Aug-84 17:37")
(* Takes a word as input, focusses on the STRUCTURE field of the WORD, i.e. where the the syllables sit, and
parses the STRUCTURE into feet; finally we replace the parentheses with foot-boundary markers)
(PROG (FEET (SYLLABLES (fetch STRUCTURE of WREC)))
(SETQ FEET (FALLING-FOOT SYLLABLES))
(COND
((AND (BOUNDP DEBUG)
DEBUG)
(printout T (QUOTE "Falling-foot ===> ")
T FEET T)))
(SETQ FEET (SECONDARY-FOOT FEET))
(COND
((AND (BOUNDP DEBUG)
DEBUG)
(printout T (QUOTE "Secondary-foot ===> ")
T FEET T)))
(SETQ FEET (HEAVY-SYLLABLE-FOOT FEET))
(COND
((AND (BOUNDP DEBUG)
DEBUG)
(printout T (QUOTE "Heavy-syllable-foot ===> ")
T FEET T)))
(SETQ FEET (ANAPEST-FOOT FEET))
(COND
((AND (BOUNDP DEBUG)
DEBUG)
(printout T (QUOTE "Anapest-foot ===> ")
T FEET T)))
(SETQ FEET (DEFAULT.FOOT FEET))
(COND
((AND (BOUNDP DEBUG)
DEBUG)
(printout T (QUOTE "Default-foot ===> ")
T FEET T)))
(SETQ FEET (LEFT.SYLLABLE.INCORPORATION FEET))
(COND
((AND (BOUNDP DEBUG)
DEBUG)
(printout T (QUOTE "Left Syllable Incorporation ===> ")
T FEET T)))
(RETURN (replace STRUCTURE of WREC with FEET])
(FOOT?
[LAMBDA (FOOTCANDIDATE) (* kh: "23-MAR-83 20:28")
(COND
((EQUAL (CAR FOOTCANDIDATE)
(QUOTE FOOT))
FOOTCANDIDATE)
(T NIL])
(HEAVY-SYLLABLE-FOOT
[LAMBDA (SYLLABLES) (* pkh: " 7-Aug-84 11:41")
(* Makes a heavy-syllable into a foot provided either that it is not the final syllable or that provided that
there is no long vowel in the syllable (tentative comment))
(for SYLLABLE in SYLLABLES bind (HEAVYSYLLABLERESULT (SYLL# ← (LENGTH SYLLABLES))
FOOTHOLDER)
do [COND
[[AND (NOT (FOOT? SYLLABLE))
(AND (SETQ HEAVYSYLLABLEHOLDER (HEAVY-SYLLABLE? SYLLABLE))
(OR [NOT (EQUAL SYLL# (ADD1 (LENGTH FOOTHOLDER]
(NOT (LONG-VOWEL? (CAR (LAST.BUT.NOT.SEPR HEAVYSYLLABLEHOLDER]
(SETQ FOOTHOLDER (APPEND FOOTHOLDER (LIST (MAKE-FOOT (LIST SYLLABLE]
(T (SETQ FOOTHOLDER (APPEND FOOTHOLDER (LIST SYLLABLE]
finally (RETURN FOOTHOLDER])
(LAST.BUT.NOT.SEPR
[LAMBDA (SYLLABLE) (* pkh: " 7-Aug-84 15:23")
(COND
[(MEMBER (CAR (LAST SYLLABLE))
(QUOTE (- < *)))
(NTH SYLLABLE (SUB1 (LENGTH SYLLABLE]
(T (LAST SYLLABLE])
(HEAVY-SYLLABLE?
[LAMBDA (SYLLABLE) (* pkh: " 7-Aug-84 17:53")
(* Returns the rest of the syllable starting with a long-vowel (VV's have to be treated separately) or starting
with the VCCC sequence; if the syllable isn't long we return NIL)
(OR (SOME SYLLABLE (QUOTE LONG-VOWEL?))
(SOME (CDR (SOME (CDR (SOME (CDR (SOME SYLLABLE (QUOTE VOWEL?)))
(QUOTE CONSONANT?)))
(QUOTE CONSONANT?)))
(QUOTE CONSONANT?])
(LASTSYLLABLE
[LAMBDA (SYLLABLES) (* kh: "29-Mar-82 18:31" posted: "29-Mar-82 18:41")
(CAR SYLLABLES])
(LOADFOOT
[LAMBDA (FLG) (* pkh: " 1-Aug-84 20:39")
(* Loads the files necessary to run the foot parser)
(* I use DLAMBDAs so this file from <lisp>library> needs
to be loaded)
(LOAD? (QUOTE DECL.DCOM))
(COND
[FLG (PROGN (LOAD (QUOTE {PHYLUM}<HALVORSEN>LISP>DFOOT.DCOM))
(LOAD (QUOTE {PHYLUM}<HALVORSEN>LISP>SYLLABLE.DCOM))
(LOAD (QUOTE {PHYLUM}<HALVORSEN>LISP>METRICS.DCOM))
(LOAD (QUOTE {PHYLUM}<HALVORSEN>LISP>METRICSPATCH]
(T (PROGN (LOAD? (QUOTE {PHYLUM}<HALVORSEN>LISP>DFOOT.DCOM))
(LOAD? (QUOTE {PHYLUM}<HALVORSEN>LISP>SYLLABLE.DCOM))
(LOAD? (QUOTE {PHYLUM}<HALVORSEN>LISP>METRICS.DCOM])
(LONG-VOWEL?
[LAMBDA (SEGMENT) (* pkh: " 7-Aug-84 10:32" posted: "28-Mar-82 23:09")
(* Checks to see if the segment is among the long-vowels
listed in LONG-VOWELS (and returns the vowel if it is))
(COND
((MEMBER SEGMENT LONG-VOWELS)
SEGMENT)
(T NIL])
(MAINSTRESS
[LAMBDA (SYLLABLE) (* pkh: " 7-Aug-84 16:55" posted: "29-Mar-82 16:44")
(* Takes a syllable and inserts main stress indication
(3) after the first vowel; SHOULDNT if there is no
vowel)
(STRESS-VOWEL SYLLABLE 1])
(MAKE-FOOT
[LAMBDA (DOMAIN) (* edited: " 8-Apr-82 15:44")
(LIST (QUOTE FOOT)
DOMAIN])
(ONSET
[LAMBDA (SYLLABLE) (* kh: "31-Mar-82 20:33" posted: "31-Mar-82 20:37")
(CAR SYLLABLE])
(PACKFEET
[LAMBDA (FEET) (* edited: "11-Apr-82 18:16")
(for ELT in old FEET bind PACKEDFEET first ELT#← (LENGTH FEET)
do (if (FOOT? ELT)
then ELT← (TRANSFORMFOOT ELT))
(if (LENGTH FEET) gt 1
then PACKEDFEET← < ! PACKEDFEET ! ELT '- >
else PACKEDFEET← < ! PACKEDFEET ! ELT>)
finally (RETURN PACKEDFEET])
(PACKWORD
[LAMBDA (STRUC PRINTTOTERMINAL) (* edited: " 7-Aug-84 23:44")
(* Takes as input the structure field of a WORD-record
and produces string output which goes back into the
dictionary as a pronunciation)
(for FOOT FLG RESULT in old STRUC join (COND
[FLG (PROG1 (CONS (QUOTE \)
(PACKFOOT FOOT]
(T (SETQ FLG T)
(PACKFOOT FOOT)))
finally (RETURN (PROG1 (SETQ RESULT (APPLY (FUNCTION CONCAT)
$$VAL))
(COND
(PRINTTOTERMINAL (printout FOOTOUTPUTFILE RESULT T])
(PACKFOOT
[LAMBDA (FOOT) (* pkh: " 7-Aug-84 15:28")
(* Takes a foot and returns a string with syllable
indications)
(PROG [(SEGMENTS (COND
((type? FOOT FOOT)
(fetch (FOOT SYLLABLES) of FOOT))
(T FOOT]
(RETURN (for X in SEGMENTS join X])
(PARSE
[LAMBDA (WORDLIST CATEGORIES) (* edited: " 8-Apr-82 22:44")
(for WORD in WORDLIST do (PARSE-TEST WORD])
(PARSE-1-WORD
[LAMBDA (ARRAYENTRY PRINTTOTERMINAL) (* edited: " 7-Aug-84 22:20")
(* "Gumby" " 2-Aug-84 18:43")
(* 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)
(PROG ([BITTBL (MAKEBITTABLE (QUOTE (- < *]
RESULT)
(SETQ WREC (create WORD
INPUT ← (fetch (LEXENTRY ORTH) of ARRAYENTRY)))
(replace (WORD STRUCTURE) of WREC with (LISTIFY.SYLLABIFICATION (fetch (LEXENTRY PRON)
of ARRAYENTRY)
BITTBL))
(PARSE-WORD-RECORD WREC)
(SETQ RESULT (PACKWORD (fetch STRUCTURE of WREC)))
(COND
(PRINTTOTERMINAL (printout FOOTOUTPUTFILE (fetch INPUT of WREC)
.TAB 22 RESULT T)))
(RETURN RESULT])
(PARSE-TEST
[LAMBDA (WREC) (* pkh: " 7-Aug-84 15:39")
(PROGN (SYLLABLE-STACKER WREC) (* Takes word with syllables indicated by -, explodes
the strings and puts them in reverse order under the
property SYLLABLES)
(STRESS WREC) (* Replace with English stress rule)
(EDGEMARKER (fetch STRUCTURE of WREC)) (* Put the stress-indications on the list under the
SYLLABLES property; ready to do a parse of feet)
(replace STRUCTURE of WREC with (REVERSE (fetch STRUCTURE of WREC)))
(* Get the syllables in the correct order
(left-to-right))
(COND
((AND (BOUNDP DEBUG)
DEBUG)
(printout FOOTOUTPUTFILE WREC T)))
(FOOT-PARSER WREC)
(FOOT.DOMAINS WREC])
(FOOT.DOMAINS
[LAMBDA (WREC) (* pkh: " 3-Aug-84 22:21")
(PROG ((FEET (fetch STRUCTURE of WREC)))
(create DOMAINS
STRONG ← FEET])
(PENULTRULE
[LAMBDA (SYLLABLE) (* pkh: " 7-Aug-84 16:55" posted: "30-Mar-82 21:38")
(* Stresses a syllable if it is long, i.e. if it has a
long vowel, or is closed (finnsonant))
(PROG [(LONG-VOWEL (SOME SYLLABLE (QUOTE LONG-VOWEL?]
(COND
([OR (CONSONANT? (CAR (LAST SYLLABLE)))
(REAL-LONG-VOWEL? LONG-VOWEL (ONSET (LASTSYLLABLE SYLLABLES]
(* Stress the penult if it is closed or if it has a long-vowel provided it is not immediately succeeded by an
initial-vowel in the next syllable)
(RETURN (STRESS-SYLLABLE SYLLABLE 1)))
(T NIL])
(PENULTSYLLABLE
[LAMBDA (SYLLABLES) (* kh: "29-Mar-82 21:20" posted: "29-Mar-82 21:48")
(* Returns the penultimate syllable of a word given the
syllables of the word as input)
(CADR SYLLABLES])
(PRETTYFOOT
[LAMBDA (LONGFOOT) (* kh: "23-MAR-83 20:30")
(for ELT in (if (type? DOMAINS LONGFOOT)
then < ! LONGFOOT:WEAK ! LONGFOOT:STRONG>
else LONGFOOT)
join (if (FOOT? ELT)
then (STRIPFOOT ELT)
elseif (LISTP ELT:1)
then (PRETTYFOOT FOOT)
else < (QUOTE -) ! ELT (QUOTE -)
>)
finally $$VAL])
(PRINTFOOT
[LAMBDA (F) (* pkh: " 7-Aug-84 16:55")
(COND
[(type? DOMAINS F) (* We are at the first pass through PRINTFOOT;
there is only one domain in a word)
(COND
((fetch WEAK of F)
(LEFT.WEAK.BRACKET)
(PRINTFOOT (fetch WEAK of F))
(RIGHT.WEAK.BRACKET)))
(COND
((fetch STRONG of F)
(PRINTSTRONGFOOT (fetch STRONG of F]
((type? FOOT (CAR F))
(* Input must be a WEAK or a STRONG from a DOMAIN; There will be one or more feet, print them with vertical bars
"\" in between)
(for F FLG in F
do (printout FOOTOUTPUTFILE "\")
(PRINTFOOT F)))
[(type? FOOT F)
(for SYLLABLE FLG in (fetch SYLLABLES of F) do (COND
(FLG (printout FOOTOUTPUTFILE (QUOTE -))
(PRINTFOOT SYLLABLE))
(T (SETQ FLG T)
(PRINTFOOT SYLLABLE]
(T (for ELT in F do (COND
[(LISTP ELT)
(for SOUND in ELT do (printout FOOTOUTPUTFILE (COND
((EQ SOUND 1)
1)
(T SOUND]
(T (printout FOOTOUTPUTFILE (COND
((EQ ELT 1)
1)
(T ELT])
(LEFT.SYLLABLE.INCORPORATION
[LAMBDA (SYLLABLES) (* pkh: " 6-Aug-84 17:30")
(* Incorporate the unstressed syllable before a foot
into the foot)
(for SYLL KEEPER in old SYLLABLES collect (COND
((type? FOOT SYLL)
SYLL)
[(AND (STRESS? SYLL 0)
(type? FOOT (CADR SYLLABLES)))
(SETQ KEEPER SYLLABLES)
(SETQ SYLLABLES (CDR SYLLABLES))
(MAKE-FOOT (APPEND (LIST SYLL)
(fetch (FOOT SYLLABLES)
of (CADR KEEPER]
(T SYLL))
finally $$VAL])
(PRUNE1
[LAMBDA (TREE) (* edited: "13-Apr-82 23:57")
(for LEAF in old TREE join (if (AND (EQUAL LEAF '-)
~$$VAL)
then NIL
elseif (AND (EQUAL LEAF '-)
(MEMBER TREE:2 ' (- %] %[)))
then NIL
elseif (AND (OR (EQUAL LEAF '%[)
(EQUAL LEAF '%]))
(EQUAL TREE:2 '-))
then (TREE←TREE::1)
(<LEAF>)
elseif (AND (EQUAL LEAF '-)
TREE::1=NIL)
then NIL
else <LEAF>)
finally $$VAL])
(REAL-LONG-VOWEL?
[LAMBDA (SYLLABLETAIL NEXTONSET) (* kh: "31-Mar-82 20:27" posted: "31-Mar-82 20:37")
(* Checks that the long-vowel isn't followed by a
vowel-onset in the next syllable)
(COND
((OR (IGREATERP (LENGTH SYLLABLETAIL)
1)
(NOT (VOWEL? NEXTONSET)))
SYLLABLETAIL)
(T NIL])
(RUNFEET
[LAMBDA NIL (* kh: "23-MAR-83 16:38")
(LOAD (QUOTE {PHYLUM}<HALVORSEN>FOOT>DFOOT.DCOM))
(LOAD (QUOTE {PHYLUM}<HALVORSEN>FOOT>SYLLABLE.DCOM])
(SECONDARY-FOOT
[LAMBDA (SYLLABLES) (* edited: " 7-Aug-84 21:40")
(* Makes a foot of a domain consisting of a secondary
stress and following unstressed syllables up to a stress
or a foot)
(for SYLLABLE-TAIL on old SYLLABLES bind AFTER-STRESS-STRETCH FOOT-SECONDARY-UPTO-STRESS
collect (COND
([AND (NOT (type? FOOT (CAR SYLLABLE-TAIL)))
(STRESS? (CAR SYLLABLE-TAIL)
2)
(SETQ AFTER-STRESS-STRETCH (FIND-STRESS (CDR SYLLABLE-TAIL]
[SETQ FOOT-SECONDARY-UPTO-STRESS (CONS (CAR SYLLABLE-TAIL)
(REVERSE (CDR (REVERSE AFTER-STRESS-STRETCH]
(* Recurse down the syllable-tail until a 3 stress is found, if FIND-1-STRESS can find a 1 stress on the tail then
make this domain of a 3 and 1 stress into a foot pop it off the stack (i.e. remainder))
[SETQ SYLLABLES (NTH SYLLABLES (MAX 1 (LENGTH FOOT-SECONDARY-UPTO-STRESS]
(MAKE-FOOT FOOT-SECONDARY-UPTO-STRESS))
((AND (NOT (type? FOOT (CAR SYLLABLE-TAIL)))
(STRESS? (CAR SYLLABLE-TAIL)
2))
(SETQ AFTER-STRESS-STRETCH (FIND-BOUNDARY (CDR SYLLABLE-TAIL)))
(SETQ FOOT-SECONDARY-UPTO-STRESS (CONS (CAR SYLLABLE-TAIL)
AFTER-STRESS-STRETCH))
(* Recurse down the syllable-tail until a 3 stress is found, if FIND-1-STRESS can find a 1 stress on the tail then
make this domain of a 3 and 1 stress into a foot pop it off the stack (i.e. remainder))
(SETQ SYLLABLES (NTH SYLLABLES (LENGTH FOOT-SECONDARY-UPTO-STRESS)))
(MAKE-FOOT FOOT-SECONDARY-UPTO-STRESS))
(T (* If we don't find a foot return the syllable at top of
the stack unchanged)
(CAR SYLLABLE-TAIL)))
finally (RETURN $$VAL])
(SECONDARY-STRESS
[LAMBDA (SYLLABLE) (* kh: "29-Mar-82 16:40" posted: "29-Mar-82 16:43")
(STRESS-VOWEL SYLLABLE 2])
(SELECTIVE-PARSE
[LAMBDA (WORDLIST CATEGORY) (* edited: " 8-Apr-82 23:04")
(for WORD in WORDLIST do (PROG ((WORDSTRIPPED (CATEGORIZE WORD))
TEMP)
(if (EQUAL CATEGORY (GETP WORDSTRIPPED 'CAT))
then (PARSE-TEST WORD])
(STRESS
[LAMBDA (WREC) (* pkh: " 7-Aug-84 16:57" posted: "29-Mar-82 16:46")
(* Top-level function for stress-assignment. Takes a word (with the morphological information stripped off) and
assigns stress to the syllables of the word according to the stress-rules. Outputs the word on the terminal and
stores the stress-indication (PRINT-STRESSED-WORD))
(PROG ((SYLLABLES (fetch STRUCTURE of WREC))
(SYLLABLE# (fetch SYLLABLE# of WREC)))
(COND
((EQ SYLLABLE# 1)
(STRESS-SYLLABLE (LASTSYLLABLE SYLLABLES)
1)
(RETURN WREC))
((VVAS.RULE (LASTSYLLABLE SYLLABLES))
(RETURN WREC))) (* If it is a monosyllable, stress it and quit, else see
if there is a long vowel in the last syllable)
(COND
((EQ SYLLABLE# 2)
(STRESS-SYLLABLE (PENULTSYLLABLE SYLLABLES)
1)
(RETURN WREC))
((PENULTRULE (PENULTSYLLABLE SYLLABLES))
(RETURN WREC)))
(* If it is a diasyllable (which didn't match the VVAS.RULE) stress the penult, for longer words see if the
PENTULTRULE (long V or closed syllable) is matched)
(STRESS-SYLLABLE (ANTEPENULTSYLLABLE SYLLABLES)
1)
(for SYLL in SYLLABLES do (COND
((MARKED.STRONG SYLL)
(* REMOVE.MARK SYLL)
(STRESS-SYLLABLE SYLL 1)))
finally (RETURN WREC)) (* If everything else fails the antepenult gets the
stress)
(RETURN WREC])
(STRESS&STRIP
[LAMBDA (WORD) (* kh: " 7-Apr-82 00:35" posted: " 7-Apr-82 00:40")
(* Takes a word, strips off the category indication and puts it on the property-list of the word
(minus the /<cat>) under the property name CAT)
(PROG ((STRIPPED-WORD (CATEGORIZE WORD)))
(SYLLABLE-STACKER STRIPPED-WORD)
(STRESS STRIPPED-WORD)
(PUTPROP STRIPPED-WORD 'SYLLABLES (REVERSE (GETP STRIPPED-WORD 'SYLLABLES)))
(RETURN STRIPPED-WORD])
(STRESS-SYLLABLE
[LAMBDA (SYLLABLE STRESS) (* kh: " 4-APR-83 21:00" posted: "30-Mar-82 20:52")
(* Smashes STRESS, which should be an integer (3 for main stress, 2 for secondary and 1 for tertiary), onto the
end of the list of characters which represents the syllable)
(NCONC SYLLABLE (LIST STRESS])
(MAINSTRESS.FOOT
[LAMBDA (FOOT) (* pkh: " 7-Aug-84 16:57")
(for SYLLABLE in (CADR FOOT) thereis (STRESS? SYLLABLE 1])
(STRESS?
[LAMBDA (SYLLABLE STRESS#) (* pkh: " 7-Aug-84 15:06")
(* Returns the stress# if a syllable is stressed, returns NIL if the syllable is empty and 0 if the stress# is 0
and the syllable is infact unstressed)
(COND
((EQ NIL SYLLABLE) (* Didn't find a stress)
NIL)
((OR [AND (ZEROP STRESS#)
(NOT (NUMBERP (CAR (LAST.BUT.NOT.SEPR SYLLABLE]
(EQUAL (CAR (LAST.BUT.NOT.SEPR SYLLABLE))
STRESS#))
(* If STRESS# is 0 then we are looking for an UNstressed syllable, therefore we return a non-nil value
(i.e. STRESS#) when there is no stress indication (i.e. no number at the end of the list of segments))
(* If the STRESS# is a number other than 0 then return the STRESS# when we find its match at the end of the
segment list)
STRESS#)
(T NIL])
(STRIPFOOT
[LAMBDA (FOOT) (* kh: "23-MAR-83 19:16")
<
(QUOTE %[) ! (PRETTYFOOT FOOT:2)
(QUOTE %])
>])
(SYLLABLE-STACKER
[LAMBDA (WREC) (* kh: " 4-APR-83 20:43" posted: "29-Mar-82 15:09")
(* edited: "10-Apr-82 03:47")
(* Finds the syllables in a word (no morphological info (/-info) allowed) and puts them (represented as a list of
characters) last syllable first on a stack on the the property list of the word under the property-name SYLLABLES.
The property-name SYLLABLE# gives the number of syllables in the word)
(PROG (SYLLABLE-STACK SYLLABLE# (BPOS 0)
EPOS
(SYLLABIFIEDWORD (fetch STRUCTURE of WREC)))
(* The STRUCTURE of the word is at this point simply the
syllabified version of the word
(hyphens indicating syllabification))
(while BPOS count (COND
((SETQ EPOS (STRPOS (QUOTE -)
SYLLABIFIEDWORD
(ADD1 BPOS)))
(* if -
is found put the material from the beginning of the word or the last -
on the syllable stack, and set BPOS to the character-position where the search is to resume)
[push SYLLABLE-STACK (UNPACK (SUBSTRING SYLLABIFIEDWORD (ADD1 BPOS)
(SUB1 EPOS]
(SETQ BPOS EPOS))
(T (* -
hasn't been found; put whole word or rest of word on the
syllable-stack and set BPOS to NIL so we quit)
(push SYLLABLE-STACK (UNPACK (SUBSTRING SYLLABIFIEDWORD
(ADD1 BPOS)
NIL)))
(SETQ BPOS EPOS)))
finally ((replace STRUCTURE of WREC with SYLLABLE-STACK)
(replace SYLLABLE# of WREC with (ADD1 $$VAL])
(TERTIARY-STRESS
[LAMBDA (SYLLABLE) (* kh: "29-Mar-82 16:40" posted: "29-Mar-82 16:43")
(STRESS-VOWEL SYLLABLE 1])
(TEST-FUNCTION
[LAMBDA (WORDLIST) (* pkh: " 7-Aug-84 15:39" posted: " 7-Apr-82 00:08")
(for WORD in WORDLIST do (PROG ((TEMP (CATEGORIZE WORD)))
(TEST-STRESSER TEMP)
(EDGEMARKER TEMP)
(COND
((AND (BOUNDP DEBUG)
DEBUG)
(printout FOOTOUTPUTFILE T (REVERSE (GETP TEMP (QUOTE
SYLLABLES)))
T])
(TEST-STRESSER
[LAMBDA (WORD) (* pkh: " 7-Aug-84 15:39" posted: "30-Mar-82 21:40")
(* Test-function for the foot-parser, extendable)
(CATEGORIZE WORD)
(SYLLABLE-STACKER WORD)
(STRESS WORD)
(COND
((AND (NEQ (QUOTE NOBIND)
(EVALV (QUOTE DEBUG)))
DEBUG)
(printout FOOTOUTPUTFILE , WORD (QUOTE " has the stress pattern")
, , , , (REVERSE (GETP WORD (QUOTE SYLLABLES)))
T])
(TRANSFORMFOOT
[LAMBDA (FOOT) (* edited: "10-Apr-82 19:02")
(PROG (TEMP)
(RETURN (if ELT#=1
then (PACKFEET FOOT:2)
else TEMP← <'%[ ! (PACKFEET FOOT:2)
'%] >])
(VOWEL?
[LAMBDA (SEGMENT) (* kh: "29-Mar-82 13:33" posted: "28-Mar-82 23:10")
(* Checks if segment is a vowel according to VOWELS.
Returns the vowel or NIL)
(COND
((MEMBER SEGMENT VOWELS)
SEGMENT)
(T NIL])
)
(DEFINEQ
(DEBUG
[LAMBDA (FLG)
(GLOBALVARS DEBUG)
DEBUG←FLG])
(SETUP.FOOTWINDOW
[LAMBDA NIL (* kh: " 6-APR-83 21:18")
(PROG ((W (CREATEW (create REGION
LEFT ← 10
BOTTOM ← 15
WIDTH ← 560
HEIGHT ← 370)
"Prosodic Structure")))
(DSPRIGHTMARGIN 32000 W)
(RETURN W])
(FOOTFONTS
[LAMBDA (FONT) (* kh: " 6-APR-83 21:04")
(DECLARE (GLOBALVARS FOOTFONT FOOTSUBFONT FOOTSUBOFFSET))
(SELECTQ FONT
(LARGE FONT← ' (GACHA 12))
((SMALL NIL)
FONT← ' (GACHA 10))
NIL)
FOOTFONT←
(FONTCREATE FONT)
FOOTSUBFONT←
(FONTCREATE ' (HIPPO 10))
FOOTSUBOFFSET←
(FONTPROP FOOTFONT 'SIZE)/2
(DSPFONT FONT (TTYDISPLAYSTREAM])
(DEFAULT.FOOT
[LAMBDA (SYLLABLES) (* pkh: " 7-Aug-84 16:40")
(* Looks at individual syllables;
the variable SYLL holds the syllables/feet)
(* Finds a final syllable, whether it is in a foot or on its own and makes a foot of it if there is a tense vowel)
(for SYLL TEMP LASTINFOOT in old SYLLABLES
join (COND
[[AND (type? FOOT SYLL)
(NULL (CDR SYLLABLES))
(NEQ 1 (LENGTH (SETQ TEMP (fetch (FOOT SYLLABLES) of SYLL]
(* The final syllable is in a foot;
look inside it)
(SETQ LASTINFOOT (CAR (LAST TEMP)))
(COND
[(NOT (OR (MEMBER (QUOTE x)
LASTINFOOT)
(MEMBER (QUOTE %|)
LASTINFOOT)
(MEMBER (QUOTE i)
LASTINFOOT)
(MEMBER (QUOTE I)
LASTINFOOT)
(MEMBER (QUOTE E)
LASTINFOOT)
(MEMBER (QUOTE ↑)
LASTINFOOT)
(MEMBER (QUOTE U)
LASTINFOOT)
(MEMBER (QUOTE N)
LASTINFOOT)
(MEMBER (QUOTE X)
LASTINFOOT)
(MEMBER (QUOTE L)
LASTINFOOT)
(MEMBER (QUOTE M)
LASTINFOOT)
(MEMBER (QUOTE N)
LASTINFOOT)
(MEMBER (QUOTE R)
LASTINFOOT)))
(LIST [MAKE-FOOT (REVERSE (CDR (REVERSE TEMP]
(MAKE-FOOT (LIST LASTINFOOT]
(T (LIST SYLL]
[[AND (NOT (type? FOOT SYLL))
(NULL (CDR SYLLABLES))
(NOT (OR (MEMBER (QUOTE x)
LASTINFOOT)
(MEMBER (QUOTE %|)
LASTINFOOT)
(MEMBER (QUOTE i)
LASTINFOOT)
(MEMBER (QUOTE I)
LASTINFOOT)
(MEMBER (QUOTE E)
LASTINFOOT)
(MEMBER (QUOTE ↑)
LASTINFOOT)
(MEMBER (QUOTE U)
LASTINFOOT)
(MEMBER (QUOTE N)
LASTINFOOT)
(MEMBER (QUOTE X)
LASTINFOOT)
(MEMBER (QUOTE L)
LASTINFOOT)
(MEMBER (QUOTE M)
LASTINFOOT)
(MEMBER (QUOTE N)
LASTINFOOT)
(MEMBER (QUOTE R)
LASTINFOOT] (* The final syllable is not in a foot and it is tense)
(LIST (MAKE-FOOT (LIST SYLL]
(T (LIST SYLL)))
finally $$VAL])
)
(* Functions to parse feet)
(RPAQQ CONSONANTS (w r t T y p s S d D f g G h J k l z Z C v b n m))
(RPAQQ FOOT-RULES ((FALLING-FOOT)
FALLING-FOOT HEAVY-SYLLABLE-FOOT ANAPEST-FOOT))
(RPAQQ FOOTFILES (SYLLABLE))
(RPAQQ FOOTOUTPUTFILE T)
(RPAQQ LONG-CONSONANTS (G))
(RPAQQ LONG-VOWELS (A e u Y i o W))
(RPAQQ NAMEFILES (<LFG.PARSER>LFG.NAMES))
(RPAQQ VOWELS (@ ↑ e E u U i I o O a A R L N c Y W x))
(RPAQQ TEST-WORDS (bi b@-bxl/v beb be-bxl b@-bun bx-bUS-kx be-bi b@-kx-lc-ri-xt b@-kx-nel-yx b@-Cx-lR
b@-Cx-lE-ri bx-sI-lxs b@k b@k-fild/c b@k-g@-mxn b@k-rEst/c b@k-sAd/c b@k-spIn/c
b@k-wcS/c be-kxn b@k-tI-ri-a-lx-Ji b@k-tI-ri-xm b@d/a bed/v b@J b@-JR b@d-x-naZ
b@d-mIn-txn b@-fxl/v b@g bx-g@s b@-gx-tEl be-gxl JRnLIstIk J↑kstxpoz JuJItsu
xt@lyxn @bxtwar xt bl@ndISmxnt bl@Gkxt bl@st bletNt blit))
(RPAQQ Z (JRnLIstIk J↑kstxpoz/a JuJItsu xt@lyxn @bxtwar xt bl@ndISmxnt bl@Gkxt bl@st bletNt blit))
(RPAQ? FOOTFONT (FONTCREATE (QUOTE GACHA)
10))
(RPAQ? FOOTSUBFONT (FONTCREATE (QUOTE HIPPO)
10))
(RPAQ? FOOTSUBOFFSET 2)
(RPAQ? DEBUG NIL)
(ADDTOVAR FOOTFILES SYLLABLE)
(ADDTOVAR FOOT-RULES (FALLING-FOOT))
[DECLARE: EVAL@COMPILE
(TYPERECORD DOMAINS (NONFOOT WEAK STRONG))
(TYPERECORD FOOT (SYLLABLES))
(TYPERECORD WORD (INPUT SPELLING TRANSCRIPTION STRUCTURE CATEGORY SYLLABLE#))
]
(LOAD (QUOTE SYLLABLE.DCOM))
(LOAD? (QUOTE {ERIS}<LISP>LIBRARY>DECL.DCOM))
(PUTPROPS DFOOT COPYRIGHT ("XEROX" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1590 34873 (ANAPEST-FOOT 1600 . 2466) (ANTEPENULTSYLLABLE 2468 . 2793) (CATEGORIZE 2795
. 4043) (CONSONANT? 4045 . 4365) (COUNTTHEM 4367 . 4582) (VVAS.RULE 4584 . 5682) (EDGEMARKER 5684 .
6178) (FALLING-FOOT 6180 . 8446) (FIND-BOUNDARY 8448 . 8751) (FIND-1-STRESS 8753 . 9277) (FIND-STRESS
9279 . 10287) (FOOT-PARSER 10289 . 11813) (FOOT? 11815 . 12012) (HEAVY-SYLLABLE-FOOT 12014 . 12882) (
LAST.BUT.NOT.SEPR 12884 . 13135) (HEAVY-SYLLABLE? 13137 . 13643) (LASTSYLLABLE 13645 . 13800) (
LOADFOOT 13802 . 14631) (LONG-VOWEL? 14633 . 15032) (MAINSTRESS 15034 . 15414) (MAKE-FOOT 15416 .
15560) (ONSET 15562 . 15709) (PACKFEET 15711 . 16167) (PACKWORD 16169 . 16869) (PACKFOOT 16871 . 17303
) (PARSE 17305 . 17474) (PARSE-1-WORD 17476 . 18769) (PARSE-TEST 18771 . 19781) (FOOT.DOMAINS 19783 .
19995) (PENULTRULE 19997 . 20740) (PENULTSYLLABLE 20742 . 21070) (PRETTYFOOT 21072 . 21531) (PRINTFOOT
21533 . 22883) (LEFT.SYLLABLE.INCORPORATION 22885 . 23580) (PRUNE1 23582 . 24163) (REAL-LONG-VOWEL?
24165 . 24598) (RUNFEET 24600 . 24814) (SECONDARY-FOOT 24816 . 26760) (SECONDARY-STRESS 26762 . 26935)
(SELECTIVE-PARSE 26937 . 27258) (STRESS 27260 . 29012) (STRESS&STRIP 29014 . 29573) (STRESS-SYLLABLE
29575 . 29945) (MAINSTRESS.FOOT 29947 . 30138) (STRESS? 30140 . 31080) (STRIPFOOT 31082 . 31257) (
SYLLABLE-STACKER 31259 . 33069) (TERTIARY-STRESS 33071 . 33243) (TEST-FUNCTION 33245 . 33704) (
TEST-STRESSER 33706 . 34248) (TRANSFORMFOOT 34250 . 34515) (VOWEL? 34517 . 34871)) (34874 38093 (DEBUG
34884 . 34949) (SETUP.FOOTWINDOW 34951 . 35283) (FOOTFONTS 35285 . 35737) (DEFAULT.FOOT 35739 . 38091
)))))
STOP