(FILECREATED " 9-Aug-84 11:19:49" {ERIS}<SPEECH>HALVORSEN>DFOOT.;6 41386
changes to: (VARS DFOOTCOMS)
previous date: " 8-Aug-84 12:37:08" {ERIS}<SPEECH>HALVORSEN>DFOOT.;5)
(* 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-1-WORD PARSE-TEST FOOT.DOMAINS PENULTRULE PENULTSYLLABLE PRETTYFOOT
PRINTFOOT LEFT.WEAK.BRACKET RIGHT.STRONG.BRACKET LEFT.STRONG.BRACKET
LEFT.SYLLABLE.INCORPORATION RIGHT.WEAK.BRACKET PRINTSTRONGFOOT PRUNE PRUNE1
REAL-LONG-VOWEL? RUNFEET SECONDARY-FOOT SECONDARY-STRESS STRESS STRESS&STRIP
STRESS-SYLLABLE STRESS-VOWEL MAINSTRESS.FOOT STRESS? STRIPFOOT
SYLLABLE-STACKER TERTIARY-STRESS TEST-FUNCTION TEST-STRESSER TRANSFORMFOOT
VOWEL?)
(FNS DEBUG FOOTSUBSCRIPT MARKED.STRONG SETUP.FOOTWINDOW FOOTFONTS DEFAULT.FOOT)
(* Functions to parse feet)
(VARS CONSONANTS FOOT-RULES FOOTFILES FOOTOUTPUTFILE LONG-CONSONANTS LONG-VOWELS NAMEFILES
VOWELS TEST-WORDS Z)
(ADDVARS (FOOTFILES SYLLABLE)
(FOOT-RULES (FALLING-FOOT)))
(RECORDS DOMAINS FOOT WORD)))
(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
[LAMBDA (W) (* pkh: " 8-Aug-84 11:59" 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 (SETQ ELT# (LENGTH FEET))
do [COND
((FOOT? ELT)
(SETQ ELT (TRANSFORMFOOT ELT]
[COND
[(IGREATERP (LENGTH FEET)
1)
(SETQ PACKEDFEET (APPEND PACKEDFEET ELT (LIST (QUOTE -]
(T (SETQ PACKEDFEET (APPEND PACKEDFEET ELT]
finally (RETURN PACKEDFEET])
(PACKWORD
[LAMBDA (STRUC) (* pkh: " 7-Aug-84 15:45")
(* 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 (PACK $$VAL))
(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-1-WORD
[LAMBDA (ARRAYENTRY PRINTTOTERMINAL) (* pkh: " 7-Aug-84 18:56")
(* Top level function; Input is a LEXENTRY outputted by READLEXENTRY on PARSE-LEX; Output is a modified version of
the PRON field of LEXENTRY which has foot indication; the RESULT is a string which can be substituted for the
original pronunciation in the dictionary)
(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 (COND
((type? DOMAINS LONGFOOT)
(APPEND (fetch WEAK of LONGFOOT)
(fetch STRONG of LONGFOOT)))
(T LONGFOOT))
join [COND
((FOOT? ELT)
(STRIPFOOT ELT))
((LISTP (CAR ELT))
(PRETTYFOOT FOOT))
(T (CONS (QUOTE -)
(APPEND ELT (LIST (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.WEAK.BRACKET
[LAMBDA NIL (* pkh: " 7-Aug-84 15:39")
(FOOTSUBSCRIPT "a")
(printout FOOTOUTPUTFILE # (DSPFONT FOOTFONT (TTYDISPLAYSTREAM))
"[")
(DSPFONT FOOTFONT (TTYDISPLAYSTREAM])
(RIGHT.STRONG.BRACKET
[LAMBDA NIL (* pkh: " 7-Aug-84 15:39")
(printout FOOTOUTPUTFILE "]"])
(LEFT.STRONG.BRACKET
[LAMBDA NIL (* pkh: " 7-Aug-84 15:39")
(FOOTSUBSCRIPT "b")
(printout FOOTOUTPUTFILE # (DSPFONT FOOTFONT (TTYDISPLAYSTREAM))
"[")
(DSPFONT FOOTFONT (TTYDISPLAYSTREAM])
(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])
(RIGHT.WEAK.BRACKET
[LAMBDA NIL (* pkh: " 7-Aug-84 15:39")
(printout FOOTOUTPUTFILE "]"])
(PRINTSTRONGFOOT
[LAMBDA (STRONGFOOT) (* kh: "24-MAR-83 12:35")
(LEFT.STRONG.BRACKET)
(PRINTFOOT (fetch STRONG of FOOT))
(RIGHT.STRONG.BRACKET])
(PRUNE
[LAMBDA (FOOT) (* edited: "12-Apr-82 02:21")
(PRUNE1 (LEAVES FOOT])
(PRUNE1
[LAMBDA (TREE) (* edited: "13-Apr-82 23:57")
(for LEAF in old TREE join (COND
((AND (EQUAL LEAF (QUOTE -))
(NOT $$VAL))
NIL)
([AND (EQUAL LEAF (QUOTE -))
(MEMBER (CADR TREE)
(QUOTE (- %] %[]
NIL)
((AND (OR (EQUAL LEAF (QUOTE %[))
(EQUAL LEAF (QUOTE %])))
(EQUAL (CADR TREE)
(QUOTE -)))
(SETQ TREE (CDR TREE))
(LIST LEAF))
((AND (EQUAL LEAF (QUOTE -))
(NULL (CDR TREE)))
NIL)
(T (LIST 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) (* pkh: " 7-Aug-84 16:24")
(* 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 (SUB1 (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])
(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])
(STRESS-VOWEL
[LAMBDA (SYLLABLE STRESS) (* kh: "29-Mar-82 16:37" posted: "29-Mar-82 16:44")
(* Iterate down the segments in the syllable, if it isn't a vowel put it at the end of the list TEMP, and set REST
to the remainder of the syllable; if it is a vowel splice in the stress (an integer) in a list inbetween TEMP
(the front) and (CDR REST))
(for SEGMENT in SYLLABLE bind (TEMP (REST ← SYLLABLE))
do [COND
((NOT (VOWEL? SEGMENT))
(SETQ TEMP (APPEND TEMP (LIST SEGMENT)))
(SETQ REST (CDR REST)))
(T (RETURN (APPEND TEMP (CONS SEGMENT (CONS STRESS (CDR REST]
finally (COND
((NULL $$VAL)
(SHOULDNT])
(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 (COND
((EQ ELT# 1)
(PACKFEET (CADR FOOT)))
(T (SETQ TEMP (CONS (QUOTE %[)
(APPEND (PACKFEET (CADR FOOT))
(LIST (QUOTE %]])
(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])
(FOOTSUBSCRIPT
[LAMBDA (X) (* kh: " 6-APR-83 21:09")
(* Prints X as a subscript in the LFGSMALLFONT)
(DECLARE (GLOBALVARS FOOTSUBFONT FOOTSUBOFFSET))
(RELMOVETO 0 (IMINUS FOOTSUBOFFSET)
(TTYDISPLAYSTREAM))
(RESETFORM (DSPFONT FOOTSUBFONT (TTYDISPLAYSTREAM))
(PRIN1 X))
(RELMOVETO 0 FOOTSUBOFFSET (TTYDISPLAYSTREAM])
(MARKED.STRONG
[LAMBDA (SYLLABLE) (* pkh: " 3-Aug-84 18:10" posted: "29-Mar-82 21:33")
(* COND ((MEMBER NIL) (for SOUND in SYLLABLE collect
SOUND unless (EQ (QUOTE (QUOTE NIL) SOUND)))))
(DREMOVE NIL SYLLABLE])
(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))
(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#))
]
(PUTPROPS DFOOT COPYRIGHT ("XEROX" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1472 36020 (ANAPEST-FOOT 1482 . 2348) (ANTEPENULTSYLLABLE 2350 . 2675) (CATEGORIZE 2677
. 3903) (CONSONANT? 3905 . 4225) (COUNTTHEM 4227 . 4442) (VVAS.RULE 4444 . 5542) (EDGEMARKER 5544 .
6038) (FALLING-FOOT 6040 . 8306) (FIND-BOUNDARY 8308 . 8611) (FIND-1-STRESS 8613 . 9137) (FIND-STRESS
9139 . 10147) (FOOT-PARSER 10149 . 11673) (FOOT? 11675 . 11872) (HEAVY-SYLLABLE-FOOT 11874 . 12742) (
LAST.BUT.NOT.SEPR 12744 . 12995) (HEAVY-SYLLABLE? 12997 . 13503) (LASTSYLLABLE 13505 . 13660) (
LOADFOOT 13662 . 14491) (LONG-VOWEL? 14493 . 14892) (MAINSTRESS 14894 . 15274) (MAKE-FOOT 15276 .
15420) (ONSET 15422 . 15569) (PACKFEET 15571 . 16053) (PACKWORD 16055 . 16698) (PACKFOOT 16700 . 17132
) (PARSE-1-WORD 17134 . 18135) (PARSE-TEST 18137 . 19147) (FOOT.DOMAINS 19149 . 19361) (PENULTRULE
19363 . 20106) (PENULTSYLLABLE 20108 . 20436) (PRETTYFOOT 20438 . 20927) (PRINTFOOT 20929 . 22279) (
LEFT.WEAK.BRACKET 22281 . 22550) (RIGHT.STRONG.BRACKET 22552 . 22708) (LEFT.STRONG.BRACKET 22710 .
22981) (LEFT.SYLLABLE.INCORPORATION 22983 . 23678) (RIGHT.WEAK.BRACKET 23680 . 23834) (PRINTSTRONGFOOT
23836 . 24060) (PRUNE 24062 . 24198) (PRUNE1 24200 . 24835) (REAL-LONG-VOWEL? 24837 . 25270) (RUNFEET
25272 . 25486) (SECONDARY-FOOT 25488 . 27435) (SECONDARY-STRESS 27437 . 27610) (STRESS 27612 . 29364)
(STRESS&STRIP 29366 . 29925) (STRESS-SYLLABLE 29927 . 30297) (STRESS-VOWEL 30299 . 31047) (
MAINSTRESS.FOOT 31049 . 31240) (STRESS? 31242 . 32182) (STRIPFOOT 32184 . 32359) (SYLLABLE-STACKER
32361 . 34171) (TERTIARY-STRESS 34173 . 34345) (TEST-FUNCTION 34347 . 34806) (TEST-STRESSER 34808 .
35350) (TRANSFORMFOOT 35352 . 35662) (VOWEL? 35664 . 36018)) (36021 40063 (DEBUG 36031 . 36096) (
FOOTSUBSCRIPT 36098 . 36571) (MARKED.STRONG 36573 . 36919) (SETUP.FOOTWINDOW 36921 . 37253) (FOOTFONTS
37255 . 37707) (DEFAULT.FOOT 37709 . 40061)))))
STOP