home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.cs.arizona.edu
/
ftp.cs.arizona.edu.tar
/
ftp.cs.arizona.edu
/
icon
/
contrib
/
treefox.lzh
/
FOX.ICN
< prev
next >
Wrap
Text File
|
1993-04-24
|
35KB
|
1,190 lines
# FOX (ENGLISH)
global indx, bstack, out, lex, anfpos, st, current, previous, pending,
Lines, max, inter, verbose, steps, normattr
procedure main(opt)
if not(&features=="MS-DOS extensions") then {
writes("\nThis program requires a non-386 DOS ICON. ")
getch(); stop()
}
verbose := 0 ## don't write debugs
steps := 2 ## 0 no steps, 1 stepwise, 2 stepwise auto
srows := 25
bstack := [];
#if *opt=0 then max:=10 else max := opt[1]+1;
max := 11
normattr := 7
if *opt>0 then normattr := numeric(opt[1]);
clrscr(normattr)
out := open("fox.tmp", "w")
indx := create seq(1,1)
lex := table()
if inp:=open("fox-lex") then {
write("Integrating fox-lex")
while st := trim(read(inp)) do {
if match("#",st) | (st=="") then next
st ? if word := tab(find(" ")) then {
tab(many(' '))
lex[word] := trim(tab(0))
}
while st[-1]==";" do {
(st := trim(read(inp))) | break
lex[word] ||:= st[upto(~' ',st):0]
}
}
close(inp)
} else {
write("Not found: fox-lex"); getch()
}
inp := &null
repeat {
clrscr(normattr)
qwrite(1,2,"FOX - A FRAME ORIENTED X-BAR PARSER",normattr)
qwrite(1,3,"M. Jahn (1993)",normattr)
qwrite(1,5,"ESC:quit ENTER:list corpus SPACE:interactive mode s:SYSVARS",normattr)
gotoXY(65,5)
st := getch()
write()
if st==("q"|"\e") then break
if st==char(13) then {
if normattr=240 then system("SCROLLER.EXE fox.in 192,206,240,48,112") else
system("SCROLLER.EXE fox.in")
inp:=open("SCROLLER.DSK")
(st := read(inp)) | stop("nothing in SCROLLER.DSK")
if match("exit",st) then stop()
close(inp); inp := &null
} else
if st=="s" then {
repeat {
writes("SYSVARS settings: v:verbose m:max s:steps ENTER:continue")
writes("(",verbose,", ",max,", ", steps,") ")
st := getch()
case st of {
"s": { steps+:=1
if steps>=3 then steps:=0; write() }
"v": { if verbose=0 then verbose:=1 else verbose:=0; write() }
"m": { writes("\nMax= "); max:=numeric(read())
if (max>11) then {
if srows=25 then {
srows:=43; system("mode 80,43")
clrscr(normattr)
}
} else if srows=43 then {
srows:=25; system("mode 80,25")
clrscr(normattr)
}
}
default: break
}
}
next
} else st := ""
indx := ^indx
(st := "xxx,"||lookup(st)) | next
clrscr(normattr);
showtree(st,"Given:")
while st := build()
if steps=0 then showtree(st,"")
qwrite(1,2*max+2,"ENTER to continue ",normattr)
gotoXY(18,2*max+2)
until getch()==char(13)
#write("\n\n\n")
}
write("\n\nFOX stopped. Protocol file is fox.tmp.")
if max>11 then system("mode 80,25")
end #main
procedure writ(L[])
if verbose=0 then fail
if not numeric(L[1]) then {
every writes(!L)
every writes(out,!L)
} else {
every writes(!L[2:0])
every writes(out,!L[2:0])
}
writes("\n",out,"\n")
if numeric(L[1]) then if getch()==("q"|"\e") then {
stop()
}
end
procedure Auxadjust(st1)
local word
## adjust wrong I-attrib for "who did she/are you ..."
matrix := "(IP,?NP,(Ibar,?I,?VP)),(VP,(Vbar,(V,1),?NP?AP)),"
#writ(1,"auxadjust:")
st1 ? if (tab(anfpos<-bal(',')+1) & tab(match("(I,"))) then {
word := tab(upto(')'))
move(2)
#writ("anf,word=",anfpos,word)
if word == ("did"|"does"|"do"| "am"|"are"|"is"|"was"|"were") &
(not find("(VP,",st1)) then {
current := "(I,+t),"
matrix := xchg(matrix,"1",word)
if anfpos = 5 then ## was he a boy
st1 := st[1:anfpos] || current || tab(bal(',')+1) || matrix || tab(0)
else ## who did it
st1 := st1[1:anfpos] || current || matrix || tab(0)
# writ(1,"st1=", st1)
showtree(st1,"I adjusted to full vb.")
return st1
}
}
end
procedure build()
st := trim(st,',') || ","
pending := ""
previous:= "***"
writ("BUILD:")
st ? while anfpos:=&pos do {
current := tab(bal(','))
move(1) | break
writ("current=",current)
writ("pending=",pending)
## check ambiguous headcat
w := (current[2:upto(',',current)] | "")
if find("/",w) then {
writ("multiple main categories.")
if newcurrent := handlevariants(anfpos,current,st) then {
newcurrent := expandentry(current)
writ("st=anfpos=",st,anfpos)
st := st[1:anfpos] || newcurrent || tab(0)
&subject := st
&pos := 1
writ("st=",st)
showtree(st,"Built: category.select:")
next
}
}
cat := "***"
cat := current[2:upto(',',current)]
if p := proc("handle_"||cat,1) then {
writ("calling handle_",cat)
if anfpos := p(current) then {
writ("pending=",pending)
&subject := st; &pos := anfpos
writ("anfpos/st=",anfpos,st)
next
}
}
previous := current
}
## level 2 handling:
st1 := st
grab("AP,NP,NSp,Nbar,Vbar,Ibar,PP,VP,")
st := Auxadjust(st)
if st ~== st1 then return st
grab("")
if st := procontrol(st) then {
grab("IP,CP,")
return st
}
st1 := st
while st := traced(st) do grab("CP,IP,VP,")
if st ~== st1 then return st
if st := cleanout(st) then {
showtree(st," ")
if grab("")=1 then fail
}
write(out,st,"\n\n")
if *bstack > 0 then {
st := pop(bstack)
writ("popped from bstack=", st)
showtree(st,"Resetting to unexplored variant")
indx:=^indx
return st
}
end # build
procedure cleanout(st)
st1 := ""
st ? {
while st1 ||:= tab(find(",%")) do {
move(2)
tab(upto(',?)'))
}
if st[&pos]=="?" then st1 ||:= ","
st1 ||:= tab(0)
}
return st1
end
procedure expandentry(current)
local i, entry, word, entrybit
current ? if tab(find(",")+1) then word:=tab(-1)
writ("word=",word)
(entry := \lex[word]) | stop("no lex entry for "|| word)
if find(";",entry) then {
i := 0
entry||";" ? while entry1 := tab(upto(';')+1) do {
entrybit := ""
i +:= 1
entry1 ? if match(current[2]) then {
entrybit := tab(-1)
if find("(",entrybit) then entrybit := entrybit[3:0]
word ||:= string(i)
lex[word]:=entrybit
writ("entrybit=", entrybit)
return lookup(word)
}
}
}
end
procedure handlevariants(anfpos,current, st)
local i, j, w, newcurrent
current ? if tab(find("/")) then {
i := &pos
w := ""
while (&pos>1) & (&pos-:=1) do {
if match(","|"(") then {
j := &pos
tab(i+1)
w := tab(upto(',)'))
if *w>0 then {
newcurrent := current[1:j+1] || current[i+1:0]
writ("pushing=", newcurrent)
push(bstack, st[1:anfpos]||newcurrent||st[anfpos+*current:0])
}
newcurrent := current[1:i] || tab(0)
writ("newcurrent=", newcurrent)
return newcurrent
}
}
}
end
procedure handle_CSp(current)
pending := "(CP,?CSp,(Cbar,C,?IP))"
previous := current
return anfpos + *current + 1
end
procedure handle_C(current)
if (*pending=0) then pending := "(CP,CSp,(Cbar,C,?IP))"
if find("C,",pending) then {
current := xchg(pending,"C,",current||",")
st := st[1:anfpos] || current || "," || tab(0)
writ(1,"st=", st)
showtree(st,"Built:"||current)
pending := ""
previous := current
return anfpos + *current + 1
}
end
procedure handle_I(current)
writ("previous=",previous)
if find("(wh,",previous) & not(find("?",current)) &
not(match("(N")) then {
## grab-protect this I
current := "(I,??" || current[4:0]
st := st[1:anfpos] || current || "," || tab(0)
writ(1,"st=", st)
showtree(st,"Built:I grab-protected")
previous := current
return anfpos + *current + 1
}
end
procedure handle_IP(current)
if match("(CP,", pending) then {
st := st[1:anfpos] || pending || "," || st[anfpos:0]
pending := ""
return anfpos + *pending + 1
}
if i:=find("?I,",current) & (not ((find("(I,",st)|*st) < &pos)) then {
current := current[1:i] || "(I,+t1)" || current[i+2:0]
st := st[1:anfpos] || current || "," || tab(0)
showtree(st,"Built: I,+t1")
previous := current
return anfpos + *current + 1
}
end
procedure handle_NP(current)
local nbar
if not match("(VP,",pending) then {
if match("(NP",pending) then {
nbar := ""
current ? if tab(find("(Nbar")) then {
nbar := tab(bal(')'))
writ(1,"nbar=",nbar)
}
if *nbar > 0 then {
current := xchg(pending,"(Nbar,?N)",nbar)
st := st[1:anfpos] || current || "," || tab(0)
}
}
pending := ""
previous := current
return anfpos + *current + 1
}
end
procedure handle_NSp(current)
if *pending=0 then {
pending := "(NP,?NSp,(Nbar,?N))"
previous := current
return anfpos + *current + 1
} else
if find("?NSp", pending) then {
# (the >book's) covers...
newcurrent := xchg(current,"NSp","N") # sex change
pending := xchg(pending,"?N)",newcurrent||")")
st := st[1:anfpos] || "(NSp," || pending || ")," || tab(0)
pending := ""
return anfpos
} else fail
end
procedure handle_N(current)
if match("(VP",pending) then fail
if (*pending=0) then pending :="(NP,(Nbar,?N))"
if match("(NP,",pending) then {
current := xchg(pending,"?N)",current||")")
st := st[1:anfpos] || current || "," || tab(0)
writ(1,"st=", st)
showtree(st,"Built:"||current)
pending := ""
previous := current
return anfpos + *current + 1
}
end
procedure handle_AP(current)
local i, newbar
static oldbar
initial oldbar := "(Nbar,?N)"
if pending=="" then pending := "(NP,(Nbar,?N))"
newbar := "(Nbar,?AP,(Nbar,?N))"
if match("(Adv",previous) then
current := "(AP,(Abar,?Adv," || current[5:0] || ")"
if i := find(oldbar,pending) then {
pending := pending[1:i] || newbar || pending[i+*oldbar:0]
st := st[1:anfpos] || current || "," || tab(0)
previous := ""
return anfpos + *current + 1
}
end
procedure handle_PP(current)
if find("(wh,",current) then {
pending := "(VP,(Vbar,1,?PP))"
previous := current
return anfpos + *current + 1
}
end
procedure handle_VP(current)
local i
if match("(VP",pending) & (not find("?PP",current)) then {
## skip if ?PP already in current
i := find("(Vbar",current)
pending := current[1:i] || pending[5:0]
current := xchg(pending,"1",current[i:-1])
writ("new current=",current)
st := st[1:anfpos] || current || "," || tab(0)
writ(1,"st=", st)
showtree(st,"PP-adjunct to VP")
previous := current
pending := ""
return anfpos + *current + 1
}
end
procedure lookup_getst(st0)
local i, a, word, st1
if /st0 | (st0=="") then {
write("current lexicon:")
a := sort(lex,1)
every i:=1 to *a do writes(a[i][1]," ")
write("\n\nENTER A SENTENCE:")
st0 := read()
}
st1 := ""
st0 ? {
while a := tab(upto('(')) do {
st1 ||:= map(a,",.;:?!-"," ")
st1 ||:= (tab(bal(' ')) | tab(0))
}
st1 ||:= map(tab(0),",.;:?!-"," ")
}
st1 := xchg(st1," "," ")
if st1=="" then stop()
word := st1[1:find(" ",st1)|0]
if /lex[word] then {
a := ord(word[1])
if (65<=a) & (a<=90) then st1[1] := char(a+32)
}
return st1
end
procedure lookup_lex(word)
local entry, dummy, root
if word=="" then return""
entry := ""
if /lex[word] then {
if (word[1]=="(") | (word[-2:0]==("'s"|"s'"|"ly")) then fail
write("NO LEX ENTRY FOR ",word)
writes(" CATEGORIZE [A,Adv,N,NPwh,NSp,NSpwh,P,PPwh,V ?NP_?NP]: ")
dummy := read()
if *dummy>0 then entry := lex[word] := dummy
if entry[1]=="+" then {
root := entry[find(" ",entry)+1:0]
if /lex[root] then {
write("NO LEX ENTRY FOR ",root)
writes(" CATEGORIZE: ")
dummy := read()
if *dummy > 0 then lex[root] := dummy
if \lex[dummy] then {
lex[root] := lex[dummy]
write(" CATEGORIZED LIKE ", dummy)
}
}
}
if \lex[entry] then {
write(" CATEGORIZED LIKE ", entry)
lex[word] := lex[entry]
return lex[word]
}
}
return lex[word]
end #lookup_lex
procedure lookup(st0)
local entry, options, word, st1, vpat, compl, vsp, affix, matrix, verbmatrix,i
vpat := verbmatrix := "(IP,1,(Ibar,?I,?VP)),(VP,(Vbar,(V,_),2))"
compl := ""; matrix := ""; affix := ""; vsp := ""; entry := ""
st0 := lookup_getst(st0) || " "
writ("LOOKING UP: ", st0)
pending := ""
st1 := ""
st0 ? while (i:=&pos) & (word := tab(many(~' '))) do {
if word[1] == "(" then {
&pos := i
st1 ||:= tab(bal(' ')) || ","
writ("i,word=",i,word)
writ("st1=",st1)
tab(many(' '))
next
}
if word[-2:0]==("'s"|"s'") then entry := "NSp" else
if (word[-2:0]=="ly") & (not lookup_lex(word)) then
entry := "Adv"
tab(many(' '))
i := &pos
writ("i/word=", i, word)
writ("st1=",st1)
if find(word||",","am,are,be,been,do,does,to,did,is,was,were,have,had,has,") then {
if (st1=="") | (find("(wh",st1) & (not find("(I,",st1))) then {
#if word==("do"|"does"|"did"|"to"|"have"|"had"|"has") then {
st1 ||:= "(I," || word || "),"; next
#}
}
nextword := (tab(many(~' ')) | "")
writ("nextw (auxblock)=",nextword)
## DO + TO
if word==("do"|"does"|"did"|"to") then {
if lookup_lex(nextword)[1]=="V" then {
if (word=="to" | not find("(I,",st1)) then
matrix := "(I," || word || "),"
word := nextword; tab(many(' '))
} else &pos := i ## push nextword; word = fullvb
## HAVE, HAS, HAD + pt2
} else if word==("have"|"has"|"had") then {
if nextword ~== "been" then {
if find("+pt2",lookup_lex(nextword)) then {
if not find("(I,",st1) then matrix := "(I," || word || ")," else
vsp := "(VSp," || word || "),"
word := nextword; tab(many(' '))
entry := xchg(lookup_lex(word),"+t2","")
# del t2-reference; set entry
} else &pos := i
## HAVE + BEEN + -ing/-en
} else if nextword=="been" then {
move(1); nextword := (tab(many(~' ')) | "")
if find("+pt",\lex[nextword]) then {
if not find("(I,",st1) then {
matrix := "(I," || word || "),"
vsp := "(VSp,been),"
} else vsp := "(VSp," || word || ",been),"
if find("+pt2",\lex[nextword]) then ##passive
verbmatrix := xchg(verbmatrix,"1","?ISp")
word := nextword; tab(many(' '))
entry := xchg(lookup_lex(word),"+t2","") # kill t2 func of -ed
entry := xchg(entry,"+a","") # kill adj func of -ing
} else { ## fullverb: have been boys/eager
if not find("(I,",st1) then matrix := "(I," || word || ")," else
vsp := "(VSp," || word || "),"
&pos := i + 5 ## i + *"been" + 1
word := "been"
}
}
## BE
} else if word == ("am"|"are"|"was"|"were"|"is"|"be"|"been") then {
if find("+pt",\lex[nextword]) then { ##passive or progr.
vsp := "(VSp," || word || "),"
if find("+pt2",\lex[nextword]) then ##passive
verbmatrix := xchg(verbmatrix,"1","?ISp")
writ(1,"vsp=",vsp)
word := nextword
entry := xchg(lookup_lex(word),"+t2","")
entry := xchg(entry,"+a","")
tab(many(' '))
} else &pos := i
}
}
writ("word=",word)
writ("pending=",pending)
writ("entry=",entry)
if *entry=0 then entry := lookup_lex(word)
if /entry | (entry=="") then fail
if not find(";",entry) then {
if find("+a",entry) then entry := "A" # set +pt1 to A
else if entry[1]=="+" then {
if i:=find("+t",entry) then
matrix := "(I,+t" || entry[i+2] || ")," else
if i := find("+pt"||("1"|"2"),entry) then
affix := "(" || entry[i+:4] || ",_)"
if find("+pt2",entry) & ((*vsp>0 & not find("ha",vsp)) |
find("(I,"|| ("am"|"are"|"is"|"was"|"were"),st1)) then
verbmatrix := xchg(verbmatrix,"1","?ISp") else
if find("+pt1",entry) then {
if (*matrix=0) & (*vsp=0) then matrix := "(I,-t),"
}
root := entry[find(" ",entry)+1:0]
entry := lookup_lex(root)
}
if entry=="" then fail
if entry=="A" then entry := "(AP,(Abar,(A,_)))" else
if entry=="P" then entry := "(PP,(Pbar,(P,_),?NP))" else
if find("wh",entry) then
entry := "(" || entry[1:find("wh",entry)] || ",(wh,_))"
if find("_"|"(",entry) then {
if match("A _",entry) then
entry := xchg("(AP,(Abar,(A,_),2))","2",entry[4:0]) else
if match("N _",entry) then {
entry := xchg("(NP,(Nbar,(N,_),2))","2",entry[4:0])
} else if match("P _",entry) then {
entry := xchg("(PP,(Pbar,(P,_),2))","2",entry[4:0])
} else if match("V ",entry) then {
entry ? if move(2) then {
matrix||:=xchg(verbmatrix,"1",tab(upto('_')))
writ("newmatrix=",matrix)
move(1)
compl := ","
compl ||:= tab(0)
if *compl=1 then compl := ""
entry := xchg(matrix,",2",compl)
if *vsp>0 then entry := xchg(entry,"(VP,","(VP," || vsp)
writ("entry_c=",entry)
if *affix>0 then entry := xchg(entry,"_",affix)
vsp := ""; affix := ""; matrix := ""; compl := ""
verbmatrix := vpat
}
}
entry := xchg(entry,"_",word)
if *pending>0 then {
entry := xchg(pending,"?3",entry)
pending:=""
}
## get prep complement
entry ? { vsp:=tab(upto('?')+1) & (compl:=tab(many(&lcase))) &
(affix:=tab(0)) }
if *compl>0 then {
nextword := (tab(many(~' ')) | "")
if nextword==compl then {
pending := vsp || "3" || affix
entry := ""; vsp := ""; affix := ""
&pos := i
next
} else {
entry := xchg(entry,",?"||compl,"")
entry := xchg(entry,",,",",")
}
&pos := i
}
vsp := ""; affix := ""; compl:=""
writ(1,"new entry=", entry)
st1 ||:= entry || ","
} else st1 ||:="(" || entry || "," || word || "),"
} else {
options := ""
entry||";" ? while entry1 := tab(upto(';')+1) do {
entry1 ? {
options ||:= (tab(upto(' ')) | tab(-1)) || "/"
}
}
st1 ||:="(" || options || "," || word || "),"
}
entry:=""
}
writ(1,"looked up:",st1)
return st1
end # lookup
procedure procontrol(st)
## NB mark CP/IP complement ?IP1 ?IP2 ?CP1 ?CP2 for subject/object
## replace an unfillable (IP,?NP by PRO#n, coindexed with a preceding NP
local i, i1, i2, j, current, prevIP, prevVP, nptype, previous
if not (find("CP1"|"CP2", st)) then fail
st := trim(st,',') || ","
current := prevVP := prevIP := ""
writ(1,"PROCONTROL:")
st ? while (previous:=current) & (i:=&pos) do {
current := tab(bal(','))
move(1) | fail
writ("current=",i,current)
## save previously NP-saturated IP
if match("(IP,(NP,",current) then { i1:=i; prevIP := current}
if (k := find("%CP"|"?CP",current)+3) then {
if numeric(current[k]) then nptype:=current[k] else next
j := k+i+1
i2 := i
prevVP := current
writ("prevIP=",prevIP)
writ("type=",nptype)
next
}
## check unsaturated NP in IP
(match("(IP,?NP,",current) & (*prevIP>0) & find("(I,to)",current)) | next
writ("prevIP=",prevIP)
writ(1,"type=",nptype)
if match("(CP",previous) then insert := "" else
insert:="(CP,CSp,(Cbar,C,?IP))," ## wondered whether/if/how
if numeric(nptype) & nptype<3 then {
n := "#" || @indx
if nptype == "1" then st := st[1:i1] || "(IP,(NP" || n ||
st[i1+7:i] || insert || "(IP,PRO" || n || st[i+7:0] else
if nptype == "2" & *prevVP>0 then {
newVP := xchg(prevVP,"(NP","(NP"||n)
if prevVP==newVP then fail
st := st[1:i2] || newVP || st[i2+*prevVP:i] || insert ||
"(IP,PRO" || n || st[i+7:0]
}
st[j]:="" ## delete mark 1 or 2
writ(1,"st=", st)
showtree(st,"Procontrol: "||n)
return st
}
}
end #procontrol
procedure traced(st)
local i, cat, current, newcurrent, pc
st := trim(st,',') || ","
pc := 0
writ(1,"TRACED:")
## sequence: I, wh-NP, Operator, NP(passive,raising)
# what/which book ... NP
# PP= where/how/why
# CP= ? (Operator)
# NP = seems/passive
st ? if (tab(i<-bal(',')+1) & cat<-tab(match("(I,"))) |
(tab(i<-bal(',')+1) & cat<-tab(match("(NP,(wh"|"(NP,(NSp,(wh"))) |
(tab(i<-bal(',')+1) & cat<-tab(match("(PP,("))) |
(tab(i<-bal(',')+1) & cat<-tab(match("(CP,CSp,("))) |
(tab(i<-bal(',')+1) & cat<-tab(match("(NP"))) then {
&pos := i
cat[1]:=""
current := tab(bal(','))
writ("current=",current)
if cat=="I," then newcurrent := "(C," else
if match("CP",cat) then {
newcurrent:="CP"
cat := "NP"
} else
if *cat>3 then { ##PP or NPwh
cat := cat[1:3]
newcurrent :="(CSp,"
} else if cat=="NP" then {
if (find("?ISp")>i) then newcurrent := "(ISp," else fail
}
every pc:=find(("?"|"%")||cat) do tab(pc)
if pc > 0 then {
pd := upto(',)')
until st[pc]==(","|"(") do pc-:=1
pc +:= 1
## return to build CP before NP/ISp
#if ((newcurrent=="(ISp,") & (find(",(CSp",st)<pc)) then fail
writ("distant cat=", cat)
}
} ## scanning finished
if pc > 0 then {
n := "#" || @indx
## replace trace by index
if cat=="I," then cat :="I"
st := st[1:pc] || "(" || cat || "," || n || ")" || st[pd:0]
writ("st/1=",st)
W := st[i+*current:pc]
Z := st[pc:0]
writ("W=",W)
writ("Z=",Z)
if cat=="NP" then
W := xchg(W, ",CSp,", ",CSp"||n||",")
#st:=st[1:i]||xchg(st[i:pc], ",CSp,", ",CSp"||n||",") || st[pc:0] # chain traces
writ("st/2=",st)
if newcurrent == "CP" then
newcurrent := xchg(current,"CSp","(CSp,O"||n||")") else
newcurrent ||:= "(" || cat || n || current[find(",",current):0] || ")"
## abandon previous grab-protection
newcurrent := xchg(newcurrent,"??","")
writ("newcurrent=",newcurrent)
writ("current= ",current)
#pd := *newcurrent - *current
#st := st[1:i] || newcurrent || st[i+*current+pd:0]
st := st[1:i] || newcurrent || W || Z
writ(1,"st/3=",st)
showtree(st,"Traced: "||n)
return st
}
end #traced
procedure grab_headpos(current)
headpos := 0
head := current[2]
if head=="w" then head := "N"
current ? {
if ="(NP,(NSp" then {
move(-5)
tab(bal(')')) ## skip NSp
}
headpos := find(("?"|"(")||head||(","|")"))+2
}
if headpos=0 then
every headpos := find(head||"bar",current)
writ("headpos=",headpos)
if headpos > 0 then return headpos
end
procedure grableft(opt,headpos,current,previous)
local cat, pc
writ("grabbing left")
if find("?"|opt,previous) then {
writ("left is blocked"); fail
}
current ? if move(headpos) then {
while move(-1) do {
if any ('?'++opt) then {
pc := &pos
move(1)
cat:=tab(many(&letters))
writ("cat=",cat)
if match("("||cat||",",previous) then {
while move(-1) do if current[&pos]=="," then break
move(1)
pc:=&pos
tab(upto(',)'))
return current[1:pc] || previous || current[&pos:0]
}
&pos := pc-1
if current[&pos]~=="," then next else break
}
}
}
writ("grableft failed for current=", current)
end
procedure grabright(opt,headpos,current,nextitem,buildcat)
local newcurrent
writ("grabbing right")
if find("?"|opt,nextitem) then {
writ("right is blocked"); fail
}
current ? if move(headpos) then {
if tab(upto('?'++opt)) then {
move(1)
repeat {
cat:=tab(many(&letters))
writ("right-cat=",cat)
if match("("||cat||",",nextitem) then {
while move(-1) do if current[&pos]=="," then break
move(1)
pc:=&pos
tab(upto(',)'))
return current[1:pc] || nextitem || current[&pos:0]
}
tab(any('?'++opt)) | break
}
}
}
if (buildcat=="") & (find("bar",nextitem)=3) &
(current[3:6]~=="bar") then {
writ("PREF-Handling:")
xbar := nextitem[1:7]
writ("xbar=",xbar)
current ? if newcurrent:=tab(find(xbar)) then {
writ("nc/&p=",&pos,newcurrent)
newcurrent ||:= xbar || tab(bal(')')) || "," ||
nextitem[7:0] || tab(0)
writ(1,"newpref=",newcurrent)
return newcurrent
}
}
writ("grabright failed for current= ", current)
end
procedure grab(buildcat)
## "" = all cats, "NP,PP," specified mothers only
local current, previous, i, head, headpos, nextitem, opt, st1, sublst
st := trim(st,',') || ","
sublst := []
st1 := ""
opt := "%"
writ("GRAB(",buildcat,"):")
writ("st=",st)
st ? {
&pos := 5
while (current := tab(bal(','))) do {
move(1)
put(sublst, current)
}
}
writ("*sublst=", *sublst)
if *sublst=1 then {
if *bstack>0 then return 99 else return 1
}
i := *sublst+1
if buildcat == "" then opt := ""
repeat {
i -:= 1
#writ("i/sublst=",i)
#every writes(!sublst," ")
#writ("")
if i < 1 then break
current := (sublst[i] | "")
if *current < 4 then next
(find(current[2:find(",",current)]||",",buildcat) | (*buildcat<=1)) | next
(headpos := grab_headpos(current)) | next
pp := i
previous := "***"
until (*previous>4) | (pp<=1) do previous := sublst[pp-:=1]
writ("previous=", previous)
writ("current=", current)
if current := grableft(opt,headpos,current,previous) then {
sublst[pp] := "*"
sublst[i] := current
i +:= 3
next
}
nextitem := "***"
pn := i
until (*nextitem>4) | (pn>=*sublst) do nextitem := sublst[pn+:=1]
writ("current=", current)
writ(1,"nextitem=", nextitem)
## poss. ECM exception I want him...to do it
if find(",VP",buildcat) & match("(VP,",current) &
find("?NP?IP",current) then next
if current := grabright(opt,headpos,current,nextitem,buildcat) then {
sublst[pn] := "*"
sublst[i] := current
i +:= 3
next
}
}
st1 := "xxx,"
count := 0
every i := 1 to *sublst do {
if sublst[i] ~== "*" then {
st1 ||:= sublst[i] || ","
count +:= 1
}
}
writ(1,"new st=",st1)
if st==st1 then writ("**st unchanged") else {
st := st1
showtree(st,"Grabbed: ["||buildcat||"]")
}
if *bstack>0 then count:=99
writ("GRAB(",buildcat,") returns ", count)
return count
end # grab
procedure xchg(s1,s2,s3)
local result, i
result := ""
i := *s2
s1 ? {
while result ||:= tab(find(s2)) do {
result ||:= s3
move(i)
}
return result || tab(0)
}
end
procedure showtree(L, message, x)
if steps=0 then if *message>0 then fail
mlist := []
write(out,L)
L:="(" || L || ")"
Lines := []; inter := []
every 1 to max do {
put(Lines,""); put(inter,"")
}
message := left(trim(message,":"),79)
gotoXY(5,2*max)
qwrite(5,2*max,message,normattr)
handlelist(L,1)
postproc()
show()
write(out,message,repl("\n",2))
end
procedure show()
local screenst,xf
screenst := ""
every i:=2 to max do {
screenst ||:= left(map(Lines[i],".ⁿ·√"," .,"),80)
screenst ||:= left(map(inter[i],"ⁿ."," "), 80)
write(out,map(Lines[i],".ⁿ·√"," .,"))
write(out,map(inter[i],"ⁿ."," "))
}
attr := char(normattr)
st1 := repl(attr,*screenst)
#while xattr := get(mlist) do {
# xpos := get(mlist)
# every i := xpos to xpos+(get(mlist)-1) do
# st1[i] := xattr
#}
#xattr := char(78)||char(14)||char(6)||char(120)
#st1 := map(st1,"!$~^",xattr)
screenst := collate(screenst, st1)
Poke([47104,0],screenst)
screenst:=&null; st1 := &null
if steps=2 then fail
ch := getch()
if ch=="q" then stop() else
# s = secret TreeCad interface:
if ch=="s" then {
xf := open("treecad.in","a")
write(xf,st[5:0])
close(xf)
}
end # show
procedure get_terms(tree)
local st, x
st:=""
tree ? if tab(bal(',)')+1) then {
while x := tab(bal(',)')) do {
if x[1] ~== "(" then st ||:= x || "_"
else st ||:= get_terms(x[2:-1]||",")
move(1)
}
}
return st
end
procedure handlelist(tree,n)
local ccol, clen, cattr, xcol,xlen,xattr
tree ? if move(1) then {
(cat := tab(upto(','))) | { write("empty list:",tree[&pos:0])
read(); stop()}
catlen := 4
if any('$!~^',cat) then {
cattr := cat[1]
cat[1] := ""
} else cattr := ""
clen := *cat
if *cat<catlen then cat:=center(cat,catlen,"ⁿ") else catlen:=*cat
repeat {
move(1)
(x:=tab(bal(',)'))) | break
if (n>=(max-1)) & (x[1]=="(") then x:=get_terms(x[2:-1]||",")
if x[1]~=="(" then {
x:=trim(x,"_")
if any('$!~^',x) then {
xattr := x[1]
x[1] := ""
} else xattr := ""
xlen := *x
if *x<catlen then x:=center(x,catlen,"ⁿ")
if *Lines[max]>*Lines[n+1] then {
Lines[n+1]:=left(Lines[n+1], *Lines[max], ".")
inter[n+1]:=left(inter[n+1], *Lines[max], ".")
}
a := "." || center("│",*x,"ⁿ") || "."
Lines[n+1] ||:= a
inter[n+1] ||:= a
every i := n+2 to max-1 do {
Lines[i] := left(Lines[i], *Lines[n+1]- (*x+2)) || a
inter[i]:= left(inter[i], *Lines[n+1]- (*x+2),".") || a
}
Lines[max] := left(Lines[max], *Lines[n+1]- (*x+2)) || "." || x || "."
xcol := *Lines[max]-(*x+1)
Lines[max] ? if move(xcol) then {
tab(many('.ⁿ'))
xcol := &pos
}
if *xattr>0 then {
put(mlist,xattr)
put(mlist,(max-2)*160+xcol)
put(mlist,xlen)
xattr := ""
}
inter[max] := left(".", *Lines[max])
#show("item")
} else handlelist(x, n+1)
}
Lines[n+1] ? if move(*Lines[n]) then {
x:=tab(upto(~'.'))
Lines[n]||:= x; inter[n]||:=x
}
len:=*Lines[n]
x:= center("-", *trim(Lines[n+1],".")-len,"-")
Lines[n+1][len+1:0] ? while tab(a:=upto(~'.')) do {
if x[a]==("-") then {
tab(b:=many(~'.'))
b-:=1
mid :=a+integer((b-a)/2)
x[mid]:="!"
} else tab(b:=many(~'.'))
}
x:="." || x || "."
while a:=find(".-", x) do x[a+1]:="."
while a:=find("-.", x) do x[a]:="."
x:= x[2:-1]
inter[n]||:=x
(L:=find("!", x)) | (L:=10)
(R:=find("!.", x||".")) | (R:=10)
vor := left(".", L-1,".")
insert := center(cat,R-L+1,".")
if (R-L)>=*cat then { # range of items
a:=upto(~'.',insert)-1
mid := len + *vor + a+ integer((*cat+1)/2)
ccol := *Lines[n] + *vor
Lines[n] ||:= vor || insert
Lines[n] := left(Lines[n], *inter[n],".")
Lines[n] ? if move(ccol) then {
tab(many('.ⁿ'))
ccol := &pos
}
if inter[n][mid]=="-" then inter[n][mid]:="t"
else inter[n][mid]:="+"
#show("RL-item")
} else { # single item
if integer(*cat/2*2)=*cat then cat:="."||cat
#show("embedded list")
if inter[n][-1]~=="." then {
Lines[n]:=left(Lines[n],*inter[n]-(integer(*cat/2)+1),".")
ccol := *Lines[n]
Lines[n] ||:= cat
Lines[n] ? if move(ccol) then {
tab(many('.ⁿ'))
ccol := &pos
}
} else {
a:=*trim(Lines[n+1],".")-len
ccol := *Lines[n] + (a - *cat)/2
Lines[n] ||:= center(cat, a,".")
Lines[n] ? if move(ccol) then {
tab(many('.ⁿ'))
ccol := &pos
}
#show("single item")
}
} # if else
if *cattr>0 then {
put(mlist,cattr)
put(mlist,(n-2)*160+ccol)
put(mlist,clen)
cattr := ""
}
} #treescan
end
procedure postproc()
static rep1, rep2
initial {
rep1:=[".!.",".!", "-!.", "-!-", "t!", "!t",".+."]
rep2:=[".i.",".L", "-R.", "-T-", "tT", "Tt",".!."]
}
every i:= 2 to max do {
inter[i-1] := replace(inter[i-1]||".",rep1,rep2)
inter[i-1] := map(inter[i-1],"i!LRTt+-.","││┌┐┬┴┼─ ")
}
end #postproc
procedure replace(subject, rep1, rep2)
every i:= 1 to *rep1 do subject := xchg(subject,rep1[i],rep2[i])
return subject
end
procedure collate(s1,s2)
# ex Icon Prog Lib
local length, ltemp, rtemp
static llabels, rlabels, clabels, blabels, half
initial {
llabels := "ab"
rlabels := "cd"
blabels := llabels || rlabels
clabels := "acbd"
half := 2
ltemp := left(&cset,*&cset / 2)
rtemp := right(&cset,*&cset / 2)
clabels := collate(ltemp,rtemp)
llabels := ltemp
rlabels := rtemp
blabels := string(&cset)
half := *llabels
}
length := *s1
if length <= half then
return map(left(clabels,2 * length),left(llabels,length) ||
left(rlabels,length),s1 || s2)
else return map(clabels,blabels,left(s1,half) || left(s2,half)) ||
collate(right(s1,length - half),right(s2,length - half))
end
#### VIDEO ROUTINES ########
procedure clrscr(attr)
Poke([47104, 0], repl(" "||char(attr), 4000))
end
procedure qwrite(x, y, s1, attr)
s1 := collate(s1, repl(char(attr), *s1))
offset := 2*((y-1)*80 + (x - 1))
Poke([47104,offset],s1)
end
procedure gotoXY(X, Y)
local dx
X -:= 1; Y-:=1 # 0,0 = upper left for int 10
dx := Y * 256 + X
Int86([16,512,0,0,dx,0,0,0,0])
end