home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.cs.arizona.edu
/
ftp.cs.arizona.edu.tar
/
ftp.cs.arizona.edu
/
icon
/
contrib
/
treefox.lzh
/
TREECAD.ICN
< prev
next >
Wrap
Text File
|
1993-04-24
|
31KB
|
1,087 lines
#############
# TREECAD #
#############
global Lines, max, inter, out,
st, mlist, rstack, ustack, verbose, indx, optline,
mouseOK, paste, post, posting, insitu,
xattr, normattr, hiattr, nomode
procedure main(args)
if not(&features=="MS-DOS extensions") then {
writes("\nThis program requires a non-386 DOS ICON. ")
getch(); stop()
}
nomode := 0
normattr := 7
hiattr := 15
xattr := char(78)||char(14)||char(6)||char(120)
st1 := " "
if *args>0 then {
while st1 ||:= get(args) || " "
if find("nomode",st1) then nomode:=1
st1 ? while tab(upto(&digits)) do {
normattr := tab(many(&digits))
hiattr := (move(1), tab(many(&digits)))
xattr := ""
every 1 to 4 do
xattr ||:= (move(1), char(tab(many(&digits))))
if *xattr~=4 then {
write("error in attr specs:", st1)
getch(); stop()
}
}
}
out := open("treecad.tmp","w")
ustack := [] # undo
rstack := [] # redo
max := 11
insitu:=0
if max <= 11 then optline := 23 else optline := 33
verbose := 0 # 0=no
st := ""
if initmouse()=65535 then {
mouseOK:=1
} else mouseOK:=0
indx := create seq(1,1)
repeat {
clrscr(normattr)
qwrite(58,15," TREECAD",normattr)
qwrite(58,16," Tree Designer",normattr)
qwrite(58,17," M. Jahn 1993",normattr)
qwrite(1,optline-2," data system action ",normattr)
qwrite(1,optline-1," ┌──────┼───────┐ ┌──────┬─────┴─────┬──────┐ ┌────┼──────┐",normattr)
repeat {
gotoXY(1,optline)
qwrite(1,optline," │corpus│scratch│ │max= │verbose= │tree= │ │quit│resume│ ",normattr)
qwrite(35,optline,string(max-1),normattr)
if verbose=0 then st1 := "OFF" else st1:="ON "
qwrite(46,optline,st1,normattr)
qwrite(55,optline,map(string(insitu),"01","bs"),normattr)
gotoXY(75,optline)
showmouse()
st1 := getaction(1)[3][1] #1=act on getch
hidemouse()
if st1==("q"|"\e") then break break
if st1=="c" then {
if normattr=240 then system("SCROLLER.EXE treecad.in 192,206,240,48,112") else
system("SCROLLER.EXE treecad.in")
inp:=open("SCROLLER.DSK")
(st := read(inp)) | stop("nothing in SCROLLER.DSK")
if st[1]~=="(" then stop(st)
if match("exit",st) then stop()
st := "xxx," || st
close(inp); inp := &null
break
} else if st1=="s" then {
st:="xxx,(CP,CSp,(Cbar,C,IP)),(IP,NP,(Ibar,I,(VP,(Vbar,V,NP)))),"
break
} else if st1=="t" then {
if insitu=0 then insitu:=1 else insitu:=0
next
} else if st1=="m" then {
gotoXY(5,optline+1)
writes("Set maxlevels<3-≈15>: ")
oldmax:=max
max := read()+1
if max>16 then max := 16
gotoXY(5,optline+1); clreol(normattr)
if max>11 & oldmax<=11 then {
optline := 33
if nomode=0 then system("mode 80,43")
setY(1,336)
clrscr(normattr)
} else if max<=11 & oldmax>11 then {
optline := 23
if nomode=0 then system("mode 80,25")
setY(1,192)
clrscr(normattr)
}
next
} else if st1=="r" then {
if st=="" then next else break
} else if st1=="v" then {
if verbose=0 then verbose:=1 else verbose:=0
next
} else next
}
writ("st=", st)
#hidemouse()
clrscr(normattr)
if st1~=="r" then {
ustack := [] # undo
rstack := [] # redo
savetree(st)
}
hilight()
indx := ^indx
}
hidemouse()
if (max>11) & (nomode=0) then system("mode 80,25")
end
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 {
if (max>11) & (nomode=0) then system("mode 80,25")
stop()
}
end
procedure getaction(N)
repeat {
if buttonpress(0)>0 then {
pos := getmousepos()
X:= (pos[1] / 8)+1
Y:= (pos[2] / 8)+1
if qread(X,Y)==" " then return [X,Y,""]
s := ""
hidemouse()
while any(~' /(│',qread(X-1,Y)) & (X>1) do X -:= 1
if Y=optline then {
every x:=1 to 79 do newattr(x,optline,normattr)
attr := hiattr
} else {
attr := readattr(X,Y)
if attr ~= normattr then attr:=normattr else attr := hiattr
}
x := X
repeat {
ch := qread(X,Y)
if any(' /)│',ch) then break else newattr(X,Y,attr)
s ||:= ch
if X < 79 then X+:=1 else break
}
showmouse()
return [x,Y, s]
} else if kbhit() then {
Y := whereXY()[2]
X := whereXY()[1]
if \N then return [X,Y, getch()]
s := readst(X,Y)
if type(s)~=="string" then return s
gotoXY(X,Y)
clreol(normattr)
return [X,Y, s]
}
}
end
procedure readst(X,Y)
s := ""
repeat {
c:=getch()
case c of {
char(0): { s := movecursor(); break }
char(13): break
char(32): if *s=0 then s:=" " else {
#while kbhit() do getch()
break
}
char(8): if *s>0 then s := s[1:-1]
default: s ||:= c
}
qwrite(X,Y,s||" ",normattr)
gotoXY(X+*s,Y)
}
return s
end
procedure movecursor()
c := getch()
XY := whereXY()
gotoXY(10,12); X:=10; Y:=12
s := ""
repeat {
c := getch()
if c==(char(13)|" ") then {
x := X
repeat {
c := qread(X,Y)
if any(' /)│',c) then break
s ||:= c
if X < 79 then X+:=1 else break
}
gotoXY(XY[1],XY[2])
writes(s)
return [x,Y, s]
} else if c~==char(0) then break
if c==char(0) & kbhit() then
case getch() of {
"t": { while any(~' ',qread(X,Y)) & (X<79) do gotoXY(X+:=1,Y)
while any(' │',qread(X,Y)) & (X<79) do gotoXY(X+:=1,Y)
}
"s": { while any(~' ',qread(X,Y)) & (X>1) do gotoXY(X-:=1,Y)
while any(' │',qread(X,Y)) & (X>1) do gotoXY(X-:=1,Y)
while any(~' ',qread(X-1,Y)) & (X>1) do gotoXY(X-:=1,Y)
}
"K": if X>1 then gotoXY(X-:=1,Y)
"M": if X<80 then gotoXY(X+:=1,Y)
"H": if Y>1 then gotoXY(X,Y-:=1)
"P": if Y<25 then gotoXY(X,Y+:=1)
"I": if Y>1 then gotoXY(X,Y:=1)
"Q": if Y<25 then gotoXY(X,Y:=25)
} #else break
}
gotoXY(XY[1],XY[2])
end
procedure savetree(s)
push(ustack,s)
if *ustack>5 then pull(ustack)
end
procedure hilight()
local word, st1
menu := " │hi│cc│mc│gv│Gv│ │adj│mov│ │cpy│cut│gen│mir│ren│ │un│Re│sv│qu│ "
choice := "h"
showtree(st, " ",1) ## 1=gen.post
qwrite(1,optline-2," show ops edit system ",normattr)
qwrite(1,optline-1," ┌──┬──┬─┴┬──┬──┐ ┌───┼───┐ ┌───┬───┬─┴─┬───┬───┐ ┌──┬──┼──┬──┐",normattr)
#menu := " │hi│cc│mc│gv│Gv│ │adj│mov│ │cpy│cut│gen│mir│ren│ │un│Re│sv│qu│ "
qwrite(1,optline,menu,normattr)
gotoXY(*menu+1,optline)
showmouse()
repeat {
word := getaction()
if word[2]=optline then { ## else treerange...
choice:=left(word[3],2)
word := ""
#writes(choice)
qwrite(*menu+1,optline,choice,normattr)
} else { # keep choice and exec
if word[2]<=max*2-3 then { # Y in tree display range ?
X := word[1]
Y := (word[2]+3)/2
XY := "," || X || "." || Y || "="
word := word[3]
} else {
choice==" "; word:="";
gotoXY(*menu+1,optline)
next
}
}
gotoXY(1,optline+1); clreol(normattr)
case choice of {
" ": next
"mo": writes("MOVEALFA<node>: ")
"cc": writes("C-COMMAND<node>: ")
"cp": writes("COPY<node>: ")
"cu": writes("CUT<node>: ")
"ge": writes("GENERATE<node>: ")
"gv": writes("GOVERN<node>: ")
"Gv": writes("GOVERN: PATIENT:<node>: ")
"hi": writes("")
"ad": writes("ADJOIN<subtree>: ")
"mc": writes("M-COMMAND<node>: ")
"mi": writes("MIRROR<nonterminal>: ")
"qu": { hidemouse(); fail }
"re": writes("RENAME<node>: ")
"Re": writes("REDONE")
"sv": { writes("SAVED")
xf := open("treecad.in","a")
write(xf,st[5:0])
close(xf)
choice := "h"
}
"un": { writes("UNDONE")
push(rstack,st)
if *rstack>3 then pull(rstack)
}
}
st1 := st
if find(choice, "cc,mc,gv,Gv,ad,mo,cp,cu,ge,mi,re") & (word=="") then {
word := getaction()
if word[2]<=max*2-3 then { # Y in tree display range ?
X := word[1]
Y := (word[2]+3)/2
XY := "," || X || "." || Y || "="
word := word[3]
} else choice==" " # donothing
}
if type(word)~=="string" then choice:= " "
if choice=="un" then {
if st := pop(ustack) then showtree(st,"undone",1)
} else if choice=="Re" then {
savetree(st)
if st := pop(rstack) then showtree(st,"redone",1)
} else if choice=="ad" then {
writes(word,XY, " TO<nonterminal>: ")
x := whereXY()[1]
repeat {
dest := getaction()
X := dest[1]
Y := (dest[2]+3)/2
dest := dest[3]
if dest=="" then break
(dpos := getnodepos(dest,"," || X || "." || Y || "=",st1)-1) | break
if st1[dpos]=="(" then {
writes(dest,XY)
savetree(st1)
#st := adjoin(word,XY,dest, "," || X || "." || Y || "=",st1)
st := adjoin(word,XY,dpos,st1)
showtree(st,"adjoined",1)
break
} else gotoXY(x,optline+1)
}
} else if choice=="mo" then {
writes(word, XY," TO<terminal>: ")
x := whereXY()[1]
repeat {
dest := getaction()
X := dest[1]
Y := (dest[2]+3)/2
dest := dest[3]
if dest=="" then break ## null st = ESC
(dpos := getnodepos(dest,"," || X || "." || Y || "=",st1)) | break
if st1[dpos-1]~=="(" then {
writes(dest,XY)
savetree(st1)
st := movealfa(word,XY,dest,dpos,st1)
st := xchg(st,",,",",")
showtree(st,"Alfa-moved",1)
break
} else gotoXY(x,optline+1)
}
} else if choice=="cp" then {
writes(word, XY," TO<node>: ")
dest := getaction()
X := dest[1]
Y := (dest[2]+3)/2
dest := dest[3]
writes(dest,XY)
writ(1,"dest0=",dest)
savetree(st1)
st := cpy(word,XY,dest, "," || X || "." || Y || "=",st1)
showtree(st,"copied",1)
} else if choice=="cc" then {
writes(word,XY)
st1 := x_cmd(word,XY,st1,"c")
showtree(st1,"c-command",0)
} else if choice=="cu" then {
if *word>0 then {
savetree(st1)
st := expand(word,XY,"",st1)
showtree(st,"cut",1)
}
} else if choice=="ge" then {
writes(word,XY, " TO<head/paste/list>: ")
dest := getaction()[3]
if dest==" " then {
dest := paste; paste := ""
writes(left(dest,60))
}
savetree(st1)
st := expand(word,XY,dest,st1)
showtree(st,"expanded",1)
} else if choice=="mc" then {
writes(word,XY)
st1 := x_cmd(word,XY,st1,"m")
showtree(st1,"m-command",0)
} else if choice=="mi" then {
writes(word,XY)
savetree(st1)
st := mirror(word, XY, st1)
showtree(st,"mirrored",1)
} else if choice == "gv" then {
writes(word,XY)
st1 := x_cmd(word,XY,st1,"m")
st1 := govern(st1)
showtree(st1,"government",0)
} else if choice == "Gv" then {
writes(word,XY)
st1 := govern1(word,XY,st1)
showtree(st1,"passive government",0)
} else if choice == "re" then {
x := whereXY()[1]
writes(word,XY, " TO<string>: ")
repeat {
dest := readst(whereXY()[1],whereXY()[2])
if not find("(",dest) then {
savetree(st1)
st := Rename(word,XY,dest,st1)
showtree(st,"renamed",1)
break
} else gotoXY(x,optline+1)
}
}
qwrite(1,optline,menu,normattr)
gotoXY(1,optline+1); clreol(normattr)
gotoXY(1,optline+2); clreol(normattr)
gotoXY(*menu+1,optline)
while kbhit() do getch()
}
end
procedure cpy(source, sXY, dest, dXY, st1)
local spos, dpos
writ("COPY:")
writ("st1=",st1)
(spos := getnodepos(source,sXY,st1)) | fail
if st1[spos-1]=="(" then spos-:=1
st1 ? if tab(spos) then source := tab(bal(',)'))
if (dest=="") & find("(",source) then { # freefloat copies
if match(",1.",dXY) then dpos:=1 else dpos:=2
if dpos=1 then return "xxx," || source || "," || st1[5:0] # add to left
else return st1 || source || ","
}
(dpos := getnodepos(dest,dXY,st1)) | fail
if st1[dpos-1]=="(" then dpos -:=1
st1 ? if tab(dpos) then dest := tab(bal(',)'))
writ("spos/dpos=", spos, " ", dpos)
writ("source=",source)
writ("dest=",dest)
st1 := st1[1:dpos] || source || st1[dpos+*dest:0]
writ(1,"st1=",st1)
return st1
end
procedure getnodepos(word,XY,st1)
if integer(XY) then wpos:=XY else {
wpos := 0
post ? if tab(find(XY)) then {
=XY
wpos := tab(many(&digits))
}
}
if wpos>0 then return +wpos
end
procedure x_cmd(word,XY,st1,cmdtype)
## m or c-command
if word=="" then fail
if integer(XY) then tpos:=XY else {
tpos := 0
post ? if tab(find(XY)) then {
=XY
tpos := tab(many(&digits))
}
}
writ("tpos=",tpos)
# flag word
st1 ? if tab(tpos) & ="(" then {
tab(find(","||word)+1) ## else fail
tpos:=&pos
}
if tpos>0 then st1:=st1[1:tpos] || "°" || st1[tpos:0] else fail
writ("st1=",st1)
st1 := xchg(st1,"(","( ")
st1 := xchg(st1,",",", ")
st1 := xchg(st1," (","(")
word := " °" || word
#(xp := getnodepos(word, st1)) | fail
(xp := find(word,st1)) | fail
writ(1,"xp:0=",st1[xp:0])
st1 ? if tab(xp) then {
##=","
move(-1)
xp := &pos
if any("(") then { ## is a subtree
subtree := tab(bal(',)'))
subtree[2] := "!"
subtree := map(subtree," ","~")
#writ("subtree=", subtree)
st1 := st1[1:xp] || subtree || st1[xp+*subtree:0]
} else { ## a terminal
move(1)
st1[&pos] := "!"
move(1)
}
&subject := st1
&pos := xp
while move(-1) do {
xp := &pos
if st1[xp]=="(" then {
subtree := tab(bal(',)'))
if not find("!",subtree) then {
&pos := xp
next
}
subtree[2] := "~"
subtree := map(subtree," ","$")
#writ("subtree=", subtree)
st1 := st1[1:xp] || subtree || st1[xp+*subtree:0]
if (st1[xp+3] == "P") & (cmdtype=="m") then break
if find("$",subtree) & (cmdtype=="c") then break
&subject := st1
&pos := xp
}
}
}
st1 := xchg(st1," ","")
st1 := xchg(st1,"°","")
#writ(1,"ret st1=", st1)
return st1
end
procedure mirror(source,XY, st1)
writ("source=",source)
if source~=="" then {
(spos := getnodepos(source, XY, st1)) | fail
if st1[spos-1]=="(" then spos-:=1 else fail
}
st1 ? if tab(spos) then source := tab(bal(',)'))
A:=B:=W:=newst:=""
source ? if ="(" then {
W := "(" || tab(upto(',')+1)
A := tab(bal(',)'))
move(1)
while B := tab(bal(',)')+1) do
if &pos < *source then newst ||:= B
}
if *A * *B * *W=0 then fail
B := B[1:-1] || ","
newst := W || B || newst || A || ")"
writ(1,"new=",newst)
return st1[1:spos] || newst || st1[spos+*source:0]
end
procedure expand(source, XY, dest,st1)
writ("EXPAND")
writ("source=",source)
writ("XY/dest=",XY,dest)
if match(",1.",XY) then X:=1 else X:=2 #leftright
if X>1 & source~=="" then {
(spos := getnodepos(source, XY, st1)) | fail
if st1[spos-1]=="(" then spos-:=1
st1 ? if tab(spos) then source := tab(bal(',)'))
}
if dest~=="" then { # handle dest options
if not find("(",dest) then {
if dest[1]==" " then { # ditto char [space]John; .A,B
dest := dest[2:0]
if any(~'(',source) then # source=term?
dest:= "(" || source || "," || dest || ")" else # (N,John)
dest:= source[1:-1] || "," || dest || ")" # (NP,det,A,B)
}
else dest := map("(1P,1Sp,(1bar,1,YP))","1",dest[1])
}
}
writ(1,"st1=",st1)
if X=1 then return "xxx," || dest || "," || st1[5:0] # add to left
if source=="" then return st1 || dest || ","
st1 ? if tab(spos) then {
paste := tab(bal(',)'))
if dest=="" then spos-:=1
st1 := st1[1:spos] || dest || tab(0)
if st1[spos+:2]==",)" then fail # cutting (A,x)
}
## avoid ..(XP)..
st1 ? if tab(spos<-find("(")) & ="(" & tab(many(~',)')) & any(')') then {
st1[&pos]:=""
st1[spos]:=""
}
writ(1,"st1=",st1)
return st1
end
procedure Rename(source,XY,dest,st1)
writ("RENAME:")
(spos := getnodepos(source, XY, st1)) | fail
st1 ? if tab(spos) then {
tab(find(source)) | fail
spos := &pos
tab(upto(',)'))
st1 := st1[1:spos] || dest || tab(0)
}
return st1
end
procedure movealfa(source, sXY, dest, dpos, st1)
local spos, x
writ("MOVEALFA:")
writ("st1=",st1)
(spos := getnodepos(source,sXY,st1)) | fail
if st1[spos-1]=="(" then spos-:=1
st1 ? if tab(spos) then source := tab(bal(',)'))
writ("spos/dpos=", spos, " ", dpos)
writ("source=",source)
writ(1,"dest=",dest)
## chk move with/o trace: 1) whole trees 2) grabs
if source[1]=="(" then {
if find(".2=",sXY) | (dest=="?"||source[2:upto(',',source)]) then {
if dpos<spos then
return st1[1:dpos] || source || st1[dpos+*dest:spos] ||
st1[spos+*source:0] else
if spos<dpos then
return st1[1:spos] || st1[spos+*source:dpos] || source ||
st1[dpos+*dest:0] else fail
}
}
n := "#" || @indx
source ? if ="(" then newsource := "(" || tab(upto(',')) || n || tab(0) else
newsource := source || n
if dpos < spos then {
st1 := st1[1:dpos] || newsource || st1[dpos+*dest:spos] ||
n || st1[spos+*source:0]
until st1[-1]==")" do st1[-1]:=""
} else if spos < dpos then {
st1 := st1[1:spos] || n || st1[spos+*source:dpos] || newsource ||
st1[dpos+*dest:0]
until st1[-1]==")" do st1[-1]:=""
} else fail
st1 ||:= ","
writ(1,"st1=",st1)
return st1
end
procedure adjoin(source,sXY,dpos,st1)
local spos, x, xpos
writ("ADJOIN:")
if *source = 0 then fail
(spos := getnodepos(source,sXY,st1)) | fail
st1 ? while tab(xpos:=upto(',')+1) do {
x := tab(bal(','))
if &pos>spos then { source := x; spos:=xpos; break }
}
if /x then fail
st1 ? if tab(dpos) then dest := tab(bal(',)'))
writ("spos/dpos=", spos, " ", dpos)
writ("source=",source)
writ(1,"dest=",dest)
if find("(",dest) then {
oribar := dest
if spos > dpos then
newbar := oribar[1:upto(',',oribar)+1] || oribar || ",11)" else
newbar := oribar[1:upto(',',oribar)+1] || "11," || oribar || ")"
newbar := xchg(newbar,"11",source)
writ("oribar=",oribar)
writ("newbar=",newbar)
}
if spos>dpos then
st1 := st1[1:dpos] || newbar || st1[dpos+*dest:spos] ||
st1[spos+*source+1:0] else
st1 := st1[1:spos] || st1[spos+*source+1:dpos] || newbar ||
st1[dpos+*dest:0]
writ(1,"st1=",st1)
return st1
end
procedure govern1(word,XY,st1)
if word=="" then fail
(spos := getnodepos(word,XY,st1)) | fail
offs := 0
st1 ? if tab(spos) then {
tab(upto(',)'))
offs:=&pos
}
st1 := st1[1:offs] || "²" || st1[offs:0]
writ(1,"st1/²=",st1)
st1 ? while tab(spos:=upto('(')) do {
st0 := st1
if match("(P,"|"(V,"|"(I,"|"(N,") then {
XY := &pos+1
word := st1[XY]
writ(1,"word=",word)
guvcat := tab(bal(',)'))
writ(1,"guvcat=",guvcat)
if (word=="I") & find(",to)"|",+t0)", guvcat) then {
&pos:=spos+1; next
}
writ("word=",word)
writ(1,"st0=",st0)
st0 := x_cmd(word,XY,st0,"m")
writ("st0 after mcmd=",st0)
st0 := govern(st0)
writ(1,"st0 after gov=",st0)
st0 ? while tab(upto('^')) do {
tab(many(~' ²,)'))
if any('²') then return xchg(st0,"²","")
}
}
&pos:=spos+1
}
end
procedure govern(st1)
local xp, xpos
writ(1,"gov.st1=", st1)
if find(("!I,~to"|"!I,~+t0"),st1) then return st1
st1 ? while tab(xpos:=upto('$')) do {
tab(upto('²,)'))
if st1[&pos-1]=="P" then {
&pos := xpos
st1[&pos] := "^"
if st1[&pos-1]=="(" then {
move(-1)
xp := tab(bal(',)'))
writ("xp=",xp)
# enter IP if..
if match("($IP",xp) & find("($I,$to)"|"($I,$+t0",xp) then move(-(*xp-2))
next
}
} else &pos:=xpos
move(2)
}
return st1
end
procedure showtree(L, message, x)
write(out,L)
mlist := []
hidemouse()
L:="(" || L || ")"
if find(" ,"|",,",L) then {
L := xchg(L," ,",",")
L := xchg(L,",,",",")
#writes("error in treestring")
#getch()
}
Lines := []; inter := []
every 1 to max do {
##Lines[i]:=""; inter[i]:=""
put(Lines,""); put(inter,"")
}
if x=0 then posting:=0 else {
posting := 1; post := ""
}
message := left(trim(message,":"),79)
handlelist(L,1,0)
postproc()
show()
showmouse()
#gotoXY(1,22); write(post);
#write(out,post)
end
procedure show()
local screenst
screenst := ""
every i:=2 to max do {
screenst ||:= left(map(Lines[i],".ⁿ·√"," .,"),80)
if i < max then screenst ||:= left(map(inter[i],"ⁿ."," "), 80)
write(out,map(Lines[i],".ⁿ·√"," .,"))
write(out,map(inter[i],"ⁿ."," "))
}
attr := char(normattr)
st1 := repl(attr,*screenst)
while attr := get(mlist) do {
xpos := get(mlist)
every i := xpos to xpos+(get(mlist)-1) do
st1[i] := attr
}
if verbose=1 then {
gotoXY(1,1)
write(screenst)
fail
}
st1 := map(st1,"!$~^",xattr)
screenst := collate(screenst, st1)
Poke([47104,0],screenst)
#if getch()=="q" then stop()
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,tpos)
local ccol, clen, cattr, xcol,xlen, xxattr,mempos
#writ(1,tpos)
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)
mempos := &pos-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 {
xxattr := x[1]
x[1] := ""
} else xxattr := ""
xlen := *x
if *x<catlen then x:=center(x,catlen,"ⁿ")
if insitu=1 then xline:=n+2 else xline := max
if xline> max then xline:=max
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
if insitu=0 then
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
} else {
every i := n+2 to max do {
Lines[i]:=left(Lines[i], *Lines[n+1],".")
inter[i]:=left(inter[i], *Lines[n+1],".")
}
}
Lines[xline] := left(Lines[xline], *Lines[n+1]- (*x+2)) || "." || x || "."
if insitu=0 then inter[xline] := left(".", *Lines[xline])
xcol := *Lines[xline]-(*x+1)
Lines[xline] ? if move(xcol) then {
tab(many('.ⁿ'))
xcol := &pos
}
if posting=1 then
post ||:= "," || xcol || "." || xline || "=" || tpos+mempos
if *xxattr>0 then {
put(mlist,xxattr)
put(mlist,(xline-2)*160+xcol)
put(mlist,xlen)
xxattr := ""
}
#show("item")
} else handlelist(x, n+1, tpos+mempos)
}
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 posting=1 then post ||:= "," || ccol || "." || n || "=" || tpos+1
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
}
if posting=1 then post ||:= "," || ccol || "." || n || "=" || tpos+1
} 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
}
if posting=1 then post ||:= "," || ccol || "." || n || "=" || tpos+1
#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 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
#### VIDEO ROUTINES ########
procedure collate(s1,s2)
# ex ICON PROG LIBRARY
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
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
procedure clrscr(attr)
Poke([47104, 0], repl(" "||char(attr), 4000))
end
procedure newattr(x,y,attr)
local offset
offset := 2*((y-1)*80 + (x - 1))+1
Poke([47104,offset],char(attr))
end
procedure qread(x,y)
# read the char at screen position x,y
local offset
offset:= 2* ((y-1)*80+(x-1))
return Peek([47104, offset],1)
end
procedure readattr(x,y)
# read the attr at screen position x,y
local offset
offset:= 2* ((y-1)*80+(x-1)) + 1
return ord(Peek([47104, offset],1))
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 clreol(attr)
local x, y, offset, s
x := whereXY()[1]; y := whereXY()[2]
offset := 2*((y-1)*80 + (x - 1))
s := repl(" "||char(attr), 81-x)
Poke([47104,offset],s)
end
procedure whereXY()
local dx
dx := Int86([16,768,0,0,0,0,0,0,0])[5]
return [ (dx % 256)+1, (dx / 256)+1 ]
end
### MOUSE ####
procedure setY(min,max)
# vertical limits for mouse moves
Int86([51, 8,0,min,max, 0,0,0,0])
end
procedure initmouse()
return Int86([51, 0,0,0,0, 0,0,0,0])[2]
end
procedure showmouse()
Int86([51,1,0,0,0,0,0,0,0])
end
procedure hidemouse()
Int86([51,2,0,0,0,0,0,0,0])
end
procedure getmousepos()
local a
static L
initial L := [51,3,0,0,0,0,0,0,0]
a := Int86(L)
return [ a[4], a[5], a[3]]
end
procedure buttonpress(button)
return Int86([51, 5,button,0,0, 0,0,0,0])[3]
end