{4:} {9:} (*$C-*) {(*$C+*)} {:9} program MF(input, output); {6:} {------------------------------} { declarations are in mf2ps1.h } {------------------------------} #include "mf2ps1.h" {------------------------------} #include "mf_ext.h" #include "mf_window.h" procedure initialize; {19:} var i: 0..127; {:19} {130:} k: integer; {:130} {21:} begin xchr[32] := ' '; xchr[33] := '!'; xchr[34] := '"'; xchr[35] := '#'; xchr[36] := '$'; xchr[37] := '%'; xchr[38] := '&'; xchr[39] := ''''; xchr[40] := '('; xchr[41] := ')'; xchr[42] := '*'; xchr[43] := '+'; xchr[44] := ','; xchr[45] := '-'; xchr[46] := '.'; xchr[47] := '/'; xchr[48] := '0'; xchr[49] := '1'; xchr[50] := '2'; xchr[51] := '3'; xchr[52] := '4'; xchr[53] := '5'; xchr[54] := '6'; xchr[55] := '7'; xchr[56] := '8'; xchr[57] := '9'; xchr[58] := ':'; xchr[59] := ';'; xchr[60] := '<'; xchr[61] := '='; xchr[62] := '>'; xchr[63] := '?'; xchr[64] := '@'; xchr[65] := 'A'; xchr[66] := 'B'; xchr[67] := 'C'; xchr[68] := 'D'; xchr[69] := 'E'; xchr[70] := 'F'; xchr[71] := 'G'; xchr[72] := 'H'; xchr[73] := 'I'; xchr[74] := 'J'; xchr[75] := 'K'; xchr[76] := 'L'; xchr[77] := 'M'; xchr[78] := 'N'; xchr[79] := 'O'; xchr[80] := 'P'; xchr[81] := 'Q'; xchr[82] := 'R'; xchr[83] := 'S'; xchr[84] := 'T'; xchr[85] := 'U'; xchr[86] := 'V'; xchr[87] := 'W'; xchr[88] := 'X'; xchr[89] := 'Y'; xchr[90] := 'Z'; xchr[91] := '['; xchr[92] := '\'; xchr[93] := ']'; xchr[94] := '^'; xchr[95] := '_'; xchr[96] := '`'; xchr[97] := 'a'; xchr[98] := 'b'; xchr[99] := 'c'; xchr[100] := 'd'; xchr[101] := 'e'; xchr[102] := 'f'; xchr[103] := 'g'; xchr[104] := 'h'; xchr[105] := 'i'; xchr[106] := 'j'; xchr[107] := 'k'; xchr[108] := 'l'; xchr[109] := 'm'; xchr[110] := 'n'; xchr[111] := 'o'; xchr[112] := 'p'; xchr[113] := 'q'; xchr[114] := 'r'; xchr[115] := 's'; xchr[116] := 't'; xchr[117] := 'u'; xchr[118] := 'v'; xchr[119] := 'w'; xchr[120] := 'x'; xchr[121] := 'y'; xchr[122] := 'z'; xchr[123] := '{'; xchr[124] := '|'; xchr[125] := '}'; xchr[126] := '~'; xchr[0] := ' '; xchr[127] := ' '; {:21} {22:} for i := 1 to 31 do xchr[i] := ' '; xchr[9] := chr(9); xchr[12] := chr(12); {:22} {23:} for i := 0 to 127 do xord[chr(i)] := 127; for i := 1 to 126 do xord[xchr[i]] := i; {:23} {69:} interaction := 3; {:69} {72:} deletionsallowed := true; errorcount := 0; {:72} {75:} helpptr := 0; useerrhelp := false; errhelp := 0; {:75} {92:} interrupt := 0; OKtointerrupt := true; {:92} {98:} aritherror := false; {:98} {131:} twotothe[0] := 1; for k := 1 to 30 do twotothe[k] := 2 * twotothe[k - 1]; speclog[1] := 93032640; speclog[2] := 38612034; speclog[3] := 17922280; speclog[4] := 8662214; speclog[5] := 4261238; speclog[6] := 2113709; speclog[7] := 1052693; speclog[8] := 525315; speclog[9] := 262400; speclog[10] := 131136; speclog[11] := 65552; speclog[12] := 32772; speclog[13] := 16385; for k := 14 to 27 do speclog[k] := twotothe[27 - k]; speclog[28] := 1; {:131} {138:} specatan[1] := 27855475; specatan[2] := 14718068; specatan[3] := 7471121; specatan[4] := 3750058; specatan[5] := 1876857; specatan[6] := 938658; specatan[7] := 469357; specatan[8] := 234682; specatan[9] := 117342; specatan[10] := 58671; specatan[11] := 29335; specatan[12] := 14668; specatan[13] := 7334; specatan[14] := 3667; specatan[15] := 1833; specatan[16] := 917; specatan[17] := 458; specatan[18] := 229; specatan[19] := 115; specatan[20] := 57; specatan[21] := 29; specatan[22] := 14; specatan[23] := 7; specatan[24] := 4; specatan[25] := 2; specatan[26] := 1; {:138} {179:} {wasmemend:=-30000;waslomax:=-30000;washimin:=memmax;panicking:=false;} {:179} {191:} for k := 1 to 40 do internal[k] := 0; intptr := 40; {:191} {199:} for k := 48 to 57 do charclass[k] := 0; charclass[46] := 1; charclass[32] := 2; charclass[37] := 3; charclass[34] := 4; charclass[44] := 5; charclass[59] := 6; charclass[40] := 7; charclass[41] := 8; for k := 65 to 90 do charclass[k] := 9; for k := 97 to 122 do charclass[k] := 9; charclass[95] := 9; charclass[60] := 10; charclass[61] := 10; charclass[62] := 10; charclass[58] := 10; charclass[124] := 10; charclass[96] := 11; charclass[39] := 11; charclass[43] := 12; charclass[45] := 12; charclass[47] := 13; charclass[42] := 13; charclass[92] := 13; charclass[33] := 14; charclass[63] := 14; charclass[35] := 15; charclass[38] := 15; charclass[64] := 15; charclass[36] := 15; charclass[94] := 16; charclass[126] := 16; charclass[91] := 17; charclass[93] := 18; charclass[123] := 19; charclass[125] := 19; for k := 0 to 31 do charclass[k] := 20; charclass[127] := 20; charclass[9] := 2; charclass[12] := 2; {:199} {202:} hash[1].lh := 0; hash[1].rh := 0; eqtb[1].lh := 41; eqtb[1].rh := -30000; for k := 2 to 2241 do begin hash[k] := hash[1]; eqtb[k] := eqtb[1] end; {:202} {231:} bignodesize[13] := 12; bignodesize[14] := 4; {:231} {251:} saveptr := -30000; {:251} {396:} octantdir[1] := 415; octantdir[5] := 416; octantdir[6] := 417; octantdir[2] := 418; octantdir[4] := 419; octantdir[8] := 420; octantdir[7] := 421; octantdir[3] := 422; {:396} {428:} maxroundingptr := 0; {:428} {449:} octantcode[1] := 1; octantcode[2] := 5; octantcode[3] := 6; octantcode[4] := 2; octantcode[5] := 4; octantcode[6] := 8; octantcode[7] := 7; octantcode[8] := 3; for k := 1 to 8 do octantnumber[octantcode[k]] := k; {:449} {456:} revturns := false; {:456} {462:} xcorr[1] := 0; ycorr[1] := 0; xycorr[1] := 0; xcorr[5] := 0; ycorr[5] := 0; xycorr[5] := 1; xcorr[6] := -1; ycorr[6] := 1; xycorr[6] := 0; xcorr[2] := 1; ycorr[2] := 0; xycorr[2] := 1; xcorr[4] := 0; ycorr[4] := 1; xycorr[4] := 1; xcorr[8] := 0; ycorr[8] := 1; xycorr[8] := 0; xcorr[7] := 1; ycorr[7] := 0; xycorr[7] := 1; xcorr[3] := -1; ycorr[3] := 1; xycorr[3] := 0; for k := 1 to 8 do zcorr[k] := xycorr[k] - xcorr[k]; {:462} {570:} screenstarted := false; screenOK := false; {:570} {573:} for k := 0 to 15 do begin windowopen[k] := false; windowtime[k] := 0 end; {:573} {593:} fixneeded := false; watchcoefs := true; {:593} {739:} condptr := -30000; iflimit := 0; curif := 0; ifline := 0; {:739} {753:} loopptr := -30000; {:753} {776:} MFbasedefault := 'plain.base'; {:776} {797:} curexp := 0; {:797} {822:} varflag := 0; {:822} {1078:} startsym := 0; {:1078} {1085:} longhelpseen := false; {:1085} {1097:} for k := 0 to 255 do begin tfmwidth[k] := 0; tfmheight[k] := 0; tfmdepth[k] := 0; tfmitalcorr[k] := 0; charexists[k] := false; chartag[k] := 0; charremainder[k] := 0 end; for k := 1 to headersize do headerbyte[k] := -1; bc := 255; ec := 0; nl := 0; nk := 0; ne := 0; np := 0; {:1097} {1150:} gfprevptr := 0; totalchars := 0; {:1150} {1153:} halfbuf := gfbufsize div 2; gflimit := gfbufsize; gfptr := 0; gfoffset := 0; {:1153} {1184:} baseident := 0; {:1184} {1215:} editnamestart := 0 end; {:1215} {57:} procedure println; begin case selector of 3: begin writeln(output); writeln(logfile); termoffset := 0; fileoffset := 0 end; 2: begin writeln(logfile); fileoffset := 0 end; 1: begin writeln(output); termoffset := 0 end; 0, 4, 5: null end end; {:57} {58:} procedure printchar(s: ASCIIcode); var tmp : integer; begin case selector of 3: begin {----------------------------------} if xchr[s] = '[' then begin ascii_on := true; ascval := 0; end else if xchr[s] = ']' then begin ascii_on := false; sendascii(ascval); end else if ascii_on then begin tmp := s - ord('0'); ascval := ascval*10+tmp; end; {-------------------------------------} write(output, xchr[s]); write(logfile, xchr[s]); termoffset := termoffset + 1; fileoffset := fileoffset + 1; if termoffset = maxprintline then begin writeln(output); termoffset := 0 end; if fileoffset = maxprintline then begin writeln(logfile); fileoffset := 0 end end; 2: begin write(logfile, xchr[s]); fileoffset := fileoffset + 1; if fileoffset = maxprintline then println end; 1: begin write(output, xchr[s]); termoffset := termoffset + 1; if termoffset = maxprintline then println end; 0: null; 4: if tally < trickcount then trickbuf[tally mod errorline] := s; 5: begin if poolptr < poolsize then begin strpool[poolptr] := s; poolptr := poolptr + 1 end end end; tally := tally + 1 end; {:58} {59:} procedure print(s: integer); var j: poolpointer; begin if (s < 0) or (s >= strptr) then s := 131; j := strstart[s]; while j < strstart[s + 1] do begin printchar(strpool[j]); j := j + 1 end end; {:59} {60:} procedure slowprint(s: integer); var j: poolpointer; begin if (s < 0) or (s >= strptr) then s := 131; j := strstart[s]; while j < strstart[s + 1] do begin print(strpool[j]); j := j + 1 end end; {:60} {62:} procedure printnl(s: strnumber); begin if ((termoffset > 0) and odd(selector)) or ((fileoffset > 0) and (selector >= 2)) then println; print(s) end; {:62} {63:} procedure printthedigs(k: eightbits); begin while k > 0 do begin k := k - 1; printchar(48 + dig[k]) end end; {:63} {64:} procedure printint(n: integer); var k: 0..23; m: integer; begin k := 0; if n < 0 then begin printchar(45); if n > (-100000000) then n := -n else begin m := (-1) - n; n := m div 10; m := (m mod 10) + 1; k := 1; if m < 10 then dig[0] := m else begin dig[0] := 0; n := n + 1 end end end; repeat dig[k] := n mod 10; n := n div 10; k := k + 1 until n = 0; printthedigs(k) end; {:64} {103:} procedure printscaled(s: scaled); var delta: scaled; begin if s < 0 then begin printchar(45); s := -s end; printint(s div 65536); s := (10 * (s mod 65536)) + 5; if s <> 5 then begin delta := 10; printchar(46); repeat if delta > 65536 then s := (s + 32768) - (delta div 2); printchar(48 + (s div 65536)); s := 10 * (s mod 65536); delta := delta * 10 until s <= delta end end; {:103} {104:} procedure printtwo(x, y: scaled); begin printchar(40); printscaled(x); printchar(44); printscaled(y); printchar(41) end; {:104} {187:} procedure printtype(t: smallnumber); begin if t in [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 17, 18, 15, 19, 20, 21, 22, 23] then case t of 1: print(194); 2: print(195); 3: print(196); 4: print(197); 5: print(198); 6: print(199); 7: print(200); 8: print(201); 9: print(202); 10: print(203); 11: print(204); 12: print(205); 13: print(206); 14: print(207); 16: print(208); 17: print(209); 18: print(210); 15: print(211); 19: print(212); 20: print(213); 21: print(214); 22: print(215); 23: print(216) end else print(217) end; {:187} {195:} procedure begindiagnostic; begin oldsetting := selector; if (internal[13] <= 0) and (selector = 3) then begin selector := selector - 1; if history = 0 then history := 1 end end; { begindiagnostic } procedure enddiagnostic(blankline: boolean); begin printnl(155); if blankline then println; selector := oldsetting end; {:195} {197:} procedure printdiagnostic(s, t: strnumber; nuline: boolean); begin begindiagnostic; if nuline then printnl(s) else print(s); print(320); printint(line); print(t); printchar(58) end; {:197} {773:} procedure printfilename(n, a, e: integer); begin print(a); print(n); print(e) end; {:773} {73:} procedure normalizeselector; forward; procedure getnext; forward; procedure terminput; forward; procedure showcontext; forward; procedure beginfilereading; forward; procedure openlogfile; forward; procedure closefilesandtermina; forward; procedure clearforerrorprompt; forward; {procedure debughelp;forward;} {43:} procedure flushstring(s: strnumber); begin if s < (strptr - 1) then strref[s] := 0 else repeat strptr := strptr - 1 until strref[strptr - 1] <> 0; poolptr := strstart[strptr] end; {:43} {:73} {76:} procedure jumpout; begin goto 9998 end; {:76} {77:} procedure error; label 22, 10; var c: ASCIIcode; s1, s2, s3: integer; j: poolpointer; begin if history < 2 then history := 2; printchar(46); showcontext; if interaction = 3 then {78:} while true do begin 22: clearforerrorprompt; begin print(135); terminput end; if last = first then goto 10; c := buffer[first]; if c >= 97 then c := c - 32; {79:} if c in [48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 69, 72, 73, 81, 82, 83, 88] then case c of 48, 49, 50, 51, 52, 53, 54, 55, 56, 57: if deletionsallowed then begin {83:} s1 := curcmd; s2 := curmod; s3 := cursym; OKtointerrupt := false; if ((last > (first + 1)) and (buffer[first + 1] >= 48)) and (buffer[first + 1] <= 57) then c := ((c * 10) + buffer[first + 1]) - (48 * 11) else c := c - 48; while c > 0 do begin getnext; {743:} if curcmd = 39 then begin if strref[curmod] < 127 then if strref[curmod] > 1 then strref[curmod] := strref[curmod] - 1 else flushstring(curmod) end {:743}; c := c - 1 end; curcmd := s1; curmod := s2; cursym := s3; OKtointerrupt := true; begin helpptr := 2; helpline[1] := 148; helpline[0] := 149 end; showcontext; goto 22 end {:83}; {68:begin debughelp;goto 22;end;} 69: if fileptr > 0 then begin editnamestart := strstart[inputstack[fileptr].namefield]; editnamelength := strstart[inputstack[fileptr].namefield + 1] - strstart[inputstack[fileptr].namefield]; editline := line; jumpout end; 72: begin {84:} if useerrhelp then begin {85:} j := strstart[errhelp]; while j < strstart[errhelp + 1] do begin if strpool[j] <> 37 then print(strpool[j]) else if (j + 1) = strstart[errhelp + 1] then println else if strpool[j + 1] <> 37 then println else begin j := j + 1; printchar(37) end; j := j + 1 end {:85}; useerrhelp := false end else begin if helpptr = 0 then begin helpptr := 2; helpline[1] := 150; helpline[0] := 151 end; repeat helpptr := helpptr - 1; print(helpline[helpptr]); println until helpptr = 0 end; begin helpptr := 4; helpline[3] := 152; helpline[2] := 151; helpline[1] := 153; helpline[0] := 154 end; goto 22 end; {:84} 73: begin {82:} beginfilereading; if last > (first + 1) then begin curinput.locfield := first + 1; buffer[first] := 32 end else begin begin print(147); terminput end; curinput.locfield := first end; first := last + 1; curinput.limitfield := last; goto 10 end; {:82} 81, 82, 83: begin {81:} errorcount := 0; interaction := (0 + c) - 81; print(142); case c of 81: begin print(143); selector := selector - 1 end; 82: print(144); 83: print(145) end; print(146); println; flush(output); goto 10 end; {:81} 88: begin interaction := 2; jumpout end end else null; {80:} begin print(136); printnl(137); printnl(138); if fileptr > 0 then print(139); if deletionsallowed then printnl(140); printnl(141) end {:80} {:79} end {:78}; errorcount := errorcount + 1; if errorcount = 100 then begin printnl(134); history := 3; jumpout end; {86:} if interaction > 0 then selector := selector - 1; if useerrhelp then begin printnl(155); {85:} j := strstart[errhelp]; while j < strstart[errhelp + 1] do begin if strpool[j] <> 37 then print(strpool[j]) else if (j + 1) = strstart[errhelp + 1] then println else if strpool[j + 1] <> 37 then println else begin j := j + 1; printchar(37) end; j := j + 1 end {:85} end else while helpptr > 0 do begin helpptr := helpptr - 1; printnl(helpline[helpptr]) end; println; if interaction > 0 then selector := selector + 1; {:86} println; 10: null end; {:77} {88:} procedure fatalerror(s: strnumber); begin normalizeselector; begin if interaction = 3 then null; printnl(133); print(156) end; begin helpptr := 1; helpline[0] := s end; begin if interaction = 3 then interaction := 2; error; {if interaction>0 then debughelp;} history := 3; jumpout end end; {:88} {89:} procedure overflow(s: strnumber; n: integer); begin normalizeselector; begin if interaction = 3 then null; printnl(133); print(157) end; print(s); printchar(61); printint(n); printchar(93); begin helpptr := 2; helpline[1] := 158; helpline[0] := 159 end; begin if interaction = 3 then interaction := 2; error; {if interaction>0 then debughelp;} history := 3; jumpout end end; {:89} {90:} procedure confusion; begin normalizeselector; if history < 2 then begin begin if interaction = 3 then null; printnl(133); print(160) end; print(s); printchar(41); begin helpptr := 1; helpline[0] := 161 end end else begin begin if interaction = 3 then null; printnl(133); print(162) end; begin helpptr := 2; helpline[1] := 163; helpline[0] := 164 end end; begin if interaction = 3 then interaction := 2; error; {if interaction>0 then debughelp;} history := 3; jumpout end end; {:90} {:4} {26:} function aopenin(var f: alphafile; pathspecifier: integer): boolean; var ok: boolean; begin if testaccess(nameoffile, realnameoffile, 4, pathspecifier) then begin reset(f, realnameoffile); ok := true end else ok := false; aopenin := ok end; { aopenin } function aopenout(var f: alphafile): boolean; var ok: boolean; begin if testaccess(nameoffile, realnameoffile, 2, 0) then begin rewrite(f, realnameoffile); ok := true end else ok := false; aopenout := ok end; { aopenout } function wopenin(var f: wordfile): boolean; var ok: boolean; begin if testaccess(nameoffile, realnameoffile, 4, 7) then begin reset(f, realnameoffile); ok := true end else ok := false; wopenin := ok end; { wopenin } function wopenout(var f: wordfile): boolean; var ok: boolean; begin if testaccess(nameoffile, realnameoffile, 2, 0) then begin rewrite(f, nameoffile); ok := true end else ok := false; wopenout := ok end; {:26} {27:} procedure aclose(var f: alphafile); begin closea(f) end; { aclose } procedure wclose(var f: wordfile); begin closew(f) end; {:27} {30:} function inputln(var f: alphafile; bypasseoln: boolean): boolean; var lastnonblank: 0..bufsize; begin if bypasseoln then if not eof(f) then if eoln(f) then get(f); last := first; if eof(f) then inputln := false else begin lastnonblank := first; while not eoln(f) do begin if last >= maxbufstack then begin maxbufstack := last + 1; if maxbufstack = bufsize then overflow(128, bufsize) end; buffer[last] := xord[f^]; get(f); last := last + 1; if buffer[last - 1] <> 32 then lastnonblank := last end; last := lastnonblank; inputln := true end end; {:30} {36:} function initterminal: boolean; label 10; var dummy, i, j, k: integer; arg: packed array [1..100] of char; begin if argc > 1 then begin last := first; for i := 1 to argc - 1 do begin argv(i, arg); j := 1; k := 100; while (k > 1) and (arg[k] = ' ') do k := k - 1; while j <= k do begin buffer[last] := xord[arg[j]]; j := j + 1; last := last + 1 end; if k > 1 then begin buffer[last] := xord[' ']; last := last + 1 end end; if last > first then begin curinput.locfield := first; initterminal := true; goto 10 end end; while true do begin write(output, '**'); flush(output); if not inputln(input, true) then begin writeln(output); writeln(output, '! End of file on the terminal... why?'); initterminal := false; goto 10 end; curinput.locfield := first; while (curinput.locfield < last) and (buffer[curinput.locfield] = 32) do curinput.locfield := curinput.locfield + 1; if curinput.locfield < last then begin initterminal := true; goto 10 end; writeln(output, 'Please type the name of your input file.') end; 10: null end; { initterminal } {:36} {44:} function makestring: strnumber; begin if strptr = maxstrptr then begin if strptr = maxstrings then overflow(130, maxstrings - initstrptr); maxstrptr := maxstrptr + 1 end; strref[strptr] := 1; strptr := strptr + 1; strstart[strptr] := poolptr; makestring := strptr - 1 end; { makestring } {:44} {45:} function streqbuf(s: strnumber; k: integer): boolean; label 45; var j: poolpointer; result: boolean; begin j := strstart[s]; while j < strstart[s + 1] do begin if strpool[j] <> buffer[k] then begin result := false; goto 45 end; j := j + 1; k := k + 1 end; result := true; 45: streqbuf := result end; {:45} {46:} function strvsstr(s, t: strnumber): integer; label 10; var j, k: poolpointer; ls, lt: integer; l: integer; begin ls := strstart[s + 1] - strstart[s]; lt := strstart[t + 1] - strstart[t]; if ls <= lt then l := ls else l := lt; j := strstart[s]; k := strstart[t]; while l > 0 do begin if strpool[j] <> strpool[k] then begin strvsstr := strpool[j] - strpool[k]; goto 10 end; j := j + 1; k := k + 1; l := l - 1 end; strvsstr := ls - lt; 10: null end; {:46} {47:} {function getstringsstarted:boolean;label 30,10; var k,l:0..127;m,n:char;g:strnumber;a:integer;c:boolean; begin poolptr:=0;strptr:=0;maxpoolptr:=0;maxstrptr:=0;strstart[0]:=0; [48:]for k:=0 to 127 do begin if([49:](k<32)or(k>126)[:49])then begin begin strpool[poolptr]:=94;poolptr:=poolptr+1;end; begin strpool[poolptr]:=94;poolptr:=poolptr+1;end; if k<64 then begin strpool[poolptr]:=k+64;poolptr:=poolptr+1; end else begin strpool[poolptr]:=k-64;poolptr:=poolptr+1;end; end else begin strpool[poolptr]:=k;poolptr:=poolptr+1;end;g:=makestring; strref[g]:=127;end[:48];[51:]nameoffile:=poolname; if aopenin(poolfile,8)then begin c:=false; repeat[52:]begin if eof(poolfile)then begin; writeln(output,'! mf.pool has no check sum.');aclose(poolfile); getstringsstarted:=false;goto 10;end;read(poolfile,m,n); if m='*'then[53:]begin a:=0;k:=1; while true do begin if(xord[n]<48)or(xord[n]>57)then begin; writeln(output,'! mf.pool check sum doesn''t have nine digits.'); aclose(poolfile);getstringsstarted:=false;goto 10;end; a:=10*a+xord[n]-48;if k=9 then goto 30;k:=k+1;read(poolfile,n);end; 30:if a<>503742536 then begin; writeln(output,'! mf.pool doesn''t match; tangle me again.'); aclose(poolfile);getstringsstarted:=false;goto 10;end;c:=true; end[:53]else begin if(xord[m]<48)or(xord[m]>57)or(xord[n]<48)or(xord[n]> 57)then begin; writeln(output,'! mf.pool line doesn''t begin with two digits.'); aclose(poolfile);getstringsstarted:=false;goto 10;end; l:=xord[m]*10+xord[n]-48*11; if poolptr+l+stringvacancies>poolsize then begin; writeln(output,'! You have to increase POOLSIZE.');aclose(poolfile); getstringsstarted:=false;goto 10;end; for k:=1 to l do begin if eoln(poolfile)then m:=' 'else read(poolfile,m) ;begin strpool[poolptr]:=xord[m];poolptr:=poolptr+1;end;end; readln(poolfile);g:=makestring;strref[g]:=127;end;end[:52];until c; aclose(poolfile);getstringsstarted:=true;end else begin; writeln(output,'! I can''t read mf.pool.');aclose(poolfile); getstringsstarted:=false;goto 10;end[:51];10:end;} {:47} {65:} procedure printdd(n: integer); begin n := abs(n) mod 100; printchar(48 + (n div 10)); printchar(48 + (n mod 10)) end; {:65} {66:} procedure terminput; var k: 0..bufsize; begin flush(output); if not inputln(input, true) then fatalerror(132); termoffset := 0; selector := selector - 1; if last <> first then for k := first to last - 1 do print(buffer[k]); println; buffer[last] := 37; selector := selector + 1 end; {:66} {87:} procedure normalizeselector; begin if jobname > 0 then selector := 3 else selector := 1; if jobname = 0 then openlogfile; if interaction = 0 then selector := selector - 1 end; {:87} {93:} procedure pauseforinstructions; begin if OKtointerrupt then begin interaction := 3; if (selector = 2) or (selector = 0) then selector := selector + 1; begin if interaction = 3 then null; printnl(133); print(165) end; begin helpptr := 3; helpline[2] := 166; helpline[1] := 167; helpline[0] := 168 end; deletionsallowed := false; error; deletionsallowed := true; interrupt := 0 end end; {:93} {94:} procedure missingerr(s: strnumber); begin begin if interaction = 3 then null; printnl(133); print(169) end; print(s); print(170) end; {:94} {99:} procedure cleararith; begin begin if interaction = 3 then null; printnl(133); print(171) end; begin helpptr := 4; helpline[3] := 172; helpline[2] := 173; helpline[1] := 174; helpline[0] := 175 end; error; aritherror := false end; {:99} {100:} function slowadd(x, y: integer): integer; begin if x >= 0 then if y <= (2147483647 - x) then slowadd := x + y else begin aritherror := true; slowadd := 2147483647 end else if (-y) <= (2147483647 + x) then slowadd := x + y else begin aritherror := true; slowadd := -2147483647 end end; {:100} {102:} function rounddecimals(k: smallnumber): scaled; var a: integer; begin a := 0; while k > 0 do begin k := k - 1; a := (a + (dig[k] * 131072)) div 10 end; rounddecimals := (a + 1) div 2 end; {:102} {112:} function takescaled(q: integer; f: scaled): integer; var p: integer; negative: boolean; n: integer; becareful: integer; {110:} begin if f >= 0 then negative := false else begin f := -f; negative := true end; if q < 0 then begin q := -q; negative := not negative end; {:110} if f < 65536 then n := 0 else begin n := f div 65536; f := f mod 65536; if q <= (2147483647 div n) then n := n * q else begin aritherror := true; n := 2147483647 end end; f := f + 65536; {113:} p := 32768; if q < 1073741824 then repeat if odd(f) then p := (p + q) div 2 else p := p div 2; f := f div 2 until f = 1 else repeat if odd(f) then p := p + ((q - p) div 2) else p := p div 2; f := f div 2 until f = 1 {:113}; becareful := n - 2147483647; if (becareful + p) > 0 then begin aritherror := true; n := 2147483647 - p end; if negative then takescaled := -(n + p) else takescaled := n + p end; {:112} {114:} function makescaled(p, q: integer): scaled; var f: integer; n: integer; negative: boolean; becareful: integer; begin if p >= 0 then negative := false else begin p := -p; negative := true end; if q <= 0 then begin {if q=0 then confusion(47);} q := -q; negative := not negative end; n := p div q; p := p mod q; if n >= 32768 then begin aritherror := true; if negative then makescaled := -2147483647 else makescaled := 2147483647 end else begin n := (n - 1) * 65536; {115:} f := 1; repeat becareful := p - q; p := becareful + p; if p >= 0 then f := (f + f) + 1 else begin f := f + f; p := p + q end until f >= 65536; becareful := p - q; if (becareful + p) >= 0 then f := f + 1 {:115}; if negative then makescaled := -(f + n) else makescaled := f + n end end; {:114} {116:} function velocity(st, ct, sf, cf: fraction; t: scaled): fraction; var acc, num, denom: integer; begin acc := takefraction(st - (sf div 16), sf - (st div 16)); acc := takefraction(acc, ct - cf); num := 536870912 + takefraction(acc, 379625062); denom := (805306368 + takefraction(ct, 497706707)) + takefraction(cf, 307599661); if t <> 65536 then num := makescaled(num, t); if (num div 4) >= denom then velocity := 1073741824 else velocity := makefraction(num, denom) end; {:116} {117:} function abvscd ; label 10; var q, r: integer; {118:} begin if a < 0 then begin a := -a; b := -b end; if c < 0 then begin c := -c; d := -d end; if d <= 0 then begin if b >= 0 then if ((a = 0) or (b = 0)) and ((c = 0) or (d = 0)) then begin abvscd := 0; goto 10 end else begin abvscd := 1; goto 10 end; if d = 0 then if a = 0 then begin abvscd := 0; goto 10 end else begin abvscd := -1; goto 10 end; q := a; a := c; c := q; q := -b; b := -d; d := q end else if b <= 0 then begin if b < 0 then if a > 0 then begin abvscd := -1; goto 10 end; if c = 0 then begin abvscd := 0; goto 10 end else begin abvscd := -1; goto 10 end end {:118}; while true do begin q := a div d; r := c div b; if q <> r then if q > r then begin abvscd := 1; goto 10 end else begin abvscd := -1; goto 10 end; q := a mod d; r := c mod b; if r = 0 then if q = 0 then begin abvscd := 0; goto 10 end else begin abvscd := 1; goto 10 end; if q = 0 then begin abvscd := -1; goto 10 end; a := b; b := q; c := d; d := r end; 10: null end; {:117} {119:} function floorscaled(x: scaled): scaled; var becareful: integer; begin if x >= 0 then floorscaled := x - (x mod 65536) else begin becareful := x + 1; floorscaled := (x + ((-becareful) mod 65536)) - 65535 end end; { floorscaled } function floorunscaled(x: scaled): integer; var becareful: integer; begin if x >= 0 then floorunscaled := x div 65536 else begin becareful := x + 1; floorunscaled := -(1 + ((-becareful) div 65536)) end end; { floorunscaled } function roundunscaled(x: scaled): integer; var becareful: integer; begin if x >= 32768 then roundunscaled := 1 + ((x - 32768) div 65536) else if x >= (-32768) then roundunscaled := 0 else begin becareful := x + 1; roundunscaled := -(1 + (((-becareful) - 32768) div 65536)) end end; { roundunscaled } function roundfraction(x: fraction): scaled; var becareful: integer; begin if x >= 2048 then roundfraction := 1 + ((x - 2048) div 4096) else if x >= (-2048) then roundfraction := 0 else begin becareful := x + 1; roundfraction := -(1 + (((-becareful) - 2048) div 4096)) end end; {:119} {121:} function squarert(x: scaled): scaled; var k: smallnumber; y, q: integer; begin if x <= 0 then begin {122:} if x < 0 then begin begin if interaction = 3 then null; printnl(133); print(176) end; printscaled(x); print(177); begin helpptr := 2; helpline[1] := 178; helpline[0] := 179 end; error end; squarert := 0 end else begin {:122} k := 23; q := 2; while x < 536870912 do begin k := k - 1; x := ((x + x) + x) + x end; if x < 1073741824 then y := 0 else begin x := x - 1073741824; y := 1 end; {123:} repeat x := x + x; y := y + y; if x >= 1073741824 then begin x := x - 1073741824; y := y + 1 end; x := x + x; y := (y + y) - q; q := q + q; if x >= 1073741824 then begin x := x - 1073741824; y := y + 1 end; if y > q then begin y := y - q; q := q + 2 end else if y <= 0 then begin q := q - 2; y := y + q end; k := k - 1 {:123} until k = 0; squarert := q div 2 end end; {:121} {124:} function pythadd(a, b: integer): integer; label 30; var r: fraction; big: boolean; begin a := abs(a); b := abs(b); if a < b then begin r := b; b := a; a := r end; if a > 0 then begin if a < 536870912 then big := false else begin a := a div 4; b := b div 4; big := true end; {125:} while true do begin r := makefraction(b, a); r := takefraction(r, r); if r = 0 then goto 30; r := makefraction(r, 1073741824 + r); a := a + takefraction(a + a, r); b := takefraction(b, r) end; 30: {:125} null; if big then if a < 536870912 then a := ((a + a) + a) + a else begin aritherror := true; a := 2147483647 end end; pythadd := a end; {:124} {126:} function pythsub(a, b: integer): integer; label 30; var r: fraction; big: boolean; begin a := abs(a); b := abs(b); if a <= b then begin {128:} if a < b then begin begin if interaction = 3 then null; printnl(133); print(180) end; printscaled(a); print(181); printscaled(b); print(177); begin helpptr := 2; helpline[1] := 178; helpline[0] := 179 end; error end; a := 0 end else begin {:128} if a < 1073741824 then big := false else begin a := a div 2; b := b div 2; big := true end; {127:} while true do begin r := makefraction(b, a); r := takefraction(r, r); if r = 0 then goto 30; r := makefraction(r, 1073741824 - r); a := a - takefraction(a + a, r); b := takefraction(b, r) end; 30: {:127} null; if big then a := a + a end; pythsub := a end; {:126} {132:} function mlog(x: scaled): scaled; var y, z: integer; k: integer; begin if x <= 0 then begin {134:} begin if interaction = 3 then null; printnl(133); print(182) end; printscaled(x); print(177); begin helpptr := 2; helpline[1] := 183; helpline[0] := 179 end; error; mlog := 0 end else begin {:134} y := 1302456860; z := 6581195; while x < 1073741824 do begin x := x + x; y := y - 93032639; z := z - 48782 end; y := y + (z div 65536); k := 2; while x > 1073741828 do begin {133:} z := ((x - 1) div twotothe[k]) + 1; while x < (1073741824 + z) do begin z := (z + 1) div 2; k := k + 1 end; y := y + speclog[k]; x := x - z end {:133}; mlog := y div 8 end end; {:132} {135:} function mexp(x: scaled): scaled; var k: smallnumber; y, z: integer; begin if x > 174436200 then begin aritherror := true; mexp := 2147483647 end else if x < (-197694359) then mexp := 0 else begin if x <= 0 then begin z := -(8 * x); y := 1048576 end else begin if x <= 127919879 then z := 1023359037 - (8 * x) else z := 8 * (174436200 - x); y := 2147483647 end; {136:} k := 1; while z > 0 do begin while z >= speclog[k] do begin z := z - speclog[k]; y := (y - 1) - ((y - twotothe[k - 1]) div twotothe[k]) end; k := k + 1 end {:136}; if x <= 127919879 then mexp := (y + 8) div 16 else mexp := y end end; {:135} {139:} function narg(x, y: integer): angle; var z: angle; t: integer; k: smallnumber; octant: 1..8; begin if x >= 0 then octant := 1 else begin x := -x; octant := 2 end; if y < 0 then begin y := -y; octant := octant + 2 end; if x < y then begin t := y; y := x; x := t; octant := octant + 4 end; if x = 0 then begin {140:} begin if interaction = 3 then null; printnl(133); print(184) end; begin helpptr := 2; helpline[1] := 185; helpline[0] := 179 end; error; narg := 0 end else begin {:140} {142:} while x >= 536870912 do begin x := x div 2; y := y div 2 end; z := 0; if y > 0 then begin while x < 268435456 do begin x := x + x; y := y + y end; {143:} k := 0; repeat y := y + y; k := k + 1; if y > x then begin z := z + specatan[k]; t := x; x := x + (y div twotothe[k + k]); y := y - t end until k = 15; repeat y := y + y; k := k + 1; if y > x then begin z := z + specatan[k]; y := y - x end until k = 26 {:143} end {:142}; {141:} case octant of 1: narg := z; 5: narg := 94371840 - z; 6: narg := 94371840 + z; 2: narg := 188743680 - z; 4: narg := z - 188743680; 8: narg := (-z) - 94371840; 7: narg := z - 94371840; 3: narg := -z end {:141} end end; {:139} {145:} procedure nsincos(z: angle); var k: smallnumber; q: 0..7; r: fraction; x, y, t: integer; begin while z < 0 do z := z + 377487360; z := z mod 377487360; q := z div 47185920; z := z mod 47185920; x := 268435456; y := x; if not odd(q) then z := 47185920 - z; {147:} k := 1; while z > 0 do begin if z >= specatan[k] then begin z := z - specatan[k]; t := x; x := t + (y div twotothe[k]); y := y - (t div twotothe[k]) end; k := k + 1 end; if y < 0 then y := 0 {:147}; {146:} case q of 0: null; 1: begin t := x; x := y; y := t end; 2: begin t := x; x := -y; y := t end; 3: x := -x; 4: begin x := -x; y := -y end; 5: begin t := x; x := -y; y := -t end; 6: begin t := x; x := y; y := -t end; 7: y := -y end {:146}; r := pythadd(x, y); ncos := makefraction(x, r); nsin := makefraction(y, r) end; {:145} {149:} procedure newrandoms; var k: 0..54; x: fraction; begin for k := 0 to 23 do begin x := randoms[k] - randoms[k + 31]; if x < 0 then x := x + 268435456; randoms[k] := x end; for k := 24 to 54 do begin x := randoms[k] - randoms[k - 24]; if x < 0 then x := x + 268435456; randoms[k] := x end; jrandom := 54 end; {:149} {150:} procedure initrandoms(seed: scaled); var j, jj, k: fraction; i: 0..54; begin j := abs(seed); while j >= 268435456 do j := j div 2; k := 1; for i := 0 to 54 do begin jj := k; k := j - k; j := jj; if k < 0 then k := k + 268435456; randoms[(i * 21) mod 55] := j end; newrandoms; newrandoms; newrandoms end; {:150} {151:} function unifrand(x: scaled): scaled; var y: scaled; begin if jrandom = 0 then newrandoms else jrandom := jrandom - 1; y := takefraction(abs(x), randoms[jrandom]); if y = abs(x) then unifrand := 0 else if x > 0 then unifrand := y else unifrand := -y end; {:151} {152:} function normrand: scaled; var x, u, l: integer; begin repeat repeat if jrandom = 0 then newrandoms else jrandom := jrandom - 1; x := takefraction(112429, randoms[jrandom] - 134217728); if jrandom = 0 then newrandoms else jrandom := jrandom - 1; u := randoms[jrandom] until abs(x) < u; x := makefraction(x, u); l := 139548960 - mlog(u) until abvscd(1024, l, x, x) >= 0; normrand := x end; {:152} {157:} {procedure printword(w:memoryword);begin printint(w.int); printchar(32);printscaled(w.int);printchar(32); printscaled(w.int div 4096);println;printint(w.hh.lh);printchar(61); printint(w.hh.b0);printchar(58);printint(w.hh.b1);printchar(59); printint(w.hh.rh);printchar(32);printint(w.qqqq.b0);printchar(58); printint(w.qqqq.b1);printchar(58);printint(w.qqqq.b2);printchar(58); printint(w.qqqq.b3);end;} {:157} {162:} {217:} procedure printcapsule; forward; procedure showtokenlist(p, q: integer; l, nulltally: integer); label 10; var class, c: smallnumber; r, v: integer; begin class := 3; tally := nulltally; while (p <> (-30000)) and (tally < l) do begin if p = q then begin {646:} firstcount := tally; trickcount := ((tally + 1) + errorline) - halferrorline; if trickcount < errorline then trickcount := errorline end {:646}; {218:} c := 9; if (p < (-30000)) or (p > memend) then begin print(360); goto 10 end; if p < himemmin then {219:} if mem[p].hh.b1 = 12 then if mem[p].hh.b0 = 16 then begin {220:} if class = 0 then printchar(32); v := mem[p + 1].int; if v < 0 then begin if class = 17 then printchar(32); printchar(91); printscaled(v); printchar(93); c := 18 end else begin printscaled(v); c := 0 end end else if mem[p].hh.b0 <> 4 then {:220} print(363) else begin printchar(34); slowprint(mem[p + 1].int); printchar(34); c := 4 end else if ((mem[p].hh.b1 <> 11) or (mem[p].hh.b0 < 1)) or (mem[p].hh.b0 > 19) then print(363) else begin gpointer := p; printcapsule; c := 8 end {:219} else begin r := mem[p].hh.lh; if r >= 2242 then begin {222:} if r < 2392 then begin print(365); r := r - 2242 end else if r < 2542 then begin print(366); r := r - 2392 end else begin print(367); r := r - 2542 end; printint(r); printchar(41); c := 8 end else if r < 1 then {:222} if r = 0 then begin {221:} if class = 17 then printchar(32); print(364); c := 18 end else {:221} print(361) else begin r := hash[r].rh; if (r < 0) or (r >= strptr) then print(362) {223:} else begin c := charclass[strpool[strstart[r]]]; if c = class then if c in [9, 5, 6, 7, 8] then case c of 9: printchar(46); 5, 6, 7, 8: null end else printchar(32); print(r) end {:223} end end {:218}; class := c; p := mem[p].hh.rh end; if p <> (-30000) then print(359); 10: null end; {:217} {665:} procedure runaway; begin if scannerstatus > 2 then begin printnl(503); case scannerstatus of 3: print(504); 4, 5: print(505); 6: print(506) end; println; showtokenlist(mem[29998].hh.rh, -30000, errorline - 10, 0) end end; { runaway } {:665} {:162} {163:} function getavail: halfword; var p: halfword; begin p := avail; if p <> (-30000) then avail := mem[avail].hh.rh else if memend < memmax then begin memend := memend + 1; p := memend end else begin himemmin := himemmin - 1; p := himemmin; if himemmin <= lomemmax then begin runaway; overflow(186, memmax + 30001) end end; mem[p].hh.rh := -30000; {dynused:=dynused+1;} getavail := p end; {:163} {167:} function getnode(s: integer): halfword; label 40, 10, 20; var p: halfword; q: halfword; r: integer; t, tt: integer; begin 20: p := rover; {169:} repeat q := p + mem[p].hh.lh; while mem[q].hh.rh = 32767 do begin t := mem[q + 1].hh.rh; tt := mem[q + 1].hh.lh; if q = rover then rover := t; mem[t + 1].hh.lh := tt; mem[tt + 1].hh.rh := t; q := q + mem[q].hh.lh end; r := q - s; if r > (p + 1) then begin {170:} mem[p].hh.lh := r - p; rover := p; goto 40 end {:170}; {171 :} if r = p then if (mem[p + 1].hh.rh <> rover) or (mem[p + 1].hh.lh <> rover) then begin rover := mem[p + 1].hh.rh; t := mem[p + 1].hh.lh; mem[rover + 1].hh.lh := t; mem[t + 1].hh.rh := rover; goto 40 end {:171}; mem[p].hh.lh := q - p {:169}; p := mem[p + 1].hh.rh until p = rover; if s = 1073741824 then begin getnode := 32767; goto 10 end; if (lomemmax + 2) < himemmin then if (lomemmax + 2) <= 2767 then begin {168:} if (lomemmax + 1000) < himemmin then t := lomemmax + 1000 else t := ((lomemmax + himemmin) + 2) div 2; if t > 2767 then t := 2767; p := mem[rover + 1].hh.lh; q := lomemmax; mem[p + 1].hh.rh := q; mem[rover + 1].hh.lh := q; mem[q + 1].hh.rh := rover; mem[q + 1].hh.lh := p; mem[q].hh.rh := 32767; mem[q].hh.lh := t - lomemmax; lomemmax := t; mem[lomemmax].hh.rh := -30000; mem[lomemmax].hh.lh := -30000; rover := q; goto 20 end {:168}; overflow(186, memmax + 30001); 40: mem[r].hh.rh := -30000; {varused:=varused+s;} getnode := r; 10: null end; {:167} {172:} procedure freenode(p: halfword; s: halfword); var q: halfword; begin mem[p].hh.lh := s; mem[p].hh.rh := 32767; q := mem[rover + 1].hh.lh; mem[p + 1].hh.lh := q; mem[p + 1].hh.rh := rover; mem[rover + 1].hh.lh := p; mem[q + 1].hh.rh := p end; {varused:=varused-s;} {:172} {173:} {procedure sortavail;var p,q,r:halfword;oldrover:halfword; begin p:=getnode(1073741824);p:=mem[rover+1].hh.rh; mem[rover+1].hh.rh:=32767;oldrover:=rover; while p<>oldrover do[174:]if p32767 do begin mem[mem[p+1].hh.rh+1].hh.lh:=p; p:=mem[p+1].hh.rh;end;mem[p+1].hh.rh:=rover;mem[rover+1].hh.lh:=p;end;} {:173} {177:} procedure flushlist(p: halfword); label 30; var q, r: halfword; begin if p >= himemmin then if p <> 30000 then begin r := p; repeat q := r; r := mem[r].hh.rh; {dynused:=dynused-1;} if r < himemmin then goto 30 until r = 30000; 30: mem[q].hh.rh := avail; avail := p end end; { flushlist } procedure flushnodelist(p: halfword); var q: halfword; begin while p <> (-30000) do begin q := p; p := mem[p].hh.rh; if q < himemmin then freenode(q, 2) else begin mem[q].hh.rh := avail; avail := q end {dynused:=dynused-1;} end end; {:177} {180:} {procedure checkmem(printlocs:boolean);label 31,32;var p,q,r:halfword; clobbered:boolean;begin for p:=-30000 to lomemmax do freearr[p]:=false; for p:=himemmin to memend do freearr[p]:=false;[181:]p:=avail;q:=-30000; clobbered:=false; while p<>-30000 do begin if(p>memend)or(p=lomemmax)or(p<-30000)then clobbered:=true else if(mem[p+1]. hh.rh>=lomemmax)or(mem[p+1].hh.rh<-30000)then clobbered:=true else if not((mem[p].hh.rh=32767))or(mem[p].hh.lh<2)or(p+mem[p].hh.lh>lomemmax)or (mem[mem[p+1].hh.rh+1].hh.lh<>p)then clobbered:=true; if clobbered then begin printnl(188);printint(q);goto 32;end; for q:=p to p+mem[p].hh.lh-1 do begin if freearr[q]then begin printnl( 189);printint(q);goto 32;end;freearr[q]:=true;end;q:=p; p:=mem[p+1].hh.rh;until p=rover;32:[:182];[183:]p:=-30000; while p<=lomemmax do begin if(mem[p].hh.rh=32767)then begin printnl(190) ;printint(p);end;while(p<=lomemmax)and not freearr[p]do p:=p+1; while(p<=lomemmax)and freearr[p]do p:=p+1;end[:183];[617:]q:=-29987; p:=mem[q].hh.rh; while p<>-29987 do begin if mem[p+1].hh.lh<>q then begin printnl(463); printint(p);end;p:=mem[p+1].hh.rh;r:=himemmin; repeat if mem[p].hh.lh>=r then begin printnl(464);printint(p);end; r:=mem[p].hh.lh;q:=p;p:=mem[q].hh.rh;until r=-30000;end[:617]; if printlocs then[184:]begin printnl(191); for p:=-30000 to lomemmax do if not freearr[p]and((p>waslomax)or wasfree [p])then begin printchar(32);printint(p);end; for p:=himemmin to memend do if not freearr[p]and((p wasmemend)or wasfree[p])then begin printchar(32);printint(p);end; end[:184];for p:=-30000 to lomemmax do wasfree[p]:=freearr[p]; for p:=himemmin to memend do wasfree[p]:=freearr[p];wasmemend:=memend; waslomax:=lomemmax;washimin:=himemmin;end;} {:180} {185:} {procedure searchmem(p:halfword);var q:integer; begin for q:=-30000 to lomemmax do begin if mem[q].hh.rh=p then begin printnl(192);printint(q);printchar(41);end; if mem[q].hh.lh=p then begin printnl(193);printint(q);printchar(41);end; end; for q:=himemmin to memend do begin if mem[q].hh.rh=p then begin printnl( 192);printint(q);printchar(41);end; if mem[q].hh.lh=p then begin printnl(193);printint(q);printchar(41);end; end; [209:]for q:=1 to 2241 do begin if eqtb[q].rh=p then begin printnl(328); printint(q);printchar(41);end;end[:209];end;} {:185} {189:} procedure printop(c: quarterword); begin if c <= 15 then printtype(c) else if c in [30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 94, 95, 96, 97, 98, 99, 100] then case c of 30: print(218); 31: print(219); 32: print(220); 33: print(221); 34: print(222); 35: print(223); 36: print(224); 37: print(225); 38: print(226); 39: print(227); 40: print(228); 41: print(229); 42: print(230); 43: print(231); 44: print(232); 45: print(233); 46: print(234); 47: print(235); 48: print(236); 49: print(237); 50: print(238); 51: print(239); 52: print(240); 53: print(241); 54: print(242); 55: print(243); 56: print(244); 57: print(245); 58: print(246); 59: print(247); 60: print(248); 61: print(249); 62: print(250); 63: print(251); 64: print(252); 65: print(253); 66: print(254); 67: print(255); 68: print(256); 69: printchar(43); 70: printchar(45); 71: printchar(42); 72: printchar(47); 73: print(257); 74: print(181); 75: print(258); 76: print(259); 77: printchar(60); 78: print(260); 79: printchar(62); 80: print(261); 81: printchar(61); 82: print(262); 83: print(38); 84: print(263); 85: print(264); 86: print(265); 87: print(266); 88: print(267); 89: print(268); 90: print(269); 91: print(270); 92: print(271); 94: print(272); 95: print(273); 96: print(274); 97: print(275); 98: print(276); 99: print(277); 100: print(278) end else print(279) end; { printop } {:189} {194:} procedure fixdateandtime; begin dateandtime(internal[17], internal[16], internal[15], internal[14]); internal[17] := internal[17] * 65536; internal[16] := internal[16] * 65536; internal[15] := internal[15] * 65536; internal[14] := internal[14] * 65536; {----------------------------------} lastyearval := internal[14]; lastmonthval:= internal[15]; {----------------------------------} end; { fixdateandtime } {:194} {205:} function idlookup(j, l: integer): halfword; label 40; var h: integer; p: halfword; k: halfword; begin if l = 1 then begin {206:} p := buffer[j] + 1; hash[p].rh := p - 1; goto 40 end {:206}; {208:} h := buffer[j]; for k := j + 1 to (j + l) - 1 do begin h := (h + h) + buffer[k]; while h >= 1777 do h := h - 1777 end {:208}; p := h + 129; while true do begin if hash[p].rh > 0 then if (strstart[hash[p].rh + 1] - strstart[hash[p].rh]) = l then if streqbuf(hash[p].rh, j) then goto 40; if hash[p].lh = 0 then begin {207:} if hash[p].rh > 0 then begin repeat if hashused = 1 then overflow(327, 2100); hashused := hashused - 1 until hash[hashused].rh = 0; hash[p].lh := hashused; p := hashused end; begin if (poolptr + l) > maxpoolptr then begin if (poolptr + l) > poolsize then overflow(129, poolsize - initpoolptr); maxpoolptr := poolptr + l end end; for k := j to (j + l) - 1 do begin strpool[poolptr] := buffer[k]; poolptr := poolptr + 1 end; hash[p].rh := makestring; strref[hash[p].rh] := 127; {stcount:=stcount+1;} goto 40 end {:207}; p := hash[p].lh end; 40: idlookup := p end; {:205} {210:} {procedure primitive(s:strnumber;c:halfword;o:halfword); var k:poolpointer;j:smallnumber;l:smallnumber;begin k:=strstart[s]; l:=strstart[s+1]-k;for j:=0 to l-1 do buffer[j]:=strpool[k+j]; cursym:=idlookup(0,l);if s>=128 then begin flushstring(strptr-1); hash[cursym].rh:=s;end;eqtb[cursym].lh:=c;eqtb[cursym].rh:=o;end;} {:210} {215:} function newnumtok(v: scaled): halfword; var p: halfword; begin p := getnode(2); mem[p + 1].int := v; mem[p].hh.b0 := 16; mem[p].hh.b1 := 12; newnumtok := p end; {:215} {216:} procedure tokenrecycle; forward; procedure flushtokenlist(p: halfword); var q: halfword; begin while p <> (-30000) do begin q := p; p := mem[p].hh.rh; if q >= himemmin then begin mem[q].hh.rh := avail; avail := q end else begin {dynused:=dynused-1;} if mem[q].hh.b0 in [1, 2, 16, 4, 3, 5, 7, 12, 10, 6, 9, 8, 11, 14, 13, 17, 18, 19] then case mem[q].hh.b0 of 1, 2, 16: null; 4: begin if strref[mem[q + 1].int] < 127 then if strref[mem[q + 1].int] > 1 then strref[mem[q + 1].int] := strref[mem[q + 1].int] - 1 else flushstring(mem[q + 1].int) end; 3, 5, 7, 12, 10, 6, 9, 8, 11, 14, 13, 17, 18, 19: begin gpointer := q; tokenrecycle end end else confusion(358); freenode(q, 2) end end end; { flushtokenlist } {:216} {226:} procedure deletemacref(p: halfword); begin if mem[p].hh.lh = (-30000) then flushtokenlist(p) else mem[p].hh.lh := mem[p].hh.lh - 1 end; {:226} {227:} {625:} procedure printcmdmod(c, m: integer); begin if c in [18, 77, 59, 72, 32, 78, 79, 57, 19, 60, 27, 11, 81, 26, 6, 9, 70, 73, 13, 46, 63, 14, 15, 69, 28, 47, 24, 7, 65, 64, 12, 8, 80, 17, 74, 35, 58, 71, 75, 16, 4, 61, 56, 3, 1, 2, 33, 34, 37, 55, 45, 50, 36, 43, 54, 48, 51, 52, 30, 82, 23, 21, 22, 31, 62, 41, 10, 53, 44, 49, 5, 40, 68, 66, 67, 25, 20, 76, 29] then case c of {212:} 18: print(330); 77: print(329); 59: print(332); 72: print(331); 32: print(333); 78: print(58); 79: print(44); 57: print(334); 19: print(335); 60: print(336); 27: print(337); 11: print(338); 81: print(323); 26: print(339); 6: print(340); 9: print(341); 70: print(342); 73: print(343); 13: print(344); 46: print(123); 63: print(91); 14: print(345); 15: print(346); 69: print(347); 28: print(348); 47: print(279); 24: print(349); 7: printchar(92); 65: print(125); 64: print(93); 12: print(350); 8: print(351); 80: print(59); 17: print(352); 74: print(353); 35: print(354); 58: print(355); 71: print(356); 75: print(357); {:212} {684:} 16: if m <= 2 then if m = 1 then print(520) else if m < 1 then print(324) else print(521) else if m = 53 then print(522) else if m = 44 then print(523) else print(524); 4: if m <= 1 then if m = 1 then print(527) else print(325) else if m = 2242 then print(525) else print(526); {:684} {689:} 61: if m in [1, 2, 3] then case m of 1: print(529); 2: printchar(64); 3: print(530) end else print(528); {:689} {696:} 56: if m >= 2242 then if m = 2242 then print(541) else if m = 2392 then print(542) else print(543) else if m < 2 then print(544) else if m = 2 then print(545) else print(546); {:696} {710:} 3: if m = 0 then print(556) else print(482); {:710} {741:} 1, 2: if m in [1, 2, 3] then case m of 1: print(583); 2: print(322); 3: print(584) end else print(585); {:741} {894:} 33, 34, 37, 55, 45, 50, 36, 43, 54, 48, 51, 52: printop(m); {:894} {1014:} 30: printtype(m); {:1014} {1019:} 82: if m = 0 then print(776) else print(777); {:1019} {1025:} 23: if m in [0, 1, 2] then case m of 0: print(143); 1: print(144); 2: print(145) end else print(783); {:1025} {1028:} 21: if m = 0 then print(784) else print(785); {:1028} {1038:} 22: if m in [0, 1, 2, 3] then case m of 0: print(799); 1: print(800); 2: print(801); 3: print(802) end else print(803); {:1038} {1043:} 31, 62: begin if c = 31 then print(806) else print(807); print(808); print(hash[m].rh) end; 41: if m = (-30000) then print(809) else print(810); 10: print(811); 53, 44, 49: begin printcmdmod(16, c); print(812); println; showtokenlist(mem[mem[m].hh.rh].hh.rh, -30000, 1000, 0) end; 5: print(813); 40: print(intname[m]); {:1043} {1053:} 68: if m = 1 then print(820) else if m = 0 then print(821) else print(822); 66: if m = 6 then print(823) else print(824); 67: if m = 0 then print(825) else print(826); {:1053} {1080:} 25: if m < 1 then print(856) else if m = 1 then print(857) else print(858); {:1080} {1102:} 20: if m in [0, 1, 2, 3] then case m of 0: print(868); 1: print(869); 2: print(870); 3: print(871) end else print(872); {:1102} {1110:} 76: if m = 0 then print(889) else print(890); {:1110} {1180:} 29: if m = 16 then print(913) else print(912) end else {:1180} print(468) end; {:625} procedure showmacro(p: halfword; q, l: integer); label 10; var r: halfword; begin p := mem[p].hh.rh; while mem[p].hh.lh > 7 do begin r := mem[p].hh.rh; mem[p].hh.rh := -30000; showtokenlist(p, -30000, l, 0); mem[p].hh.rh := r; p := r; if l > 0 then l := l - tally else goto 10 end; tally := 0; case mem[p].hh.lh of 0: print(368); 1, 2, 3: begin printchar(60); printcmdmod(56, mem[p].hh.lh); print(369) end; 4: print(370); 5: print(371); 6: print(372); 7: print(373) end; showtokenlist(mem[p].hh.rh, q, l - tally, 0); 10: null end; {:227} {232:} procedure initbignode(p: halfword); var q: halfword; s: smallnumber; begin s := bignodesize[mem[p].hh.b0]; q := getnode(s); repeat s := s - 2; {586:} begin mem[q + s].hh.b0 := 19; serialno := serialno + 64; mem[(q + s) + 1].int := serialno end {:586}; mem[q + s].hh.b1 := (s div 2) + 5; mem[q + s].hh.rh := -30000 until s = 0; mem[q].hh.rh := p; mem[p + 1].int := q end; { initbignode } {:232} {233:} function idtransform: halfword; var p, q, r: halfword; begin p := getnode(2); mem[p].hh.b0 := 13; mem[p].hh.b1 := 11; mem[p + 1].int := -30000; initbignode(p); q := mem[p + 1].int; r := q + 12; repeat r := r - 2; mem[r].hh.b0 := 16; mem[r + 1].int := 0 until r = q; mem[q + 5].int := 65536; mem[q + 11].int := 65536; idtransform := p end; {:233} {234:} procedure newroot(x: halfword); var p: halfword; begin p := getnode(2); mem[p].hh.b0 := 0; mem[p].hh.b1 := 0; mem[p].hh.rh := x; eqtb[x].rh := p end; {:234} {235:} procedure printvariablename(p: halfword); label 40, 10; var q: halfword; r: halfword; begin while mem[p].hh.b1 >= 5 do begin {237:} case mem[p].hh.b1 of 5: printchar(120); 6: printchar(121); 7: print(376); 8: print(377); 9: print(378); 10: print(379); 11: begin print(380); printint(p + 30000); goto 10 end end; print(381); p := mem[p - (2 * (mem[p].hh.b1 - 5))].hh.rh end {:237}; q := -30000; while mem[p].hh.b1 > 1 do begin {236:} if mem[p].hh.b1 = 3 then begin r := newnumtok(mem[p + 2].int); repeat p := mem[p].hh.rh until mem[p].hh.b1 = 4 end else if mem[p].hh.b1 = 2 then begin p := mem[p].hh.rh; goto 40 end else begin if mem[p].hh.b1 <> 4 then confusion(375); r := getavail; mem[r].hh.lh := mem[p + 2].hh.lh end; mem[r].hh.rh := q; q := r; 40: p := mem[p + 2].hh.rh end {:236}; r := getavail; mem[r].hh.lh := mem[p].hh.rh; mem[r].hh.rh := q; if mem[p].hh.b1 = 1 then print(374); showtokenlist(r, -30000, 2147483647, tally); flushtokenlist(r); 10: null end; {:235} {238:} function interesting(p: halfword): boolean; var t: smallnumber; begin if internal[3] > 0 then interesting := true else begin t := mem[p].hh.b1; if t >= 5 then if t <> 11 then t := mem[mem[p - (2 * (t - 5))].hh.rh].hh.b1; interesting := t <> 11 end end; {:238} {239:} function newstructure(p: halfword): halfword; var q, r: halfword; begin if mem[p].hh.b1 in [0, 3, 4] then case mem[p].hh.b1 of 0: begin q := mem[p].hh.rh; r := getnode(2); eqtb[q].rh := r end; 3: begin {240:} q := p; repeat q := mem[q].hh.rh until mem[q].hh.b1 = 4; q := mem[q + 2].hh.rh; r := q + 1; repeat q := r; r := mem[r].hh.rh until r = p; r := getnode(3); mem[q].hh.rh := r; mem[r + 2].int := mem[p + 2].int end; {:240} 4: begin {241:} q := mem[p + 2].hh.rh; r := mem[q + 1].hh.lh; repeat q := r; r := mem[r].hh.rh until r = p; r := getnode(3); mem[q].hh.rh := r; mem[r + 2] := mem[p + 2]; if mem[p + 2].hh.lh = 0 then begin q := mem[p + 2].hh.rh + 1; while mem[q].hh.rh <> p do q := mem[q].hh.rh; mem[q].hh.rh := r end end end else {:241} confusion(382); mem[r].hh.rh := mem[p].hh.rh; mem[r].hh.b0 := 21; mem[r].hh.b1 := mem[p].hh.b1; mem[r + 1].hh.lh := p; mem[p].hh.b1 := 2; q := getnode(3); mem[p].hh.rh := q; mem[r + 1].hh.rh := q; mem[q + 2].hh.rh := r; mem[q].hh.b0 := 0; mem[q].hh.b1 := 4; mem[q].hh.rh := -29983; mem[q + 2].hh.lh := 0; newstructure := r end; {:239} {242:} function findvariable(t: halfword): halfword; label 10; var p, q, r, s: halfword; pp, qq, rr, ss: halfword; n: integer; saveword: memoryword; begin p := mem[t].hh.lh; t := mem[t].hh.rh; if (eqtb[p].lh mod 83) <> 41 then begin findvariable := -30000; goto 10 end; if eqtb[p].rh = (-30000) then newroot(p); p := eqtb[p].rh; pp := p; while t <> (-30000) do begin {243:} if mem[pp].hh.b0 <> 21 then begin if mem[pp].hh.b0 > 21 then begin findvariable := -30000; goto 10 end; ss := newstructure(pp); if p = pp then p := ss; pp := ss end; if mem[p].hh.b0 <> 21 then p := newstructure(p) {:243}; if t < himemmin then begin {244:} n := mem[t + 1].int; pp := mem[mem[pp + 1].hh.lh].hh.rh; q := mem[mem[p + 1].hh.lh].hh.rh; saveword := mem[q + 2]; mem[q + 2].int := 2147483647; s := p + 1; repeat r := s; s := mem[s].hh.rh until n <= mem[s + 2].int; if n = mem[s + 2].int then p := s else begin p := getnode(3); mem[r].hh.rh := p; mem[p].hh.rh := s; mem[p + 2].int := n; mem[p].hh.b1 := 3; mem[p].hh.b0 := 0 end; mem[q + 2] := saveword end else begin {:244} {245:} n := mem[t].hh.lh; ss := mem[pp + 1].hh.lh; repeat rr := ss; ss := mem[ss].hh.rh until n <= mem[ss + 2].hh.lh; if n < mem[ss + 2].hh.lh then begin qq := getnode(3); mem[rr].hh.rh := qq; mem[qq].hh.rh := ss; mem[qq + 2].hh.lh := n; mem[qq].hh.b1 := 4; mem[qq].hh.b0 := 0; mem[qq + 2].hh.rh := pp; ss := qq end; if p = pp then begin p := ss; pp := ss end else begin pp := ss; s := mem[p + 1].hh.lh; repeat r := s; s := mem[s].hh.rh until n <= mem[s + 2].hh.lh; if n = mem[s + 2].hh.lh then p := s else begin q := getnode(3); mem[r].hh.rh := q; mem[q].hh.rh := s; mem[q + 2].hh.lh := n; mem[q].hh.b1 := 4; mem[q].hh.b0 := 0; mem[q + 2].hh.rh := p; p := q end end end {:245}; t := mem[t].hh.rh end; if mem[pp].hh.b0 >= 21 then if mem[pp].hh.b0 = 21 then pp := mem[pp + 1].hh.lh else begin findvariable := -30000; goto 10 end; if mem[p].hh.b0 = 21 then p := mem[p + 1].hh.lh; if mem[p].hh.b0 = 0 then begin if mem[pp].hh.b0 = 0 then begin mem[pp].hh.b0 := 15; mem[pp + 1].int := -30000 end; mem[p].hh.b0 := mem[pp].hh.b0; mem[p + 1].int := -30000 end; findvariable := p; 10: null end; {:242} {246:} {257:} procedure printpath(h: halfword; s: strnumber; nuline: boolean); label 30, 31; var p, q: halfword; begin printdiagnostic(384, s, nuline); println; p := h; repeat q := mem[p].hh.rh; if (p = (-30000)) or (q = (-30000)) then begin printnl(131); goto 30 end; {258:} printtwo(mem[p + 1].int, mem[p + 2].int); if mem[p].hh.b1 in [0, 1, 4, 3, 2] then case mem[p].hh.b1 of 0: begin if mem[p].hh.b0 = 4 then print(385); if (mem[q].hh.b0 <> 0) or (q <> h) then q := -30000; goto 31 end; 1: begin {261:} print(391); printtwo(mem[p + 5].int, mem[p + 6].int); print(390); if mem[q].hh.b0 <> 1 then print(392) else printtwo(mem[q + 3].int, mem[q + 4].int); goto 31 end; {:261} 4: {262:} if (mem[p].hh.b0 <> 1) and (mem[p].hh.b0 <> 4) then print(385) {:262}; 3, 2: begin {263:} if mem[p].hh.b0 = 4 then print(392); if mem[p].hh.b1 = 3 then begin print(388); printscaled(mem[p + 5].int) end else begin nsincos(mem[p + 5].int); printchar(123); printscaled(ncos); printchar(44); printscaled(nsin) end; printchar(125) end end else {:263} print(131); if mem[q].hh.b0 <= 1 then print(386) else if (mem[p + 6].int <> 65536) or (mem[q + 4].int <> 65536) then begin {260:} print(389); if mem[p + 6].int < 0 then print(332); printscaled(abs(mem[p + 6].int)); if mem[p + 6].int <> mem[q + 4].int then begin print(390); if mem[q + 4].int < 0 then print(332); printscaled(abs(mem[q + 4].int)) end end {:260}; 31: {:258} null; p := q; if (p <> h) or (mem[h].hh.b0 <> 0) then begin {259:} printnl(387); if mem[p].hh.b0 = 2 then begin nsincos(mem[p + 3].int); printchar(123); printscaled(ncos); printchar(44); printscaled(nsin); printchar(125) end else if mem[p].hh.b0 = 3 then begin print(388); printscaled(mem[p + 3].int); printchar(125) end end {:259} until p = h; if mem[h].hh.b0 <> 0 then print(256); 30: enddiagnostic(true) end; {:257} {332:} {333:} procedure printweight(q: halfword; xoff: integer); var w, m: integer; d: integer; begin d := mem[q].hh.lh + 32768; w := d mod 8; m := (d div 8) - mem[curedges + 3].hh.lh; if fileoffset > (maxprintline - 9) then printnl(32) else printchar(32); printint(m + xoff); while w > 4 do begin printchar(43); w := w - 1 end; while w < 4 do begin printchar(45); w := w + 1 end end; {:333} procedure printedges(s: strnumber; nuline: boolean; xoff, yoff: integer); var p, q, r: halfword; n: integer; begin printdiagnostic(399, s, nuline); p := mem[curedges].hh.lh; n := mem[curedges + 1].hh.rh - 4096; while p <> curedges do begin q := mem[p + 1].hh.lh; r := mem[p + 1].hh.rh; if (q > (-29999)) or (r <> 30000) then begin printnl(400); printint(n + yoff); printchar(58); while q > (-29999) do begin printweight(q, xoff); q := mem[q].hh.rh end; print(401); while r <> 30000 do begin printweight(r, xoff); r := mem[r].hh.rh end end; p := mem[p].hh.lh; n := n - 1 end; enddiagnostic(true) end; {:332} {388:} {--------------------------------------------------- procedure unskew(x, y: scaled; octant: smallnumber); moved to mf2ps1.p ---------------------------------------------------} procedure printpen(p: halfword; s: strnumber; nuline: boolean); var nothingprinted: boolean; k: 1..8; h: halfword; m, n: integer; w, ww: halfword; begin printdiagnostic(436, s, nuline); nothingprinted := true; println; for k := 1 to 8 do begin octant := octantcode[k]; h := p + octant; n := mem[h].hh.lh; w := mem[h].hh.rh; if not odd(k) then w := mem[w].hh.lh; for m := 1 to n + 1 do begin if odd(k) then ww := mem[w].hh.rh else ww := mem[w].hh.lh; if (mem[ww + 1].int <> mem[w + 1].int) or (mem[ww + 2].int <> mem[w + 2].int) then begin {474:} if nothingprinted then nothingprinted := false else printnl(438); unskew(mem[ww + 1].int, mem[ww + 2].int, octant); printtwo(curx, cury) end {:474}; w := ww end end; if nothingprinted then begin w := mem[p + 1].hh.rh; printtwo(mem[w + 1].int + mem[w + 2].int, mem[w + 2].int) end; printnl(437); enddiagnostic(true) end; {:473} {589:} procedure printdependency(p: halfword; t: smallnumber); label 10; var v: integer; pp, q: halfword; begin pp := p; while true do begin v := abs(mem[p + 1].int); q := mem[p].hh.lh; if q = (-30000) then begin if (v <> 0) or (p = pp) then begin if mem[p + 1].int > 0 then if p <> pp then printchar(43); printscaled(mem[p + 1].int) end; goto 10 end; {590:} if mem[p + 1].int < 0 then printchar(45) else if p <> pp then printchar(43); if t = 17 then v := roundfraction(v); if v <> 65536 then printscaled(v) {:590}; if mem[q].hh.b0 <> 19 then confusion(454); printvariablename(q); v := mem[q + 1].int mod 64; while v > 0 do begin print(455); v := v - 2 end; p := mem[p].hh.rh end; 10: null end; {:589} {801:} {805:} procedure printdp(t: smallnumber; p: halfword; verbosity: smallnumber); var q: halfword; begin q := mem[p].hh.rh; if (mem[q].hh.lh = (-30000)) or (verbosity > 0) then printdependency(p, t) else print(628) end; {:805} {799:} function stashcurexp: halfword; var p: halfword; begin if curtype in [3, 5, 7, 12, 10, 13, 14, 17, 18, 19] then case curtype of 3, 5, 7, 12, 10, 13, 14, 17, 18, 19: p := curexp end else begin p := getnode(2); mem[p].hh.b1 := 11; mem[p].hh.b0 := curtype; mem[p + 1].int := curexp end; curtype := 1; mem[p].hh.rh := -29999; stashcurexp := p end; {:799} {800:} procedure unstashcurexp(p: halfword); begin curtype := mem[p].hh.b0; if curtype in [3, 5, 7, 12, 10, 13, 14, 17, 18, 19] then case curtype of 3, 5, 7, 12, 10, 13, 14, 17, 18, 19: curexp := p end else begin curexp := mem[p + 1].int; freenode(p, 2) end end; {:800} procedure printexp(p: halfword; verbosity: smallnumber); var restorecurexp: boolean; t: smallnumber; v: integer; q: halfword; begin if p <> (-30000) then restorecurexp := false else begin p := stashcurexp; restorecurexp := true end; t := mem[p].hh.b0; if t < 17 then v := mem[p + 1].int else if t < 19 then v := mem[p + 1].hh.rh; {802:} if t in [1, 2, 3, 5, 7, 12, 10, 15, 4, 6, 8, 9, 11, 13, 14, 16, 17, 18, 19] then case t of 1: print(194); 2: if v = 30 then print(218) else print(219); 3, 5, 7, 12, 10, 15: begin {806:} printtype(t); if v <> (-30000) then begin printchar(32); while (mem[v].hh.b1 = 11) and (v <> p) do v := mem[v + 1].int; printvariablename(v) end end; {:806} 4: begin printchar(34); slowprint(v); printchar(34) end; 6, 8, 9, 11: {804:} if verbosity <= 1 then printtype(t) else begin if selector = 3 then if internal[13] <= 0 then begin selector := 1; printtype(t); print(626); selector := 3 end; case t of 6: printpen(v, 155, false); 8: printpath(v, 627, false); 9: printpath(v, 155, false); 11: begin curedges := v; printedges(155, false, 0, 0) end end end {:804}; 13, 14: if v = (-30000) then printtype(t) {803:} else begin printchar(40); q := v + bignodesize[t]; repeat if mem[v].hh.b0 = 16 then printscaled(mem[v + 1].int) else if mem[v].hh.b0 = 19 then printvariablename(v) else printdp(mem[v].hh.b0, mem[v + 1].hh.rh, verbosity); v := v + 2; if v <> q then printchar(44) until v = q; printchar(41) end {:803}; 16: printscaled(v); 17, 18: printdp(t, v, verbosity); 19: printvariablename(p) end else confusion(625) {:802}; if restorecurexp then unstashcurexp(p) end; {:801} {807:} procedure disperr(p: halfword; s: strnumber); begin if interaction = 3 then null; printnl(629); printexp(p, 1); if s <> 155 then begin printnl(133); print(s) end end; {:807} {594:} function pplusfq(p: halfword; f: integer; q: halfword; t, tt: smallnumber): halfword; label 30; var pp, qq: halfword; r, s: halfword; threshold: integer; v: integer; begin if t = 17 then threshold := 2685 else threshold := 8; r := 29999; pp := mem[p].hh.lh; qq := mem[q].hh.lh; while true do if pp = qq then if pp = (-30000) then goto 30 {595:} else begin if tt = 17 then v := mem[p + 1].int + takefraction(f, mem[q + 1].int) else v := mem[p + 1].int + takescaled(f, mem[q + 1].int); mem[p + 1].int := v; s := p; p := mem[p].hh.rh; if abs(v) < threshold then freenode(s, 2) else begin if abs(v) >= 626349397 then if watchcoefs then begin mem[qq].hh.b0 := 0; fixneeded := true end; mem[r].hh.rh := s; r := s end; pp := mem[p].hh.lh; q := mem[q].hh.rh; qq := mem[q].hh.lh end {:595} else if mem[pp + 1].int < mem[qq + 1].int then begin {596:} if tt = 17 then v := takefraction(f, mem[q + 1].int) else v := takescaled(f, mem[q + 1].int); if abs(v) > (threshold div 2) then begin s := getnode(2); mem[s].hh.lh := qq; mem[s + 1].int := v; if abs(v) >= 626349397 then if watchcoefs then begin mem[qq].hh.b0 := 0; fixneeded := true end; mem[r].hh.rh := s; r := s end; q := mem[q].hh.rh; qq := mem[q].hh.lh end else begin {:596} mem[r].hh.rh := p; r := p; p := mem[p].hh.rh; pp := mem[p].hh.lh end; 30: if t = 17 then mem[p + 1].int := slowadd(mem[p + 1].int, takefraction(mem[q + 1].int, f)) else mem[p + 1].int := slowadd(mem[p + 1].int, takescaled(mem[q + 1].int, f)); mem[r].hh.rh := p; depfinal := p; pplusfq := mem[29999].hh.rh end; {:594} {600:} function poverv(p: halfword; v: scaled; t0, t1: smallnumber): halfword; var r, s: halfword; w: integer; threshold: integer; scalingdown: boolean; begin if t0 <> t1 then scalingdown := true else scalingdown := false; if t1 = 17 then threshold := 1342 else threshold := 4; r := 29999; while mem[p].hh.lh <> (-30000) do begin if scalingdown then if abs(v) < 524288 then w := makescaled(mem[p + 1].int, v * 4096) else w := makescaled(roundfraction(mem[p + 1].int), v) else w := makescaled(mem[p + 1].int, v); if abs(w) <= threshold then begin s := mem[p].hh.rh; freenode(p, 2); p := s end else begin if abs(w) >= 626349397 then begin fixneeded := true; mem[mem[p].hh.lh].hh.b0 := 0 end; mem[r].hh.rh := p; r := p; mem[p + 1].int := w; p := mem[p].hh.rh end end; mem[r].hh.rh := p; mem[p + 1].int := makescaled(mem[p + 1].int, v); poverv := mem[29999].hh.rh end; { poverv } {:600} {602:} procedure valtoobig(x: scaled); begin if internal[40] > 0 then begin begin if interaction = 3 then null; printnl(133); print(456) end; printscaled(x); printchar(41); begin helpptr := 4; helpline[3] := 457; helpline[2] := 458; helpline[1] := 459; helpline[0] := 460 end; error end end; {:602} {603:} procedure makeknown(p, q: halfword); var t: 17..18; begin mem[mem[q].hh.rh + 1].hh.lh := mem[p + 1].hh.lh; mem[mem[p + 1].hh.lh].hh.rh := mem[q].hh.rh; t := mem[p].hh.b0; mem[p].hh.b0 := 16; mem[p + 1].int := mem[q + 1].int; freenode(q, 2); if abs(mem[p + 1].int) >= 268435456 then valtoobig(mem[p + 1].int); if internal[2] > 0 then if interesting(p) then begin begindiagnostic; printnl(461); printvariablename(p); printchar(61); printscaled(mem[p + 1].int); enddiagnostic(false) end; if curexp = p then if curtype = t then begin curtype := 16; curexp := mem[p + 1].int; freenode(p, 2) end end; {:603} {604:} procedure fixdependencies; label 30; var p, q, r, s, t: halfword; x: halfword; begin r := mem[-29987].hh.rh; s := -30000; while r <> (-29987) do begin t := r; {605:} r := t + 1; while true do begin q := mem[r].hh.rh; x := mem[q].hh.lh; if x = (-30000) then goto 30; if mem[x].hh.b0 <= 1 then begin if mem[x].hh.b0 < 1 then begin p := getavail; mem[p].hh.rh := s; s := p; mem[s].hh.lh := x; mem[x].hh.b0 := 1 end; mem[q + 1].int := mem[q + 1].int div 4; if mem[q + 1].int = 0 then begin mem[r].hh.rh := mem[q].hh.rh; freenode(q, 2); q := r end end; r := q end; 30: {:605} null; r := mem[q].hh.rh; if q = mem[t + 1].hh.rh then makeknown(t, q) end; while s <> (-30000) do begin p := mem[s].hh.rh; x := mem[s].hh.lh; begin mem[s].hh.rh := avail; avail := s end {dynused:=dynused-1;}; s := p; mem[x].hh.b0 := 19; mem[x + 1].int := mem[x + 1].int + 2 end; fixneeded := false end; { fixdependencies } {:604} {268:} procedure tossknotlist(p: halfword); var q: halfword; r: halfword; begin q := p; repeat r := mem[q].hh.rh; freenode(q, 7); q := r until q = p end; {:268} {385:} procedure tossedges(h: halfword); var p, q: halfword; begin q := mem[h].hh.rh; while q <> h do begin flushlist(mem[q + 1].hh.rh); if mem[q + 1].hh.lh > (-29999) then flushlist(mem[q + 1].hh.lh); p := q; q := mem[q].hh.rh; freenode(p, 2) end; freenode(h, 6) end; {:385} {487:} procedure tosspen(p: halfword); var k: 1..8; w, ww: halfword; begin if p <> (-29997) then begin for k := 1 to 8 do begin w := mem[p + k].hh.rh; repeat ww := mem[w].hh.rh; freenode(w, 3); w := ww until w = mem[p + k].hh.rh end; freenode(p, 10) end end; {:487} {620:} procedure ringdelete(p: halfword); var q: halfword; begin q := mem[p + 1].int; if q <> (-30000) then if q <> p then begin while mem[q + 1].int <> p do q := mem[q + 1].int; mem[q + 1].int := mem[p + 1].int end end; {:620} {809:} procedure recyclevalue(p: halfword); label 30; var t: smallnumber; v: integer; vv: integer; q, r, s, pp: halfword; begin t := mem[p].hh.b0; if t < 17 then v := mem[p + 1].int; case t of 0, 1, 2, 16, 15: null; 3, 5, 7, 12, 10: ringdelete(p); 4: begin if strref[v] < 127 then if strref[v] > 1 then strref[v] := strref[v] - 1 else flushstring(v) end; 6: if mem[v].hh.lh = (-30000) then tosspen(v) else mem[v].hh.lh := mem[v].hh.lh - 1; 9, 8: tossknotlist(v); 11: tossedges(v); 14, 13: {810:} if v <> (-30000) then begin q := v + bignodesize[t]; repeat q := q - 2; recyclevalue(q) until q = v; freenode(v, bignodesize[t]) end {:810}; 17, 18: begin {811:} q := mem[p + 1].hh.rh; while mem[q].hh.lh <> (-30000) do q := mem[q].hh.rh; mem[mem[p + 1].hh.lh].hh.rh := mem[q].hh.rh; mem[mem[q].hh.rh + 1].hh.lh := mem[p + 1].hh.lh; mem[q].hh.rh := -30000; flushnodelist(mem[p + 1].hh.rh) end; {:811} 19: begin {812:} maxc[17] := 0; maxc[18] := 0; maxlink[17] := -30000; maxlink[18] := -30000; q := mem[-29987].hh.rh; while q <> (-29987) do begin s := q + 1; while true do begin r := mem[s].hh.rh; if mem[r].hh.lh = (-30000) then goto 30; if mem[r].hh.lh <> p then s := r else begin t := mem[q].hh.b0; mem[s].hh.rh := mem[r].hh.rh; mem[r].hh.lh := q; if abs(mem[r + 1].int) > maxc[t] then begin {814:} if maxc[t] > 0 then begin mem[maxptr[t]].hh.rh := maxlink[t]; maxlink[t] := maxptr[t] end; maxc[t] := abs(mem[r + 1].int); maxptr[t] := r end else begin {:814} mem[r].hh.rh := maxlink[t]; maxlink[t] := r end end end; 30: q := mem[r].hh.rh end; if (maxc[17] > 0) or (maxc[18] > 0) then begin {815:} if (maxc[17] >= 268435456) or ((maxc[17] div 4096) >= maxc[18]) then t := 17 else t := 18; {816:} s := maxptr[t]; pp := mem[s].hh.lh; v := mem[s + 1].int; if t = 17 then mem[s + 1].int := -268435456 else mem[s + 1].int := -65536; r := mem[pp + 1].hh.rh; mem[s].hh.rh := r; while mem[r].hh.lh <> (-30000) do r := mem[r].hh.rh; q := mem[r].hh.rh; mem[r].hh.rh := -30000; mem[q + 1].hh.lh := mem[pp + 1].hh.lh; mem[mem[pp + 1].hh.lh].hh.rh := q; begin mem[pp].hh.b0 := 19; serialno := serialno + 64; mem[pp + 1].int := serialno end; if curexp = pp then if curtype = t then curtype := 19; if internal[2] > 0 then {817:} if interesting(p) then begin begindiagnostic; printnl(631); if v > 0 then printchar(45); if t = 17 then vv := roundfraction(maxc[17]) else vv := maxc[18]; if vv <> 65536 then printscaled(vv); printvariablename(p); while (mem[p + 1].int mod 64) > 0 do begin print(455); mem[p + 1].int := mem[p + 1].int - 2 end; if t = 17 then printchar(61) else print(632); printdependency(s, t); enddiagnostic(false) end {:817} {:816}; t := 35 - t; if maxc[t] > 0 then begin mem[maxptr[t]].hh.rh := maxlink[t]; maxlink[t] := maxptr[t] end; if t <> 17 then {818:} for t := 17 to 18 do begin r := maxlink[t]; while r <> (-30000) do begin q := mem[r].hh.lh; mem[q + 1].hh.rh := pplusfq(mem[q + 1].hh.rh, makefraction(mem[r + 1].int, -v), s, t, 17); if mem[q + 1].hh.rh = depfinal then makeknown(q, depfinal); q := r; r := mem[r].hh.rh; freenode(q, 2) end end {:818} {819:} else for t := 17 to 18 do begin r := maxlink[t]; while r <> (-30000) do begin q := mem[r].hh.lh; if t = 17 then begin if curexp = q then if curtype = 17 then curtype := 18; mem[q + 1].hh.rh := poverv(mem[q + 1].hh.rh, 65536, 17, 18); mem[q].hh.b0 := 18; mem[r + 1].int := roundfraction(mem[r + 1].int) end; mem[q + 1].hh.rh := pplusfq(mem[q + 1].hh.rh, makescaled(mem[r + 1].int, -v), s, 18, 18); if mem[q + 1].hh.rh = depfinal then makeknown(q, depfinal); q := r; r := mem[r].hh.rh; freenode(q, 2) end end {:819}; flushnodelist(s); if fixneeded then fixdependencies; begin if aritherror then cleararith end end {:815} end; {:812} 20, 21: confusion(630); 22, 23: deletemacref(mem[p + 1].int) end; mem[p].hh.b0 := 0 end; {:809} {808:} procedure flushcurexp(v: scaled); begin if curtype in [3, 5, 7, 12, 10, 13, 14, 17, 18, 19, 6, 4, 8, 9, 11] then case curtype of 3, 5, 7, 12, 10, 13, 14, 17, 18, 19: begin recyclevalue(curexp); freenode(curexp, 2) end; 6: if mem[curexp].hh.lh = (-30000) then tosspen(curexp) else mem[curexp].hh.lh := mem[curexp].hh.lh - 1; 4: begin if strref[curexp] < 127 then if strref[curexp] > 1 then strref[curexp] := strref[curexp] - 1 else flushstring(curexp) end; 8, 9: tossknotlist(curexp); 11: tossedges(curexp) end else null; curtype := 16; curexp := v end; {:808} {820:} procedure flusherror(v: scaled); begin error; flushcurexp(v) end; procedure backerror; forward; procedure getxnext; forward; procedure putgeterror; begin backerror; getxnext end; { putgeterror } procedure putgetflusherror(v: scaled); begin putgeterror; flushcurexp(v) end; {:820} {247:} procedure flushbelowvariable(p: halfword); var q, r: halfword; begin if mem[p].hh.b0 <> 21 then recyclevalue(p) else begin q := mem[p + 1].hh.rh; while mem[q].hh.b1 = 3 do begin flushbelowvariable(q); r := q; q := mem[q].hh.rh; freenode(r, 3) end; r := mem[p + 1].hh.lh; q := mem[r].hh.rh; recyclevalue(r); if mem[p].hh.b1 <= 1 then freenode(r, 2) else freenode(r, 3); repeat flushbelowvariable(q); r := q; q := mem[q].hh.rh; freenode(r, 3) until q = (-29983); mem[p].hh.b0 := 0 end end; {:247} procedure flushvariable(p, t: halfword; discardsuffixes: boolean); label 10; var q, r: halfword; n: halfword; begin while t <> (-30000) do begin if mem[p].hh.b0 <> 21 then goto 10; n := mem[t].hh.lh; t := mem[t].hh.rh; if n = 0 then begin r := p + 1; q := mem[r].hh.rh; while mem[q].hh.b1 = 3 do begin flushvariable(q, t, discardsuffixes); if t = (-30000) then if mem[q].hh.b0 = 21 then r := q else begin mem[r].hh.rh := mem[q].hh.rh; freenode(q, 3) end else r := q; q := mem[r].hh.rh end end; p := mem[p + 1].hh.lh; repeat r := p; p := mem[p].hh.rh until mem[p + 2].hh.lh >= n; if mem[p + 2].hh.lh <> n then goto 10 end; if discardsuffixes then flushbelowvariable(p) else begin if mem[p].hh.b0 = 21 then p := mem[p + 1].hh.lh; recyclevalue(p) end; 10: null end; {:246} {248:} function undtype(p: halfword): smallnumber; begin case mem[p].hh.b0 of 0, 1: undtype := 0; 2, 3: undtype := 3; 4, 5: undtype := 5; 6, 7, 8: undtype := 7; 9, 10: undtype := 10; 11, 12: undtype := 12; 13, 14, 15: undtype := mem[p].hh.b0; 16, 17, 18, 19: undtype := 15 end end; {:248} {249:} procedure clearsymbol(p: halfword; saving: boolean); var q: halfword; begin q := eqtb[p].rh; if eqtb[p].lh mod 83 in [10, 53, 44, 49, 41] then case eqtb[p].lh mod 83 of 10, 53, 44, 49: if not saving then deletemacref(q); 41: if q <> (-30000) then if saving then mem[q].hh.b1 := 1 else begin flushbelowvariable(q); freenode(q, 2) end end else null; eqtb[p] := eqtb[2241] end; {:249} {252:} procedure savevariable(q: halfword); var p: halfword; begin if saveptr <> (-30000) then begin p := getnode(2); mem[p].hh.lh := q; mem[p].hh.rh := saveptr; mem[p + 1].hh := eqtb[q]; saveptr := p end; clearsymbol(q, saveptr <> (-30000)) end; {:252} {253:} procedure saveinternal(q: halfword); var p: halfword; begin if saveptr <> (-30000) then begin p := getnode(2); mem[p].hh.lh := 2241 + q; mem[p].hh.rh := saveptr; mem[p + 1].int := internal[q]; saveptr := p end end; { saveinternal } {:253} {254:} procedure unsave; var q: halfword; p: halfword; begin while mem[saveptr].hh.lh <> 0 do begin q := mem[saveptr].hh.lh; if q > 2241 then begin if internal[8] > 0 then begin begindiagnostic; printnl(383); print(intname[q - 2241]); printchar(61); printscaled(mem[saveptr + 1].int); printchar(125); enddiagnostic(false) end; internal[q - 2241] := mem[saveptr + 1].int end else begin if internal[8] > 0 then begin begindiagnostic; printnl(383); print(hash[q].rh); printchar(125); enddiagnostic(false) end; clearsymbol(q, false); eqtb[q] := mem[saveptr + 1].hh; if (eqtb[q].lh mod 83) = 41 then begin p := eqtb[q].rh; if p <> (-30000) then mem[p].hh.b1 := 0 end end; p := mem[saveptr].hh.rh; freenode(saveptr, 2); saveptr := p end; p := mem[saveptr].hh.rh; begin mem[saveptr].hh.rh := avail; avail := saveptr end {dynused:=dynused-1;}; saveptr := p end; {:254} {264:} function copyknot(p: halfword): halfword; var q: halfword; k: 0..6; begin q := getnode(7); for k := 0 to 6 do mem[q + k] := mem[p + k]; copyknot := q end; {:264} {265:} function copypath(p: halfword): halfword; label 10; var q, pp, qq: halfword; begin q := getnode(7); qq := q; pp := p; while true do begin mem[qq].hh.b0 := mem[pp].hh.b0; mem[qq].hh.b1 := mem[pp].hh.b1; mem[qq + 1].int := mem[pp + 1].int; mem[qq + 2].int := mem[pp + 2].int; mem[qq + 3].int := mem[pp + 3].int; mem[qq + 4].int := mem[pp + 4].int; mem[qq + 5].int := mem[pp + 5].int; mem[qq + 6].int := mem[pp + 6].int; if mem[pp].hh.rh = p then begin mem[qq].hh.rh := q; copypath := q; goto 10 end; mem[qq].hh.rh := getnode(7); qq := mem[qq].hh.rh; pp := mem[pp].hh.rh end; 10: null end; {:265} {266:} function htapypoc(p: halfword): halfword; label 10; var q, pp, qq, rr: halfword; begin q := getnode(7); qq := q; pp := p; while true do begin mem[qq].hh.b1 := mem[pp].hh.b0; mem[qq].hh.b0 := mem[pp].hh.b1; mem[qq + 1].int := mem[pp + 1].int; mem[qq + 2].int := mem[pp + 2].int; mem[qq + 5].int := mem[pp + 3].int; mem[qq + 6].int := mem[pp + 4].int; mem[qq + 3].int := mem[pp + 5].int; mem[qq + 4].int := mem[pp + 6].int; if mem[pp].hh.rh = p then begin mem[q].hh.rh := qq; pathtail := pp; htapypoc := q; goto 10 end; rr := getnode(7); mem[rr].hh.rh := qq; qq := rr; pp := mem[pp].hh.rh end; 10: null end; {:266} {269:} {284:} {296:} function curlratio(gamma, atension, btension: scaled): fraction; var alpha, beta, num, denom, ff: fraction; begin alpha := makefraction(65536, atension); beta := makefraction(65536, btension); if alpha <= beta then begin ff := makefraction(alpha, beta); ff := takefraction(ff, ff); gamma := takefraction(gamma, ff); beta := beta div 4096; denom := (takefraction(gamma, alpha) + 196608) - beta; num := takefraction(gamma, 805306368 - alpha) + beta end else begin ff := makefraction(beta, alpha); ff := takefraction(ff, ff); beta := takefraction(beta, ff) div 4096; denom := (takefraction(gamma, alpha) + (ff div 1365)) - beta; num := takefraction(gamma, 805306368 - alpha) + beta end; if num >= (((denom + denom) + denom) + denom) then curlratio := 1073741824 else curlratio := makefraction(num, denom) end; {:296} {299:} procedure setcontrols(p, q: halfword; k: integer); var rr, ss: fraction; lt, rt: scaled; sine: fraction; begin lt := abs(mem[q + 4].int); rt := abs(mem[p + 6].int); rr := velocity(st, ct, sf, cf, rt); ss := velocity(sf, cf, st, ct, lt); if (mem[p + 6].int < 0) or (mem[q + 4].int < 0) then {300:} if ((st >= 0) and (sf >= 0)) or ((st <= 0) and (sf <= 0)) then begin sine := takefraction(abs(st), cf) + takefraction(abs(sf), ct); if sine > 0 then begin sine := takefraction(sine, 268500992); if mem[p + 6].int < 0 then if abvscd(abs(sf), 268435456, rr, sine) < 0 then rr := makefraction(abs(sf), sine); if mem[q + 4].int < 0 then if abvscd(abs(st), 268435456, ss, sine) < 0 then ss := makefraction(abs(st), sine) end end {:300}; mem[p + 5].int := mem[p + 1].int + takefraction(takefraction(deltax[k], ct) - takefraction(deltay[k], st), rr); mem[p + 6].int := mem[p + 2].int + takefraction(takefraction(deltay[k], ct) + takefraction(deltax[k], st), rr); mem[q + 3].int := mem[q + 1].int - takefraction(takefraction(deltax[k], cf) + takefraction(deltay[k], sf), ss); mem[q + 4].int := mem[q + 2].int - takefraction(takefraction(deltay[k], cf) - takefraction(deltax[k], sf), ss); mem[p].hh.b1 := 1; mem[q].hh.b0 := 1 end; { setcontrols } {:299} procedure solvechoices(p, q: halfword; n: halfword); label 40, 10; var k: 0..pathsize; r, s, t: halfword; sine, cosine: fraction; {286:} aa, bb, cc, ff, acc: fraction; dd, ee: scaled; lt, rt: scaled; {:286} begin k := 0; s := p; while true do begin t := mem[s].hh.rh; if k = 0 then {285:} case mem[s].hh.b1 of 2: if mem[t].hh.b0 = 2 then begin {301:} aa := narg(deltax[0], deltay[0]); nsincos(mem[p + 5].int - aa); ct := ncos; st := nsin; nsincos(mem[q + 3].int - aa); cf := ncos; sf := -nsin; setcontrols(p, q, 0); goto 10 end else begin {:301} {293:} vv[0] := mem[s + 5].int - narg(deltax[0], deltay[0]); if abs(vv[0]) > 188743680 then if vv[0] > 0 then vv[0] := vv[0] - 377487360 else vv[0] := vv[0] + 377487360; uu[0] := 0; ww[0] := 0 end {:293}; 3: if mem[t].hh.b0 = 3 then begin {302:} mem[p].hh.b1 := 1; mem[q].hh.b0 := 1; lt := abs(mem[q + 4].int); rt := abs(mem[p + 6].int); if rt = 65536 then begin if deltax[0] >= 0 then mem[p + 5].int := mem[p + 1].int + ((deltax[0] + 1) div 3) else mem[p + 5].int := mem[p + 1].int + ((deltax[0] - 1) div 3); if deltay[0] >= 0 then mem[p + 6].int := mem[p + 2].int + ((deltay[0] + 1) div 3) else mem[p + 6].int := mem[p + 2].int + ((deltay[0] - 1) div 3) end else begin ff := makefraction(65536, 3 * rt); mem[p + 5].int := mem[p + 1].int + takefraction(deltax[0], ff); mem[p + 6].int := mem[p + 2].int + takefraction(deltay[0], ff) end; if lt = 65536 then begin if deltax[0] >= 0 then mem[q + 3].int := mem[q + 1].int - ((deltax[0] + 1) div 3) else mem[q + 3].int := mem[q + 1].int - ((deltax[0] - 1) div 3); if deltay[0] >= 0 then mem[q + 4].int := mem[q + 2].int - ((deltay[0] + 1) div 3) else mem[q + 4].int := mem[q + 2].int - ((deltay[0] - 1) div 3) end else begin ff := makefraction(65536, 3 * lt); mem[q + 3].int := mem[q + 1].int - takefraction(deltax[0], ff); mem[q + 4].int := mem[q + 2].int - takefraction(deltay[0], ff) end; goto 10 end else begin {:302} {294:} cc := mem[s + 5].int; lt := abs(mem[t + 4].int); rt := abs(mem[s + 6].int); if (rt = 65536) and (lt = 65536) then uu[0] := makefraction((cc + cc) + 65536, cc + 131072) else uu[0] := curlratio(cc, rt, lt); vv[0] := -takefraction(psi[1], uu[0]); ww[0] := 0 end {:294}; 4: begin uu[0] := 0; vv[0] := 0; ww[0] := 268435456 end end {:285} else case mem[s].hh.b0 of 5, 4: begin {287:} {288:} if abs(mem[r + 6].int) = 65536 then begin aa := 134217728; dd := 2 * delta[k] end else begin aa := makefraction(65536, (3 * abs(mem[r + 6].int)) - 65536); dd := takefraction(delta[k], 805306368 - makefraction(65536, abs(mem[r + 6].int))) end; if abs(mem[t + 4].int) = 65536 then begin bb := 134217728; ee := 2 * delta[k - 1] end else begin bb := makefraction(65536, (3 * abs(mem[t + 4].int)) - 65536); ee := takefraction(delta[k - 1], 805306368 - makefraction(65536, abs(mem[t + 4].int))) end; cc := 268435456 - takefraction(uu[k - 1], aa) {:288}; {289:} dd := takefraction(dd, cc); lt := abs(mem[s + 4].int); rt := abs(mem[s + 6].int); if lt <> rt then if lt < rt then begin ff := makefraction(lt, rt); ff := takefraction(ff, ff); dd := takefraction(dd, ff) end else begin ff := makefraction(rt, lt); ff := takefraction(ff, ff); ee := takefraction(ee, ff) end; ff := makefraction(ee, ee + dd) {:289}; uu[k] := takefraction(ff, bb); {290:} acc := -takefraction(psi[k + 1], uu[k]); if mem[r].hh.b1 = 3 then begin ww[k] := 0; vv[k] := acc - takefraction(psi[1], 268435456 - ff) end else begin ff := makefraction(268435456 - ff, cc); acc := acc - takefraction(psi[k], ff); ff := takefraction(ff, aa); vv[k] := acc - takefraction(vv[k - 1], ff); if ww[k - 1] = 0 then ww[k] := 0 else ww[k] := -takefraction(ww[k - 1], ff) end {:290}; if mem[s].hh.b0 = 5 then begin {291:} aa := 0; bb := 268435456; repeat k := k - 1; if k = 0 then k := n; aa := vv[k] - takefraction(aa, uu[k]); bb := ww[k] - takefraction(bb, uu[k]) until k = n; aa := makefraction(aa, 268435456 - bb); theta[n] := aa; vv[0] := aa; for k := 1 to n - 1 do vv[k] := vv[k] + takefraction(aa, ww[k]); goto 40 end {:291} end; {:287} 3: begin {295:} cc := mem[s + 3].int; lt := abs(mem[s + 4].int); rt := abs(mem[r + 6].int); if (rt = 65536) and (lt = 65536) then ff := makefraction((cc + cc) + 65536, cc + 131072) else ff := curlratio(cc, lt, rt); theta[n] := -makefraction(takefraction(vv[n - 1], ff), 268435456 - takefraction(ff, uu[n - 1])); goto 40 end; {:295} 2: begin {292:} theta[n] := mem[s + 3].int - narg(deltax[n - 1], deltay[n - 1]); if abs(theta[n]) > 188743680 then if theta[n] > 0 then theta[n] := theta[n] - 377487360 else theta[n] := theta[n] + 377487360; goto 40 end end {:292}; r := s; s := t; k := k + 1 end; 40: {297:} for k := n - 1 downto 0 do theta[k] := vv[k] - takefraction(theta[k + 1], uu[k]); s := p; k := 0; repeat t := mem[s].hh.rh; nsincos(theta[k]); st := nsin; ct := ncos; nsincos((-psi[k + 1]) - theta[k + 1]); sf := nsin; cf := ncos; setcontrols(s, t, k); k := k + 1; s := t until k = n {:297}; 10: null end; {:284} procedure makechoices(knots: halfword); label 30; var h: halfword; p, q: halfword; {280:} k, n: 0..pathsize; r, s, t: halfword; delx, dely: scaled; sine, cosine: fraction; {:280} begin begin if aritherror then cleararith end; if internal[4] > 0 then printpath(knots, 393, true); {271:} p := knots; repeat q := mem[p].hh.rh; if mem[p + 1].int = mem[q + 1].int then if mem[p + 2].int = mem[q + 2].int then if mem[p].hh.b1 > 1 then begin mem[p].hh.b1 := 1; if mem[p].hh.b0 = 4 then begin mem[p].hh.b0 := 3; mem[p + 3].int := 65536 end; mem[q].hh.b0 := 1; if mem[q].hh.b1 = 4 then begin mem[q].hh.b1 := 3; mem[q + 5].int := 65536 end; mem[p + 5].int := mem[p + 1].int; mem[q + 3].int := mem[p + 1].int; mem[p + 6].int := mem[p + 2].int; mem[q + 4].int := mem[p + 2].int end; p := q until p = knots {:271}; {272:} h := knots; while true do begin if mem[h].hh.b0 <> 4 then goto 30; if mem[h].hh.b1 <> 4 then goto 30; h := mem[h].hh.rh; if h = knots then begin mem[h].hh.b0 := 5; goto 30 end end; 30: {:272} null; p := h; {273:} repeat q := mem[p].hh.rh; if mem[p].hh.b1 >= 2 then begin while (mem[q].hh.b0 = 4) and (mem[q].hh.b1 = 4) do q := mem[q].hh.rh; {278:} {281:} k := 0; s := p; n := pathsize; repeat t := mem[s].hh.rh; deltax[k] := mem[t + 1].int - mem[s + 1].int; deltay[k] := mem[t + 2].int - mem[s + 2].int; delta[k] := pythadd(deltax[k], deltay[k]); if k > 0 then begin sine := makefraction(deltay[k - 1], delta[k - 1]); cosine := makefraction(deltax[k - 1], delta[k - 1]); psi[k] := narg(takefraction(deltax[k], cosine) + takefraction(deltay[k], sine), takefraction(deltay[k], cosine) - takefraction(deltax[k], sine)) end; k := k + 1; s := t; if k = pathsize then overflow(398, pathsize); if s = q then n := k until (k >= n) and (mem[s].hh.b0 <> 5); if k = n then psi[n] := 0 else psi[k] := psi[1] {:281}; {282:} if mem[q].hh.b0 = 4 then begin delx := mem[q + 5].int - mem[q + 1].int; dely := mem[q + 6].int - mem[q + 2].int; if (delx = 0) and (dely = 0) then begin mem[q].hh.b0 := 3; mem[q + 3].int := 65536 end else begin mem[q].hh.b0 := 2; mem[q + 3].int := narg(delx, dely) end end; if (mem[p].hh.b1 = 4) and (mem[p].hh.b0 = 1) then begin delx := mem[p + 1].int - mem[p + 3].int; dely := mem[p + 2].int - mem[p + 4].int; if (delx = 0) and (dely = 0) then begin mem[p].hh.b1 := 3; mem[p + 5].int := 65536 end else begin mem[p].hh.b1 := 2; mem[p + 5].int := narg(delx, dely) end end {:282}; solvechoices(p, q, n) {:278} end; p := q {:273} until p = h; if internal[4] > 0 then printpath(knots, 394, true); if aritherror then begin {270:} begin if interaction = 3 then null; printnl(133); print(395) end; begin helpptr := 2; helpline[1] := 396; helpline[0] := 397 end; putgeterror; aritherror := false end {:270} end; {:269} {311:} {------------------------------------------------------------------- procedure makemoves(xx0, xx1, xx2, xx3, yy0, yy1, yy2, yy3: scaled; xicorr, etacorr: smallnumber); moved to mf2ps3.p -------------------------------------------------------------------} procedure smoothmoves(b, t: integer); var k: 1..movesize; a, aa, aaa: integer; begin if (t - b) >= 3 then begin k := b + 2; aa := move[k - 1]; aaa := move[k - 2]; repeat a := move[k]; if abs(a - aa) > 1 then {322:} if a > aa then begin if aaa >= aa then if a >= move[k + 1] then begin move[k - 1] := move[k - 1] + 1; move[k] := a - 1 end end else begin if aaa <= aa then if a <= move[k + 1] then begin move[k - 1] := move[k - 1] - 1; move[k] := a + 1 end end {:322}; k := k + 1; aaa := aa; aa := a until k = t end end; {:321} {326:} procedure initedges(h: halfword); begin mem[h].hh.lh := h; mem[h].hh.rh := h; mem[h + 1].hh.lh := 8191; mem[h + 1].hh.rh := 1; mem[h + 2].hh.lh := 8191; mem[h + 2].hh.rh := 1; mem[h + 3].hh.lh := 4096; mem[h + 3].hh.rh := 0; mem[h + 4].int := 0; mem[h + 5].hh.rh := h; mem[h + 5].hh.lh := 0 end; {:326} {328:} procedure fixoffset; var p, q: halfword; delta: integer; begin delta := 8 * (mem[curedges + 3].hh.lh - 4096); mem[curedges + 3].hh.lh := 4096; q := mem[curedges].hh.rh; while q <> curedges do begin p := mem[q + 1].hh.rh; while p <> 30000 do begin mem[p].hh.lh := mem[p].hh.lh - delta; p := mem[p].hh.rh end; p := mem[q + 1].hh.lh; while p > (-29999) do begin mem[p].hh.lh := mem[p].hh.lh - delta; p := mem[p].hh.rh end; q := mem[q].hh.rh end end; {:328} {329:} procedure edgeprep(ml, mr, nl, nr: integer); var delta: halfword; p, q: halfword; begin ml := ml + 4096; mr := mr + 4096; nl := nl + 4096; nr := nr + 4095; if ml < mem[curedges + 2].hh.lh then mem[curedges + 2].hh.lh := ml; if mr > mem[curedges + 2].hh.rh then mem[curedges + 2].hh.rh := mr; if (not (abs((mem[curedges + 2].hh.lh + mem[curedges + 3].hh.lh) - 8192) < 4096)) or (not (abs((mem[curedges + 2].hh.rh + mem[curedges + 3].hh.lh) - 8192) < 4096)) then fixoffset; if mem[curedges].hh.rh = curedges then begin mem[curedges + 1].hh.lh := nr + 1; mem[curedges + 1].hh.rh := nr end; if nl < mem[curedges + 1].hh.lh then begin {330:} delta := mem[curedges + 1].hh.lh - nl; mem[curedges + 1].hh.lh := nl; p := mem[curedges].hh.rh; repeat q := getnode(2); mem[q + 1].hh.rh := 30000; mem[q + 1].hh.lh := -29999; mem[p].hh.lh := q; mem[q].hh.rh := p; p := q; delta := delta - 1 until delta = 0; mem[p].hh.lh := curedges; mem[curedges].hh.rh := p; if mem[curedges + 5].hh.rh = curedges then mem[curedges + 5].hh.lh := nl - 1 end {:330}; if nr > mem[curedges + 1].hh.rh then begin {331:} delta := nr - mem[curedges + 1].hh.rh; mem[curedges + 1].hh.rh := nr; p := mem[curedges].hh.lh; repeat q := getnode(2); mem[q + 1].hh.rh := 30000; mem[q + 1].hh.lh := -29999; mem[p].hh.rh := q; mem[q].hh.lh := p; p := q; delta := delta - 1 until delta = 0; mem[p].hh.rh := curedges; mem[curedges].hh.lh := p; if mem[curedges + 5].hh.rh = curedges then mem[curedges + 5].hh.lh := nr + 1 end {:331} end; {:329} {334:} function copyedges(h: halfword): halfword; var p, r: halfword; hh, pp, qq, rr, ss: halfword; begin hh := getnode(6); mem[hh + 1] := mem[h + 1]; mem[hh + 2] := mem[h + 2]; mem[hh + 3] := mem[h + 3]; mem[hh + 4] := mem[h + 4]; mem[hh + 5].hh.lh := mem[hh + 1].hh.rh + 1; mem[hh + 5].hh.rh := hh; p := mem[h].hh.rh; qq := hh; while p <> h do begin pp := getnode(2); mem[qq].hh.rh := pp; mem[pp].hh.lh := qq; {335:} r := mem[p + 1].hh.rh; rr := pp + 1; while r <> 30000 do begin ss := getavail; mem[rr].hh.rh := ss; rr := ss; mem[rr].hh.lh := mem[r].hh.lh; r := mem[r].hh.rh end; mem[rr].hh.rh := 30000; r := mem[p + 1].hh.lh; rr := 29999; while r > (-29999) do begin ss := getavail; mem[rr].hh.rh := ss; rr := ss; mem[rr].hh.lh := mem[r].hh.lh; r := mem[r].hh.rh end; mem[rr].hh.rh := r; mem[pp + 1].hh.lh := mem[29999].hh.rh {:335}; p := mem[p].hh.rh; qq := pp end; mem[qq].hh.rh := hh; mem[hh].hh.lh := qq; copyedges := hh end; {:334} {336:} procedure yreflectedges; var p, q, r: halfword; begin p := mem[curedges + 1].hh.lh; mem[curedges + 1].hh.lh := 8191 - mem[curedges + 1].hh.rh; mem[curedges + 1].hh.rh := 8191 - p; mem[curedges + 5].hh.lh := 8191 - mem[curedges + 5].hh.lh; p := mem[curedges].hh.rh; q := curedges; repeat r := mem[p].hh.rh; mem[p].hh.rh := q; mem[q].hh.lh := p; q := p; p := r until q = curedges; mem[curedges + 4].int := 0 end; {:336} {337:} procedure xreflectedges; var p, q, r, s: halfword; m: integer; begin p := mem[curedges + 2].hh.lh; mem[curedges + 2].hh.lh := 8192 - mem[curedges + 2].hh.rh; mem[curedges + 2].hh.rh := 8192 - p; m := ((4096 + mem[curedges + 3].hh.lh) * 8) - 65528; mem[curedges + 3].hh.lh := 4096; p := mem[curedges].hh.rh; {339:} repeat q := mem[p + 1].hh.rh; r := 30000; while q <> 30000 do begin s := mem[q].hh.rh; mem[q].hh.rh := r; r := q; mem[r].hh.lh := m - mem[q].hh.lh; q := s end; mem[p + 1].hh.rh := r {:339}; {338:} q := mem[p + 1].hh.lh; while q > (-29999) do begin mem[q].hh.lh := m - mem[q].hh.lh; q := mem[q].hh.rh end {:338}; p := mem[p].hh.rh until p = curedges; mem[curedges + 4].int := 0 end; { xreflectedges } {:337} {340:} procedure yscaleedges(s: integer); var p, q, pp, r, rr, ss: halfword; t: integer; begin if ((s * (mem[curedges + 1].hh.rh - 4095)) >= 4096) or ((s * (mem[curedges + 1].hh.lh - 4096)) <= (-4096)) then begin begin if interaction = 3 then null; printnl(133); print(402) end; begin helpptr := 3; helpline[2] := 403; helpline[1] := 404; helpline[0] := 405 end; putgeterror end else begin mem[curedges + 1].hh.rh := (s * (mem[curedges + 1].hh.rh - 4095)) + 4095; mem[curedges + 1].hh.lh := (s * (mem[curedges + 1].hh.lh - 4096)) + 4096; {341:} p := curedges; repeat q := p; p := mem[p].hh.rh; for t := 2 to s do begin pp := getnode(2); mem[q].hh.rh := pp; mem[p].hh.lh := pp; mem[pp].hh.rh := p; mem[pp].hh.lh := q; q := pp; {335:} r := mem[p + 1].hh.rh; rr := pp + 1; while r <> 30000 do begin ss := getavail; mem[rr].hh.rh := ss; rr := ss; mem[rr].hh.lh := mem[r].hh.lh; r := mem[r].hh.rh end; mem[rr].hh.rh := 30000; r := mem[p + 1].hh.lh; rr := 29999; while r > (-29999) do begin ss := getavail; mem[rr].hh.rh := ss; rr := ss; mem[rr].hh.lh := mem[r].hh.lh; r := mem[r].hh.rh end; mem[rr].hh.rh := r; mem[pp + 1].hh.lh := mem[29999].hh.rh {:335} end until mem[p].hh.rh = curedges {:341}; mem[curedges + 4].int := 0 end end; {:340} {342:} procedure xscaleedges(s: integer); var p, q: halfword; t: 0..65535; w: 0..7; delta: integer; begin if ((s * (mem[curedges + 2].hh.rh - 4096)) >= 4096) or ((s * (mem[curedges + 2].hh.lh - 4096)) <= (-4096)) then begin begin if interaction = 3 then null; printnl(133); print(402) end; begin helpptr := 3; helpline[2] := 406; helpline[1] := 404; helpline[0] := 405 end; putgeterror end else if (mem[curedges + 2].hh.rh <> 4096) or (mem[curedges + 2].hh.lh <> 4096) then begin mem[curedges + 2].hh.rh := (s * (mem[curedges + 2].hh.rh - 4096)) + 4096; mem[curedges + 2].hh.lh := (s * (mem[curedges + 2].hh.lh - 4096)) + 4096; delta := (8 * (4096 - (s * mem[curedges + 3].hh.lh))) - 32768; mem[curedges + 3].hh.lh := 4096; {343:} q := mem[curedges].hh.rh; repeat p := mem[q + 1].hh.rh; while p <> 30000 do begin t := mem[p].hh.lh + 32768; w := t mod 8; mem[p].hh.lh := (((t - w) * s) + w) + delta; p := mem[p].hh.rh end; p := mem[q + 1].hh.lh; while p > (-29999) do begin t := mem[p].hh.lh + 32768; w := t mod 8; mem[p].hh.lh := (((t - w) * s) + w) + delta; p := mem[p].hh.rh end; q := mem[q].hh.rh until q = curedges {:343}; mem[curedges + 4].int := 0 end end; { xscaleedges } {:342} {344:} procedure negateedges(h: halfword); label 30; var p, q, r, s, t, u: halfword; begin p := mem[h].hh.rh; while p <> h do begin q := mem[p + 1].hh.lh; while q > (-29999) do begin mem[q].hh.lh := (8 - (2 * ((mem[q].hh.lh + 32768) mod 8))) + mem[q].hh.lh; q := mem[q].hh.rh end; q := mem[p + 1].hh.rh; if q <> 30000 then begin repeat mem[q].hh.lh := (8 - (2 * ((mem[q].hh.lh + 32768) mod 8))) + mem[q].hh.lh; q := mem[q].hh.rh until q = 30000; {345:} u := p + 1; q := mem[u].hh.rh; r := q; s := mem[r].hh.rh; while true do if mem[s].hh.lh > mem[r].hh.lh then begin mem[u].hh.rh := q; if s = 30000 then goto 30; u := r; q := s; r := q; s := mem[r].hh.rh end else begin t := s; s := mem[t].hh.rh; mem[t].hh.rh := q; q := t end; 30: mem[r].hh.rh := 30000 {:345} end; p := mem[p].hh.rh end; mem[h + 4].int := 0 end; {:344} {346:} procedure sortedges(h: halfword); label 30; var k: halfword; p, q, r, s: halfword; begin r := mem[h + 1].hh.lh; mem[h + 1].hh.lh := -30000; p := mem[r].hh.rh; mem[r].hh.rh := 30000; mem[29999].hh.rh := r; while p > (-29999) do begin k := mem[p].hh.lh; q := 29999; repeat r := q; q := mem[r].hh.rh until k <= mem[q].hh.lh; mem[r].hh.rh := p; r := mem[p].hh.rh; mem[p].hh.rh := q; p := r end; {347:} begin r := h + 1; q := mem[r].hh.rh; p := mem[29999].hh.rh; while true do begin k := mem[p].hh.lh; while k > mem[q].hh.lh do begin r := q; q := mem[r].hh.rh end; mem[r].hh.rh := p; s := mem[p].hh.rh; mem[p].hh.rh := q; if s = 30000 then goto 30; r := p; p := s end; 30: {:347} null end end; {:346} {348:} procedure culledges(wlo, whi, wout, win: integer); label 30; var p, q, r, s: halfword; w: integer; d: integer; m: integer; mm: integer; ww: integer; prevw: integer; n, minn, maxn: halfword; mind, maxd: halfword; begin mind := 32767; maxd := -32768; minn := 32767; maxn := -32768; p := mem[curedges].hh.rh; n := mem[curedges + 1].hh.lh; while p <> curedges do begin if mem[p + 1].hh.lh > (-29999) then sortedges(p); if mem[p + 1].hh.rh <> 30000 then begin {349:} r := 29999; q := mem[p + 1].hh.rh; ww := 0; m := 1000000; prevw := 0; while true do begin if q = 30000 then mm := 1000000 else begin d := mem[q].hh.lh + 32768; mm := d div 8; ww := (ww + (d mod 8)) - 4 end; if mm > m then begin {350:} if w <> prevw then begin s := getavail; mem[r].hh.rh := s; mem[s].hh.lh := (((8 * m) - 32764) + w) - prevw; r := s; prevw := w end {:350}; if q = 30000 then goto 30 end; m := mm; if ww >= wlo then if ww <= whi then w := win else w := wout else w := wout; s := mem[q].hh.rh; begin mem[q].hh.rh := avail; avail := q end {dynused:=dynused-1;}; q := s end; 30: mem[r].hh.rh := 30000; mem[p + 1].hh.rh := mem[29999].hh.rh; if r <> 29999 then begin {351:} if minn = 32767 then minn := n; maxn := n; if mind > mem[mem[29999].hh.rh].hh.lh then mind := mem[mem[29999].hh.rh].hh.lh; if maxd < mem[r].hh.lh then maxd := mem[r].hh.lh end {:351} end {:349}; p := mem[p].hh.rh; n := n + 1 end; {352:} if minn > maxn then begin {353:} p := mem[curedges].hh.rh; while p <> curedges do begin q := mem[p].hh.rh; freenode(p, 2); p := q end; initedges(curedges) end else begin {:353} n := mem[curedges + 1].hh.lh; mem[curedges + 1].hh.lh := minn; while minn > n do begin p := mem[curedges].hh.rh; mem[curedges].hh.rh := mem[p].hh.rh; mem[mem[p].hh.rh].hh.lh := curedges; freenode(p, 2); n := n + 1 end; n := mem[curedges + 1].hh.rh; mem[curedges + 1].hh.rh := maxn; mem[curedges + 5].hh.lh := maxn + 1; mem[curedges + 5].hh.rh := curedges; while maxn < n do begin p := mem[curedges].hh.lh; mem[curedges].hh.lh := mem[p].hh.lh; mem[mem[p].hh.lh].hh.rh := curedges; freenode(p, 2); n := n - 1 end; mem[curedges + 2].hh.lh := (((mind + 32768) div 8) - mem[curedges + 3].hh.lh) + 4096; mem[curedges + 2].hh.rh := (((maxd + 32768) div 8) - mem[curedges + 3].hh.lh) + 4096 end {:352}; mem[curedges + 4].int := 0 end; {:348} {354:} procedure xyswapedges; label 30; var mmagic, nmagic: integer; p, q, r, s: halfword; {357:} mspread: integer; j, jj: 0..movesize; m, mm: integer; pd, rd: integer; pm, rm: integer; w: integer; ww: integer; dw: integer; {:357} {363:} extras: integer; xw: -3..3; k: integer; {:363} {356:} begin mspread := mem[curedges + 2].hh.rh - mem[curedges + 2].hh.lh; if mspread > movesize then overflow(407, movesize); for j := 0 to mspread do move[j] := 30000 {:356}; {355:} p := getnode(2); mem[p + 1].hh.rh := 30000; mem[p + 1].hh.lh := -30000; mem[p].hh.lh := curedges; mem[mem[curedges].hh.rh].hh.lh := p; p := getnode(2); mem[p + 1].hh.rh := 30000; mem[p].hh.lh := mem[curedges].hh.lh; {:355} {365:} mmagic := (mem[curedges + 2].hh.lh + mem[curedges + 3].hh.lh) - 4096; nmagic := (8 * mem[curedges + 1].hh.rh) - 32756 {:365}; repeat q := mem[p].hh.lh; if mem[q + 1].hh.lh > (-29999) then sortedges(q); {358:} r := mem[p + 1].hh.rh; freenode(p, 2); p := r; pd := mem[p].hh.lh + 32768; pm := pd div 8; r := mem[q + 1].hh.rh; rd := mem[r].hh.lh + 32768; rm := rd div 8; w := 0; while true do begin if pm < rm then mm := pm else mm := rm; if w <> 0 then {362:} if m <> mm then begin if (mm - mmagic) >= movesize then confusion(377); extras := (abs(w) - 1) div 3; if extras > 0 then begin if w > 0 then xw := +3 else xw := -3; ww := w - (extras * xw) end else ww := w; repeat j := m - mmagic; for k := 1 to extras do begin s := getavail; mem[s].hh.lh := nmagic + xw; mem[s].hh.rh := move[j]; move[j] := s end; s := getavail; mem[s].hh.lh := nmagic + ww; mem[s].hh.rh := move[j]; move[j] := s; m := m + 1 until m = mm end {:362}; if pd < rd then begin dw := (pd mod 8) - 4; {360:} s := mem[p].hh.rh; begin mem[p].hh.rh := avail; avail := p end {dynused:=dynused-1;}; p := s; pd := mem[p].hh.lh + 32768; pm := pd div 8 {:360} end else begin if r = 30000 then goto 30; dw := -((rd mod 8) - 4); {359:} r := mem[r].hh.rh; rd := mem[r].hh.lh + 32768; rm := rd div 8 {:359} end; m := mm; w := w + dw end; 30: {:358} null; p := q; nmagic := nmagic - 8 until mem[p].hh.lh = curedges; freenode(p, 2); {364:} move[mspread] := 0; j := 0; while move[j] = 30000 do j := j + 1; if j = mspread then initedges(curedges) else begin mm := mem[curedges + 2].hh.lh; mem[curedges + 2].hh.lh := mem[curedges + 1].hh.lh; mem[curedges + 2].hh.rh := mem[curedges + 1].hh.rh + 1; mem[curedges + 3].hh.lh := 4096; jj := mspread - 1; while move[jj] = 30000 do jj := jj - 1; mem[curedges + 1].hh.lh := j + mm; mem[curedges + 1].hh.rh := jj + mm; q := curedges; repeat p := getnode(2); mem[q].hh.rh := p; mem[p].hh.lh := q; mem[p + 1].hh.rh := move[j]; mem[p + 1].hh.lh := -30000; j := j + 1; q := p until j > jj; mem[q].hh.rh := curedges; mem[curedges].hh.lh := q; mem[curedges + 5].hh.lh := mem[curedges + 1].hh.rh + 1; mem[curedges + 5].hh.rh := curedges; mem[curedges + 4].int := 0 end end; {:364} {:354} {366:} procedure mergeedges(h: halfword); label 30; var p, q, r, pp, qq, rr: halfword; n: integer; k: halfword; delta: integer; begin if mem[h].hh.rh <> h then begin if (((mem[h + 2].hh.lh < mem[curedges + 2].hh.lh) or (mem[h + 2].hh.rh > mem[curedges + 2].hh.rh)) or (mem[h + 1].hh.lh < mem[curedges + 1].hh.lh)) or (mem[h + 1].hh.rh > mem[curedges + 1].hh.rh) then edgeprep(mem[h + 2].hh.lh - 4096, mem[h + 2].hh.rh - 4096, mem[h + 1].hh.lh - 4096, mem[h + 1].hh.rh - 4095); if mem[h + 3].hh.lh <> mem[curedges + 3].hh.lh then begin {367:} pp := mem[h].hh.rh; delta := 8 * (mem[curedges + 3].hh.lh - mem[h + 3].hh.lh); repeat qq := mem[pp + 1].hh.rh; while qq <> 30000 do begin mem[qq].hh.lh := mem[qq].hh.lh + delta; qq := mem[qq].hh.rh end; qq := mem[pp + 1].hh.lh; while qq > (-29999) do begin mem[qq].hh.lh := mem[qq].hh.lh + delta; qq := mem[qq].hh.rh end; pp := mem[pp].hh.rh until pp = h end {:367}; n := mem[curedges + 1].hh.lh; p := mem[curedges].hh.rh; pp := mem[h].hh.rh; while n < mem[h + 1].hh.lh do begin n := n + 1; p := mem[p].hh.rh end; {368:} repeat qq := mem[pp + 1].hh.lh; if qq > (-29999) then if mem[p + 1].hh.lh <= (-29999) then mem[p + 1].hh.lh := qq else begin while mem[qq].hh.rh > (-29999) do qq := mem[qq].hh.rh; mem[qq].hh.rh := mem[p + 1].hh.lh; mem[p + 1].hh.lh := mem[pp + 1].hh.lh end; mem[pp + 1].hh.lh := -30000; qq := mem[pp + 1].hh.rh; if qq <> 30000 then begin if mem[p + 1].hh.lh = (-29999) then mem[p + 1].hh.lh := -30000; mem[pp + 1].hh.rh := 30000; r := p + 1; q := mem[r].hh.rh; if q = 30000 then mem[p + 1].hh.rh := qq else while true do begin k := mem[qq].hh.lh; while k > mem[q].hh.lh do begin r := q; q := mem[r].hh.rh end; mem[r].hh.rh := qq; rr := mem[qq].hh.rh; mem[qq].hh.rh := q; if rr = 30000 then goto 30; r := qq; qq := rr end end; 30: {:368} null; pp := mem[pp].hh.rh; p := mem[p].hh.rh until pp = h end end; {:366} {369:} function totalweight(h: halfword): integer; var p, q: halfword; n: integer; m: 0..65535; begin n := 0; p := mem[h].hh.rh; while p <> h do begin q := mem[p + 1].hh.rh; while q <> 30000 do begin {370:} m := mem[q].hh.lh + 32768; n := n - (((m mod 8) - 4) * (m div 8)); q := mem[q].hh.rh end {:370}; q := mem[p + 1].hh.lh; while q > (-29999) do begin {370:} m := mem[q].hh.lh + 32768; n := n - (((m mod 8) - 4) * (m div 8)); q := mem[q].hh.rh end {:370}; p := mem[p].hh.rh end; totalweight := n end; {:369} {372:} procedure beginedgetracing; begin printdiagnostic(408, 155, true); print(409); printint(curwt); printchar(41); tracex := -4096 end; { beginedgetracing } procedure traceacorner; begin if fileoffset > (maxprintline - 13) then printnl(155); printchar(40); printint(tracex); printchar(44); printint(traceyy); printchar(41); tracey := traceyy end; procedure endedgetracing; begin if tracex = (-4096) then printnl(410) else begin traceacorner; printchar(46) end; enddiagnostic(true) end; {:372} {373:} procedure tracenewedge(r: halfword; n: integer); var d: integer; w: -3..3; m, n0, n1: integer; begin d := mem[r].hh.lh + 32768; w := (d mod 8) - 4; m := (d div 8) - mem[curedges + 3].hh.lh; if w = curwt then begin n0 := n + 1; n1 := n end else begin n0 := n; n1 := n + 1 end; if m <> tracex then begin if tracex = (-4096) then begin printnl(155); traceyy := n0 end else if traceyy <> n0 then printchar(63) else traceacorner; tracex := m; traceacorner end else begin if n0 <> traceyy then printchar(33); if ((n0 < n1) and (tracey > traceyy)) or ((n0 > n1) and (tracey < traceyy)) then traceacorner end; traceyy := n1 end; {:373} {374:} procedure lineedges(x0, y0, x1, y1: scaled); label 30, 31; var m0, n0, m1, n1: integer; delx, dely: scaled; yt: scaled; tx: scaled; p, r: halfword; base: integer; n: integer; begin n0 := roundunscaled(y0); n1 := roundunscaled(y1); if n0 <> n1 then begin m0 := roundunscaled(x0); m1 := roundunscaled(x1); delx := x1 - x0; dely := y1 - y0; yt := (n0 * 65536) - 32768; y0 := y0 - yt; y1 := y1 - yt; if n0 < n1 then begin {375:} base := ((8 * mem[curedges + 3].hh.lh) - 32764) - curwt; if m0 <= m1 then edgeprep(m0, m1, n0, n1) else edgeprep(m1, m0, n0, n1); {377:} n := mem[curedges + 5].hh.lh - 4096; p := mem[curedges + 5].hh.rh; if n <> n0 then if n < n0 then repeat n := n + 1; p := mem[p].hh.rh until n = n0 else repeat n := n - 1; p := mem[p].hh.lh until n = n0 {:377}; y0 := 65536 - y0; while true do begin r := getavail; mem[r].hh.rh := mem[p + 1].hh.lh; mem[p + 1].hh.lh := r; tx := takefraction(delx, makefraction(y0, dely)); if abvscd(delx, y0, dely, tx) < 0 then tx := tx - 1; mem[r].hh.lh := (8 * roundunscaled(x0 + tx)) + base; y1 := y1 - 65536; if internal[10] > 0 then tracenewedge(r, n); if y1 < 65536 then goto 30; p := mem[p].hh.rh; y0 := y0 + 65536; n := n + 1 end; 30: {:375} null end else begin {376:} base := ((8 * mem[curedges + 3].hh.lh) - 32764) + curwt; if m0 <= m1 then edgeprep(m0, m1, n1, n0) else edgeprep(m1, m0, n1, n0); n0 := n0 - 1; {377:} n := mem[curedges + 5].hh.lh - 4096; p := mem[curedges + 5].hh.rh; if n <> n0 then if n < n0 then repeat n := n + 1; p := mem[p].hh.rh until n = n0 else repeat n := n - 1; p := mem[p].hh.lh until n = n0 {:377}; while true do begin r := getavail; mem[r].hh.rh := mem[p + 1].hh.lh; mem[p + 1].hh.lh := r; tx := takefraction(delx, makefraction(y0, dely)); if abvscd(delx, y0, dely, tx) < 0 then tx := tx + 1; mem[r].hh.lh := (8 * roundunscaled(x0 - tx)) + base; y1 := y1 + 65536; if internal[10] > 0 then tracenewedge(r, n); if y1 >= 0 then goto 31; p := mem[p].hh.lh; y0 := y0 + 65536; n := n - 1 end; 31: {:376} null end; mem[curedges + 5].hh.rh := p; mem[curedges + 5].hh.lh := n + 4096 end end; {:374} {378:} procedure movetoedges(m0, n0, m1, n1: integer); label 60, 61, 62, 63, 30; var delta: 0..movesize; k: 0..movesize; p, r: halfword; dx: integer; edgeandweight: integer; j: integer; n: integer; {sum:integer;} {sum:=move[0]; for k:=1 to delta do sum:=sum+abs(move[k]); if sum<>m1-m0 then confusion(48);} begin delta := n1 - n0; {380:} case octant of 1: begin dx := 8; edgeprep(m0, m1, n0, n1); goto 60 end; 5: begin dx := 8; edgeprep(n0, n1, m0, m1); goto 62 end; 6: begin dx := -8; edgeprep(-n1, -n0, m0, m1); n0 := -n0; goto 62 end; 2: begin dx := -8; edgeprep(-m1, -m0, n0, n1); m0 := -m0; goto 60 end; 4: begin dx := -8; edgeprep(-m1, -m0, -n1, -n0); m0 := -m0; goto 61 end; 8: begin dx := -8; edgeprep(-n1, -n0, -m1, -m0); n0 := -n0; goto 63 end; 7: begin dx := 8; edgeprep(n0, n1, -m1, -m0); goto 63 end; 3: begin dx := 8; edgeprep(m0, m1, -n1, -n0); goto 61 end end; {:380} 60: {381:} {377:} n := mem[curedges + 5].hh.lh - 4096; p := mem[curedges + 5].hh.rh; if n <> n0 then if n < n0 then repeat n := n + 1; p := mem[p].hh.rh until n = n0 else repeat n := n - 1; p := mem[p].hh.lh until n = n0 {:377}; if delta > 0 then begin k := 0; edgeandweight := ((8 * (m0 + mem[curedges + 3].hh.lh)) - 32764) - curwt; repeat edgeandweight := edgeandweight + (dx * move[k]); begin r := avail; if r = (-30000) then r := getavail else begin avail := mem[r].hh.rh; mem[r].hh.rh := -30000 end {dynused:=dynused+1;} end; mem[r].hh.rh := mem[p + 1].hh.lh; mem[r].hh.lh := edgeandweight; if internal[10] > 0 then tracenewedge(r, n); mem[p + 1].hh.lh := r; p := mem[p].hh.rh; k := k + 1; n := n + 1 until k = delta end; goto 30 {:381}; 61: {382:} n0 := (-n0) - 1; {377:} n := mem[curedges + 5].hh.lh - 4096; p := mem[curedges + 5].hh.rh; if n <> n0 then if n < n0 then repeat n := n + 1; p := mem[p].hh.rh until n = n0 else repeat n := n - 1; p := mem[p].hh.lh until n = n0 {:377}; if delta > 0 then begin k := 0; edgeandweight := ((8 * (m0 + mem[curedges + 3].hh.lh)) - 32764) + curwt; repeat edgeandweight := edgeandweight + (dx * move[k]); begin r := avail; if r = (-30000) then r := getavail else begin avail := mem[r].hh.rh; mem[r].hh.rh := -30000 end {dynused:=dynused+1;} end; mem[r].hh.rh := mem[p + 1].hh.lh; mem[r].hh.lh := edgeandweight; if internal[10] > 0 then tracenewedge(r, n); mem[p + 1].hh.lh := r; p := mem[p].hh.lh; k := k + 1; n := n - 1 until k = delta end; goto 30 {:382}; 62: {383:} edgeandweight := ((8 * (n0 + mem[curedges + 3].hh.lh)) - 32764) - curwt; n0 := m0; k := 0; {377:} n := mem[curedges + 5].hh.lh - 4096; p := mem[curedges + 5].hh.rh; if n <> n0 then if n < n0 then repeat n := n + 1; p := mem[p].hh.rh until n = n0 else repeat n := n - 1; p := mem[p].hh.lh until n = n0 {:377}; repeat j := move[k]; while j > 0 do begin begin r := avail; if r = (-30000) then r := getavail else begin avail := mem[r].hh.rh; mem[r].hh.rh := -30000 end {dynused:=dynused+1;} end; mem[r].hh.rh := mem[p + 1].hh.lh; mem[r].hh.lh := edgeandweight; if internal[10] > 0 then tracenewedge(r, n); mem[p + 1].hh.lh := r; p := mem[p].hh.rh; j := j - 1; n := n + 1 end; edgeandweight := edgeandweight + dx; k := k + 1 until k > delta; goto 30 {:383}; 63: {384:} edgeandweight := ((8 * (n0 + mem[curedges + 3].hh.lh)) - 32764) + curwt; n0 := (-m0) - 1; k := 0; {377:} n := mem[curedges + 5].hh.lh - 4096; p := mem[curedges + 5].hh.rh; if n <> n0 then if n < n0 then repeat n := n + 1; p := mem[p].hh.rh until n = n0 else repeat n := n - 1; p := mem[p].hh.lh until n = n0 {:377}; repeat j := move[k]; while j > 0 do begin begin r := avail; if r = (-30000) then r := getavail else begin avail := mem[r].hh.rh; mem[r].hh.rh := -30000 end {dynused:=dynused+1;} end; mem[r].hh.rh := mem[p + 1].hh.lh; mem[r].hh.lh := edgeandweight; if internal[10] > 0 then tracenewedge(r, n); mem[p + 1].hh.lh := r; p := mem[p].hh.lh; j := j - 1; n := n - 1 end; edgeandweight := edgeandweight + dx; k := k + 1 until k > delta; goto 30 {:384}; 30: mem[curedges + 5].hh.lh := n + 4096; mem[curedges + 5].hh.rh := p end; {:378} {387:} procedure skew(x, y: scaled; octant: smallnumber); begin case octant of 1: begin curx := x - y; cury := y end; 5: begin curx := y - x; cury := x end; 6: begin curx := y + x; cury := -x end; 2: begin curx := (-x) - y; cury := y end; 4: begin curx := (-x) + y; cury := -y end; 8: begin curx := (-y) + x; cury := -x end; 7: begin curx := (-y) - x; cury := x end; 3: begin curx := x + y; cury := -y end end end; {:387} {390:} procedure abnegate(x, y: scaled; octantbefore, octantafter: smallnumber); begin if odd(octantbefore) = odd(octantafter) then curx := x else curx := -x; if (octantbefore > 2) = (octantafter > 2) then cury := y else cury := -y end; {:390} {391:} function crossingpoint(a, b, c: integer): fraction; label 10; var d: integer; x, xx, x0, x1, x2: integer; begin if a < 0 then begin crossingpoint := 0; goto 10 end; if c >= 0 then begin if b >= 0 then if c > 0 then begin crossingpoint := 268435457; goto 10 end else if (a = 0) and (b = 0) then begin crossingpoint := 268435457; goto 10 end else begin crossingpoint := 268435456; goto 10 end; if a = 0 then begin crossingpoint := 0; goto 10 end end else if a = 0 then if b <= 0 then begin crossingpoint := 0; goto 10 end; {392:} d := 1; x0 := a; x1 := a - b; x2 := b - c; repeat x := (x1 + x2) div 2; if (x1 - x0) > x0 then begin x2 := x; x0 := x0 + x0; d := d + d end else begin xx := (x1 + x) - x0; if xx > x0 then begin x2 := x; x0 := x0 + x0; d := d + d end else begin x0 := x0 - xx; if x <= x0 then if (x + x2) <= x0 then begin crossingpoint := 268435457; goto 10 end; x1 := x; d := (d + d) + 1 end end until d >= 268435456; crossingpoint := d - 268435456 {:392}; 10: null end; {:391} {394:} procedure printspec(s: strnumber); label 45, 30; var p, q: halfword; octant: smallnumber; begin printdiagnostic(411, s, true); p := curspec; octant := mem[p + 3].int; println; unskew(mem[curspec + 1].int, mem[curspec + 2].int, octant); printtwo(curx, cury); print(412); while true do begin print(octantdir[octant]); printchar(39); while true do begin q := mem[p].hh.rh; if mem[p].hh.b1 = 0 then goto 45; {397:} begin printnl(423); unskew(mem[p + 5].int, mem[p + 6].int, octant); printtwo(curx, cury); print(390); unskew(mem[q + 3].int, mem[q + 4].int, octant); printtwo(curx, cury); printnl(387); unskew(mem[q + 1].int, mem[q + 2].int, octant); printtwo(curx, cury); print(424); printint(mem[q].hh.b0 - 1) end {:397}; p := q end; 45: if q = curspec then goto 30; p := q; octant := mem[p + 3].int; printnl(413) end; 30: printnl(414); enddiagnostic(true) end; {:394} {398:} procedure printstrange(s: strnumber); var p: halfword; f: halfword; q: halfword; t: integer; begin if interaction = 3 then null; printnl(62); {399:} p := curspec; t := 128; repeat p := mem[p].hh.rh; if mem[p].hh.b0 <> 0 then begin if mem[p].hh.b0 < t then f := p; t := mem[p].hh.b0 end until p = curspec {:399}; {400:} p := curspec; q := p; repeat p := mem[p].hh.rh; if mem[p].hh.b0 = 0 then q := p until p = f {:400}; t := 0; repeat if mem[p].hh.b0 <> 0 then begin if mem[p].hh.b0 <> t then begin t := mem[p].hh.b0; printchar(32); printint(t - 1) end; if q <> (-30000) then begin {401:} if mem[mem[q].hh.rh].hh.b0 = 0 then begin print(425); print(octantdir[mem[q + 3].int]); q := mem[q].hh.rh; while mem[mem[q].hh.rh].hh.b0 = 0 do begin printchar(32); print(octantdir[mem[q + 3].int]); q := mem[q].hh.rh end; printchar(41) end {:401}; printchar(32); print(octantdir[mem[q + 3].int]); q := -30000 end end else if q = (-30000) then q := p; p := mem[p].hh.rh until p = f; printchar(32); printint(mem[p].hh.b0 - 1); if q <> (-30000) then {401:} if mem[mem[q].hh.rh].hh.b0 = 0 then begin print(425); print(octantdir[mem[q + 3].int]); q := mem[q].hh.rh; while mem[mem[q].hh.rh].hh.b0 = 0 do begin printchar(32); print(octantdir[mem[q + 3].int]); q := mem[q].hh.rh end; printchar(41) end {:401}; begin if interaction = 3 then null; printnl(133); print(s) end end; { printstrange } {:398} {402:} {405:} procedure removecubic(p: halfword); var q: halfword; begin q := mem[p].hh.rh; mem[p].hh.b1 := mem[q].hh.b1; mem[p].hh.rh := mem[q].hh.rh; mem[p + 1].int := mem[q + 1].int; mem[p + 2].int := mem[q + 2].int; mem[p + 5].int := mem[q + 5].int; mem[p + 6].int := mem[q + 6].int; freenode(q, 7) end; {:405} {406:} {410:} procedure splitcubic(p: halfword; t: fraction; xq, yq: scaled); var v: scaled; q, r: halfword; begin q := mem[p].hh.rh; r := getnode(7); mem[p].hh.rh := r; mem[r].hh.rh := q; mem[r].hh.b0 := mem[q].hh.b0; mem[r].hh.b1 := mem[p].hh.b1; v := mem[p + 5].int - takefraction(mem[p + 5].int - mem[q + 3].int, t); mem[p + 5].int := mem[p + 1].int - takefraction(mem[p + 1].int - mem[p + 5].int, t); mem[q + 3].int := mem[q + 3].int - takefraction(mem[q + 3].int - xq, t); mem[r + 3].int := mem[p + 5].int - takefraction(mem[p + 5].int - v, t); mem[r + 5].int := v - takefraction(v - mem[q + 3].int, t); mem[r + 1].int := mem[r + 3].int - takefraction(mem[r + 3].int - mem[r + 5].int, t); v := mem[p + 6].int - takefraction(mem[p + 6].int - mem[q + 4].int, t); mem[p + 6].int := mem[p + 2].int - takefraction(mem[p + 2].int - mem[p + 6].int, t); mem[q + 4].int := mem[q + 4].int - takefraction(mem[q + 4].int - yq, t); mem[r + 4].int := mem[p + 6].int - takefraction(mem[p + 6].int - v, t); mem[r + 6].int := v - takefraction(v - mem[q + 4].int, t); mem[r + 2].int := mem[r + 4].int - takefraction(mem[r + 4].int - mem[r + 6].int, t) end; {:410} procedure quadrantsubdivide; label 22, 10; var p, q, r, s, pp, qq: halfword; firstx, firsty: scaled; del1, del2, del3, del, dmax: scaled; t: fraction; destx, desty: scaled; constantx: boolean; begin p := curspec; firstx := mem[curspec + 1].int; firsty := mem[curspec + 2].int; repeat 22: q := mem[p].hh.rh; {407:} if q = curspec then begin destx := firstx; desty := firsty end else begin destx := mem[q + 1].int; desty := mem[q + 2].int end; del1 := mem[p + 5].int - mem[p + 1].int; del2 := mem[q + 3].int - mem[p + 5].int; del3 := destx - mem[q + 3].int; {408:} if del1 <> 0 then del := del1 else if del2 <> 0 then del := del2 else del := del3; if del <> 0 then begin dmax := abs(del1); if abs(del2) > dmax then dmax := abs(del2); if abs(del3) > dmax then dmax := abs(del3); while dmax < 134217728 do begin dmax := dmax + dmax; del1 := del1 + del1; del2 := del2 + del2; del3 := del3 + del3 end end {:408}; if del = 0 then constantx := true else begin constantx := false; if del < 0 then begin {409:} mem[p + 1].int := -mem[p + 1].int; mem[p + 5].int := -mem[p + 5].int; mem[q + 3].int := -mem[q + 3].int; del1 := -del1; del2 := -del2; del3 := -del3; destx := -destx; mem[p].hh.b1 := 2 end {:409}; t := crossingpoint(del1, del2, del3); if t < 268435456 then begin {411:} splitcubic(p, t, destx, desty); r := mem[p].hh.rh; if mem[r].hh.b1 > 1 then mem[r].hh.b1 := 1 else mem[r].hh.b1 := 2; if mem[r + 1].int < mem[p + 1].int then mem[r + 1].int := mem[p + 1].int; mem[r + 3].int := mem[r + 1].int; mem[r + 1].int := -mem[r + 1].int; mem[r + 5].int := mem[r + 1].int; mem[q + 3].int := -mem[q + 3].int; destx := -destx; del2 := del2 - takefraction(del2 - del3, t); if del2 > 0 then del2 := 0; t := crossingpoint(0, -del2, -del3); if t < 268435456 then begin {412:} splitcubic(r, t, destx, desty); s := mem[r].hh.rh; if mem[s + 1].int < destx then mem[s + 1].int := destx; if mem[s + 1].int < mem[r + 1].int then mem[s + 1].int := mem[r + 1].int; mem[s].hh.b1 := mem[p].hh.b1; mem[s + 3].int := mem[s + 1].int; mem[s + 1].int := -mem[s + 1].int; mem[s + 5].int := mem[s + 1].int; mem[q + 3].int := -mem[q + 3].int end else if mem[r + 1].int > destx then {:412} mem[r + 1].int := destx end {:411} end {:407}; {413:} pp := p; repeat qq := mem[pp].hh.rh; abnegate(mem[qq + 1].int, mem[qq + 2].int, mem[qq].hh.b1, mem[pp].hh.b1); destx := curx; desty := cury; del1 := mem[pp + 6].int - mem[pp + 2].int; del2 := mem[qq + 4].int - mem[pp + 6].int; del3 := desty - mem[qq + 4].int; {408:} if del1 <> 0 then del := del1 else if del2 <> 0 then del := del2 else del := del3; if del <> 0 then begin dmax := abs(del1); if abs(del2) > dmax then dmax := abs(del2); if abs(del3) > dmax then dmax := abs(del3); while dmax < 134217728 do begin dmax := dmax + dmax; del1 := del1 + del1; del2 := del2 + del2; del3 := del3 + del3 end end {:408}; if del <> 0 then begin if del < 0 then begin {414:} mem[pp + 2].int := -mem[pp + 2].int; mem[pp + 6].int := -mem[pp + 6].int; mem[qq + 4].int := -mem[qq + 4].int; del1 := -del1; del2 := -del2; del3 := -del3; desty := -desty; mem[pp].hh.b1 := mem[pp].hh.b1 + 2 end {:414}; t := crossingpoint(del1, del2, del3); if t < 268435456 then begin {415:} splitcubic(pp, t, destx, desty); r := mem[pp].hh.rh; if mem[r].hh.b1 > 2 then mem[r].hh.b1 := mem[r].hh.b1 - 2 else mem[r].hh.b1 := mem[r].hh.b1 + 2; if mem[r + 1].int > destx then mem[r + 1].int := destx else if mem[r + 1].int < mem[pp + 1].int then mem[r + 1].int := mem[pp + 1].int; if mem[r + 2].int < mem[pp + 2].int then mem[r + 2].int := mem[pp + 2].int; mem[r + 4].int := mem[r + 2].int; mem[r + 2].int := -mem[r + 2].int; mem[r + 6].int := mem[r + 2].int; mem[qq + 4].int := -mem[qq + 4].int; desty := -desty; del2 := del2 - takefraction(del2 - del3, t); if del2 > 0 then del2 := 0; t := crossingpoint(0, -del2, -del3); if t < 268435456 then begin {416:} splitcubic(r, t, destx, desty); s := mem[r].hh.rh; if mem[s + 1].int > destx then mem[s + 1].int := destx else if mem[s + 1].int < mem[r + 1].int then mem[s + 1].int := mem[r + 1].int; if mem[s + 2].int < desty then mem[s + 2].int := desty; if mem[s + 2].int < mem[r + 2].int then mem[s + 2].int := mem[r + 2].int; mem[s].hh.b1 := mem[pp].hh.b1; mem[s + 4].int := mem[s + 2].int; mem[s + 2].int := -mem[s + 2].int; mem[s + 6].int := mem[s + 2].int; mem[qq + 4].int := -mem[qq + 4].int end else if mem[r + 2].int > desty then {:416} mem[r + 2].int := desty end {:415} end else if constantx then begin {417:} if q <> p then begin removecubic(p); if curspec <> q then goto 22 else begin curspec := p; goto 10 end end end else if not odd(mem[pp].hh.b1) then begin {414:} mem[pp + 2].int := -mem[pp + 2].int; mem[pp + 6].int := -mem[pp + 6].int; mem[qq + 4].int := -mem[qq + 4].int; del1 := -del1; del2 := -del2; del3 := -del3; desty := -desty; mem[pp].hh.b1 := mem[pp].hh.b1 + 2 end {:414} {:417}; pp := qq until pp = q; if constantx then begin {418:} pp := p; repeat qq := mem[pp].hh.rh; if mem[pp].hh.b1 > 2 then begin mem[pp].hh.b1 := mem[pp].hh.b1 + 1; mem[pp + 1].int := -mem[pp + 1].int; mem[pp + 5].int := -mem[pp + 5].int; mem[qq + 3].int := -mem[qq + 3].int end; pp := qq until pp = q end {:418} {:413}; p := q until p = curspec; 10: null end; {:406} {419:} procedure octantsubdivide; var p, q, r, s: halfword; del1, del2, del3, del, dmax: scaled; t: fraction; destx, desty: scaled; begin p := curspec; repeat q := mem[p].hh.rh; mem[p + 1].int := mem[p + 1].int - mem[p + 2].int; mem[p + 5].int := mem[p + 5].int - mem[p + 6].int; mem[q + 3].int := mem[q + 3].int - mem[q + 4].int; {420:} {421:} if q = curspec then begin unskew(mem[q + 1].int, mem[q + 2].int, mem[q].hh.b1); skew(curx, cury, mem[p].hh.b1); destx := curx; desty := cury end else begin abnegate(mem[q + 1].int, mem[q + 2].int, mem[q].hh.b1, mem[p].hh.b1); destx := curx - cury; desty := cury end; del1 := mem[p + 5].int - mem[p + 1].int; del2 := mem[q + 3].int - mem[p + 5].int; del3 := destx - mem[q + 3].int {:421}; {408:} if del1 <> 0 then del := del1 else if del2 <> 0 then del := del2 else del := del3; if del <> 0 then begin dmax := abs(del1); if abs(del2) > dmax then dmax := abs(del2); if abs(del3) > dmax then dmax := abs(del3); while dmax < 134217728 do begin dmax := dmax + dmax; del1 := del1 + del1; del2 := del2 + del2; del3 := del3 + del3 end end {:408}; if del <> 0 then begin if del < 0 then begin {423:} mem[p + 2].int := mem[p + 1].int + mem[p + 2].int; mem[p + 1].int := -mem[p + 1].int; mem[p + 6].int := mem[p + 5].int + mem[p + 6].int; mem[p + 5].int := -mem[p + 5].int; mem[q + 4].int := mem[q + 3].int + mem[q + 4].int; mem[q + 3].int := -mem[q + 3].int; del1 := -del1; del2 := -del2; del3 := -del3; desty := destx + desty; destx := -destx; mem[p].hh.b1 := mem[p].hh.b1 + 4 end {:423}; t := crossingpoint(del1, del2, del3); if t < 268435456 then begin {424:} splitcubic(p, t, destx, desty); r := mem[p].hh.rh; if mem[r].hh.b1 > 4 then mem[r].hh.b1 := mem[r].hh.b1 - 4 else mem[r].hh.b1 := mem[r].hh.b1 + 4; if mem[r + 2].int > desty then mem[r + 2].int := desty else if mem[r + 2].int < mem[p + 2].int then mem[r + 2].int := mem[p + 2].int; if mem[r + 1].int < mem[p + 1].int then mem[r + 1].int := mem[p + 1].int; mem[r + 3].int := mem[r + 1].int; mem[r + 2].int := mem[r + 2].int + mem[r + 1].int; mem[r + 1].int := -mem[r + 1].int; mem[r + 5].int := mem[r + 1].int; mem[r + 6].int := mem[r + 6].int - mem[r + 5].int; mem[q + 4].int := mem[q + 4].int + mem[q + 3].int; mem[q + 3].int := -mem[q + 3].int; desty := desty + destx; destx := -destx; del2 := del2 - takefraction(del2 - del3, t); if del2 > 0 then del2 := 0; t := crossingpoint(0, -del2, -del3); if t < 268435456 then begin {425:} splitcubic(r, t, destx, desty); s := mem[r].hh.rh; if mem[s + 2].int > desty then mem[s + 2].int := desty else if mem[s + 2].int < mem[r + 2].int then mem[s + 2].int := mem[r + 2].int; if mem[s + 1].int < destx then mem[s + 1].int := destx; if mem[s + 1].int < mem[r + 1].int then mem[s + 1].int := mem[r + 1].int; mem[s].hh.b1 := mem[p].hh.b1; mem[s + 3].int := mem[s + 1].int; mem[s + 2].int := mem[s + 2].int + mem[s + 1].int; mem[s + 1].int := -mem[s + 1].int; mem[s + 6].int := mem[s + 6].int - mem[s + 1].int; mem[s + 5].int := mem[s + 1].int; mem[q + 4].int := mem[q + 4].int + mem[q + 3].int; mem[q + 3].int := -mem[q + 3].int end else if mem[r + 1].int > destx then {:425} mem[r + 1].int := destx {:424} end end {:420}; p := q until p = curspec end; {:419} {426:} procedure makesafe; var k: 0..maxwiggle; allsafe: boolean; nexta: scaled; deltaa, deltab: scaled; begin before[curroundingptr] := before[0]; nodetoround[curroundingptr] := nodetoround[0]; repeat after[curroundingptr] := after[0]; allsafe := true; nexta := after[0]; for k := 0 to curroundingptr - 1 do begin deltab := before[k + 1] - before[k]; if deltab >= 0 then deltaa := after[k + 1] - nexta else deltaa := nexta - after[k + 1]; nexta := after[k + 1]; if (deltaa < 0) or (deltaa > abs(deltab + deltab)) then begin allsafe := false; after[k] := before[k]; if k = (curroundingptr - 1) then after[0] := before[0] else after[k + 1] := before[k + 1] end end until allsafe end; {:426} {429:} procedure beforeandafter(b, a: scaled; p: halfword); begin if curroundingptr = maxroundingptr then if maxroundingptr < maxwiggle then maxroundingptr := maxroundingptr + 1 else overflow(435, maxwiggle); after[curroundingptr] := a; before[curroundingptr] := b; nodetoround[curroundingptr] := p; curroundingptr := curroundingptr + 1 end; { beforeandafter } {:429} {431:} function goodval(b, o: scaled): scaled; var a: scaled; begin a := b + o; if a >= 0 then a := (a - (a mod curgran)) - o else a := (((a + ((-(a + 1)) mod curgran)) - curgran) + 1) - o; if (b - a) < ((a + curgran) - b) then goodval := a else goodval := a + curgran end; {:431} {432:} function compromise(u, v: scaled): scaled; begin compromise := goodval(u + u, (-u) - v) div 2 end; {:432} {433:} procedure xyround; var p, q: halfword; b, a: scaled; penedge: scaled; alpha: fraction; begin curgran := abs(internal[37]); if curgran = 0 then curgran := 65536; p := curspec; curroundingptr := 0; repeat q := mem[p].hh.rh; {434:} if odd(mem[p].hh.b1) <> odd(mem[q].hh.b1) then begin if odd(mem[q].hh.b1) then b := mem[q + 1].int else b := -mem[q + 1].int; if (abs(mem[q + 1].int - mem[q + 5].int) < 655) or (abs(mem[q + 1].int + mem[q + 3].int) < 655) then begin {435:} if curpen = (-29997) then penedge := 0 else if curpathtype = 0 then penedge := compromise(mem[mem[curpen + 5].hh.rh + 2].int, mem[mem[curpen + 7].hh.rh + 2].int) else if odd(mem[q].hh.b1) then penedge := mem[mem[curpen + 7].hh.rh + 2].int else penedge := mem[mem[curpen + 5].hh.rh + 2].int; a := goodval(b, penedge) end else {:435} a := b; if abs(a) > maxallowed then if a > 0 then a := maxallowed else a := -maxallowed; beforeandafter(b, a, q) end {:434}; p := q until p = curspec; if curroundingptr > 0 then begin {436:} makesafe; repeat curroundingptr := curroundingptr - 1; if (after[curroundingptr] <> before[curroundingptr]) or (after[curroundingptr + 1] <> before[curroundingptr + 1]) then begin p := nodetoround[curroundingptr]; if odd(mem[p].hh.b1) then begin b := before[curroundingptr]; a := after[curroundingptr] end else begin b := -before[curroundingptr]; a := -after[curroundingptr] end; if before[curroundingptr] = before[curroundingptr + 1] then alpha := 268435456 else alpha := makefraction(after[curroundingptr + 1] - after[curroundingptr], before[curroundingptr + 1] - before[curroundingptr]); repeat mem[p + 1].int := takefraction(alpha, mem[p + 1].int - b) + a; mem[p + 5].int := takefraction(alpha, mem[p + 5].int - b) + a; p := mem[p].hh.rh; mem[p + 3].int := takefraction(alpha, mem[p + 3].int - b) + a until p = nodetoround[curroundingptr + 1] end until curroundingptr = 0 end {:436}; p := curspec; curroundingptr := 0; repeat q := mem[p].hh.rh; {437:} if (mem[p].hh.b1 > 2) <> (mem[q].hh.b1 > 2) then begin if mem[q].hh.b1 <= 2 then b := mem[q + 2].int else b := -mem[q + 2].int; if (abs(mem[q + 2].int - mem[q + 6].int) < 655) or (abs(mem[q + 2].int + mem[q + 4].int) < 655) then begin {438:} if curpen = (-29997) then penedge := 0 else if curpathtype = 0 then penedge := compromise(mem[mem[curpen + 2].hh.rh + 2].int, mem[mem[curpen + 1].hh.rh + 2].int) else if mem[q].hh.b1 <= 2 then penedge := mem[mem[curpen + 1].hh.rh + 2].int else penedge := mem[mem[curpen + 2].hh.rh + 2].int; a := goodval(b, penedge) end else {:438} a := b; if abs(a) > maxallowed then if a > 0 then a := maxallowed else a := -maxallowed; beforeandafter(b, a, q) end {:437}; p := q until p = curspec; if curroundingptr > 0 then begin {439:} makesafe; repeat curroundingptr := curroundingptr - 1; if (after[curroundingptr] <> before[curroundingptr]) or (after[curroundingptr + 1] <> before[curroundingptr + 1]) then begin p := nodetoround[curroundingptr]; if mem[p].hh.b1 <= 2 then begin b := before[curroundingptr]; a := after[curroundingptr] end else begin b := -before[curroundingptr]; a := -after[curroundingptr] end; if before[curroundingptr] = before[curroundingptr + 1] then alpha := 268435456 else alpha := makefraction(after[curroundingptr + 1] - after[curroundingptr], before[curroundingptr + 1] - before[curroundingptr]); repeat mem[p + 2].int := takefraction(alpha, mem[p + 2].int - b) + a; mem[p + 6].int := takefraction(alpha, mem[p + 6].int - b) + a; p := mem[p].hh.rh; mem[p + 4].int := takefraction(alpha, mem[p + 4].int - b) + a until p = nodetoround[curroundingptr + 1] end until curroundingptr = 0 end {:439} end; {:433} {440:} procedure diaground; var p, q, pp: halfword; b, a, bb, aa, d, c, dd, cc: scaled; penedge: scaled; alpha, beta: fraction; nexta: scaled; allsafe: boolean; k: 0..maxwiggle; firstx, firsty: scaled; begin p := curspec; curroundingptr := 0; repeat q := mem[p].hh.rh; {441:} if mem[p].hh.b1 <> mem[q].hh.b1 then begin if mem[q].hh.b1 > 4 then b := -mem[q + 1].int else b := mem[q + 1].int; if abs(mem[q].hh.b1 - mem[p].hh.b1) = 4 then if (abs(mem[q + 1].int - mem[q + 5].int) < 655) or (abs(mem[q + 1].int + mem[q + 3].int) < 655) then begin {442:} if curpen = (-29997) then penedge := 0 else if curpathtype = 0 then {443:} case mem[q].hh.b1 of 1, 5: penedge := compromise(mem[mem[mem[curpen + 1].hh.rh].hh.lh + 1].int, -mem[mem[mem[curpen + 4].hh.rh].hh.lh + 1].int); 4, 8: penedge := -compromise(mem[mem[mem[curpen + 1].hh.rh].hh.lh + 1].int, -mem[mem[mem[curpen + 4].hh.rh].hh.lh + 1].int); 6, 2: penedge := compromise(mem[mem[mem[curpen + 2].hh.rh].hh.lh + 1].int, -mem[mem[mem[curpen + 3].hh.rh].hh.lh + 1].int); 7, 3: penedge := -compromise(mem[mem[mem[curpen + 2].hh.rh].hh.lh + 1].int, -mem[mem[mem[curpen + 3].hh.rh].hh.lh + 1].int) end {:443} else if mem[q].hh.b1 <= 4 then penedge := mem[mem[mem[curpen + mem[q].hh.b1].hh.rh].hh.lh + 1].int else penedge := -mem[mem[mem[curpen + mem[q].hh.b1].hh.rh].hh.lh + 1].int; if odd(mem[q].hh.b1) then a := goodval(b, penedge + (curgran div 2)) else a := goodval(b - 1, penedge + (curgran div 2)) end else {:442} a := b else a := b; beforeandafter(b, a, q) end {:441}; p := q until p = curspec; if curroundingptr > 0 then begin {444:} p := nodetoround[0]; firstx := mem[p + 1].int; firsty := mem[p + 2].int; {446:} before[curroundingptr] := before[0]; nodetoround[curroundingptr] := nodetoround[0]; repeat after[curroundingptr] := after[0]; allsafe := true; nexta := after[0]; for k := 0 to curroundingptr - 1 do begin a := nexta; b := before[k]; nexta := after[k + 1]; aa := nexta; bb := before[k + 1]; if (a <> b) or (aa <> bb) then begin p := nodetoround[k]; pp := nodetoround[k + 1]; {445:} if aa = bb then begin if pp = nodetoround[0] then unskew(firstx, firsty, mem[pp].hh.b1) else unskew(mem[pp + 1].int, mem[pp + 2].int, mem[pp].hh.b1); skew(curx, cury, mem[p].hh.b1); bb := curx; aa := bb; dd := cury; cc := dd; if mem[p].hh.b1 > 4 then begin b := -b; a := -a end end else begin if mem[p].hh.b1 > 4 then begin bb := -bb; aa := -aa; b := -b; a := -a end; if pp = nodetoround[0] then dd := firsty - bb else dd := mem[pp + 2].int - bb; if odd(aa - bb) then if mem[p].hh.b1 > 4 then cc := dd - (((aa - bb) + 1) div 2) else cc := dd - (((aa - bb) - 1) div 2) else cc := dd - ((aa - bb) div 2) end; d := mem[p + 2].int; if odd(a - b) then if mem[p].hh.b1 > 4 then c := d - (((a - b) - 1) div 2) else c := d - (((a - b) + 1) div 2) else c := d - ((a - b) div 2) {:445}; if (((aa < a) or (cc < c)) or ((aa - a) > (2 * (bb - b)))) or ((cc - c) > (2 * (dd - d))) then begin allsafe := false; after[k] := before[k]; if k = (curroundingptr - 1) then after[0] := before[0] else after[k + 1] := before[k + 1] end end end until allsafe {:446}; for k := 0 to curroundingptr - 1 do begin a := after[k]; b := before[k]; aa := after[k + 1]; bb := before[k + 1]; if (a <> b) or (aa <> bb) then begin p := nodetoround[k]; pp := nodetoround[k + 1]; {445:} if aa = bb then begin if pp = nodetoround[0] then unskew(firstx, firsty, mem[pp].hh.b1) else unskew(mem[pp + 1].int, mem[pp + 2].int, mem[pp].hh.b1); skew(curx, cury, mem[p].hh.b1); bb := curx; aa := bb; dd := cury; cc := dd; if mem[p].hh.b1 > 4 then begin b := -b; a := -a end end else begin if mem[p].hh.b1 > 4 then begin bb := -bb; aa := -aa; b := -b; a := -a end; if pp = nodetoround[0] then dd := firsty - bb else dd := mem[pp + 2].int - bb; if odd(aa - bb) then if mem[p].hh.b1 > 4 then cc := dd - (((aa - bb) + 1) div 2) else cc := dd - (((aa - bb) - 1) div 2) else cc := dd - ((aa - bb) div 2) end; d := mem[p + 2].int; if odd(a - b) then if mem[p].hh.b1 > 4 then c := d - (((a - b) - 1) div 2) else c := d - (((a - b) + 1) div 2) else c := d - ((a - b) div 2) {:445}; if b = bb then alpha := 268435456 else alpha := makefraction(aa - a, bb - b); if d = dd then beta := 268435456 else beta := makefraction(cc - c, dd - d); repeat mem[p + 1].int := takefraction(alpha, mem[p + 1].int - b) + a; mem[p + 2].int := takefraction(beta, mem[p + 2].int - d) + c; mem[p + 5].int := takefraction(alpha, mem[p + 5].int - b) + a; mem[p + 6].int := takefraction(beta, mem[p + 6].int - d) + c; p := mem[p].hh.rh; mem[p + 3].int := takefraction(alpha, mem[p + 3].int - b) + a; mem[p + 4].int := takefraction(beta, mem[p + 4].int - d) + c until p = pp end end end {:444} end; {:440} {451:} procedure newboundary(p: halfword; octant: smallnumber); var q, r: halfword; begin q := mem[p].hh.rh; r := getnode(7); mem[r].hh.rh := q; mem[p].hh.rh := r; mem[r].hh.b0 := mem[q].hh.b0; mem[r + 3].int := mem[q + 3].int; mem[r + 4].int := mem[q + 4].int; mem[r].hh.b1 := 0; mem[q].hh.b0 := 0; mem[r + 5].int := octant; mem[q + 3].int := mem[q].hh.b1; unskew(mem[q + 1].int, mem[q + 2].int, mem[q].hh.b1); skew(curx, cury, octant); mem[r + 1].int := curx; mem[r + 2].int := cury end; {:451} function makespec(h: halfword; safetymargin: scaled; tracing: integer): halfword; label 22, 30; var p, q, r, s: halfword; k: integer; chopped: boolean; {453:} o1, o2: smallnumber; clockwise: boolean; dx1, dy1, dx2, dy2: integer; dmax, del: integer; {:453} begin curspec := h; if tracing > 0 then printpath(curspec, 426, true); maxallowed := 268402687 - safetymargin; {404:} p := curspec; k := 1; chopped := false; repeat if abs(mem[p + 3].int) > maxallowed then begin chopped := true; if mem[p + 3].int > 0 then mem[p + 3].int := maxallowed else mem[p + 3].int := -maxallowed end; if abs(mem[p + 4].int) > maxallowed then begin chopped := true; if mem[p + 4].int > 0 then mem[p + 4].int := maxallowed else mem[p + 4].int := -maxallowed end; if abs(mem[p + 1].int) > maxallowed then begin chopped := true; if mem[p + 1].int > 0 then mem[p + 1].int := maxallowed else mem[p + 1].int := -maxallowed end; if abs(mem[p + 2].int) > maxallowed then begin chopped := true; if mem[p + 2].int > 0 then mem[p + 2].int := maxallowed else mem[p + 2].int := -maxallowed end; if abs(mem[p + 5].int) > maxallowed then begin chopped := true; if mem[p + 5].int > 0 then mem[p + 5].int := maxallowed else mem[p + 5].int := -maxallowed end; if abs(mem[p + 6].int) > maxallowed then begin chopped := true; if mem[p + 6].int > 0 then mem[p + 6].int := maxallowed else mem[p + 6].int := -maxallowed end; p := mem[p].hh.rh; mem[p].hh.b0 := k; if k < 127 then k := k + 1 else k := 1 until p = curspec; if chopped then begin begin if interaction = 3 then null; printnl(133); print(430) end; begin helpptr := 4; helpline[3] := 431; helpline[2] := 432; helpline[1] := 433; helpline[0] := 434 end; putgeterror end {:404}; quadrantsubdivide; if internal[36] > 0 then xyround; octantsubdivide; if internal[36] > 65536 then diaground; {447:} p := curspec; repeat 22: q := mem[p].hh.rh; if p <> q then begin if mem[p + 1].int = mem[p + 5].int then if mem[p + 2].int = mem[p + 6].int then if mem[p + 1].int = mem[q + 3].int then if mem[p + 2].int = mem[q + 4].int then begin unskew(mem[q + 1].int, mem[q + 2].int, mem[q].hh.b1); skew(curx, cury, mem[p].hh.b1); if mem[p + 1].int = curx then if mem[p + 2].int = cury then begin removecubic(p); if q <> curspec then goto 22; curspec := p; q := p end end end; p := q until p = curspec; {:447} {450:} turningnumber := 0; p := curspec; q := mem[p].hh.rh; repeat r := mem[q].hh.rh; if (mem[p].hh.b1 <> mem[q].hh.b1) or (q = r) then begin {452:} newboundary(p, mem[p].hh.b1); s := mem[p].hh.rh; o1 := octantnumber[mem[p].hh.b1]; o2 := octantnumber[mem[q].hh.b1]; case o2 - o1 of 1, -7, 7, -1: goto 30; 2, -6: clockwise := false; 3, -5, 4, -4, 5, -3: begin {454:} {457:} dx1 := mem[s + 1].int - mem[s + 3].int; dy1 := mem[s + 2].int - mem[s + 4].int; if dx1 = 0 then if dy1 = 0 then begin dx1 := mem[s + 1].int - mem[p + 5].int; dy1 := mem[s + 2].int - mem[p + 6].int; if dx1 = 0 then if dy1 = 0 then begin dx1 := mem[s + 1].int - mem[p + 1].int; dy1 := mem[s + 2].int - mem[p + 2].int end end; dmax := abs(dx1); if abs(dy1) > dmax then dmax := abs(dy1); while dmax < 268435456 do begin dmax := dmax + dmax; dx1 := dx1 + dx1; dy1 := dy1 + dy1 end; dx2 := mem[q + 5].int - mem[q + 1].int; dy2 := mem[q + 6].int - mem[q + 2].int; if dx2 = 0 then if dy2 = 0 then begin dx2 := mem[r + 3].int - mem[q + 1].int; dy2 := mem[r + 4].int - mem[q + 2].int; if dx2 = 0 then if dy2 = 0 then begin if mem[r].hh.b1 = 0 then begin curx := mem[r + 1].int; cury := mem[r + 2].int end else begin unskew(mem[r + 1].int, mem[r + 2].int, mem[r].hh.b1); skew(curx, cury, mem[q].hh.b1) end; dx2 := curx - mem[q + 1].int; dy2 := cury - mem[q + 2].int end end; dmax := abs(dx2); if abs(dy2) > dmax then dmax := abs(dy2); while dmax < 268435456 do begin dmax := dmax + dmax; dx2 := dx2 + dx2; dy2 := dy2 + dy2 end {:457}; unskew(dx1, dy1, mem[p].hh.b1); del := pythadd(curx, cury); dx1 := makefraction(curx, del); dy1 := makefraction(cury, del); unskew(dx2, dy2, mem[q].hh.b1); del := pythadd(curx, cury); dx2 := makefraction(curx, del); dy2 := makefraction(cury, del); del := takefraction(dx1, dy2) - takefraction(dx2, dy1); if del > 4684844 then clockwise := false else if del < (-4684844) then clockwise := true else clockwise := revturns end; {:454} 6, -2: clockwise := true; 0: clockwise := revturns end; {458:} while true do begin if clockwise then if o1 = 1 then o1 := 8 else o1 := o1 - 1 else if o1 = 8 then o1 := 1 else o1 := o1 + 1; if o1 = o2 then goto 30; newboundary(s, octantcode[o1]); s := mem[s].hh.rh; mem[s + 3].int := mem[s + 5].int end {:458}; 30: if q = r then begin q := mem[q].hh.rh; r := q; p := s; mem[s].hh.rh := q; mem[q + 3].int := mem[q + 5].int; mem[q].hh.b0 := 0; freenode(curspec, 7); curspec := q end; {459:} p := mem[p].hh.rh; repeat s := mem[p].hh.rh; o1 := octantnumber[mem[p + 5].int]; o2 := octantnumber[mem[s + 3].int]; if abs(o1 - o2) = 1 then begin if o2 < o1 then o2 := o1; if odd(o2) then mem[p + 6].int := 0 else mem[p + 6].int := 1 end else begin if o1 = 8 then turningnumber := turningnumber + 1 else turningnumber := turningnumber - 1; mem[p + 6].int := 0 end; mem[s + 4].int := mem[p + 6].int; p := s until p = q {:459} end {:452}; p := q; q := r until p = curspec; {:450} while mem[curspec].hh.b0 <> 0 do curspec := mem[curspec].hh.rh; if tracing > 0 then if internal[36] <= 0 then printspec(427) else if internal[36] > 65536 then printspec(428) else printspec(429); makespec := curspec end; { makespec } {:402} {463:} procedure endround(x, y: scaled); begin y := (y + 32768) - ycorr[octant]; x := (x + y) - xcorr[octant]; m1 := floorunscaled(x); n1 := floorunscaled(y); if (x - (65536 * m1)) >= ((y - (65536 * n1)) + zcorr[octant]) then d1 := 1 else d1 := 0 end; {:463} {465:} procedure fillspec(h: halfword); var p, q, r, s: halfword; begin if internal[10] > 0 then beginedgetracing; p := h; {------------------------------------} print_start(psfile); { Start cycle } {------------------------------------} repeat octant := mem[p + 3].int; {466:} q := p; while mem[q].hh.b1 <> 0 do q := mem[q].hh.rh {:466}; if q <> p then begin {467:} endround(mem[p + 1].int, mem[p + 2].int); m0 := m1; n0 := n1; d0 := d1; endround(mem[q + 1].int, mem[q + 2].int) {:467}; {468:} if (n1 - n0) >= movesize then overflow(407, movesize); move[0] := d0; moveptr := 0; r := p; repeat s := mem[r].hh.rh; makemoves(mem[r + 1].int, mem[r + 5].int, mem[s + 3].int, mem[s + 1].int, mem[r + 2].int + 32768, mem[r + 6].int + 32768, mem[s + 4].int + 32768, mem[s + 2].int + 32768, xycorr[octant], ycorr[octant],465,octant); r := s until r = q; move[moveptr] := move[moveptr] - d1; if internal[35] > 0 then smoothmoves(0, moveptr) {:468}; movetoedges(m0, n0, m1, n1) end; p := mem[q].hh.rh until p = h; {------------------------------------} print_end(psfile); { End cycle } {------------------------------------} tossknotlist(h); if internal[10] > 0 then endedgetracing end; {:465} {476:} procedure dupoffset(w: halfword); var r: halfword; begin r := getnode(3); mem[r + 1].int := mem[w + 1].int; mem[r + 2].int := mem[w + 2].int; mem[r].hh.rh := mem[w].hh.rh; mem[mem[w].hh.rh].hh.lh := r; mem[r].hh.lh := w; mem[w].hh.rh := r end; {:476} {477:} function makepen(h: halfword): halfword; label 30, 31, 45, 40; var o, oo, k: smallnumber; p: halfword; q, r, s, w, hh: halfword; n: integer; dx, dy: scaled; mc: scaled; {479:} begin q := h; r := mem[q].hh.rh; mc := abs(mem[h + 1].int); if q = r then begin hh := h; mem[h].hh.b1 := 0; if mc < abs(mem[h + 2].int) then mc := abs(mem[h + 2].int) end else begin o := 0; hh := -30000; while true do begin s := mem[r].hh.rh; if mc < abs(mem[r + 1].int) then mc := abs(mem[r + 1].int); if mc < abs(mem[r + 2].int) then mc := abs(mem[r + 2].int); dx := mem[r + 1].int - mem[q + 1].int; dy := mem[r + 2].int - mem[q + 2].int; if dx = 0 then if dy = 0 then goto 45; if abvscd(dx, mem[s + 2].int - mem[r + 2].int, dy, mem[s + 1].int - mem[r + 1].int) < 0 then goto 45; {480:} if dx > 0 then octant := 1 else if dx = 0 then if dy > 0 then octant := 1 else octant := 2 else begin dx := -dx; octant := 2 end; if dy < 0 then begin dy := -dy; octant := octant + 2 end else if dy = 0 then if octant > 1 then octant := 4; if dx < dy then octant := octant + 4 {:480}; mem[q].hh.b1 := octant; oo := octantnumber[octant]; if o > oo then begin if hh <> (-30000) then goto 45; hh := q end; o := oo; if (q = h) and (hh <> (-30000)) then goto 30; q := r; r := s end; 30: {:479} null end; if mc >= 268402688 then goto 45; p := getnode(10); q := hh; mem[p + 9].int := mc; mem[p].hh.lh := -30000; if mem[q].hh.rh <> q then mem[p].hh.rh := -29999; for k := 1 to 8 do begin {481:} octant := octantcode[k]; n := 0; h := p + octant; while true do begin r := getnode(3); skew(mem[q + 1].int, mem[q + 2].int, octant); mem[r + 1].int := curx; mem[r + 2].int := cury; if n = 0 then mem[h].hh.rh := r {482:} else if odd(k) then begin mem[w].hh.rh := r; mem[r].hh.lh := w end else begin mem[w].hh.lh := r; mem[r].hh.rh := w end {:482}; w := r; if mem[q].hh.b1 <> octant then goto 31; q := mem[q].hh.rh; n := n + 1 end; 31: {483:} r := mem[h].hh.rh; if odd(k) then begin mem[w].hh.rh := r; mem[r].hh.lh := w end else begin mem[w].hh.lh := r; mem[r].hh.rh := w; mem[h].hh.rh := w; r := w end; if (mem[r + 2].int <> mem[mem[r].hh.rh + 2].int) or (n = 0) then begin dupoffset(r); n := n + 1 end; r := mem[r].hh.lh; {: 483} if mem[r + 1].int <> mem[mem[r].hh.lh + 1].int then dupoffset(r) else n := n - 1; if n >= 127 then overflow(446, 127); mem[h].hh.lh := n end {:481}; goto 40; 45: p := -29997; {478:} if mc >= 268402688 then begin begin if interaction = 3 then null; printnl(133); print(440) end; begin helpptr := 2; helpline[1] := 441; helpline[0] := 442 end end else begin begin if interaction = 3 then null; printnl(133); print(443) end; begin helpptr := 3; helpline[2] := 444; helpline[1] := 445; helpline[0] := 442 end end; {:478} putgeterror; 40: if internal[6] > 0 then printpen(p, 439, true); makepen := p end; {:477} {484:} {486:} function trivialknot(x, y: scaled): halfword; var p: halfword; begin p := getnode(7); mem[p].hh.b0 := 1; mem[p].hh.b1 := 1; mem[p + 1].int := x; mem[p + 3].int := x; mem[p + 5].int := x; mem[p + 2].int := y; mem[p + 4].int := y; mem[p + 6].int := y; trivialknot := p end; {:486} function makepath(penhead: halfword): halfword; var p: halfword; k: 1..8; h: halfword; m, n: integer; w, ww: halfword; begin p := 29999; for k := 1 to 8 do begin octant := octantcode[k]; h := penhead + octant; n := mem[h].hh.lh; w := mem[h].hh.rh; if not odd(k) then w := mem[w].hh.lh; for m := 1 to n + 1 do begin if odd(k) then ww := mem[w].hh.rh else ww := mem[w].hh.lh; if (mem[ww + 1].int <> mem[w + 1].int) or (mem[ww + 2].int <> mem[w + 2].int) then begin {485:} unskew(mem[ww + 1].int, mem[ww + 2].int, octant); mem[p].hh.rh := trivialknot(curx, cury); p := mem[p].hh.rh end {:485}; w := ww end end; if p = 29999 then begin w := mem[penhead + 1].hh.rh; p := trivialknot(mem[w + 1].int + mem[w + 2].int, mem[w + 2].int); mem[29999].hh.rh := p end; mem[p].hh.rh := mem[29999].hh.rh; makepath := mem[29999].hh.rh end; {:484} {488:} procedure findoffset(x, y: scaled; p: halfword); label 30, 10; var octant: 1..8; s: -1..+1; n: integer; h, w, ww: halfword; {489:} begin if x > 0 then octant := 1 else if x = 0 then if y <= 0 then if y = 0 then begin curx := 0; cury := 0; goto 10 end else octant := 2 else octant := 1 else begin x := -x; if y = 0 then octant := 4 else octant := 2 end; if y < 0 then begin octant := octant + 2; y := -y end; if x >= y then x := x - y else begin octant := octant + 4; x := y - x; y := y - x end {:489}; if odd(octantnumber[octant]) then s := -1 else s := +1; h := p + octant; w := mem[mem[h].hh.rh].hh.rh; ww := mem[w].hh.rh; n := mem[h].hh.lh; while n > 1 do begin if abvscd(x, mem[ww + 2].int - mem[w + 2].int, y, mem[ww + 1].int - mem[w + 1].int) <> s then goto 30; w := ww; ww := mem[w].hh.rh; n := n - 1 end; 30: unskew(mem[w + 1].int, mem[w + 2].int, octant); 10: null end; {:488} {491:} {493:} procedure splitforoffset(p: halfword; t: fraction); var q: halfword; r: halfword; begin q := mem[p].hh.rh; splitcubic(p, t, mem[q + 1].int, mem[q + 2].int); r := mem[p].hh.rh; if mem[r + 2].int < mem[p + 2].int then mem[r + 2].int := mem[p + 2].int else if mem[r + 2].int > mem[q + 2].int then mem[r + 2].int := mem[q + 2].int; if mem[r + 1].int < mem[p + 1].int then mem[r + 1].int := mem[p + 1].int else if mem[r + 1].int > mem[q + 1].int then mem[r + 1].int := mem[q + 1].int end; {:493} {497:} procedure finoffsetprep(p: halfword; k: halfword; w: halfword; x0, x1, x2, y0, y1, y2: integer; rising: boolean; n: integer); label 10; var q, ww: halfword; du, dv: scaled; t0, t1, t2: integer; t: fraction; s: fraction; v: integer; begin while true do begin q := mem[p].hh.rh; mem[p].hh.b1 := k; if rising then if k = n then goto 10 else ww := mem[w].hh.rh else if k = 1 then goto 10 else ww := mem[w].hh.lh; {498:} du := mem[ww + 1].int - mem[w + 1].int; dv := mem[ww + 2].int - mem[w + 2].int; if abs(du) >= abs(dv) then begin s := makefraction(dv, du); t0 := takefraction(x0, s) - y0; t1 := takefraction(x1, s) - y1; t2 := takefraction(x2, s) - y2 end else begin s := makefraction(du, dv); t0 := x0 - takefraction(y0, s); t1 := x1 - takefraction(y1, s); t2 := x2 - takefraction(y2, s) end {:498}; t := crossingpoint(t0, t1, t2); if t >= 268435456 then goto 10; {499:} begin splitforoffset(p, t); mem[p].hh.b1 := k; p := mem[p].hh.rh; v := x0 - takefraction(x0 - x1, t); x1 := x1 - takefraction(x1 - x2, t); x0 := v - takefraction(v - x1, t); v := y0 - takefraction(y0 - y1, t); y1 := y1 - takefraction(y1 - y2, t); y0 := v - takefraction(v - y1, t); t1 := t1 - takefraction(t1 - t2, t); if t1 > 0 then t1 := 0; t := crossingpoint(0, -t1, -t2); if t < 268435456 then begin splitforoffset(p, t); mem[mem[p].hh.rh].hh.b1 := k; v := x1 - takefraction(x1 - x2, t); x1 := x0 - takefraction(x0 - x1, t); x2 := x1 - takefraction(x1 - v, t); v := y1 - takefraction(y1 - y2, t); y1 := y0 - takefraction(y0 - y1, t); y2 := y1 - takefraction(y1 - v, t) end end {:499}; if rising then k := k + 1 else k := k - 1; w := ww end; 10: null end; {:497} procedure offsetprep(c, h: halfword); label 30, 45; var n: halfword; p, q, r, lh, ww: halfword; k: halfword; w: halfword; {495:} x0, x1, x2, y0, y1, y2: integer; t0, t1, t2: integer; du, dv, dx, dy: integer; maxcoef: integer; x0a, x1a, x2a, y0a, y1a, y2a: integer; t: fraction; s: fraction; {:495} begin p := c; n := mem[h].hh.lh; lh := mem[h].hh.rh; while mem[p].hh.b1 <> 0 do begin q := mem[p].hh.rh; {494:} if n <= 1 then mem[p].hh.b1 := 1 else begin {496:} x0 := mem[p + 5].int - mem[p + 1].int; x2 := mem[q + 1].int - mem[q + 3].int; x1 := mem[q + 3].int - mem[p + 5].int; y0 := mem[p + 6].int - mem[p + 2].int; y2 := mem[q + 2].int - mem[q + 4].int; y1 := mem[q + 4].int - mem[p + 6].int; maxcoef := abs(x0); if abs(x1) > maxcoef then maxcoef := abs(x1); if abs(x2) > maxcoef then maxcoef := abs(x2); if abs(y0) > maxcoef then maxcoef := abs(y0); if abs(y1) > maxcoef then maxcoef := abs(y1); if abs(y2) > maxcoef then maxcoef := abs(y2); if maxcoef = 0 then goto 45; while maxcoef < 268435456 do begin maxcoef := maxcoef + maxcoef; x0 := x0 + x0; x1 := x1 + x1; x2 := x2 + x2; y0 := y0 + y0; y1 := y1 + y1; y2 := y2 + y2 end {:496}; {501:} dx := x0; dy := y0; if dx = 0 then if dy = 0 then begin dx := x1; dy := y1; if dx = 0 then if dy = 0 then begin dx := x2; dy := y2 end end {:501}; if dx = 0 then {505:} finoffsetprep(p, n, mem[mem[lh].hh.lh].hh.lh, -x0, -x1, -x2, -y0, -y1, -y2, false, n) {:505} else begin {502:} k := 1; w := mem[lh].hh.rh; while true do begin if k = n then goto 30; ww := mem[w].hh.rh; if abvscd(dy, abs(mem[ww + 1].int - mem[w + 1].int), dx, abs(mem[ww + 2].int - mem[w + 2].int)) >= 0 then begin k := k + 1; w := ww end else goto 30 end; 30: {:502} null; {503:} if k = 1 then t := 268435457 else begin ww := mem[w].hh.lh; {498:} du := mem[ww + 1].int - mem[w + 1].int; dv := mem[ww + 2].int - mem[w + 2].int; if abs(du) >= abs(dv) then begin s := makefraction(dv, du); t0 := takefraction(x0, s) - y0; t1 := takefraction(x1, s) - y1; t2 := takefraction(x2, s) - y2 end else begin s := makefraction(du, dv); t0 := x0 - takefraction(y0, s); t1 := x1 - takefraction(y1, s); t2 := x2 - takefraction(y2, s) end {:498}; t := crossingpoint(-t0, -t1, -t2) end; if t >= 268435456 then finoffsetprep(p, k, w, x0, x1, x2, y0, y1, y2, true, n) else begin splitforoffset(p, t); r := mem[p].hh.rh; x1a := x0 - takefraction(x0 - x1, t); x1 := x1 - takefraction(x1 - x2, t); x2a := x1a - takefraction(x1a - x1, t); y1a := y0 - takefraction(y0 - y1, t); y1 := y1 - takefraction(y1 - y2, t); y2a := y1a - takefraction(y1a - y1, t); finoffsetprep(p, k, w, x0, x1a, x2a, y0, y1a, y2a, true, n); x0 := x2a; y0 := y2a; t1 := t1 - takefraction(t1 - t2, t); if t1 < 0 then t1 := 0; t := crossingpoint(0, t1, t2); if t < 268435456 then begin {504:} splitforoffset(r, t); x1a := x1 - takefraction(x1 - x2, t); x1 := x0 - takefraction(x0 - x1, t); x0a := x1 - takefraction(x1 - x1a, t); y1a := y1 - takefraction(y1 - y2, t); y1 := y0 - takefraction(y0 - y1, t); y0a := y1 - takefraction(y1 - y1a, t); finoffsetprep(mem[r].hh.rh, k, w, x0a, x1a, x2, y0a, y1a, y2, true, n); x2 := x0a; y2 := y0a end {:504}; finoffsetprep(r, k - 1, ww, -x0, -x1, -x2, -y0, -y1, -y2, false, n) end {:503} end; 45: {:494} null end; {492:} repeat r := mem[p].hh.rh; if mem[p + 1].int = mem[p + 5].int then if mem[p + 2].int = mem[p + 6].int then if mem[p + 1].int = mem[r + 3].int then if mem[p + 2].int = mem[r + 4].int then if mem[p + 1].int = mem[r + 1].int then if mem[p + 2].int = mem[r + 2].int then begin removecubic(p); if r = q then q := p; r := p end; p := r until p = q {:492} end end; { offsetprep } {:491} {506:} {510:} procedure skewlineedges(p, w, ww: halfword); var x0, y0, x1, y1: scaled; begin if (mem[w + 1].int <> mem[ww + 1].int) or (mem[w + 2].int <> mem[ww + 2].int) then begin x0 := mem[p + 1].int + mem[w + 1].int; y0 := mem[p + 2].int + mem[w + 2].int; x1 := mem[p + 1].int + mem[ww + 1].int; y1 := mem[p + 2].int + mem[ww + 2].int; {-------------------------------------} sendline(x0,y0,x1,y1,octant,510); {-------------------------------------} unskew(x0, y0, octant); x0 := curx; y0 := cury; unskew(x1, y1, octant); {if internal[10]>65536 then begin printnl(451);printtwo(x0,y0); print(450);printtwo(curx,cury);printnl(155);end;} lineedges(x0, y0, curx, cury) end end; {:510} {518:} procedure dualmoves(h, p, q: halfword); label 30, 31; var r, s: halfword; {511:} m, n: integer; mm0, mm1: integer; k: integer; w, ww: halfword; smoothbot, smoothtop: 0..movesize; xx, yy, xp, yp, delx, dely, tx, ty: scaled; {:511} {519:} begin k := mem[h].hh.lh + 1; ww := mem[h].hh.rh; w := mem[ww].hh.lh; mm0 := floorunscaled((mem[p + 1].int + mem[w + 1].int) - xycorr[octant]); mm1 := floorunscaled((mem[q + 1].int + mem[ww + 1].int) - xycorr[octant]); for n := 1 to (n1 - n0) + 1 do envmove[n] := mm1; envmove[0] := mm0; moveptr := 0; m := mm0 {:519}; r := p; while true do begin if r = q then smoothtop := moveptr; while mem[r].hh.b1 <> k do begin {521:} xx := mem[r + 1].int + mem[w + 1].int; yy := (mem[r + 2].int + mem[w + 2].int) + 32768; {if internal[10]>65536 then begin printnl(452);printint(k);print(453); unskew(xx,yy-32768,octant);printtwo(curx,cury);end;} {------------} my_xx := xx; my_yy := yy; {------------} if mem[r].hh.b1 < k then begin k := k - 1; w := mem[w].hh.lh; xp := mem[r + 1].int + mem[w + 1].int; yp := (mem[r + 2].int + mem[w + 2].int) + 32768; if yp <> yy then begin {522:} ty := floorscaled(yy - ycorr[octant]); dely := yp - yy; yy := yy - ty; ty := (yp - ycorr[octant]) - ty; if ty >= 65536 then begin delx := xp - xx; yy := 65536 - yy; while true do begin if m < envmove[moveptr] then envmove[moveptr] := m; tx := takefraction(delx, makefraction(yy, dely)); if (abvscd(tx, dely, delx, yy) + xycorr[octant]) > 0 then tx := tx - 1; m := floorunscaled(xx + tx); ty := ty - 65536; moveptr := moveptr + 1; if ty < 65536 then goto 31; yy := yy + 65536 end; 31: if m < envmove[moveptr] then envmove[moveptr] := m end end {:522} end else begin k := k + 1; w := mem[w].hh.rh; xp := mem[r + 1].int + mem[w + 1].int; yp := (mem[r + 2].int + mem[w + 2].int) + 32768; end; {if internal[10]>65536 then begin print(450);unskew(xp,yp-32768,octant); printtwo(curx,cury);printnl(155);end;} {---------------------------------------------------} sendline(my_xx,my_yy-32768,xp,yp-32768,octant,521); {---------------------------------------------------} m := floorunscaled(xp - xycorr[octant]); moveptr := floorunscaled(yp - ycorr[octant]) - n0; if m < envmove[moveptr] then envmove[moveptr] := m end {:521}; if r = p then smoothbot := moveptr; if r = q then goto 30; move[moveptr] := 1; n := moveptr; s := mem[r].hh.rh; makemoves(mem[r + 1].int + mem[w + 1].int, mem[r + 5].int + mem[w + 1].int, mem[s + 3].int + mem[w + 1].int, mem[s + 1].int + mem[w + 1].int, (mem[r + 2].int + mem[w + 2].int) + 32768, (mem[r + 6].int + mem[w + 2].int) + 32768, (mem[s + 4].int + mem[w + 2].int) + 32768, (mem[s + 2].int + mem[w + 2].int) + 32768, xycorr[octant], ycorr[octant],518,octant); {520:} repeat if m < envmove[n] then envmove[n] := m; m := (m + move[n]) - 1; n := n + 1 until n > moveptr {:520}; r := s end; 30: {523:} {if(m<>mm1)or(moveptr<>n1-n0)then confusion(50);} move[0] := (d0 + envmove[1]) - mm0; for n := 1 to moveptr do move[n] := (envmove[n + 1] - envmove[n]) + 1; move[moveptr] := move[moveptr] - d1; if internal[35] > 0 then smoothmoves(smoothbot, smoothtop); movetoedges(m0, n0, m1, n1); if mem[q + 6].int = 1 then begin w := mem[h].hh.rh; skewlineedges(q, w, mem[w].hh.lh) end {:523} end; {:518} procedure fillenvelope(spechead: halfword); label 30, 31; var p, q, r, s: halfword; h: halfword; www: halfword; {511:} m, n: integer; mm0, mm1: integer; k: integer; w, ww: halfword; smoothbot, smoothtop: 0..movesize; xx, yy, xp, yp, delx, dely, tx, ty: scaled; {:511} begin if internal[10] > 0 then beginedgetracing; {------------------------------------} print_start(psfile); { Start cycle } {------------------------------------} p := spechead; repeat octant := mem[p + 3].int; h := curpen + octant; {466:} q := p; while mem[q].hh.b1 <> 0 do q := mem[q].hh.rh {:466}; {508:} w := mem[h].hh.rh; if mem[p + 4].int = 1 then w := mem[w].hh.lh; {if internal[10]>65536 then[509:]begin printnl(447); print(octantdir[octant]);print(425);printint(mem[h].hh.lh);print(448); if mem[h].hh.lh<>1 then printchar(115);print(449); unskew(mem[p+1].int+mem[w+1].int,mem[p+2].int+mem[w+2].int,octant); printtwo(curx,cury);ww:=mem[h].hh.rh; if mem[q+6].int=1 then ww:=mem[ww].hh.lh;print(450); unskew(mem[q+1].int+mem[ww+1].int,mem[q+2].int+mem[ww+2].int,octant); printtwo(curx,cury);end[:509];} ww := mem[h].hh.rh; www := ww; if odd(octantnumber[octant]) then www := mem[www].hh.lh else ww := mem[ww].hh.lh; if w <> ww then skewlineedges(p, w, ww); endround(mem[p + 1].int + mem[ww + 1].int, mem[p + 2].int + mem[ww + 2].int); m0 := m1; n0 := n1; d0 := d1; endround(mem[q + 1].int + mem[www + 1].int, mem[q + 2].int + mem[www + 2].int); if (n1 - n0) >= movesize then overflow(407, movesize) {:508}; offsetprep(p, h); {466:} q := p; while mem[q].hh.b1 <> 0 do q := mem[q].hh.rh {:466}; {512:} if odd(octantnumber[octant]) then begin {513:} k := 0; w := mem[h].hh.rh; ww := mem[w].hh.lh; mm0 := floorunscaled((mem[p + 1].int + mem[w + 1].int) - xycorr[octant]); mm1 := floorunscaled((mem[q + 1].int + mem[ww + 1].int) - xycorr[octant]); for n := 0 to n1 - n0 do envmove[n] := mm0; envmove[n1 - n0] := mm1; moveptr := 0; m := mm0 {:513}; r := p; mem[q].hh.b1 := mem[h].hh.lh + 1; while true do begin if r = q then smoothtop := moveptr; while mem[r].hh.b1 <> k do begin {515:} xx := mem[r + 1].int + mem[w + 1].int; yy := (mem[r + 2].int + mem[w + 2].int) + 32768; {if internal[10]>65536 then begin printnl(452);printint(k);print(453); unskew(xx,yy-32768,octant);printtwo(curx,cury);end;} {------------} my_xx := xx; my_yy := yy; {------------} if mem[r].hh.b1 > k then begin k := k + 1; w := mem[w].hh.rh; xp := mem[r + 1].int + mem[w + 1].int; yp := (mem[r + 2].int + mem[w + 2].int) + 32768; if yp <> yy then begin {516:} ty := floorscaled(yy - ycorr[octant]); dely := yp - yy; yy := yy - ty; ty := (yp - ycorr[octant]) - ty; if ty >= 65536 then begin delx := xp - xx; yy := 65536 - yy; while true do begin tx := takefraction(delx, makefraction(yy, dely)); if (abvscd(tx, dely, delx, yy) + xycorr[octant]) > 0 then tx := tx - 1; m := floorunscaled(xx + tx); if m > envmove[moveptr] then envmove[moveptr] := m; ty := ty - 65536; if ty < 65536 then goto 31; yy := yy + 65536; moveptr := moveptr + 1 end; 31: null end end {:516} end else begin k := k - 1; w := mem[w].hh.lh; xp := mem[r + 1].int + mem[w + 1].int; yp := (mem[r + 2].int + mem[w + 2].int) + 32768; end; {if internal[10]>65536 then begin print(450);unskew(xp,yp-32768,octant); printtwo(curx,cury);printnl(155);end;} {---------------------------------------------------} sendline(my_xx,my_yy-32768,xp,yp-32768,octant,515); {---------------------------------------------------} m := floorunscaled(xp - xycorr[octant]); moveptr := floorunscaled(yp - ycorr[octant]) - n0; if m > envmove[moveptr] then envmove[moveptr] := m end {:515}; if r = p then smoothbot := moveptr; if r = q then goto 30; move[moveptr] := 1; n := moveptr; s := mem[r].hh.rh; makemoves(mem[r + 1].int + mem[w + 1].int, mem[r + 5].int + mem[w + 1].int, mem[s + 3].int + mem[w + 1].int, mem[s + 1].int + mem[w + 1].int, (mem[r + 2].int + mem[w + 2].int) + 32768, (mem[r + 6].int + mem[w + 2].int) + 32768, (mem[s + 4].int + mem[w + 2].int) + 32768, (mem[s + 2].int + mem[w + 2].int) + 32768, xycorr[octant], ycorr[octant],512,octant); {514:} repeat m := (m + move[n]) - 1; if m > envmove[n] then envmove[n] := m; n := n + 1 until n > moveptr {:514}; r := s end; 30: {517:} {if(m<>mm1)or(moveptr<>n1-n0)then confusion(49);} move[0] := (d0 + envmove[0]) - mm0; for n := 1 to moveptr do move[n] := (envmove[n] - envmove[n - 1]) + 1; move[moveptr] := move[moveptr] - d1; if internal[35] > 0 then smoothmoves(smoothbot, smoothtop); movetoedges(m0, n0, m1, n1); if mem[q + 6].int = 0 then begin w := mem[h].hh.rh; skewlineedges(q, mem[w].hh.lh, w) end {:517} end else dualmoves(h, p, q); mem[q].hh.b1 := 0 {:512}; p := mem[q].hh.rh until p = spechead; {------------------------------------} print_end(psfile); { End cycle } {------------------------------------} if internal[10] > 0 then endedgetracing; tossknotlist(spechead) end; {:506} {527:} function makeellipse(majoraxis, minoraxis: scaled; theta: angle): halfword; label 30, 31, 40; var p, q, r, s: halfword; h: halfword; alpha, beta, gamma, delta: integer; c, d: integer; u, v: integer; symmetric: boolean; {528:} begin {530:} if (majoraxis = minoraxis) or ((theta mod 94371840) = 0) then begin symmetric := true; alpha := 0; if odd(theta div 94371840) then begin beta := majoraxis; gamma := minoraxis; nsin := 268435456; ncos := 0 end else begin beta := minoraxis; gamma := majoraxis end end else begin symmetric := false; nsincos(theta); gamma := takefraction(majoraxis, nsin); delta := takefraction(minoraxis, ncos); beta := pythadd(gamma, delta); alpha := takefraction(takefraction(majoraxis, makefraction(gamma, beta)), ncos) - takefraction(takefraction(minoraxis, makefraction(delta, beta)), nsin); alpha := (alpha + 32768) div 65536; gamma := pythadd(takefraction(majoraxis, ncos), takefraction(minoraxis, nsin)) end; beta := (beta + 32768) div 65536; gamma := (gamma + 32768) div 65536 {:530}; p := getnode(7); q := getnode(7); r := getnode(7); if symmetric then s := -30000 else s := getnode(7); h := p; mem[p].hh.rh := q; mem[q].hh.rh := r; mem[r].hh.rh := s; {529:} if beta = 0 then beta := 1; if gamma = 0 then gamma := 1; if gamma <= abs(alpha) then if alpha > 0 then alpha := gamma - 1 else alpha := 1 - gamma {:529}; mem[p + 1].int := -(alpha * 32768); mem[p + 2].int := -(beta * 32768); mem[q + 1].int := gamma * 32768; mem[q + 2].int := mem[p + 2].int; mem[r + 1].int := mem[q + 1].int; mem[p + 5].int := 0; mem[q + 3].int := -32768; mem[q + 5].int := 32768; mem[r + 3].int := 0; mem[r + 5].int := 0; mem[p + 6].int := beta; mem[q + 6].int := gamma; mem[r + 6].int := beta; mem[q + 4].int := gamma + alpha; if symmetric then begin mem[r + 2].int := 0; mem[r + 4].int := beta end else begin mem[r + 2].int := -mem[p + 2].int; mem[r + 4].int := beta + beta; mem[s + 1].int := -mem[p + 1].int; mem[s + 2].int := mem[r + 2].int; mem[s + 3].int := 32768; mem[s + 4].int := gamma - alpha end {:528}; {531:} while true do begin u := mem[p + 5].int + mem[q + 5].int; v := mem[q + 3].int + mem[r + 3].int; c := mem[p + 6].int + mem[q + 6].int; {533:} delta := pythadd(u, v); if majoraxis = minoraxis then d := majoraxis else begin if theta = 0 then begin alpha := u; beta := v end else begin alpha := takefraction(u, ncos) + takefraction(v, nsin); beta := takefraction(v, ncos) - takefraction(u, nsin) end; alpha := makefraction(alpha, delta); beta := makefraction(beta, delta); d := pythadd(takefraction(majoraxis, alpha), takefraction(minoraxis, beta)) end; d := takefraction(d, delta); alpha := abs(u); beta := abs(v); if alpha < beta then begin delta := alpha; alpha := beta; beta := delta end; if internal[38] <> 0 then d := d - takefraction(internal[38], beta + beta); d := (d + 4) div 8; alpha := alpha div 32768; if d < alpha then d := alpha {:533}; delta := c - d; if delta > 0 then begin if delta > mem[r + 4].int then delta := mem[r + 4].int; if delta >= mem[q + 4].int then begin {534:} delta := mem[q + 4].int; mem[p + 6].int := c - delta; mem[p + 5].int := u; mem[q + 3].int := v; mem[q + 1].int := mem[q + 1].int - (delta * mem[r + 3].int); mem[q + 2].int := mem[q + 2].int + (delta * mem[q + 5].int); mem[r + 4].int := mem[r + 4].int - delta end else begin {:534} {535:} s := getnode(7); mem[p].hh.rh := s; mem[s].hh.rh := q; mem[s + 1].int := mem[q + 1].int + (delta * mem[q + 3].int); mem[s + 2].int := mem[q + 2].int - (delta * mem[p + 5].int); mem[q + 1].int := mem[q + 1].int - (delta * mem[r + 3].int); mem[q + 2].int := mem[q + 2].int + (delta * mem[q + 5].int); mem[s + 3].int := mem[q + 3].int; mem[s + 5].int := u; mem[q + 3].int := v; mem[s + 6].int := c - delta; mem[s + 4].int := mem[q + 4].int - delta; mem[q + 4].int := delta; mem[r + 4].int := mem[r + 4].int - delta end {:535} end else p := q; {532:} while true do begin q := mem[p].hh.rh; if q = (-30000) then goto 30; if mem[q + 4].int = 0 then begin mem[p].hh.rh := mem[q].hh.rh; mem[p + 6].int := mem[q + 6].int; mem[p + 5].int := mem[q + 5].int; freenode(q, 7) end else begin r := mem[q].hh.rh; if r = (-30000) then goto 30; if mem[r + 4].int = 0 then begin mem[p].hh.rh := r; freenode(q, 7); p := r end else goto 40 end end; 40: {:532} null end; 30: {:531} null; if symmetric then begin {536:} s := -30000; q := h; while true do begin r := getnode(7); mem[r].hh.rh := s; s := r; mem[s + 1].int := mem[q + 1].int; mem[s + 2].int := -mem[q + 2].int; if q = p then goto 31; q := mem[q].hh.rh; if mem[q + 2].int = 0 then goto 31 end; 31: mem[p].hh.rh := s; beta := -mem[h + 2].int; while mem[p + 2].int <> beta do p := mem[p].hh.rh; q := mem[p].hh.rh end {:536}; {537:} if q <> (-30000) then begin if mem[h + 5].int = 0 then begin p := h; h := mem[h].hh.rh; freenode(p, 7); mem[q + 1].int := -mem[h + 1].int end; p := q end else q := p; r := mem[h].hh.rh; repeat s := getnode(7); mem[p].hh.rh := s; p := s; mem[p + 1].int := -mem[r + 1].int; mem[p + 2].int := -mem[r + 2].int; r := mem[r].hh.rh until r = q; mem[p].hh.rh := h {:537}; makeellipse := h end; {:527} {539:} function finddirectiontime(x, y: scaled; h: halfword): scaled; label 10, 40, 45, 30; var max: scaled; p, q: halfword; n: scaled; tt: scaled; {542:} x1, x2, x3, y1, y2, y3: scaled; theta, phi: angle; t: fraction; {:542} {540:} begin if abs(x) < abs(y) then begin x := makefraction(x, abs(y)); if y > 0 then y := 268435456 else y := -268435456 end else if x = 0 then begin finddirectiontime := 0; goto 10 end else begin y := makefraction(y, abs(x)); if x > 0 then x := 268435456 else x := -268435456 end {:540}; n := 0; p := h; while true do begin if mem[p].hh.b1 = 0 then goto 45; q := mem[p].hh.rh; {541:} tt := 0; {543:} x1 := mem[p + 5].int - mem[p + 1].int; x2 := mem[q + 3].int - mem[p + 5].int; x3 := mem[q + 1].int - mem[q + 3].int; y1 := mem[p + 6].int - mem[p + 2].int; y2 := mem[q + 4].int - mem[p + 6].int; y3 := mem[q + 2].int - mem[q + 4].int; max := abs(x1); if abs(x2) > max then max := abs(x2); if abs(x3) > max then max := abs(x3); if abs(y1) > max then max := abs(y1); if abs(y2) > max then max := abs(y2); if abs(y3) > max then max := abs(y3); if max = 0 then goto 40; while max < 134217728 do begin max := max + max; x1 := x1 + x1; x2 := x2 + x2; x3 := x3 + x3; y1 := y1 + y1; y2 := y2 + y2; y3 := y3 + y3 end; t := x1; x1 := takefraction(x1, x) + takefraction(y1, y); y1 := takefraction(y1, x) - takefraction(t, y); t := x2; x2 := takefraction(x2, x) + takefraction(y2, y); y2 := takefraction(y2, x) - takefraction(t, y); t := x3; x3 := takefraction(x3, x) + takefraction(y3, y); y3 := takefraction(y3, x) - takefraction(t, y) {:543}; if y1 = 0 then if x1 >= 0 then goto 40; if n > 0 then begin {544:} theta := narg(x1, y1); if theta >= 0 then if phi <= 0 then if phi >= (theta - 188743680) then goto 40; {: 544} if theta <= 0 then if phi >= 0 then if phi <= (theta + 188743680) then goto 40; if p = h then goto 45 end; if (x3 <> 0) or (y3 <> 0) then phi := narg(x3, y3); {546:} if x1 < 0 then if x2 < 0 then if x3 < 0 then goto 30; if abvscd(y1, y3, y2, y2) = 0 then begin {548:} if abvscd(y1, y2, 0, 0) < 0 then begin t := makefraction(y1, y1 - y2); x1 := x1 - takefraction(x1 - x2, t); x2 := x2 - takefraction(x2 - x3, t); if (x1 - takefraction(x1 - x2, t)) >= 0 then begin tt := (t + 2048) div 4096; goto 40 end end else if y3 = 0 then if y1 = 0 then begin {549:} t := crossingpoint(-x1, -x2, -x3); if t <= 268435456 then begin tt := (t + 2048) div 4096; goto 40 end; if abvscd(x1, x3, x2, x2) <= 0 then begin t := makefraction(x1, x1 - x2); begin tt := (t + 2048) div 4096; goto 40 end end end else if x3 >= 0 then begin {:549} tt := 65536; goto 40 end; goto 30 end {:548}; if y1 <= 0 then if y1 < 0 then begin y1 := -y1; y2 := -y2; y3 := -y3 end else if y2 > 0 then begin y2 := -y2; y3 := -y3 end; {547:} t := crossingpoint(y1, y2, y3); if t > 268435456 then goto 30; y2 := y2 - takefraction(y2 - y3, t); x1 := x1 - takefraction(x1 - x2, t); x2 := x2 - takefraction(x2 - x3, t); x1 := x1 - takefraction(x1 - x2, t); if x1 >= 0 then begin tt := (t + 2048) div 4096; goto 40 end; if y2 > 0 then y2 := 0; tt := t; t := crossingpoint(0, -y2, -y3); if t > 268435456 then goto 30; x1 := x1 - takefraction(x1 - x2, t); x2 := x2 - takefraction(x2 - x3, t); if (x1 - takefraction(x1 - x2, t)) >= 0 then begin t := tt - takefraction(tt - 268435456, t); begin tt := (t + 2048) div 4096; goto 40 end end {:547}; 30: {:546} {:541} null; p := q; n := n + 65536 end; 45: finddirectiontime := -65536; goto 10; 40: finddirectiontime := n + tt; 10: null end; {:539} {556:} procedure cubicintersection(p, pp: halfword); label 22, 45, 10; var q, qq: halfword; begin timetogo := 5000; maxt := 2; {558:} q := mem[p].hh.rh; qq := mem[pp].hh.rh; bisectptr := 20; bisectstack[bisectptr - 5] := mem[p + 5].int - mem[p + 1].int; bisectstack[bisectptr - 4] := mem[q + 3].int - mem[p + 5].int; bisectstack[bisectptr - 3] := mem[q + 1].int - mem[q + 3].int; if bisectstack[bisectptr - 5] < 0 then if bisectstack[bisectptr - 3] >= 0 then begin if bisectstack[bisectptr - 4] < 0 then bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4] else bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5]; bisectstack[bisectptr - 1] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3]; if bisectstack[bisectptr - 1] < 0 then bisectstack[bisectptr - 1] := 0 end else begin bisectstack[bisectptr - 2] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3]; if bisectstack[bisectptr - 2] > bisectstack[bisectptr - 5] then bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5]; bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]; if bisectstack[bisectptr - 1] < 0 then bisectstack[bisectptr - 1] := 0 end else if bisectstack[bisectptr - 3] <= 0 then begin if bisectstack[bisectptr - 4] > 0 then bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4] else bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5]; bisectstack[bisectptr - 2] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3]; if bisectstack[bisectptr - 2] > 0 then bisectstack[bisectptr - 2] := 0 end else begin bisectstack[bisectptr - 1] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3]; if bisectstack[bisectptr - 1] < bisectstack[bisectptr - 5] then bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5]; bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]; if bisectstack[bisectptr - 2] > 0 then bisectstack[bisectptr - 2] := 0 end; bisectstack[bisectptr - 10] := mem[p + 6].int - mem[p + 2].int; bisectstack[bisectptr - 9] := mem[q + 4].int - mem[p + 6].int; bisectstack[bisectptr - 8] := mem[q + 2].int - mem[q + 4].int; if bisectstack[bisectptr - 10] < 0 then if bisectstack[bisectptr - 8] >= 0 then begin if bisectstack[bisectptr - 9] < 0 then bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9] else bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10]; bisectstack[bisectptr - 6] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8]; if bisectstack[bisectptr - 6] < 0 then bisectstack[bisectptr - 6] := 0 end else begin bisectstack[bisectptr - 7] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8]; if bisectstack[bisectptr - 7] > bisectstack[bisectptr - 10] then bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10]; bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]; if bisectstack[bisectptr - 6] < 0 then bisectstack[bisectptr - 6] := 0 end else if bisectstack[bisectptr - 8] <= 0 then begin if bisectstack[bisectptr - 9] > 0 then bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9] else bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10]; bisectstack[bisectptr - 7] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8]; if bisectstack[bisectptr - 7] > 0 then bisectstack[bisectptr - 7] := 0 end else begin bisectstack[bisectptr - 6] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8]; if bisectstack[bisectptr - 6] < bisectstack[bisectptr - 10] then bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10]; bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]; if bisectstack[bisectptr - 7] > 0 then bisectstack[bisectptr - 7] := 0 end; bisectstack[bisectptr - 15] := mem[pp + 5].int - mem[pp + 1].int; bisectstack[bisectptr - 14] := mem[qq + 3].int - mem[pp + 5].int; bisectstack[bisectptr - 13] := mem[qq + 1].int - mem[qq + 3].int; if bisectstack[bisectptr - 15] < 0 then if bisectstack[bisectptr - 13] >= 0 then begin if bisectstack[bisectptr - 14] < 0 then bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14] else bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15]; bisectstack[bisectptr - 11] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13]; if bisectstack[bisectptr - 11] < 0 then bisectstack[bisectptr - 11] := 0 end else begin bisectstack[bisectptr - 12] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13]; if bisectstack[bisectptr - 12] > bisectstack[bisectptr - 15] then bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15]; bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]; if bisectstack[bisectptr - 11] < 0 then bisectstack[bisectptr - 11] := 0 end else if bisectstack[bisectptr - 13] <= 0 then begin if bisectstack[bisectptr - 14] > 0 then bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14] else bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15]; bisectstack[bisectptr - 12] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13]; if bisectstack[bisectptr - 12] > 0 then bisectstack[bisectptr - 12] := 0 end else begin bisectstack[bisectptr - 11] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13]; if bisectstack[bisectptr - 11] < bisectstack[bisectptr - 15] then bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15]; bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]; if bisectstack[bisectptr - 12] > 0 then bisectstack[bisectptr - 12] := 0 end; bisectstack[bisectptr - 20] := mem[pp + 6].int - mem[pp + 2].int; bisectstack[bisectptr - 19] := mem[qq + 4].int - mem[pp + 6].int; bisectstack[bisectptr - 18] := mem[qq + 2].int - mem[qq + 4].int; if bisectstack[bisectptr - 20] < 0 then if bisectstack[bisectptr - 18] >= 0 then begin if bisectstack[bisectptr - 19] < 0 then bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19] else bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20]; bisectstack[bisectptr - 16] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18]; if bisectstack[bisectptr - 16] < 0 then bisectstack[bisectptr - 16] := 0 end else begin bisectstack[bisectptr - 17] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18]; if bisectstack[bisectptr - 17] > bisectstack[bisectptr - 20] then bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20]; bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]; if bisectstack[bisectptr - 16] < 0 then bisectstack[bisectptr - 16] := 0 end else if bisectstack[bisectptr - 18] <= 0 then begin if bisectstack[bisectptr - 19] > 0 then bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19] else bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20]; bisectstack[bisectptr - 17] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18]; if bisectstack[bisectptr - 17] > 0 then bisectstack[bisectptr - 17] := 0 end else begin bisectstack[bisectptr - 16] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18]; if bisectstack[bisectptr - 16] < bisectstack[bisectptr - 20] then bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20]; bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]; if bisectstack[bisectptr - 17] > 0 then bisectstack[bisectptr - 17] := 0 end; delx := mem[p + 1].int - mem[pp + 1].int; dely := mem[p + 2].int - mem[pp + 2].int; tol := 0; uv := bisectptr; xy := bisectptr; threel := 0; curt := 1; curtt := 1 {:558}; while true do begin 22: if (delx - tol) <= (bisectstack[xy - 11] - bisectstack[uv - 2]) then if (delx + tol) >= (bisectstack[xy - 12] - bisectstack[uv - 1]) then if (dely - tol) <= (bisectstack[xy - 16] - bisectstack[uv - 7]) then if (dely + tol) >= (bisectstack[xy - 17] - bisectstack[uv - 6]) then begin if curt >= maxt then begin if maxt = 131072 then begin curt := (curt + 1) div 2; curtt := (curtt + 1) div 2; goto 10 end; maxt := maxt + maxt; apprt := curt; apprtt := curtt end; {559:} bisectstack[bisectptr] := delx; bisectstack[bisectptr + 1] := dely; bisectstack[bisectptr + 2] := tol; bisectstack[bisectptr + 3] := uv; bisectstack[bisectptr + 4] := xy; bisectptr := bisectptr + 45; curt := curt + curt; curtt := curtt + curtt; bisectstack[bisectptr - 25] := bisectstack[uv - 5]; bisectstack[bisectptr - 3] := bisectstack[uv - 3]; bisectstack[bisectptr - 24] := (bisectstack[bisectptr - 25] + bisectstack[uv - 4]) div 2; bisectstack[bisectptr - 4] := (bisectstack[bisectptr - 3] + bisectstack[uv - 4]) div 2; bisectstack[bisectptr - 23] := (bisectstack[bisectptr - 24] + bisectstack[bisectptr - 4]) div 2; bisectstack[bisectptr - 5] := bisectstack[bisectptr - 23]; if bisectstack[bisectptr - 25] < 0 then if bisectstack[bisectptr - 23] >= 0 then begin if bisectstack[bisectptr - 24] < 0 then bisectstack[bisectptr - 22] := bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24] else bisectstack[bisectptr - 22] := bisectstack[bisectptr - 25]; bisectstack[bisectptr - 21] := (bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]) + bisectstack[bisectptr - 23]; if bisectstack[bisectptr - 21] < 0 then bisectstack[bisectptr - 21] := 0 end else begin bisectstack[bisectptr - 22] := (bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]) + bisectstack[bisectptr - 23]; if bisectstack[bisectptr - 22] > bisectstack[bisectptr - 25] then bisectstack[bisectptr - 22] := bisectstack[bisectptr - 25]; bisectstack[bisectptr - 21] := bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]; if bisectstack[bisectptr - 21] < 0 then bisectstack[bisectptr - 21] := 0 end else if bisectstack[bisectptr - 23] <= 0 then begin if bisectstack[bisectptr - 24] > 0 then bisectstack[bisectptr - 21] := bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24] else bisectstack[bisectptr - 21] := bisectstack[bisectptr - 25]; bisectstack[bisectptr - 22] := (bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]) + bisectstack[bisectptr - 23]; if bisectstack[bisectptr - 22] > 0 then bisectstack[bisectptr - 22] := 0 end else begin bisectstack[bisectptr - 21] := (bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]) + bisectstack[bisectptr - 23]; if bisectstack[bisectptr - 21] < bisectstack[bisectptr - 25] then bisectstack[bisectptr - 21] := bisectstack[bisectptr - 25]; bisectstack[bisectptr - 22] := bisectstack[bisectptr - 25] + bisectstack[bisectptr - 24]; if bisectstack[bisectptr - 22] > 0 then bisectstack[bisectptr - 22] := 0 end; if bisectstack[bisectptr - 5] < 0 then if bisectstack[bisectptr - 3] >= 0 then begin if bisectstack[bisectptr - 4] < 0 then bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4] else bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5]; bisectstack[bisectptr - 1] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3]; if bisectstack[bisectptr - 1] < 0 then bisectstack[bisectptr - 1] := 0 end else begin bisectstack[bisectptr - 2] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3]; if bisectstack[bisectptr - 2] > bisectstack[bisectptr - 5] then bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5]; bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]; if bisectstack[bisectptr - 1] < 0 then bisectstack[bisectptr - 1] := 0 end else if bisectstack[bisectptr - 3] <= 0 then begin if bisectstack[bisectptr - 4] > 0 then bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4] else bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5]; bisectstack[bisectptr - 2] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3]; if bisectstack[bisectptr - 2] > 0 then bisectstack[bisectptr - 2] := 0 end else begin bisectstack[bisectptr - 1] := (bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]) + bisectstack[bisectptr - 3]; if bisectstack[bisectptr - 1] < bisectstack[bisectptr - 5] then bisectstack[bisectptr - 1] := bisectstack[bisectptr - 5]; bisectstack[bisectptr - 2] := bisectstack[bisectptr - 5] + bisectstack[bisectptr - 4]; if bisectstack[bisectptr - 2] > 0 then bisectstack[bisectptr - 2] := 0 end; bisectstack[bisectptr - 30] := bisectstack[uv - 10]; bisectstack[bisectptr - 8] := bisectstack[uv - 8]; bisectstack[bisectptr - 29] := (bisectstack[bisectptr - 30] + bisectstack[uv - 9]) div 2; bisectstack[bisectptr - 9] := (bisectstack[bisectptr - 8] + bisectstack[uv - 9]) div 2; bisectstack[bisectptr - 28] := (bisectstack[bisectptr - 29] + bisectstack[bisectptr - 9]) div 2; bisectstack[bisectptr - 10] := bisectstack[bisectptr - 28]; if bisectstack[bisectptr - 30] < 0 then if bisectstack[bisectptr - 28] >= 0 then begin if bisectstack[bisectptr - 29] < 0 then bisectstack[bisectptr - 27] := bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29] else bisectstack[bisectptr - 27] := bisectstack[bisectptr - 30]; bisectstack[bisectptr - 26] := (bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]) + bisectstack[bisectptr - 28]; if bisectstack[bisectptr - 26] < 0 then bisectstack[bisectptr - 26] := 0 end else begin bisectstack[bisectptr - 27] := (bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]) + bisectstack[bisectptr - 28]; if bisectstack[bisectptr - 27] > bisectstack[bisectptr - 30] then bisectstack[bisectptr - 27] := bisectstack[bisectptr - 30]; bisectstack[bisectptr - 26] := bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]; if bisectstack[bisectptr - 26] < 0 then bisectstack[bisectptr - 26] := 0 end else if bisectstack[bisectptr - 28] <= 0 then begin if bisectstack[bisectptr - 29] > 0 then bisectstack[bisectptr - 26] := bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29] else bisectstack[bisectptr - 26] := bisectstack[bisectptr - 30]; bisectstack[bisectptr - 27] := (bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]) + bisectstack[bisectptr - 28]; if bisectstack[bisectptr - 27] > 0 then bisectstack[bisectptr - 27] := 0 end else begin bisectstack[bisectptr - 26] := (bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]) + bisectstack[bisectptr - 28]; if bisectstack[bisectptr - 26] < bisectstack[bisectptr - 30] then bisectstack[bisectptr - 26] := bisectstack[bisectptr - 30]; bisectstack[bisectptr - 27] := bisectstack[bisectptr - 30] + bisectstack[bisectptr - 29]; if bisectstack[bisectptr - 27] > 0 then bisectstack[bisectptr - 27] := 0 end; if bisectstack[bisectptr - 10] < 0 then if bisectstack[bisectptr - 8] >= 0 then begin if bisectstack[bisectptr - 9] < 0 then bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9] else bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10]; bisectstack[bisectptr - 6] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8]; if bisectstack[bisectptr - 6] < 0 then bisectstack[bisectptr - 6] := 0 end else begin bisectstack[bisectptr - 7] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8]; if bisectstack[bisectptr - 7] > bisectstack[bisectptr - 10] then bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10]; bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]; if bisectstack[bisectptr - 6] < 0 then bisectstack[bisectptr - 6] := 0 end else if bisectstack[bisectptr - 8] <= 0 then begin if bisectstack[bisectptr - 9] > 0 then bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9] else bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10]; bisectstack[bisectptr - 7] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8]; if bisectstack[bisectptr - 7] > 0 then bisectstack[bisectptr - 7] := 0 end else begin bisectstack[bisectptr - 6] := (bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]) + bisectstack[bisectptr - 8]; if bisectstack[bisectptr - 6] < bisectstack[bisectptr - 10] then bisectstack[bisectptr - 6] := bisectstack[bisectptr - 10]; bisectstack[bisectptr - 7] := bisectstack[bisectptr - 10] + bisectstack[bisectptr - 9]; if bisectstack[bisectptr - 7] > 0 then bisectstack[bisectptr - 7] := 0 end; bisectstack[bisectptr - 35] := bisectstack[xy - 15]; bisectstack[bisectptr - 13] := bisectstack[xy - 13]; bisectstack[bisectptr - 34] := (bisectstack[bisectptr - 35] + bisectstack[xy - 14]) div 2; bisectstack[bisectptr - 14] := (bisectstack[bisectptr - 13] + bisectstack[xy - 14]) div 2; bisectstack[bisectptr - 33] := (bisectstack[bisectptr - 34] + bisectstack[bisectptr - 14]) div 2; bisectstack[bisectptr - 15] := bisectstack[bisectptr - 33]; if bisectstack[bisectptr - 35] < 0 then if bisectstack[bisectptr - 33] >= 0 then begin if bisectstack[bisectptr - 34] < 0 then bisectstack[bisectptr - 32] := bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34] else bisectstack[bisectptr - 32] := bisectstack[bisectptr - 35]; bisectstack[bisectptr - 31] := (bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]) + bisectstack[bisectptr - 33]; if bisectstack[bisectptr - 31] < 0 then bisectstack[bisectptr - 31] := 0 end else begin bisectstack[bisectptr - 32] := (bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]) + bisectstack[bisectptr - 33]; if bisectstack[bisectptr - 32] > bisectstack[bisectptr - 35] then bisectstack[bisectptr - 32] := bisectstack[bisectptr - 35]; bisectstack[bisectptr - 31] := bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]; if bisectstack[bisectptr - 31] < 0 then bisectstack[bisectptr - 31] := 0 end else if bisectstack[bisectptr - 33] <= 0 then begin if bisectstack[bisectptr - 34] > 0 then bisectstack[bisectptr - 31] := bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34] else bisectstack[bisectptr - 31] := bisectstack[bisectptr - 35]; bisectstack[bisectptr - 32] := (bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]) + bisectstack[bisectptr - 33]; if bisectstack[bisectptr - 32] > 0 then bisectstack[bisectptr - 32] := 0 end else begin bisectstack[bisectptr - 31] := (bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]) + bisectstack[bisectptr - 33]; if bisectstack[bisectptr - 31] < bisectstack[bisectptr - 35] then bisectstack[bisectptr - 31] := bisectstack[bisectptr - 35]; bisectstack[bisectptr - 32] := bisectstack[bisectptr - 35] + bisectstack[bisectptr - 34]; if bisectstack[bisectptr - 32] > 0 then bisectstack[bisectptr - 32] := 0 end; if bisectstack[bisectptr - 15] < 0 then if bisectstack[bisectptr - 13] >= 0 then begin if bisectstack[bisectptr - 14] < 0 then bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14] else bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15]; bisectstack[bisectptr - 11] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13]; if bisectstack[bisectptr - 11] < 0 then bisectstack[bisectptr - 11] := 0 end else begin bisectstack[bisectptr - 12] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13]; if bisectstack[bisectptr - 12] > bisectstack[bisectptr - 15] then bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15]; bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]; if bisectstack[bisectptr - 11] < 0 then bisectstack[bisectptr - 11] := 0 end else if bisectstack[bisectptr - 13] <= 0 then begin if bisectstack[bisectptr - 14] > 0 then bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14] else bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15]; bisectstack[bisectptr - 12] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13]; if bisectstack[bisectptr - 12] > 0 then bisectstack[bisectptr - 12] := 0 end else begin bisectstack[bisectptr - 11] := (bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]) + bisectstack[bisectptr - 13]; if bisectstack[bisectptr - 11] < bisectstack[bisectptr - 15] then bisectstack[bisectptr - 11] := bisectstack[bisectptr - 15]; bisectstack[bisectptr - 12] := bisectstack[bisectptr - 15] + bisectstack[bisectptr - 14]; if bisectstack[bisectptr - 12] > 0 then bisectstack[bisectptr - 12] := 0 end; bisectstack[bisectptr - 40] := bisectstack[xy - 20]; bisectstack[bisectptr - 18] := bisectstack[xy - 18]; bisectstack[bisectptr - 39] := (bisectstack[bisectptr - 40] + bisectstack[xy - 19]) div 2; bisectstack[bisectptr - 19] := (bisectstack[bisectptr - 18] + bisectstack[xy - 19]) div 2; bisectstack[bisectptr - 38] := (bisectstack[bisectptr - 39] + bisectstack[bisectptr - 19]) div 2; bisectstack[bisectptr - 20] := bisectstack[bisectptr - 38]; if bisectstack[bisectptr - 40] < 0 then if bisectstack[bisectptr - 38] >= 0 then begin if bisectstack[bisectptr - 39] < 0 then bisectstack[bisectptr - 37] := bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39] else bisectstack[bisectptr - 37] := bisectstack[bisectptr - 40]; bisectstack[bisectptr - 36] := (bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]) + bisectstack[bisectptr - 38]; if bisectstack[bisectptr - 36] < 0 then bisectstack[bisectptr - 36] := 0 end else begin bisectstack[bisectptr - 37] := (bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]) + bisectstack[bisectptr - 38]; if bisectstack[bisectptr - 37] > bisectstack[bisectptr - 40] then bisectstack[bisectptr - 37] := bisectstack[bisectptr - 40]; bisectstack[bisectptr - 36] := bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]; if bisectstack[bisectptr - 36] < 0 then bisectstack[bisectptr - 36] := 0 end else if bisectstack[bisectptr - 38] <= 0 then begin if bisectstack[bisectptr - 39] > 0 then bisectstack[bisectptr - 36] := bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39] else bisectstack[bisectptr - 36] := bisectstack[bisectptr - 40]; bisectstack[bisectptr - 37] := (bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]) + bisectstack[bisectptr - 38]; if bisectstack[bisectptr - 37] > 0 then bisectstack[bisectptr - 37] := 0 end else begin bisectstack[bisectptr - 36] := (bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]) + bisectstack[bisectptr - 38]; if bisectstack[bisectptr - 36] < bisectstack[bisectptr - 40] then bisectstack[bisectptr - 36] := bisectstack[bisectptr - 40]; bisectstack[bisectptr - 37] := bisectstack[bisectptr - 40] + bisectstack[bisectptr - 39]; if bisectstack[bisectptr - 37] > 0 then bisectstack[bisectptr - 37] := 0 end; if bisectstack[bisectptr - 20] < 0 then if bisectstack[bisectptr - 18] >= 0 then begin if bisectstack[bisectptr - 19] < 0 then bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19] else bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20]; bisectstack[bisectptr - 16] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18]; if bisectstack[bisectptr - 16] < 0 then bisectstack[bisectptr - 16] := 0 end else begin bisectstack[bisectptr - 17] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18]; if bisectstack[bisectptr - 17] > bisectstack[bisectptr - 20] then bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20]; bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]; if bisectstack[bisectptr - 16] < 0 then bisectstack[bisectptr - 16] := 0 end else if bisectstack[bisectptr - 18] <= 0 then begin if bisectstack[bisectptr - 19] > 0 then bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19] else bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20]; bisectstack[bisectptr - 17] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18]; if bisectstack[bisectptr - 17] > 0 then bisectstack[bisectptr - 17] := 0 end else begin bisectstack[bisectptr - 16] := (bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]) + bisectstack[bisectptr - 18]; if bisectstack[bisectptr - 16] < bisectstack[bisectptr - 20] then bisectstack[bisectptr - 16] := bisectstack[bisectptr - 20]; bisectstack[bisectptr - 17] := bisectstack[bisectptr - 20] + bisectstack[bisectptr - 19]; if bisectstack[bisectptr - 17] > 0 then bisectstack[bisectptr - 17] := 0 end; uv := bisectptr - 20; xy := bisectptr - 20; delx := delx + delx; dely := dely + dely; tol := (tol - threel) + tolstep; tol := tol + tol; threel := threel + tolstep {:559}; goto 22 end; if timetogo > 0 then timetogo := timetogo - 1 else begin while apprt < 65536 do begin apprt := apprt + apprt; apprtt := apprtt + apprtt end; curt := apprt; curtt := apprtt; goto 10 end; {560:} 45: if odd(curtt) then if odd(curt) then begin {561:} curt := curt div 2; curtt := curtt div 2; if curt = 0 then goto 10; bisectptr := bisectptr - 45; threel := threel - tolstep; delx := bisectstack[bisectptr]; dely := bisectstack[bisectptr + 1]; tol := bisectstack[bisectptr + 2]; uv := bisectstack[bisectptr + 3]; xy := bisectstack[bisectptr + 4]; goto 45 end else begin {:561} curt := curt + 1; delx := ((delx + bisectstack[uv - 5]) + bisectstack[uv - 4]) + bisectstack[uv - 3]; dely := ((dely + bisectstack[uv - 10]) + bisectstack[uv - 9]) + bisectstack[uv - 8]; uv := uv + 20; curtt := curtt - 1; xy := xy - 20; delx := ((delx + bisectstack[xy - 15]) + bisectstack[xy - 14]) + bisectstack[xy - 13]; dely := ((dely + bisectstack[xy - 20]) + bisectstack[xy - 19]) + bisectstack[xy - 18] end else begin curtt := curtt + 1; tol := tol + threel; delx := ((delx - bisectstack[xy - 15]) - bisectstack[xy - 14]) - bisectstack[xy - 13]; dely := ((dely - bisectstack[xy - 20]) - bisectstack[xy - 19]) - bisectstack[xy - 18]; xy := xy + 20 end {:560} end; 10: null end; {:556} {562:} procedure pathintersection(h, hh: halfword); label 10; var p, pp: halfword; n, nn: integer; {563:} begin if mem[h].hh.b1 = 0 then begin mem[h + 5].int := mem[h + 1].int; mem[h + 3].int := mem[h + 1].int; mem[h + 6].int := mem[h + 2].int; mem[h + 4].int := mem[h + 2].int; mem[h].hh.b1 := 1 end; if mem[hh].hh.b1 = 0 then begin mem[hh + 5].int := mem[hh + 1].int; mem[hh + 3].int := mem[hh + 1].int; mem[hh + 6].int := mem[hh + 2].int; mem[hh + 4].int := mem[hh + 2].int; mem[hh].hh.b1 := 1 end; {:563} tolstep := 0; repeat n := -65536; p := h; repeat if mem[p].hh.b1 <> 0 then begin nn := -65536; pp := hh; repeat if mem[pp].hh.b1 <> 0 then begin cubicintersection(p, pp); if curt > 0 then begin curt := curt + n; curtt := curtt + nn; goto 10 end end; nn := nn + 65536; pp := mem[pp].hh.rh until pp = hh end; n := n + 65536; p := mem[p].hh.rh until p = h; tolstep := tolstep + 3 until tolstep > 3; curt := -65536; curtt := -65536; 10: null end; {:562} {574:} procedure openawindow(k: windownumber; r0, c0, r1, c1: scaled; x, y: scaled); var m, n: integer; {575:} begin if r0 < 0 then r0 := 0 else r0 := roundunscaled(r0); r1 := roundunscaled(r1); if r1 > screendepth then r1 := screendepth; if r1 < r0 then if r0 > screendepth then r0 := r1 else r1 := r0; if c0 < 0 then c0 := 0 else c0 := roundunscaled(c0); c1 := roundunscaled(c1); if c1 > screenwidth then c1 := screenwidth; if c1 < c0 then if c0 > screenwidth then c0 := c1 else c1 := c0 {:575}; windowopen[k] := true; windowtime[k] := windowtime[k] + 1; leftcol[k] := c0; rightcol[k] := c1; toprow[k] := r0; botrow[k] := r1; {576:} m := roundunscaled(x); n := roundunscaled(y) - 1; mwindow[k] := c0 - m; nwindow[k] := r0 + n {:576}; begin if not screenstarted then begin screenOK := initscreen; screenstarted := true end end; if screenOK then begin blankrectangle(c0, c1, r0, r1); updatescreen end end; { openawindow } {:574} {577:} procedure dispedges(k: windownumber); label 30, 40; var p, q: halfword; alreadythere: boolean; r: integer; {580:} n: screencol; w, ww: integer; b: pixelcolor; m, mm: integer; d: integer; madjustment: integer; rightedge: integer; mincol: screencol; {:580} begin if screenOK then if leftcol[k] < rightcol[k] then if toprow[k] < botrow[k] then begin alreadythere := false; if mem[curedges + 3].hh.rh = k then if mem[curedges + 4].int = windowtime[k] then alreadythere := true; if not alreadythere then blankrectangle(leftcol[k], rightcol[k], toprow[k], botrow[k]); {581:} madjustment := mwindow[k] - mem[curedges + 3].hh.lh; rightedge := 8 * (rightcol[k] - madjustment); mincol := leftcol[k] {:581}; p := mem[curedges].hh.rh; r := nwindow[k] - (mem[curedges + 1].hh.lh - 4096); while (p <> curedges) and (r >= toprow[k]) do begin if r < botrow[k] then begin {578:} if mem[p + 1].hh.lh > (-29999) then sortedges(p) else if mem[p + 1].hh.lh = (-29999) then if alreadythere then goto 30; mem[p + 1].hh.lh := -29999; {582:} n := 0; ww := 0; m := -1; w := 0; q := mem[p + 1].hh.rh; rowtransition[0] := mincol; while true do begin if q = 30000 then d := rightedge else d := mem[q].hh.lh + 32768; mm := (d div 8) + madjustment; if mm <> m then begin {583:} if w <= 0 then begin if ww > 0 then if m > mincol then begin if n = 0 then if alreadythere then begin b := 0; n := n + 1 end else b := 1 else n := n + 1; rowtransition[n] := m end end else if ww <= 0 then if m > mincol then begin if n = 0 then b := 1; n := n + 1; rowtransition[n] := m end {:583}; m := mm; w := ww end; if d >= rightedge then goto 40; ww := (ww + (d mod 8)) - 4; q := mem[q].hh.rh end; 40: {584:} if alreadythere or (ww > 0) then begin if n = 0 then if ww > 0 then b := 1 else b := 0; n := n + 1; rowtransition[n] := rightcol[k] end else if n = 0 then goto 30 {:584}; {:582} paintrow(r, b, rowtransition, n); 30: {:578} null end; p := mem[p].hh.rh; r := r - 1 end; updatescreen; windowtime[k] := windowtime[k] + 1; mem[curedges + 3].hh.rh := k; mem[curedges + 4].int := windowtime[k] end end; {:577} {591:} function maxcoef(p: halfword): fraction; var x: fraction; begin x := 0; while mem[p].hh.lh <> (-30000) do begin if abs(mem[p + 1].int) > x then x := abs(mem[p + 1].int); p := mem[p].hh.rh end; maxcoef := x end; {:591} {597:} function pplusq(p: halfword; q: halfword; t: smallnumber): halfword; label 30; var pp, qq: halfword; r, s: halfword; threshold: integer; v: integer; begin if t = 17 then threshold := 2685 else threshold := 8; r := 29999; pp := mem[p].hh.lh; qq := mem[q].hh.lh; while true do if pp = qq then if pp = (-30000) then goto 30 {598:} else begin v := mem[p + 1].int + mem[q + 1].int; mem[p + 1].int := v; s := p; p := mem[p].hh.rh; pp := mem[p].hh.lh; if abs(v) < threshold then freenode(s, 2) else begin if abs(v) >= 626349397 then if watchcoefs then begin mem[qq].hh.b0 := 0; fixneeded := true end; mem[r].hh.rh := s; r := s end; q := mem[q].hh.rh; qq := mem[q].hh.lh end {:598} else if mem[pp + 1].int < mem[qq + 1].int then begin s := getnode(2); mem[s].hh.lh := qq; mem[s + 1].int := mem[q + 1].int; q := mem[q].hh.rh; qq := mem[q].hh.lh; mem[r].hh.rh := s; r := s end else begin mem[r].hh.rh := p; r := p; p := mem[p].hh.rh; pp := mem[p].hh.lh end; 30: mem[p + 1].int := slowadd(mem[p + 1].int, mem[q + 1].int); mem[r].hh.rh := p; depfinal := p; pplusq := mem[29999].hh.rh end; {:597} {599:} function ptimesv(p: halfword; v: integer; t0, t1: smallnumber; visscaled: boolean): halfword; var r, s: halfword; w: integer; threshold: integer; scalingdown: boolean; begin if t0 <> t1 then scalingdown := true else scalingdown := not visscaled; if t1 = 17 then threshold := 1342 else threshold := 4; r := 29999; while mem[p].hh.lh <> (-30000) do begin if scalingdown then w := takefraction(v, mem[p + 1].int) else w := takescaled(v, mem[p + 1].int); if abs(w) <= threshold then begin s := mem[p].hh.rh; freenode(p, 2); p := s end else begin if abs(w) >= 626349397 then begin fixneeded := true; mem[mem[p].hh.lh].hh.b0 := 0 end; mem[r].hh.rh := p; r := p; mem[p + 1].int := w; p := mem[p].hh.rh end end; mem[r].hh.rh := p; if visscaled then mem[p + 1].int := takescaled(mem[p + 1].int, v) else mem[p + 1].int := takefraction(mem[p + 1].int, v); ptimesv := mem[29999].hh.rh end; {:599} {601:} function pwithxbecomingq(p, x, q: halfword; t: smallnumber): halfword; var r, s: halfword; v: integer; sx: integer; begin s := p; r := 29999; sx := mem[x + 1].int; while mem[mem[s].hh.lh + 1].int > sx do begin r := s; s := mem[s].hh.rh end; if mem[s].hh.lh <> x then pwithxbecomingq := p else begin mem[29999].hh.rh := p; mem[r].hh.rh := mem[s].hh.rh; v := mem[s + 1].int; freenode(s, 2); pwithxbecomingq := pplusfq(mem[29999].hh.rh, v, q, t, 17) end end; {:601} {606:} procedure newdep(q, p: halfword); var r: halfword; begin mem[q + 1].hh.rh := p; mem[q + 1].hh.lh := -29987; r := mem[-29987].hh.rh; mem[depfinal].hh.rh := r; mem[r + 1].hh.lh := depfinal; mem[-29987].hh.rh := q end; {:606} {607:} function constdependency(v: scaled): halfword; begin depfinal := getnode(2); mem[depfinal + 1].int := v; mem[depfinal].hh.lh := -30000; constdependency := depfinal end; {:607} {608:} function singledependency(p: halfword): halfword; var q: halfword; m: integer; begin m := mem[p + 1].int mod 64; if m > 28 then singledependency := constdependency(0) else begin q := getnode(2); mem[q + 1].int := twotothe[28 - m]; mem[q].hh.lh := p; mem[q].hh.rh := constdependency(0); singledependency := q end end; {:608} {609:} function copydeplist(p: halfword): halfword; label 30; var q: halfword; begin q := getnode(2); depfinal := q; while true do begin mem[depfinal].hh.lh := mem[p].hh.lh; mem[depfinal + 1].int := mem[p + 1].int; if mem[depfinal].hh.lh = (-30000) then goto 30; mem[depfinal].hh.rh := getnode(2); depfinal := mem[depfinal].hh.rh; p := mem[p].hh.rh end; 30: copydeplist := q end; {:609} {610:} procedure lineareq(p: halfword; t: smallnumber); var q, r, s: halfword; x: halfword; n: integer; v: integer; prevr: halfword; finalnode: halfword; w: integer; {611:} begin q := p; r := mem[p].hh.rh; v := mem[q + 1].int; while mem[r].hh.lh <> (-30000) do begin if abs(mem[r + 1].int) > abs(v) then begin q := r; v := mem[r + 1].int end; r := mem[r].hh.rh end {:611}; x := mem[q].hh.lh; n := mem[x + 1].int mod 64; {612:} s := 29999; mem[s].hh.rh := p; r := p; repeat if r = q then begin mem[s].hh.rh := mem[r].hh.rh; freenode(r, 2) end else begin w := makefraction(mem[r + 1].int, v); if abs(w) <= 1342 then begin mem[s].hh.rh := mem[r].hh.rh; freenode(r, 2) end else begin mem[r + 1].int := -w; s := r end end; r := mem[s].hh.rh until mem[r].hh.lh = (-30000); if t = 18 then mem[r + 1].int := -makescaled(mem[r + 1].int, v) else if v <> (-268435456) then mem[r + 1].int := -makefraction(mem[r + 1].int, v); finalnode := r; p := mem[29999].hh.rh {:612}; if internal[2] > 0 then {613:} if interesting(x) then begin begindiagnostic; printnl(462); printvariablename(x); w := n; while w > 0 do begin print(455); w := w - 2 end; printchar(61); printdependency(p, 17); enddiagnostic(false) end {:613}; {614:} prevr := -29987; r := mem[-29987].hh.rh; while r <> (-29987) do begin s := mem[r + 1].hh.rh; q := pwithxbecomingq(s, x, p, mem[r].hh.b0); if mem[q].hh.lh = (-30000) then makeknown(r, q) else begin mem[r + 1].hh.rh := q; repeat q := mem[q].hh.rh until mem[q].hh.lh = (-30000); prevr := q end; r := mem[prevr].hh.rh end {:614}; {615:} if n > 0 then begin {616:} s := 29999; mem[29999].hh.rh := p; r := p; repeat if n > 30 then w := 0 else w := mem[r + 1].int div twotothe[n]; if (abs(w) <= 1342) and (mem[r].hh.lh <> (-30000)) then begin mem[s].hh.rh := mem[r].hh.rh; freenode(r, 2) end else begin mem[r + 1].int := w; s := r end; r := mem[s].hh.rh until mem[s].hh.lh = (-30000); p := mem[29999].hh.rh end {:616}; if mem[p].hh.lh = (-30000) then begin mem[x].hh.b0 := 16; mem[x + 1].int := mem[p + 1].int; if abs(mem[x + 1].int) >= 268435456 then valtoobig(mem[x + 1].int); freenode(p, 2); if curexp = x then if curtype = 19 then begin curexp := mem[x + 1].int; curtype := 16; freenode(x, 2) end end else begin mem[x].hh.b0 := 17; depfinal := finalnode; newdep(x, p); if curexp = x then if curtype = 19 then curtype := 17 end {:615}; if fixneeded then fixdependencies end; {:610} {619:} function newringentry(p: halfword): halfword; var q: halfword; begin q := getnode(2); mem[q].hh.b1 := 11; mem[q].hh.b0 := mem[p].hh.b0; if mem[p + 1].int = (-30000) then mem[q + 1].int := p else mem[q + 1].int := mem[p + 1].int; mem[p + 1].int := q; newringentry := q end; {:619} {621:} procedure nonlineareq(v: integer; p: halfword; flushp: boolean); var t: smallnumber; q, r: halfword; begin t := mem[p].hh.b0 - 1; q := mem[p + 1].int; if flushp then mem[p].hh.b0 := 1 else p := q; repeat r := mem[q + 1].int; mem[q].hh.b0 := t; case t of 2: mem[q + 1].int := v; 4: begin mem[q + 1].int := v; begin if strref[v] < 127 then strref[v] := strref[v] + 1 end end; 6: begin mem[q + 1].int := v; mem[v].hh.lh := mem[v].hh.lh + 1 end; 9: mem[q + 1].int := copypath(v); 11: mem[q + 1].int := copyedges(v) end; q := r until q = p end; {:621} {622:} procedure ringmerge(p, q: halfword); label 10; var r: halfword; begin r := mem[p + 1].int; while r <> p do begin if r = q then begin {623:} begin begin if interaction = 3 then null; printnl(133); print(465) end; begin helpptr := 2; helpline[1] := 466; helpline[0] := 467 end; putgeterror end {:623}; goto 10 end; r := mem[r + 1].int end; r := mem[p + 1].int; mem[p + 1].int := mem[q + 1].int; mem[q + 1].int := r; 10: null end; {:622} {626:} procedure showcmdmod(c, m: integer); begin begindiagnostic; printnl(123); printcmdmod(c, m); printchar(125); enddiagnostic(false) end; {:626} {635:} procedure showcontext; label 30; var oldsetting: 0..5; {641:} i: 0..bufsize; l: integer; m: integer; n: 0..errorline; p: integer; q: integer; {:641} begin fileptr := inputptr; inputstack[fileptr] := curinput; while true do begin curinput := inputstack[fileptr]; {636:} if (((fileptr = inputptr) or (curinput.indexfield <= 6)) or (curinput.indexfield <> 10)) or (curinput.locfield <> (-30000)) then begin tally := 0; oldsetting := selector; if curinput.indexfield <= 6 then begin {637:} if curinput.namefield <= 1 then if (curinput.namefield = 0) and (fileptr = 0) then printnl(469) else printnl(470) else if curinput.namefield = 2 then printnl(471) else begin printnl(472); printint(line) end; printchar(32) {:637}; {644:} begin l := tally; tally := 0; selector := 4; trickcount := 1000000 end; if curinput.limitfield > 0 then for i := curinput.startfield to curinput.limitfield - 1 do begin if i = curinput.locfield then begin firstcount := tally; trickcount := ((tally + 1) + errorline) - halferrorline; if trickcount < errorline then trickcount := errorline end; print(buffer[i]) end {:644} end else begin {638:} if curinput.indexfield in [7, 8, 9, 10, 11, 12] then case curinput.indexfield of 7: printnl(473); 8: begin {639:} printnl(478); p := paramstack[curinput.limitfield]; if p <> (-30000) then if mem[p].hh.rh = (-29999) then printexp(p, 0) else showtokenlist(p, -30000, 20, tally); print(479) end; {:639} 9: printnl(474); 10: if curinput.locfield = (-30000) then printnl(475) else printnl(476); 11: printnl(477); 12: begin println; if curinput.namefield <> (-30000) then print(hash[curinput.namefield].rh) {640:} else begin p := paramstack[curinput.limitfield]; if p = (-30000) then showtokenlist(paramstack[curinput.limitfield + 1], -30000, 20, tally) else begin q := p; while mem[q].hh.rh <> (-30000) do q := mem[q].hh.rh; mem[q].hh.rh := paramstack[curinput.limitfield + 1]; showtokenlist(p, -30000, 20, tally); mem[q].hh.rh := -30000 end end {:640}; print(368) end end else printnl(63) {:638}; {645:} begin l := tally; tally := 0; selector := 4; trickcount := 1000000 end; if curinput.indexfield <> 12 then showtokenlist(curinput.startfield, curinput.locfield, 100000, 0) else showmacro(curinput.startfield, curinput.locfield, 100000) {:645} end; selector := oldsetting; {643:} if trickcount = 1000000 then begin firstcount := tally; trickcount := ((tally + 1) + errorline) - halferrorline; if trickcount < errorline then trickcount := errorline end; if tally < trickcount then m := tally - firstcount else m := trickcount - firstcount; if (l + firstcount) <= halferrorline then begin p := 0; n := l + firstcount end else begin print(146); p := ((l + firstcount) - halferrorline) + 3; n := halferrorline end; for q := p to firstcount - 1 do printchar(trickbuf[q mod errorline]); println; for q := 1 to n do printchar(32); if (m + n) <= errorline then p := firstcount + m else p := firstcount + ((errorline - n) - 3); for q := firstcount to p - 1 do printchar(trickbuf[q mod errorline]); if (m + n) > errorline then print(146) {:643} end {:636}; if curinput.indexfield <= 6 then if (curinput.namefield > 2) or (fileptr = 0) then goto 30; fileptr := fileptr - 1 end; 30: curinput := inputstack[inputptr] end; { showcontext } {:635} {649:} procedure begintokenlist(p: halfword; t: quarterword); begin begin if inputptr > maxinstack then begin maxinstack := inputptr; if inputptr = stacksize then overflow(480, stacksize) end; inputstack[inputptr] := curinput; inputptr := inputptr + 1 end; curinput.startfield := p; curinput.indexfield := t; curinput.limitfield := paramptr; curinput.locfield := p end; {:649} {650:} procedure endtokenlist; label 30; var p: halfword; begin if curinput.indexfield >= 10 then if curinput.indexfield <= 11 then begin flushtokenlist(curinput.startfield); goto 30 end else deletemacref(curinput.startfield); while paramptr > curinput.limitfield do begin paramptr := paramptr - 1; p := paramstack[paramptr]; if p <> (-30000) then if mem[p].hh.rh = (-29999) then begin recyclevalue(p); freenode(p, 2) end else flushtokenlist(p) end; 30: begin inputptr := inputptr - 1; curinput := inputstack[inputptr] end; begin if interrupt <> 0 then pauseforinstructions end end; {:650} {651:} {855:} {856:} procedure encapsulate(p: halfword); begin curexp := getnode(2); mem[curexp].hh.b0 := curtype; mem[curexp].hh.b1 := 11; newdep(curexp, p) end; { encapsulate } {:856} {858:} procedure install(r, q: halfword); var p: halfword; begin if mem[q].hh.b0 = 16 then begin mem[r + 1].int := mem[q + 1].int; mem[r].hh.b0 := 16 end else if mem[q].hh.b0 = 19 then begin p := singledependency(q); if p = depfinal then begin mem[r].hh.b0 := 16; mem[r + 1].int := 0; freenode(p, 2) end else begin mem[r].hh.b0 := 17; newdep(r, p) end end else begin mem[r].hh.b0 := mem[q].hh.b0; newdep(r, copydeplist(mem[q + 1].hh.rh)) end end; {:858} procedure makeexpcopy(p: halfword); label 20; var q, r, t: halfword; begin 20: curtype := mem[p].hh.b0; if curtype in [1, 2, 16, 3, 5, 7, 12, 10, 4, 6, 11, 9, 8, 13, 14, 17, 18, 15, 19] then case curtype of 1, 2, 16: curexp := mem[p + 1].int; 3, 5, 7, 12, 10: curexp := newringentry(p); 4: begin curexp := mem[p + 1].int; begin if strref[curexp] < 127 then strref[curexp] := strref[curexp] + 1 end end; 6: begin curexp := mem[p + 1].int; mem[curexp].hh.lh := mem[curexp].hh.lh + 1 end; 11: curexp := copyedges(mem[p + 1].int); 9, 8: curexp := copypath(mem[p + 1].int); 13, 14: begin {857:} if mem[p + 1].int = (-30000) then initbignode(p); t := getnode(2); mem[t].hh.b1 := 11; mem[t].hh.b0 := curtype; initbignode(t); q := mem[p + 1].int + bignodesize[curtype]; r := mem[t + 1].int + bignodesize[curtype]; repeat q := q - 2; r := r - 2; install(r, q) until q = mem[p + 1].int; curexp := t end; {:857} 17, 18: encapsulate(copydeplist(mem[p + 1].hh.rh)); 15: begin begin mem[p].hh.b0 := 19; serialno := serialno + 64; mem[p + 1].int := serialno end; goto 20 end; 19: begin q := singledependency(p); if q = depfinal then begin curtype := 16; curexp := 0; freenode(q, 2) end else begin curtype := 17; encapsulate(q) end end end else confusion(664) end; {:855} function curtok: halfword; var p: halfword; savetype: smallnumber; saveexp: integer; begin if cursym = 0 then if curcmd = 38 then begin savetype := curtype; saveexp := curexp; makeexpcopy(curmod); p := stashcurexp; mem[p].hh.rh := -30000; curtype := savetype; curexp := saveexp end else begin p := getnode(2); mem[p + 1].int := curmod; mem[p].hh.b1 := 12; if curcmd = 42 then mem[p].hh.b0 := 16 else mem[p].hh.b0 := 4 end else begin begin p := avail; if p = (-30000) then p := getavail else begin avail := mem[p].hh.rh; mem[p].hh.rh := -30000 end {dynused:=dynused+1;} end; mem[p].hh.lh := cursym end; curtok := p end; {:651} {652:} procedure backinput; var p: halfword; s: 0..150; begin p := curtok; while (curinput.indexfield > 6) and (curinput.locfield = (-30000)) do endtokenlist; begintokenlist(p, 10) end; {:652} {653:} procedure backerror; begin OKtointerrupt := false; backinput; OKtointerrupt := true; error end; { backerror } procedure inserror; begin OKtointerrupt := false; backinput; curinput.indexfield := 11; OKtointerrupt := true; error end; {:653} {654:} procedure beginfilereading; begin if inopen = 6 then overflow(481, 6); if first = bufsize then overflow(128, bufsize); inopen := inopen + 1; begin if inputptr > maxinstack then begin maxinstack := inputptr; if inputptr = stacksize then overflow(480, stacksize) end; inputstack[inputptr] := curinput; inputptr := inputptr + 1 end; curinput.indexfield := inopen; linestack[curinput.indexfield] := line; curinput.startfield := first; curinput.namefield := 0 end; {:654} {655:} procedure endfilereading; begin first := curinput.startfield; line := linestack[curinput.indexfield]; if curinput.indexfield <> inopen then confusion(482); if curinput.namefield > 2 then aclose(inputfile[curinput.indexfield]); begin inputptr := inputptr - 1; curinput := inputstack[inputptr] end; inopen := inopen - 1 end; {:655} {656:} procedure clearforerrorprompt; begin while (((curinput.indexfield <= 6) and (curinput.namefield = 0)) and (inputptr > 0)) and (curinput.locfield = curinput.limitfield) do endfilereading; println end; {:656} {661:} function checkoutervalidity: boolean; var p: halfword; begin if scannerstatus = 0 then checkoutervalidity := true else begin deletionsallowed := false; {662:} if cursym <> 0 then begin p := getavail; mem[p].hh.lh := cursym; begintokenlist(p, 10) end {:662}; if scannerstatus > 1 then begin {663:} runaway; if cursym = 0 then begin if interaction = 3 then null; printnl(133); print(488) end else begin begin if interaction = 3 then null; printnl(133); print(489) end end; print(490); begin helpptr := 4; helpline[3] := 491; helpline[2] := 492; helpline[1] := 493; helpline[0] := 494 end; case scannerstatus of {664:} 2: begin print(495); helpline[3] := 496; cursym := 2235 end; 3: begin print(497); helpline[3] := 498; if warninginfo = 0 then cursym := 2239 else begin cursym := 2231; eqtb[2231].rh := warninginfo end end; 4, 5: begin print(499); if scannerstatus = 5 then print(hash[warninginfo].rh) else printvariablename(warninginfo); cursym := 2237 end; 6: begin print(500); print(hash[warninginfo].rh); print(501); helpline[3] := 502; cursym := 2236 end end {:664}; inserror end else begin {:663} begin if interaction = 3 then null; printnl(133); print(483) end; printint(warninginfo); begin helpptr := 3; helpline[2] := 484; helpline[1] := 485; helpline[0] := 486 end; if cursym = 0 then helpline[2] := 487; cursym := 2238; inserror end; deletionsallowed := true; checkoutervalidity := false end end; {:661} {666:} procedure firmuptheline; forward; {:666} {667:} procedure getnext; label 20, 10, 40, 25, 85, 86, 87, 30; var k: 0..bufsize; c: ASCIIcode; class: ASCIIcode; n, f: integer; begin 20: cursym := 0; if curinput.indexfield <= 6 then begin {669:} 25: c := buffer[curinput.locfield]; curinput.locfield := curinput.locfield + 1; class := charclass[c]; if class in [0, 1, 2, 3, 4, 5, 6, 7, 8, 20] then case class of 0: goto 85; 1: begin class := charclass[buffer[curinput.locfield]]; if class > 1 then goto 25 else if class < 1 then begin n := 0; goto 86 end end; 2: goto 25; 3: begin {679:} if curinput.namefield > 2 then begin {681:} line := line + 1; first := curinput.startfield; if not forceeof then begin if inputln(inputfile[curinput.indexfield], true) then firmuptheline else forceeof := true end; if forceeof then begin printchar(41); forceeof := false; flush(output); endfilereading; if checkoutervalidity then goto 20 else goto 20 end; buffer[curinput.limitfield] := 37; first := curinput.limitfield + 1; curinput.locfield := curinput.startfield end else begin {:681} if inputptr > 0 then begin endfilereading; goto 20 end; if selector < 2 then openlogfile; if interaction > 1 then begin if curinput.limitfield = curinput.startfield then printnl(517); println; first := curinput.startfield; begin print(42); terminput end; curinput.limitfield := last; buffer[curinput.limitfield] := 37; first := curinput.limitfield + 1; curinput.locfield := curinput.startfield end else fatalerror(518) end {:679}; begin if interrupt <> 0 then pauseforinstructions end; goto 25 end; 4: begin {671:} if buffer[curinput.locfield] = 34 then curmod := 155 else begin k := curinput.locfield; buffer[curinput.limitfield + 1] := 34; repeat curinput.locfield := curinput.locfield + 1 until buffer[curinput.locfield] = 34; if curinput.locfield > curinput.limitfield then begin {672:} curinput.locfield := curinput.limitfield; begin if interaction = 3 then null; printnl(133); print(510) end; begin helpptr := 3; helpline[2] := 511; helpline[1] := 512; helpline[0] := 513 end; deletionsallowed := false; error; deletionsallowed := true; goto 20 end {:672}; if curinput.locfield = (k + 1) then curmod := buffer[k] else begin begin if ((poolptr + curinput.locfield) - k) > maxpoolptr then begin if ((poolptr + curinput.locfield) - k) > poolsize then overflow(129, poolsize - initpoolptr); maxpoolptr := (poolptr + curinput.locfield) - k end end; repeat begin strpool[poolptr] := buffer[k]; poolptr := poolptr + 1 end; k := k + 1 until k = curinput.locfield; curmod := makestring end end; curinput.locfield := curinput.locfield + 1; curcmd := 39; goto 10 end; {:671} 5, 6, 7, 8: begin k := curinput.locfield - 1; goto 40 end; 20: begin {670:} begin if interaction = 3 then null; printnl(133); print(507) end; begin helpptr := 2; helpline[1] := 508; helpline[0] := 509 end; deletionsallowed := false; error; deletionsallowed := true; goto 20 end end else null {:670}; k := curinput.locfield - 1; while charclass[buffer[curinput.locfield]] = class do curinput.locfield := curinput.locfield + 1; goto 40; 85: {673:} n := c - 48; while charclass[buffer[curinput.locfield]] = 0 do begin if n < 4096 then n := ((10 * n) + buffer[curinput.locfield]) - 48; curinput.locfield := curinput.locfield + 1 end; if buffer[curinput.locfield] = 46 then if charclass[buffer[curinput.locfield + 1]] = 0 then goto 30; f := 0; goto 87; 30: curinput.locfield := curinput.locfield + 1 {:673}; 86: {674:} k := 0; repeat if k < 17 then begin dig[k] := buffer[curinput.locfield] - 48; k := k + 1 end; curinput.locfield := curinput.locfield + 1 until charclass[buffer[curinput.locfield]] <> 0; f := rounddecimals(k); if f = 65536 then begin n := n + 1; f := 0 end {:674}; 87: {675:} if n < 4096 then curmod := (n * 65536) + f else begin begin if interaction = 3 then null; printnl(133); print(514) end; begin helpptr := 2; helpline[1] := 515; helpline[0] := 516 end; deletionsallowed := false; error; deletionsallowed := true; curmod := 268435455 end; curcmd := 42; goto 10 {:675}; 40: cursym := idlookup(k, curinput.locfield - k) end else if curinput.locfield >= himemmin then begin {:669} {676:} cursym := mem[curinput.locfield].hh.lh; curinput.locfield := mem[curinput.locfield].hh.rh; if cursym >= 2242 then if cursym >= 2392 then begin {677:} if cursym >= 2542 then cursym := cursym - 150; begintokenlist(paramstack[(curinput.limitfield + cursym) - 2392], 9); goto 20 end else begin {:677} curcmd := 38; curmod := paramstack[(curinput.limitfield + cursym) - 2242]; cursym := 0; goto 10 end end else if curinput.locfield > (-30000) then begin {678:} if mem[curinput.locfield].hh.b1 = 12 then begin curmod := mem[curinput.locfield + 1].int; if mem[curinput.locfield].hh.b0 = 16 then curcmd := 42 else begin curcmd := 39; begin if strref[curmod] < 127 then strref[curmod] := strref[curmod] + 1 end end end else begin curmod := curinput.locfield; curcmd := 38 end; curinput.locfield := mem[curinput.locfield].hh.rh; goto 10 end else begin {:678} endtokenlist; goto 20 end {:676}; {668:} curcmd := eqtb[cursym].lh; curmod := eqtb[cursym].rh; if curcmd >= 83 then if checkoutervalidity then curcmd := curcmd - 83 else goto 20 {:668}; 10: null end; {:667} {682:} procedure firmuptheline; var k: 0..bufsize; begin curinput.limitfield := last; if internal[31] > 0 then if interaction > 1 then begin println; if curinput.startfield < curinput.limitfield then for k := curinput.startfield to curinput.limitfield - 1 do print(buffer[k]); first := curinput.limitfield; begin print(519); terminput end; if last > first then begin for k := first to last - 1 do buffer[(k + curinput.startfield) - first] := buffer[k]; curinput.limitfield := (curinput.startfield + last) - first end end end; {:682} {685:} function scantoks(terminator: commandcode; substlist, tailend: halfword; suffixcount: smallnumber): halfword; label 30, 40; var p: halfword; q: halfword; balance: integer; begin p := 29998; balance := 1; mem[29998].hh.rh := -30000; while true do begin getnext; if cursym > 0 then begin {686:} begin q := substlist; while q <> (-30000) do begin if mem[q].hh.lh = cursym then begin cursym := mem[q + 1].int; curcmd := 7; goto 40 end; q := mem[q].hh.rh end; 40: {:686} null end; if curcmd = terminator then {687:} if curmod > 0 then balance := balance + 1 else begin balance := balance - 1; if balance = 0 then goto 30 end {:687} else if curcmd = 61 then begin {690:} if curmod = 0 then getnext else if curmod <= suffixcount then cursym := 2391 + curmod end {:690} end; mem[p].hh.rh := curtok; p := mem[p].hh.rh end; 30: mem[p].hh.rh := tailend; flushnodelist(substlist); scantoks := mem[29998].hh.rh end; {:685} {691:} procedure getsymbol; label 20; begin 20: getnext; if (cursym = 0) or (cursym > 2229) then begin begin if interaction = 3 then null; printnl(133); print(531) end; begin helpptr := 3; helpline[2] := 532; helpline[1] := 533; helpline[0] := 534 end; if cursym > 0 then helpline[2] := 535 else if curcmd = 39 then begin if strref[curmod] < 127 then if strref[curmod] > 1 then strref[curmod] := strref[curmod] - 1 else flushstring(curmod) end; cursym := 2229; inserror; goto 20 end end; { getsymbol } {:691} {692:} procedure getclearsymbol; begin getsymbol; clearsymbol(cursym, false) end; {:692} {693:} procedure checkequals; begin if curcmd <> 51 then if curcmd <> 77 then begin missingerr(61); begin helpptr := 5; helpline[4] := 536; helpline[3] := 537; helpline[2] := 538; helpline[1] := 539; helpline[0] := 540 end; backerror end end; {:693} {694:} procedure makeopdef; var m: commandcode; p, q, r: halfword; begin m := curmod; getsymbol; q := getnode(2); mem[q].hh.lh := cursym; mem[q + 1].int := 2242; getclearsymbol; warninginfo := cursym; getsymbol; p := getnode(2); mem[p].hh.lh := cursym; mem[p + 1].int := 2243; mem[p].hh.rh := q; getnext; checkequals; scannerstatus := 5; q := getavail; mem[q].hh.lh := -30000; r := getavail; mem[q].hh.rh := r; mem[r].hh.lh := 0; mem[r].hh.rh := scantoks(16, p, -30000, 0); scannerstatus := 0; eqtb[warninginfo].lh := m; eqtb[warninginfo].rh := q; getxnext end; {:694} {697:} {1032:} procedure checkdelimiter(ldelim, rdelim: halfword); label 10; begin if curcmd = 62 then if curmod = ldelim then goto 10; if cursym <> rdelim then begin missingerr(hash[rdelim].rh); begin helpptr := 2; helpline[1] := 786; helpline[0] := 787 end; backerror end else begin begin if interaction = 3 then null; printnl(133); print(788) end; print(hash[rdelim].rh); print(789); begin helpptr := 3; helpline[2] := 790; helpline[1] := 791; helpline[0] := 792 end; error end; 10: null end; {:1032} {1011:} function scandeclaredvariable: halfword; label 30; var x: halfword; h, t: halfword; l: halfword; begin getsymbol; x := cursym; if curcmd <> 41 then clearsymbol(x, false); if eqtb[x].rh = (-30000) then newroot(x); h := getavail; mem[h].hh.lh := x; t := h; while true do begin getxnext; if cursym = 0 then goto 30; if curcmd <> 41 then if curcmd <> 40 then if curcmd = 63 then begin {1012:} l := cursym; getxnext; if curcmd <> 64 then begin backinput; cursym := l; curcmd := 63; goto 30 end else cursym := 0 end else {:1012} goto 30; mem[t].hh.rh := getavail; t := mem[t].hh.rh; mem[t].hh.lh := cursym end; 30: scandeclaredvariable := h end; {:1011} procedure scandef; var m: 1..2; n: 0..3; k: 0..150; c: 0..7; r: halfword; q: halfword; p: halfword; base: halfword; ldelim, rdelim: halfword; begin m := curmod; c := 0; mem[29998].hh.rh := -30000; q := getavail; mem[q].hh.lh := -30000; r := -30000; {700:} if m = 1 then begin getclearsymbol; warninginfo := cursym; getnext; scannerstatus := 5; n := 0; eqtb[warninginfo].lh := 10; eqtb[warninginfo].rh := q end else begin p := scandeclaredvariable; flushvariable(eqtb[mem[p].hh.lh].rh, mem[p].hh.rh, true); warninginfo := findvariable(p); flushlist(p); if warninginfo = (-30000) then begin {701:} begin if interaction = 3 then null; printnl(133); print(547) end; begin helpptr := 2; helpline[1] := 548; helpline[0] := 549 end; error; warninginfo := -29979 end {:701}; scannerstatus := 4; n := 2; if curcmd = 61 then if curmod = 3 then begin n := 3; getnext end; mem[warninginfo].hh.b0 := 20 + n; mem[warninginfo + 1].int := q end {:700}; k := n; if curcmd = 31 then {703:} repeat ldelim := cursym; rdelim := curmod; getnext; if (curcmd = 56) and (curmod >= 2242) then base := curmod else begin begin if interaction = 3 then null; printnl(133); print(550) end; begin helpptr := 1; helpline[0] := 551 end; backerror; base := 2242 end; {704:} repeat mem[q].hh.rh := getavail; q := mem[q].hh.rh; mem[q].hh.lh := base + k; getsymbol; p := getnode(2); mem[p + 1].int := base + k; mem[p].hh.lh := cursym; if k = 150 then overflow(552, 150); k := k + 1; mem[p].hh.rh := r; r := p; getnext until curcmd <> 79 {:704}; checkdelimiter(ldelim, rdelim); getnext until curcmd <> 31 {:703}; if curcmd = 56 then begin {705:} p := getnode(2); if curmod < 2242 then begin c := curmod; mem[p + 1].int := 2242 + k end else begin mem[p + 1].int := curmod + k; if curmod = 2242 then c := 4 else if curmod = 2392 then c := 6 else c := 7 end; if k = 150 then overflow(552, 150); k := k + 1; getsymbol; mem[p].hh.lh := cursym; mem[p].hh.rh := r; r := p; getnext; if c = 4 then if curcmd = 69 then begin c := 5; p := getnode(2); if k = 150 then overflow(552, 150); mem[p + 1].int := 2242 + k; getsymbol; mem[p].hh.lh := cursym; mem[p].hh.rh := r; r := p; getnext end end {:705}; checkequals; p := getavail; mem[p].hh.lh := c; mem[q].hh.rh := p; {698:} if m = 1 then mem[p].hh.rh := scantoks(16, r, -30000, n) else begin q := getavail; mem[q].hh.lh := bgloc; mem[p].hh.rh := q; p := getavail; mem[p].hh.lh := egloc; mem[q].hh.rh := scantoks(16, r, p, n) end; if warninginfo = (-29979) then flushtokenlist(mem[-29978].int) {:698}; scannerstatus := 0; getxnext end; {:697} {706:} procedure scanprimary; forward; procedure scansecondary; forward; procedure scantertiary; forward; procedure scanexpression; forward; procedure scansuffix; forward; {720:} {722:} procedure printmacroname(a, n: halfword); var p, q: halfword; begin if n <> (-30000) then print(hash[n].rh) else begin p := mem[a].hh.lh; if p = (-30000) then print(hash[mem[mem[mem[a].hh.rh].hh.lh].hh.lh].rh) else begin q := p; while mem[q].hh.rh <> (-30000) do q := mem[q].hh.rh; mem[q].hh.rh := mem[mem[a].hh.rh].hh.lh; showtokenlist(p, -30000, 1000, 0); mem[q].hh.rh := -30000 end end end; {:722} {723:} procedure printarg(q: halfword; n: integer; b: halfword); begin if mem[q].hh.rh = (-29999) then printnl(365) else if (b < 2542) and (b <> 7) then printnl(366) else printnl(367); printint(n); print(568); if mem[q].hh.rh = (-29999) then printexp(q, 1) else showtokenlist(q, -30000, 1000, 0) end; {:723} {730:} procedure scantextarg(ldelim, rdelim: halfword); label 30; var balance: integer; p: halfword; begin warninginfo := ldelim; scannerstatus := 3; p := 29998; balance := 1; mem[29998].hh.rh := -30000; while true do begin getnext; if ldelim = 0 then begin {732:} if curcmd > 79 then begin if balance = 1 then goto 30 else if curcmd = 81 then balance := balance - 1 end else if curcmd = 32 then balance := balance + 1 end else begin {:732} {731:} if curcmd = 62 then begin if curmod = ldelim then begin balance := balance - 1; if balance = 0 then goto 30 end end else if curcmd = 31 then if curmod = rdelim then balance := balance + 1 end {:731}; mem[p].hh.rh := curtok; p := mem[p].hh.rh end; 30: curexp := mem[29998].hh.rh; curtype := 20; scannerstatus := 0 end; {:730} procedure macrocall(defref, arglist, macroname: halfword); label 40; var r: halfword; p, q: halfword; n: integer; ldelim, rdelim: halfword; tail: halfword; begin r := mem[defref].hh.rh; mem[defref].hh.lh := mem[defref].hh.lh + 1; if arglist = (-30000) then n := 0 {724:} else begin n := 1; tail := arglist; while mem[tail].hh.rh <> (-30000) do begin n := n + 1; tail := mem[tail].hh.rh end end {:724}; if internal[9] > 0 then begin {721:} begindiagnostic; println; printmacroname(arglist, macroname); if n = 3 then print(530); showmacro(defref, -30000, 100000); if arglist <> (-30000) then begin n := 0; p := arglist; repeat q := mem[p].hh.lh; printarg(q, n, 0); n := n + 1; p := mem[p].hh.rh until p = (-30000) end; enddiagnostic(false) end {:721}; {725:} curcmd := 80; while mem[r].hh.lh >= 2242 do begin {726:} if curcmd <> 79 then begin getxnext; if curcmd <> 31 then begin begin if interaction = 3 then null; printnl(133); print(574) end; printmacroname(arglist, macroname); begin helpptr := 3; helpline[2] := 575; helpline[1] := 576; helpline[0] := 577 end; if mem[r].hh.lh >= 2392 then begin curexp := -30000; curtype := 20 end else begin curexp := 0; curtype := 16 end; backerror; curcmd := 62; goto 40 end; ldelim := cursym; rdelim := curmod end; {729:} if mem[r].hh.lh >= 2542 then scantextarg(ldelim, rdelim) else begin getxnext; if mem[r].hh.lh >= 2392 then scansuffix else scanexpression end {:729}; if curcmd <> 79 then {727:} if (curcmd <> 62) or (curmod <> ldelim) then if mem[mem[r].hh.rh].hh.lh >= 2242 then begin missingerr(44); begin helpptr := 3; helpline[2] := 578; helpline[1] := 579; helpline[0] := 573 end; backerror; curcmd := 79 end else begin missingerr(hash[rdelim].rh); begin helpptr := 2; helpline[1] := 580; helpline[0] := 573 end; backerror end {:727}; 40: {728:} begin p := getavail; if curtype = 20 then mem[p].hh.lh := curexp else mem[p].hh.lh := stashcurexp; if internal[9] > 0 then begin begindiagnostic; printarg(mem[p].hh.lh, n, mem[r].hh.lh); enddiagnostic(false) end; if arglist = (-30000) then arglist := p else mem[tail].hh.rh := p; tail := p; n := n + 1 end {:728} {:726}; r := mem[r].hh.rh end; if curcmd = 79 then begin begin if interaction = 3 then null; printnl(133); print(569) end; printmacroname(arglist, macroname); printchar(59); printnl(570); print(hash[rdelim].rh); print(170); begin helpptr := 3; helpline[2] := 571; helpline[1] := 572; helpline[0] := 573 end; error end; if mem[r].hh.lh <> 0 then begin {733:} if mem[r].hh.lh < 7 then begin getxnext; if mem[r].hh.lh <> 6 then if (curcmd = 51) or (curcmd = 77) then getxnext end; case mem[r].hh.lh of 1: scanprimary; 2: scansecondary; 3: scantertiary; 4: scanexpression; 5: begin {734:} scanexpression; p := getavail; mem[p].hh.lh := stashcurexp; if internal[9] > 0 then begin begindiagnostic; printarg(mem[p].hh.lh, n, 0); enddiagnostic(false) end; if arglist = (-30000) then arglist := p else mem[tail].hh.rh := p; tail := p; n := n + 1; if curcmd <> 69 then begin missingerr(347); print(581); printmacroname(arglist, macroname); begin helpptr := 1; helpline[0] := 582 end; backerror end; getxnext; scanprimary end; {:734} 6: begin {735:} if curcmd <> 31 then ldelim := -30000 else begin ldelim := cursym; rdelim := curmod; getxnext end; scansuffix; if ldelim <> (-30000) then begin if (curcmd <> 62) or (curmod <> ldelim) then begin missingerr(hash[rdelim].rh); begin helpptr := 2; helpline[1] := 580; helpline[0] := 573 end; backerror end; getxnext end end; {:735} 7: scantextarg(0, 0) end; backinput; {728:} begin p := getavail; if curtype = 20 then mem[p].hh.lh := curexp else mem[p].hh.lh := stashcurexp; if internal[9] > 0 then begin begindiagnostic; printarg(mem[p].hh.lh, n, mem[r].hh.lh); enddiagnostic(false) end; if arglist = (-30000) then arglist := p else mem[tail].hh.rh := p; tail := p; n := n + 1 end {:728} end {:733}; r := mem[r].hh.rh {:725}; {736:} while (curinput.indexfield > 6) and (curinput.locfield = (-30000)) do endtokenlist; if (paramptr + n) > maxparamstack then begin maxparamstack := paramptr + n; if maxparamstack > 150 then overflow(552, 150) end; begintokenlist(defref, 12); curinput.namefield := macroname; curinput.locfield := r; if n > 0 then begin p := arglist; repeat paramstack[paramptr] := mem[p].hh.lh; paramptr := paramptr + 1; p := mem[p].hh.rh until p = (-30000); flushlist(arglist) end {:736} end; {:720} procedure getboolean; forward; procedure passtext; forward; procedure conditional; forward; procedure startinput; forward; procedure beginiteration; forward; procedure resumeiteration; forward; procedure stopiteration; forward; {:706} {707:} procedure expand; var p: halfword; k: integer; j: poolpointer; begin if internal[7] > 65536 then if curcmd <> 10 then showcmdmod(curcmd, curmod); case curcmd of 1: conditional; 2: {751:} if curmod > iflimit then if iflimit = 1 then begin missingerr(58); backinput; cursym := 2234; inserror end else begin begin if interaction = 3 then null; printnl(133); print(589) end; printcmdmod(2, curmod); begin helpptr := 1; helpline[0] := 590 end; error end else begin while curmod <> 2 do passtext; {745:} begin p := condptr; ifline := mem[p + 1].int; curif := mem[p].hh.b1; iflimit := mem[p].hh.b0; condptr := mem[p].hh.rh; freenode(p, 2) end {:745} end {:751}; 3: {711:} if curmod > 0 then forceeof := true else {:711} startinput; 4: if curmod = 0 then begin {708:} begin if interaction = 3 then null; printnl(133); print(553) end; begin helpptr := 2; helpline[1] := 554; helpline[0] := 555 end; error end else {:708} beginiteration; 5: begin {712:} while (curinput.indexfield > 6) and (curinput.locfield = (-30000)) do endtokenlist; if loopptr = (-30000) then begin begin if interaction = 3 then null; printnl(133); print(557) end; begin helpptr := 2; helpline[1] := 558; helpline[0] := 559 end; error end else resumeiteration end; {:712} 6: begin {713:} getboolean; if internal[7] > 65536 then showcmdmod(33, curexp); if curexp = 30 then if loopptr = (-30000) then begin begin if interaction = 3 then null; printnl(133); print(560) end; begin helpptr := 1; helpline[0] := 561 end; if curcmd = 80 then error else backerror end else begin {714:} p := -30000; repeat if curinput.indexfield <= 6 then endfilereading else begin if curinput.indexfield <= 8 then p := curinput.startfield; endtokenlist end until p <> (-30000); if p <> mem[loopptr].hh.lh then fatalerror(564); stopiteration end {:714} else if curcmd <> 80 then begin missingerr(59); begin helpptr := 2; helpline[1] := 562; helpline[0] := 563 end; backerror end end; {:713} 7: null; 9: begin {715:} getnext; p := curtok; getnext; if curcmd < 11 then expand else backinput; begintokenlist(p, 10) end; {:715} 8: begin {716:} getxnext; scanprimary; if curtype <> 4 then begin disperr(-30000, 565); begin helpptr := 2; helpline[1] := 566; helpline[0] := 567 end; putgetflusherror(0) end else begin backinput; if (strstart[curexp + 1] - strstart[curexp]) > 0 then begin {717:} beginfilereading; curinput.namefield := 2; k := first + (strstart[curexp + 1] - strstart[curexp]); if k >= maxbufstack then begin if k >= bufsize then begin maxbufstack := bufsize; overflow(128, bufsize) end; maxbufstack := k + 1 end; j := strstart[curexp]; curinput.limitfield := k; while first < curinput.limitfield do begin buffer[first] := strpool[j]; j := j + 1; first := first + 1 end; buffer[curinput.limitfield] := 37; first := curinput.limitfield + 1; curinput.locfield := curinput.startfield; flushcurexp(0) end {:717} end end; {:716} 10: macrocall(curmod, -30000, cursym) end end; {:707} {718:} procedure getxnext; var saveexp: halfword; begin getnext; if curcmd < 11 then begin saveexp := stashcurexp; repeat if curcmd = 10 then macrocall(curmod, -30000, cursym) else expand; getnext until curcmd >= 11; unstashcurexp(saveexp) end end; {:718} {737:} procedure stackargument(p: halfword); begin if paramptr = maxparamstack then begin maxparamstack := maxparamstack + 1; if maxparamstack > 150 then overflow(552, 150) end; paramstack[paramptr] := p; paramptr := paramptr + 1 end; {:737} {742:} procedure passtext; label 30; var l: integer; begin scannerstatus := 1; l := 0; warninginfo := line; while true do begin getnext; if curcmd <= 2 then if curcmd < 2 then l := l + 1 else begin if l = 0 then goto 30; if curmod = 2 then l := l - 1 end {743:} else if curcmd = 39 then begin if strref[curmod] < 127 then if strref[curmod] > 1 then strref[curmod] := strref[curmod] - 1 else flushstring(curmod) end {:743} end; 30: scannerstatus := 0 end; {:742} {746:} procedure changeiflimit(l: smallnumber; p: halfword); label 10; var q: halfword; begin if p = condptr then iflimit := l else begin q := condptr; while true do begin if q = (-30000) then confusion(583); if mem[q].hh.rh = p then begin mem[q].hh.b0 := l; goto 10 end; q := mem[q].hh.rh end end; 10: null end; {:746} {747:} procedure checkcolon; begin if curcmd <> 78 then begin missingerr(58); begin helpptr := 2; helpline[1] := 586; helpline[0] := 563 end; backerror end end; {:747} {748:} procedure conditional; label 10, 30, 21, 40; var savecondptr: halfword; newiflimit: 2..4; p: halfword; {744:} begin begin p := getnode(2); mem[p].hh.rh := condptr; mem[p].hh.b0 := iflimit; mem[p].hh.b1 := curif; mem[p + 1].int := ifline; condptr := p; iflimit := 1; ifline := line; curif := 1 end {:744}; savecondptr := condptr; 21: getboolean; newiflimit := 4; if internal[7] > 65536 then begin {750:} begindiagnostic; if curexp = 30 then print(587) else print(588); enddiagnostic(false) end {:750}; 40: checkcolon; if curexp = 30 then begin changeiflimit(newiflimit, savecondptr); goto 10 end; {749:} while true do begin passtext; if condptr = savecondptr then goto 30 else if curmod = 2 then begin {745:} p := condptr; ifline := mem[p + 1].int; curif := mem[p].hh.b1; iflimit := mem[p].hh.b0; condptr := mem[p].hh.rh; freenode(p, 2) end {:745} end {:749}; 30: curif := curmod; ifline := line; if curmod = 2 then begin {745:} p := condptr; ifline := mem[p + 1].int; curif := mem[p].hh.b1; iflimit := mem[p].hh.b0; condptr := mem[p].hh.rh; freenode(p, 2) end else if curmod = 4 then {:745} goto 21 else begin curexp := 30; newiflimit := 2; getxnext; goto 40 end; 10: null end; {:748} {754:} procedure badfor(s: strnumber); begin disperr(-30000, 591); print(s); print(177); begin helpptr := 4; helpline[3] := 592; helpline[2] := 593; helpline[1] := 594; helpline[0] := 179 end; putgetflusherror(0) end; {:754} {755:} procedure beginiteration; label 22, 30, 40; var m: halfword; n: halfword; p, q, s, pp: halfword; begin m := curmod; n := cursym; s := getnode(2); if m = 1 then begin mem[s + 1].hh.lh := -29999; p := -30000; getxnext; goto 40 end; getsymbol; p := getnode(2); mem[p].hh.lh := cursym; mem[p + 1].int := m; getxnext; if (curcmd <> 51) and (curcmd <> 77) then begin missingerr(61); begin helpptr := 3; helpline[2] := 595; helpline[1] := 538; helpline[0] := 596 end; backerror end; {764:} mem[s + 1].hh.lh := -30000; q := s + 1; mem[q].hh.rh := -30000; repeat getxnext; if m <> 2242 then scansuffix else begin if curcmd >= 78 then if curcmd <= 79 then goto 22; scanexpression; if curcmd = 74 then if q = (s + 1) then begin {765:} if curtype <> 16 then badfor(602); pp := getnode(4); mem[pp + 1].int := curexp; getxnext; scanexpression; if curtype <> 16 then badfor(603); mem[pp + 2].int := curexp; if curcmd <> 75 then begin missingerr(357); begin helpptr := 2; helpline[1] := 604; helpline[0] := 605 end; backerror end; getxnext; scanexpression; if curtype <> 16 then badfor(606); mem[pp + 3].int := curexp; mem[s + 1].hh.lh := pp; goto 30 end {:765}; curexp := stashcurexp end; mem[q].hh.rh := getavail; q := mem[q].hh.rh; mem[q].hh.lh := curexp; curtype := 1; 22: null until curcmd <> 79; 30: {:764} null; 40: {756:} if curcmd <> 78 then begin missingerr(58); begin helpptr := 3; helpline[2] := 597; helpline[1] := 598; helpline[0] := 599 end; backerror end {:756}; {758:} q := getavail; mem[q].hh.lh := 2230; scannerstatus := 6; warninginfo := n; mem[s].hh.lh := scantoks(4, p, q, 0); scannerstatus := 0; mem[s].hh.rh := loopptr; loopptr := s {:758}; resumeiteration end; {:755} {760:} procedure resumeiteration; label 45, 10; var p, q: halfword; begin p := mem[loopptr + 1].hh.lh; if p > (-29999) then begin curexp := mem[p + 1].int; {761:} if ((mem[p + 2].int > 0) and (curexp > mem[p + 3].int)) or ((mem[p + 2].int < 0) and (curexp < mem[p + 3].int)) then {:761} goto 45; curtype := 16; q := stashcurexp; mem[p + 1].int := curexp + mem[p + 2].int end else if p < (-29999) then begin p := mem[loopptr + 1].hh.rh; if p = (-30000) then goto 45; mem[loopptr + 1].hh.rh := mem[p].hh.rh; q := mem[p].hh.lh; begin mem[p].hh.rh := avail; avail := p end {dynused:=dynused-1;} end else begin begintokenlist(mem[loopptr].hh.lh, 7); goto 10 end; begintokenlist(mem[loopptr].hh.lh, 8); stackargument(q); if internal[7] > 65536 then begin {762:} begindiagnostic; printnl(601); if (q <> (-30000)) and (mem[q].hh.rh = (-29999)) then printexp(q, 1) else showtokenlist(q, -30000, 50, 0); printchar(125); enddiagnostic(false) end {:762}; goto 10; 45: stopiteration; 10: null end; {:760} {763:} procedure stopiteration; var p, q: halfword; begin p := mem[loopptr + 1].hh.lh; if p > (-29999) then freenode(p, 4) else if p < (-29999) then begin q := mem[loopptr + 1].hh.rh; while q <> (-30000) do begin p := mem[q].hh.lh; if p <> (-30000) then if mem[p].hh.rh = (-29999) then begin recyclevalue(p); freenode(p, 2) end else flushtokenlist(p); p := q; q := mem[q].hh.rh; begin mem[p].hh.rh := avail; avail := p end {dynused:=dynused-1;} end end; p := loopptr; loopptr := mem[p].hh.rh; flushtokenlist(mem[p].hh.lh); freenode(p, 2) end; {:763} {770:} procedure beginname; begin areadelimiter := 0; extdelimiter := 0 end; {:770} {771:} function morename(c: ASCIIcode): boolean; begin if (c = 32) or (c = 9) then morename := false else begin if c = 47 then begin areadelimiter := poolptr; extdelimiter := 0 end else if (c = 46) and (extdelimiter = 0) then extdelimiter := poolptr; begin if (poolptr + 1) > maxpoolptr then begin if (poolptr + 1) > poolsize then overflow(129, poolsize - initpoolptr); maxpoolptr := poolptr + 1 end end; begin strpool[poolptr] := c; poolptr := poolptr + 1 end; morename := true end end; { morename } {:771} {772:} procedure endname; begin if (strptr + 3) > maxstrptr then begin if (strptr + 3) > maxstrings then overflow(130, maxstrings - initstrptr); maxstrptr := strptr + 3 end; if areadelimiter = 0 then curarea := 155 else begin curarea := strptr; strptr := strptr + 1; strstart[strptr] := areadelimiter + 1 end; if extdelimiter = 0 then begin curext := 155; curname := makestring end else begin curname := strptr; strptr := strptr + 1; strstart[strptr] := extdelimiter; curext := makestring end end; {:772} {774:} procedure packfilename(n, a, e: strnumber); var k: integer; c: ASCIIcode; j: poolpointer; begin k := 0; for j := strstart[a] to strstart[a + 1] - 1 do begin c := strpool[j]; k := k + 1; if k <= filenamesize then nameoffile[k] := xchr[c] end; for j := strstart[n] to strstart[n + 1] - 1 do begin c := strpool[j]; k := k + 1; if k <= filenamesize then nameoffile[k] := xchr[c] end; for j := strstart[e] to strstart[e + 1] - 1 do begin c := strpool[j]; k := k + 1; if k <= filenamesize then nameoffile[k] := xchr[c] end; if k <= filenamesize then namelength := k else namelength := filenamesize; for k := namelength + 1 to filenamesize do nameoffile[k] := ' ' end; {:774} {778:} procedure packbufferedname(n: smallnumber; a, b: integer); var k: integer; c: ASCIIcode; j: integer; begin if (((n + b) - a) + 6) > filenamesize then b := ((a + filenamesize) - n) - 6; k := 0; for j := 1 to n do begin c := xord[MFbasedefault[j]]; k := k + 1; if k <= filenamesize then nameoffile[k] := xchr[c] end; for j := a to b do begin c := buffer[j]; k := k + 1; if k <= filenamesize then nameoffile[k] := xchr[c] end; for j := 6 to 10 do begin c := xord[MFbasedefault[j]]; k := k + 1; if k <= filenamesize then nameoffile[k] := xchr[c] end; if k <= filenamesize then namelength := k else namelength := filenamesize; for k := namelength + 1 to filenamesize do nameoffile[k] := ' ' end; {:778} {780:} function makenamestring: strnumber; var k, kstart: 1..filenamesize; begin k := 1; while (k < filenamesize) and (xord[realnameoffile[k]] <> 32) do k := k + 1; namelength := k - 1; if ((poolptr + namelength) > poolsize) or (strptr = maxstrings) then makenamestring := 63 else begin if (xord[realnameoffile[1]] = 46) and (xord[realnameoffile[2]] = 47) then kstart := 3 else kstart := 1; for k := kstart to namelength do begin strpool[poolptr] := xord[realnameoffile[k]]; poolptr := poolptr + 1 end; makenamestring := makestring end end; function amakenamestring(var f: alphafile): strnumber; begin amakenamestring := makenamestring end; { amakenamestring } function bmakenamestring(var f: bytefile): strnumber; begin bgetname(f, realnameoffile); bmakenamestring := makenamestring end; { bmakenamestring } function wmakenamestring(var f: wordfile): strnumber; begin wmakenamestring := makenamestring end; {:780} {781:} procedure scanfilename; label 30; begin beginname; while (buffer[curinput.locfield] = 32) or (buffer[curinput.locfield] = 9) do curinput.locfield := curinput.locfield + 1; while true do begin if (buffer[curinput.locfield] = 59) or (buffer[curinput.locfield] = 37) then goto 30; if not morename(buffer[curinput.locfield]) then goto 30; curinput.locfield := curinput.locfield + 1 end; 30: endname end; {:781} {784:} procedure packjobname(s: strnumber); begin curarea := 155; curext := s; curname := jobname; packfilename(curname, curarea, curext) end; {:784} {786:} procedure promptfilename(s, e: strnumber); label 30; var k: 0..bufsize; begin if interaction = 2 then null; if s = 607 then begin if interaction = 3 then null; printnl(133); print(608) end else begin if interaction = 3 then null; printnl(133); print(609) end; printfilename(curname, curarea, curext); print(610); if e = 611 then showcontext; printnl(612); print(s); if interaction < 2 then fatalerror(613); begin print(614); terminput end; {787:} begin beginname; k := first; while ((buffer[k] = 32) or (buffer[k] = 9)) and (k < last) do k := k + 1; while true do begin if k = last then goto 30; if not morename(buffer[k]) then goto 30; k := k + 1 end; 30: endname end {:787}; if curext = 155 then curext := e; packfilename(curname, curarea, curext) end; { promptfilename } {:786} {788:} procedure openlogfile; var oldsetting: 0..5; k: 0..bufsize; l: 0..bufsize; m: integer; months: packed array [1..36] of char; begin oldsetting := selector; if jobname = 0 then jobname := 615; packjobname(616); while not aopenout(logfile) do begin {789:} if interaction < 2 then begin begin if interaction = 3 then null; printnl(133); print(609) end; printfilename(curname, curarea, curext); print(610); jobname := 0; history := 3; jumpout end; promptfilename(618, 616) end {:789}; logname := amakenamestring(logfile); selector := 2; {790:} begin write(logfile, 'This is METAFONT, Version 1.0 for Berkeley UNIX'); print(baseident); print(619); printint(roundunscaled(internal[16])); printchar(32); months := 'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'; m := roundunscaled(internal[15]); for k := (3 * m) - 2 to 3 * m do write(logfile, months[k]); printchar(32); printint(roundunscaled(internal[14])); printchar(32); m := roundunscaled(internal[17]); printdd(m div 60); printchar(58); printdd(m mod 60) end {:790}; inputstack[inputptr] := curinput; printnl(617); l := inputstack[0].limitfield - 1; for k := 1 to l do print(buffer[k]); println; selector := oldsetting + 2 end; {:788} {793:} procedure startinput; label 30; {795:} begin while (curinput.indexfield > 6) and (curinput.locfield = (-30000)) do endtokenlist; if curinput.indexfield > 6 then begin begin if interaction = 3 then null; printnl(133); print(621) end; begin helpptr := 3; helpline[2] := 622; helpline[1] := 623; helpline[0] := 624 end; error end; if curinput.indexfield <= 6 then scanfilename else begin curname := 155; curext := 155; curarea := 155 end {:795}; if curext = 155 then curext := 611; packfilename(curname, curarea, curext); while true do begin beginfilereading; if aopenin(inputfile[curinput.indexfield], 6) then goto 30; endfilereading; promptfilename(607, 611) end; 30: curinput.namefield := amakenamestring(inputfile[curinput.indexfield]); strref[curname] := 127; if jobname = 0 then begin jobname := curname; openlogfile end; if (termoffset + (strstart[curinput.namefield + 1] - strstart[curinput.namefield])) > (maxprintline - 2) then println else if (termoffset > 0) or (fileoffset > 0) then printchar(32); printchar(40); print(curinput.namefield); flush(output); {794:} begin if not inputln(inputfile[curinput.indexfield], false) then null; firmuptheline; buffer[curinput.limitfield] := 37; first := curinput.limitfield + 1; curinput.locfield := curinput.startfield; line := 1 end {:794} end; {:793} {824:} procedure badexp(s: strnumber); var saveflag: 0..82; begin begin if interaction = 3 then null; printnl(133); print(s) end; print(634); printcmdmod(curcmd, curmod); printchar(39); begin helpptr := 4; helpline[3] := 635; helpline[2] := 636; helpline[1] := 637; helpline[0] := 638 end; backinput; cursym := 0; curcmd := 42; curmod := 0; inserror; saveflag := varflag; varflag := 0; getxnext; varflag := saveflag end; {:824} {827:} procedure stashin(p: halfword); var q: halfword; begin mem[p].hh.b0 := curtype; { 829:} if curtype = 16 then mem[p + 1].int := curexp else begin if curtype = 19 then begin q := singledependency(curexp); if q = depfinal then begin mem[p].hh.b0 := 16; mem[p + 1].int := 0; freenode(q, 2) end else begin mem[p].hh.b0 := 17; newdep(p, q) end; recyclevalue(curexp) end else begin {:829} mem[p + 1] := mem[curexp + 1]; mem[mem[p + 1].hh.lh].hh.rh := p end; freenode(curexp, 2) end; curtype := 1 end; { stashin } {:827} {848:} procedure backexpr; var p: halfword; begin p := stashcurexp; mem[p].hh.rh := -30000; begintokenlist(p, 10) end; {:848} {849:} procedure badsubscript; begin disperr(-30000, 650); begin helpptr := 3; helpline[2] := 651; helpline[1] := 652; helpline[0] := 653 end; flusherror(0) end; {:849} {851:} procedure obliterated(q: halfword); begin begin if interaction = 3 then null; printnl(133); print(654) end; showtokenlist(q, -30000, 1000, 0); print(655); begin helpptr := 5; helpline[4] := 656; helpline[3] := 657; helpline[2] := 658; helpline[1] := 659; helpline[0] := 660 end end; {:851} {863:} procedure binarymac(p, c, n: halfword); var q, r: halfword; begin q := getavail; r := getavail; mem[q].hh.rh := r; mem[q].hh.lh := p; mem[r].hh.lh := stashcurexp; macrocall(c, q, n) end; {:863} {865:} procedure materializepen; label 50; var aminusb, aplusb, majoraxis, minoraxis: scaled; theta: angle; p: halfword; q: halfword; begin q := curexp; if mem[q].hh.b0 = 0 then begin begin if interaction = 3 then null; printnl(133); print(670) end; begin helpptr := 2; helpline[1] := 671; helpline[0] := 442 end; putgeterror; curexp := -29997; goto 50 end else if mem[q].hh.b0 = 4 then begin {866:} tx := mem[q + 1].int; ty := mem[q + 2].int; txx := mem[q + 3].int - tx; tyx := mem[q + 4].int - ty; txy := mem[q + 5].int - tx; tyy := mem[q + 6].int - ty; aminusb := pythadd(txx - tyy, tyx + txy); aplusb := pythadd(txx + tyy, tyx - txy); majoraxis := (aminusb + aplusb) div 2; minoraxis := abs(aplusb - aminusb) div 2; if majoraxis = minoraxis then theta := 0 else theta := (narg(txx - tyy, tyx + txy) + narg(txx + tyy, tyx - txy)) div 2; freenode(q, 7); q := makeellipse(majoraxis, minoraxis, theta); if (tx <> 0) or (ty <> 0) then begin {867:} p := q; repeat mem[p + 1].int := mem[p + 1].int + tx; mem[p + 2].int := mem[p + 2].int + ty; p := mem[p].hh.rh until p = q end {:867} end {:866}; curexp := makepen(q); 50: tossknotlist(q); curtype := 6 end; {:865} {871:} {872:} procedure knownpair; var p: halfword; begin if curtype <> 14 then begin disperr(-30000, 673); begin helpptr := 5; helpline[4] := 674; helpline[3] := 675; helpline[2] := 676; helpline[1] := 677; helpline[0] := 678 end; putgetflusherror(0); curx := 0; cury := 0 end else begin p := mem[curexp + 1].int; {873:} if mem[p].hh.b0 = 16 then curx := mem[p + 1].int else begin disperr(p, 679); begin helpptr := 5; helpline[4] := 680; helpline[3] := 675; helpline[2] := 676; helpline[1] := 677; helpline[0] := 678 end; putgeterror; recyclevalue(p); curx := 0 end; if mem[p + 2].hh.b0 = 16 then cury := mem[p + 3].int else begin disperr(p + 2, 681); begin helpptr := 5; helpline[4] := 682; helpline[3] := 675; helpline[2] := 676; helpline[1] := 677; helpline[0] := 678 end; putgeterror; recyclevalue(p + 2); cury := 0 end {:873}; flushcurexp(0) end end; {:872} function newknot: halfword; var q: halfword; begin q := getnode(7); mem[q].hh.b0 := 0; mem[q].hh.b1 := 0; mem[q].hh.rh := q; knownpair; mem[q + 1].int := curx; mem[q + 2].int := cury; newknot := q end; {:871} {875:} function scandirection: smallnumber; var t: 2..4; x: scaled; begin getxnext; if curcmd = 60 then begin {876:} getxnext; scanexpression; if (curtype <> 16) or (curexp < 0) then begin disperr(-30000, 685); begin helpptr := 1; helpline[0] := 686 end; putgetflusherror(65536) end; t := 3 end else begin {:876} {877:} scanexpression; if curtype > 14 then begin {878:} if curtype <> 16 then begin disperr(-30000, 679); begin helpptr := 5; helpline[4] := 680; helpline[3] := 675; helpline[2] := 676; helpline[1] := 677; helpline[0] := 678 end; putgetflusherror(0) end; x := curexp; if curcmd <> 79 then begin missingerr(44); begin helpptr := 2; helpline[1] := 687; helpline[0] := 688 end; backerror end; getxnext; scanexpression; if curtype <> 16 then begin disperr(-30000, 681); begin helpptr := 5; helpline[4] := 682; helpline[3] := 675; helpline[2] := 676; helpline[1] := 677; helpline[0] := 678 end; putgetflusherror(0) end; cury := curexp; curx := x end else {:878} knownpair; if (curx = 0) and (cury = 0) then t := 4 else begin t := 2; curexp := narg(curx, cury) end end {:877}; if curcmd <> 65 then begin missingerr(125); begin helpptr := 3; helpline[2] := 683; helpline[1] := 684; helpline[0] := 563 end; backerror end; getxnext; scandirection := t end; {:875} {895:} procedure donullary(c: quarterword); var k: integer; begin begin if aritherror then cleararith end; if internal[7] > 131072 then showcmdmod(33, c); case c of 30, 31: begin curtype := 2; curexp := c end; 32: begin curtype := 11; curexp := getnode(6); initedges(curexp) end; 33: begin curtype := 6; curexp := -29997 end; 37: begin curtype := 16; curexp := normrand end; 36: begin {896:} curtype := 8; curexp := getnode(7); mem[curexp].hh.b0 := 4; mem[curexp].hh.b1 := 4; mem[curexp].hh.rh := curexp; mem[curexp + 1].int := 0; mem[curexp + 2].int := 0; mem[curexp + 3].int := 65536; mem[curexp + 4].int := 0; mem[curexp + 5].int := 0; mem[curexp + 6].int := 65536 end; {:896} 34: begin if jobname = 0 then openlogfile; curtype := 4; curexp := jobname end; 35: begin {897:} if interaction <= 1 then fatalerror(699); beginfilereading; curinput.namefield := 1; begin print(155); terminput end; begin if ((poolptr + last) - curinput.startfield) > maxpoolptr then begin if ((poolptr + last) - curinput.startfield) > poolsize then overflow(129, poolsize - initpoolptr); maxpoolptr := (poolptr + last) - curinput.startfield end end; for k := curinput.startfield to last - 1 do begin strpool[poolptr] := buffer[k]; poolptr := poolptr + 1 end; endfilereading; curtype := 4; curexp := makestring end end {:897}; begin if aritherror then cleararith end end; {:895} {898:} {899:} function nicepair(p: integer; t: quarterword): boolean; label 10; begin if t = 14 then begin p := mem[p + 1].int; if mem[p].hh.b0 = 16 then if mem[p + 2].hh.b0 = 16 then begin nicepair := true; goto 10 end end; nicepair := false; 10: null end; {:899} {900:} procedure printknownorunknownt(t: smallnumber; v: integer); begin printchar(40); if t < 17 then if t <> 14 then printtype(t) else if nicepair(v, 14) then print(207) else print(700) else print(701); printchar(41) end; {:900} {901:} procedure badunary(c: quarterword); begin disperr(-30000, 702); printop(c); printknownorunknownt(curtype, curexp); begin helpptr := 3; helpline[2] := 703; helpline[1] := 704; helpline[0] := 705 end; putgeterror end; {:901} {904:} procedure negatedeplist(p: halfword); label 10; begin while true do begin mem[p + 1].int := -mem[p + 1].int; if mem[p].hh.lh = (-30000) then goto 10; p := mem[p].hh.rh end; 10: null end; {:904} {908:} procedure pairtopath; begin curexp := newknot; curtype := 9 end; {:908} {910:} procedure takepart(c: quarterword); var p: halfword; begin p := mem[curexp + 1].int; mem[-29982].int := p; mem[-29983].hh.b0 := curtype; mem[p].hh.rh := -29983; freenode(curexp, 2); makeexpcopy(p + (2 * (c - 53))); recyclevalue(-29983) end; {:910} {913:} procedure strtonum(c: quarterword); var n: integer; m: ASCIIcode; k: poolpointer; b: 8..16; badchar: boolean; begin if c = 49 then if (strstart[curexp + 1] - strstart[curexp]) = 0 then n := -1 else n := strpool[strstart[curexp]] else begin if c = 47 then b := 8 else b := 16; n := 0; badchar := false; for k := strstart[curexp] to strstart[curexp + 1] - 1 do begin m := strpool[k]; if (m >= 48) and (m <= 57) then m := m - 48 else if (m >= 65) and (m <= 70) then m := m - 55 else if (m >= 97) and (m <= 102) then m := m - 87 else begin badchar := true; m := 0 end; if m >= b then begin badchar := true; m := 0 end; if n < (32768 div b) then n := (n * b) + m else n := 32767 end; {914:} if badchar then begin disperr(-30000, 707); if c = 47 then begin helpptr := 1; helpline[0] := 708 end else begin helpptr := 1; helpline[0] := 709 end; putgeterror end; if n > 4095 then begin begin if interaction = 3 then null; printnl(133); print(710) end; printint(n); printchar(41); begin helpptr := 1; helpline[0] := 711 end; putgeterror end {:914} end; flushcurexp(n * 65536) end; { strtonum } {:913} {916:} function pathlength: scaled; var n: scaled; p: halfword; begin p := curexp; if mem[p].hh.b0 = 0 then n := -65536 else n := 0; repeat p := mem[p].hh.rh; n := n + 65536 until p = curexp; pathlength := n end; { pathlength } {:916} {919:} procedure testknown(c: quarterword); label 30; var b: 30..31; p, q: halfword; begin b := 31; if curtype in [1, 2, 4, 6, 8, 9, 11, 16, 13, 14] then case curtype of 1, 2, 4, 6, 8, 9, 11, 16: b := 30; 13, 14: begin p := mem[curexp + 1].int; q := p + bignodesize[curtype]; repeat q := q - 2; if mem[q].hh.b0 <> 16 then goto 30 until q = p; b := 30; 30: null end end else null; if c = 39 then flushcurexp(b) else flushcurexp(61 - b); curtype := 2 end; {:919} procedure dounary(c: quarterword); var p, q: halfword; x: integer; begin begin if aritherror then cleararith end; if internal[7] > 131072 then begin {902:} begindiagnostic; printnl(123); printop(c); printchar(40); printexp(-30000, 0); print(706); enddiagnostic(false) end {:902}; case c of 69: if curtype < 14 then if curtype <> 11 then badunary(69); 70: {903:} if curtype in [14, 19, 17, 18, 16, 11] then case curtype of 14, 19: begin q := curexp; makeexpcopy(q); if curtype = 17 then negatedeplist(mem[curexp + 1].hh.rh) else if curtype = 14 then begin p := mem[curexp + 1].int; if mem[p].hh.b0 = 16 then mem[p + 1].int := -mem[p + 1].int else negatedeplist(mem[p + 1].hh.rh); if mem[p + 2].hh.b0 = 16 then mem[p + 3].int := -mem[p + 3].int else negatedeplist(mem[p + 3].hh.rh) end; recyclevalue(q); freenode(q, 2) end; 17, 18: negatedeplist(mem[curexp + 1].hh.rh); 16: curexp := -curexp; 11: negateedges(curexp) end else badunary(70) {:903}; {905:} 41: if curtype <> 2 then badunary(41) else curexp := 61 - curexp; {:905} {906:} 59, 60, 61, 62, 63, 64, 65, 38, 66: if curtype <> 16 then badunary(c) else case c of 59: curexp := squarert(curexp); 60: curexp := mexp(curexp); 61: curexp := mlog(curexp); 62, 63: begin nsincos((curexp mod 23592960) * 16); if c = 62 then curexp := roundfraction(nsin) else curexp := roundfraction(ncos) end; 64: curexp := floorscaled(curexp); 65: curexp := unifrand(curexp); 38: begin if odd(roundunscaled(curexp)) then curexp := 30 else curexp := 31; curtype := 2 end; 66: begin {1181:} curexp := roundunscaled(curexp) mod 256; if curexp < 0 then curexp := curexp + 256; if charexists[curexp] then curexp := 30 else curexp := 31; curtype := 2 end end {:1181}; {:906} {907:} 67: if nicepair(curexp, curtype) then begin p := mem[curexp + 1].int; x := narg(mem[p + 1].int, mem[p + 3].int); if x >= 0 then flushcurexp((x + 8) div 16) else flushcurexp(-(((-x) + 8) div 16)) end else badunary(67); {:907} {909:} 53, 54: if (curtype <= 14) and (curtype >= 13) then takepart(c) else badunary(c); 55, 56, 57, 58: if curtype = 13 then takepart(c) else badunary(c); {:909} {912:} 50: if curtype <> 16 then badunary(50) else begin curexp := roundunscaled(curexp) mod 128; curtype := 4; if curexp < 0 then curexp := curexp + 128; if (strstart[curexp + 1] - strstart[curexp]) <> 1 then begin begin if (poolptr + 1) > maxpoolptr then begin if (poolptr + 1) > poolsize then overflow(129, poolsize - initpoolptr); maxpoolptr := poolptr + 1 end end; begin strpool[poolptr] := curexp; poolptr := poolptr + 1 end; curexp := makestring end end; 42: if curtype <> 16 then badunary(42) else begin oldsetting := selector; selector := 5; printscaled(curexp); curexp := makestring; selector := oldsetting; curtype := 4 end; 47, 48, 49: if curtype <> 4 then badunary(c) else strtonum(c); {:912} {915:} 51: if curtype = 4 then flushcurexp((strstart[curexp + 1] - strstart[curexp]) * 65536) else if curtype = 9 then flushcurexp(pathlength) else if curtype = 16 then curexp := abs(curexp) else if nicepair(curexp, curtype) then flushcurexp(pythadd(mem[mem[curexp + 1].int + 1].int, mem[mem[curexp + 1].int + 3].int)) else badunary(c); {:915} {917:} 52: if curtype = 14 then flushcurexp(0) else if curtype <> 9 then badunary(52) else if mem[curexp].hh.b0 = 0 then flushcurexp(0) else begin curpen := -29997; curpathtype := 1; curexp := makespec(curexp, -1879080960, 0); flushcurexp(turningnumber * 65536) end; {:917} {918:} 2: begin if (curtype >= 2) and (curtype <= 3) then flushcurexp(30) else flushcurexp(31); curtype := 2 end; 4: begin if (curtype >= 4) and (curtype <= 5) then flushcurexp(30) else flushcurexp(31); curtype := 2 end; 6: begin if (curtype >= 6) and (curtype <= 8) then flushcurexp(30) else flushcurexp(31); curtype := 2 end; 9: begin if (curtype >= 9) and (curtype <= 10) then flushcurexp(30) else flushcurexp(31); curtype := 2 end; 11: begin if (curtype >= 11) and (curtype <= 12) then flushcurexp(30) else flushcurexp(31); curtype := 2 end; 13, 14: begin if curtype = c then flushcurexp(30) else flushcurexp(31); curtype := 2 end; 15: begin if (curtype >= 16) and (curtype <= 19) then flushcurexp(30) else flushcurexp(31); curtype := 2 end; 39, 40: testknown(c); {:918} {920:} 68: begin if curtype <> 9 then flushcurexp(31) else if mem[curexp].hh.b0 <> 0 then flushcurexp(30) else flushcurexp(31); curtype := 2 end; {:920} {921:} 45: begin if curtype = 14 then pairtopath; if curtype = 9 then curtype := 8 else badunary(45) end; 44: begin if curtype = 8 then materializepen; if curtype <> 6 then badunary(44) else begin flushcurexp(makepath(curexp)); curtype := 9 end end; 46: if curtype <> 11 then badunary(46) else flushcurexp(totalweight(curexp)); 43: if curtype = 9 then begin p := htapypoc(curexp); if mem[p].hh.b1 = 0 then p := mem[p].hh.rh; tossknotlist(curexp); curexp := p end else if curtype = 14 then pairtopath else badunary(43) end {:921}; begin if aritherror then cleararith end end; {:898} {922:} {923:} procedure badbinary(p: halfword; c: quarterword); begin disperr(p, 155); disperr(-30000, 702); if c >= 94 then printop(c); printknownorunknownt(mem[p].hh.b0, p); if c >= 94 then print(347) else printop(c); printknownorunknownt(curtype, curexp); begin helpptr := 3; helpline[2] := 703; helpline[1] := 712; helpline[0] := 713 end; putgeterror end; {:923} {928:} function tarnished(p: halfword): halfword; label 10; var q: halfword; r: halfword; begin q := mem[p + 1].int; r := q + bignodesize[mem[p].hh.b0]; repeat r := r - 2; if mem[r].hh.b0 = 19 then begin tarnished := -29999; goto 10 end until r = q; tarnished := -30000; 10: null end; {:928} {930:} {935:} procedure depfinish(v, q: halfword; t: smallnumber); var p: halfword; vv: scaled; begin if q = (-30000) then p := curexp else p := q; mem[p + 1].hh.rh := v; mem[p].hh.b0 := t; if mem[v].hh.lh = (-30000) then begin vv := mem[v + 1].int; if q = (-30000) then flushcurexp(vv) else begin recyclevalue(p); mem[q].hh.b0 := 16; mem[q + 1].int := vv end end else if q = (-30000) then curtype := t; if fixneeded then fixdependencies end; {:935} procedure addorsubtract(p, q: halfword; c: quarterword); label 30, 10; var s, t: smallnumber; r: halfword; v: integer; begin if q = (-30000) then begin t := curtype; if t < 17 then v := curexp else v := mem[curexp + 1].hh.rh end else begin t := mem[q].hh.b0; if t < 17 then v := mem[q + 1].int else v := mem[q + 1].hh.rh end; if t = 16 then begin if c = 70 then v := -v; if mem[p].hh.b0 = 16 then begin v := slowadd(mem[p + 1].int, v); if q = (-30000) then curexp := v else mem[q + 1].int := v; goto 10 end; {931:} r := mem[p + 1].hh.rh; while mem[r].hh.lh <> (-30000) do r := mem[r].hh.rh; mem[r + 1].int := slowadd(mem[r + 1].int, v); if q = (-30000) then begin q := getnode(2); curexp := q; curtype := mem[p].hh.b0; mem[q].hh.b1 := 11 end; mem[q + 1].hh.rh := mem[p + 1].hh.rh; mem[q].hh.b0 := mem[p].hh.b0; mem[q + 1].hh.lh := mem[p + 1].hh.lh; mem[mem[p + 1].hh.lh].hh.rh := q; mem[p].hh.b0 := 16 end else begin {:931} if c = 70 then negatedeplist(v); {932:} if mem[p].hh.b0 = 16 then begin {933:} while mem[v].hh.lh <> (-30000) do v := mem[v].hh.rh; mem[v + 1].int := slowadd(mem[p + 1].int, mem[v + 1].int) end else begin {:933} s := mem[p].hh.b0; r := mem[p + 1].hh.rh; if t = 17 then begin if s = 17 then if (maxcoef(r) + maxcoef(v)) < 626349397 then begin v := pplusq(v, r, 17); goto 30 end; t := 18; v := poverv(v, 65536, 17, 18) end; if s = 18 then v := pplusq(v, r, 18) else v := pplusfq(v, 65536, r, 18, 17); 30: {934:} if q <> (-30000) then depfinish(v, q, t) else begin curtype := t; depfinish(v, -30000, t) end {:934} end {:932} end; 10: null end; {:930} {943:} procedure depmult(p: halfword; v: integer; visscaled: boolean); label 10; var q: halfword; s, t: smallnumber; begin if p = (-30000) then q := curexp else if mem[p].hh.b0 <> 16 then q := p else begin if visscaled then mem[p + 1].int := takescaled(mem[p + 1].int, v) else mem[p + 1].int := takefraction(mem[p + 1].int, v); goto 10 end; t := mem[q].hh.b0; q := mem[q + 1].hh.rh; s := t; if t = 17 then if visscaled then if abvscd(maxcoef(q), abs(v), 626349396, 65536) >= 0 then t := 18; q := ptimesv(q, v, s, t, visscaled); depfinish(q, p, t); 10: null end; {:943} {946:} procedure hardtimes(p: halfword); var q: halfword; r: halfword; u, v: scaled; begin if mem[p].hh.b0 = 14 then begin q := stashcurexp; unstashcurexp(p); p := q end; r := mem[curexp + 1].int; u := mem[r + 1].int; v := mem[r + 3].int; {947:} mem[r + 2].hh.b0 := mem[p].hh.b0; newdep(r + 2, copydeplist(mem[p + 1].hh.rh)); mem[r].hh.b0 := mem[p].hh.b0; mem[r + 1] := mem[p + 1]; mem[mem[p + 1].hh.lh].hh.rh := r; freenode(p, 2) {:947}; depmult(r, u, true); depmult(r + 2, v, true) end; {:946} {949:} procedure depdiv(p: halfword; v: scaled); label 10; var q: halfword; s, t: smallnumber; begin if p = (-30000) then q := curexp else if mem[p].hh.b0 <> 16 then q := p else begin mem[p + 1].int := makescaled(mem[p + 1].int, v); goto 10 end; t := mem[q].hh.b0; q := mem[q + 1].hh.rh; s := t; if t = 17 then if abvscd(maxcoef(q), 65536, 626349396, abs(v)) >= 0 then t := 18; q := poverv(q, v, s, t); depfinish(q, p, t); 10: null end; {:949} {953:} procedure setuptrans(c: quarterword); label 30, 10; var p, q, r: halfword; begin if (c <> 88) or (curtype <> 13) then begin {955:} p := stashcurexp; curexp := idtransform; curtype := 13; q := mem[curexp + 1].int; case c of {957:} 84: if mem[p].hh.b0 = 16 then begin {958:} nsincos((mem[p + 1].int mod 23592960) * 16); mem[q + 5].int := roundfraction(ncos); mem[q + 9].int := roundfraction(nsin); mem[q + 7].int := -mem[q + 9].int; mem[q + 11].int := mem[q + 5].int; goto 30 end {:958}; 85: if mem[p].hh.b0 > 14 then begin install(q + 6, p); goto 30 end; 86: if mem[p].hh.b0 > 14 then begin install(q + 4, p); install(q + 10, p); goto 30 end; 87: if mem[p].hh.b0 = 14 then begin r := mem[p + 1].int; install(q, r); install(q + 2, r + 2); goto 30 end; 89: if mem[p].hh.b0 > 14 then begin install(q + 4, p); goto 30 end; 90: if mem[p].hh.b0 > 14 then begin install(q + 10, p); goto 30 end; 91: if mem[p].hh.b0 = 14 then begin {959:} r := mem[p + 1].int; install(q + 4, r); install(q + 10, r); install(q + 8, r + 2); if mem[r + 2].hh.b0 = 16 then mem[r + 3].int := -mem[r + 3].int else negatedeplist(mem[r + 3].hh.rh); install(q + 6, r + 2); goto 30 end {:959}; 88: null end {:957}; disperr(p, 722); begin helpptr := 3; helpline[2] := 723; helpline[1] := 724; helpline[0] := 405 end; putgeterror; 30: recyclevalue(p); freenode(p, 2) end {:955}; {956:} q := mem[curexp + 1].int; r := q + 12; repeat r := r - 2; if mem[r].hh.b0 <> 16 then goto 10 until r = q; txx := mem[q + 5].int; txy := mem[q + 7].int; tyx := mem[q + 9].int; tyy := mem[q + 11].int; tx := mem[q + 1].int; ty := mem[q + 3].int; flushcurexp(0) {:956}; 10: null end; {:953} {960:} procedure setupknowntrans(c: quarterword); begin setuptrans(c); if curtype <> 16 then begin disperr(-30000, 725); begin helpptr := 3; helpline[2] := 726; helpline[1] := 727; helpline[0] := 405 end; putgetflusherror(0); txx := 65536; txy := 0; tyx := 0; tyy := 65536; tx := 0; ty := 0 end end; {:960} {961:} procedure trans(p, q: halfword); var v: scaled; begin v := (takescaled(mem[p].int, txx) + takescaled(mem[q].int, txy)) + tx; mem[q].int := (takescaled(mem[p].int, tyx) + takescaled(mem[q].int, tyy)) + ty; mem[p].int := v end; {:961} {962:} procedure pathtrans(p: halfword; c: quarterword); label 10; var q: halfword; begin setupknowntrans(c); unstashcurexp(p); if curtype = 6 then begin if mem[curexp + 9].int = 0 then if tx = 0 then if ty = 0 then goto 10; flushcurexp(makepath(curexp)); curtype := 8 end; q := curexp; repeat if mem[q].hh.b0 <> 0 then trans(q + 3, q + 4); trans(q + 1, q + 2); if mem[q].hh.b1 <> 0 then trans(q + 5, q + 6); q := mem[q].hh.rh until q = curexp; 10: null end; {:962} {963:} procedure edgestrans(p: halfword; c: quarterword); label 10; begin setupknowntrans(c); unstashcurexp(p); curedges := curexp; if mem[curedges].hh.rh = curedges then goto 10; if txx = 0 then if tyy = 0 then if (txy mod 65536) = 0 then if (tyx mod 65536) = 0 then begin xyswapedges; txx := txy; tyy := tyx; txy := 0; tyx := 0; if mem[curedges].hh.rh = curedges then goto 10 end; if txy = 0 then if tyx = 0 then if (txy mod 65536) = 0 then if (tyy mod 65536) = 0 then begin {964:} if (txx = 0) or (tyy = 0) then begin tossedges(curedges); curexp := getnode(6); initedges(curexp) end else begin if txx < 0 then begin xreflectedges; txx := -txx end; if tyy < 0 then begin yreflectedges; tyy := -tyy end; if txx <> 65536 then xscaleedges(txx div 65536); if tyy <> 65536 then yscaleedges(tyy div 65536); {965:} tx := roundunscaled(tx); ty := roundunscaled(ty); if ((((((mem[curedges + 2].hh.lh + tx) <= 0) or ((mem[curedges + 2].hh.rh + tx) >= 8192)) or ((mem[curedges + 1].hh.lh + ty) <= 0)) or ((mem[curedges + 1].hh.rh + ty) >= 8191)) or (abs(tx) >= 4096)) or (abs(ty) >= 4096) then begin begin if interaction = 3 then null; printnl(133); print(731) end; begin helpptr := 3; helpline[2] := 732; helpline[1] := 404; helpline[0] := 405 end; putgeterror end else begin if tx <> 0 then begin if not (abs((mem[curedges + 3].hh.lh - tx) - 4096) < 4096) then fixoffset; mem[curedges + 2].hh.lh := mem[curedges + 2].hh.lh + tx; mem[curedges + 2].hh.rh := mem[curedges + 2].hh.rh + tx; mem[curedges + 3].hh.lh := mem[curedges + 3].hh.lh - tx; mem[curedges + 4].int := 0 end; if ty <> 0 then begin mem[curedges + 1].hh.lh := mem[curedges + 1].hh.lh + ty; mem[curedges + 1].hh.rh := mem[curedges + 1].hh.rh + ty; mem[curedges + 5].hh.lh := mem[curedges + 5].hh.lh + ty; mem[curedges + 4].int := 0 end end {:965} end; goto 10 end {:964}; begin if interaction = 3 then null; printnl(133); print(728) end; begin helpptr := 3; helpline[2] := 729; helpline[1] := 730; helpline[0] := 405 end; putgeterror; 10: null end; {:963} {966:} {968:} procedure bilin1(p: halfword; t: scaled; q: halfword; u, delta: scaled); var r: halfword; begin if t <> 65536 then depmult(p, t, true); if u <> 0 then if mem[q].hh.b0 = 16 then delta := delta + takescaled(mem[q + 1].int, u) else begin {969:} if mem[p].hh.b0 <> 18 then begin if mem[p].hh.b0 = 16 then newdep(p, constdependency(mem[p + 1].int)) else mem[p + 1].hh.rh := ptimesv(mem[p + 1].hh.rh, 65536, 17, 18, true); mem[p].hh.b0 := 18 end {:969}; mem[p + 1].hh.rh := pplusfq(mem[p + 1].hh.rh, u, mem[q + 1].hh.rh, 18, mem[q].hh.b0) end; if mem[p].hh.b0 = 16 then mem[p + 1].int := mem[p + 1].int + delta else begin r := mem[p + 1].hh.rh; while mem[r].hh.lh <> (-30000) do r := mem[r].hh.rh; delta := mem[r + 1].int + delta; if r <> mem[p + 1].hh.rh then mem[r + 1].int := delta else begin recyclevalue(p); mem[p].hh.b0 := 16; mem[p + 1].int := delta end end; if fixneeded then fixdependencies end; {:968} {971:} procedure addmultdep(p: halfword; v: scaled; r: halfword); begin if mem[r].hh.b0 = 16 then mem[depfinal + 1].int := mem[depfinal + 1].int + takescaled(mem[r + 1].int, v) else begin mem[p + 1].hh.rh := pplusfq(mem[p + 1].hh.rh, v, mem[r + 1].hh.rh, 18, mem[r].hh.b0); if fixneeded then fixdependencies end end; {:971} {972:} procedure bilin2(p, t: halfword; v: scaled; u, q: halfword); var vv: scaled; begin vv := mem[p + 1].int; mem[p].hh.b0 := 18; newdep(p, constdependency(0)); if vv <> 0 then addmultdep(p, vv, t); if v <> 0 then addmultdep(p, v, u); if q <> (-30000) then addmultdep(p, 65536, q); if mem[p + 1].hh.rh = depfinal then begin vv := mem[depfinal + 1].int; recyclevalue(p); mem[p].hh.b0 := 16; mem[p + 1].int := vv end end; {:972} {974:} procedure bilin3(p: halfword; t, v, u, delta: scaled); begin if t <> 65536 then delta := delta + takescaled(mem[p + 1].int, t) else delta := delta + mem[p + 1].int; if u <> 0 then mem[p + 1].int := delta + takescaled(v, u) else mem[p + 1].int := delta end; {:974} procedure bigtrans(p: halfword; c: quarterword); label 10; var q, r, pp, qq: halfword; s: smallnumber; begin s := bignodesize[mem[p].hh.b0]; q := mem[p + 1].int; r := q + s; repeat r := r - 2; if mem[r].hh.b0 <> 16 then begin {967:} setupknowntrans(c); makeexpcopy(p); r := mem[curexp + 1].int; if curtype = 13 then begin bilin1(r + 10, tyy, q + 6, tyx, 0); bilin1(r + 8, tyy, q + 4, tyx, 0); bilin1(r + 6, txx, q + 10, txy, 0); bilin1(r + 4, txx, q + 8, txy, 0) end; bilin1(r + 2, tyy, q, tyx, ty); bilin1(r, txx, q + 2, txy, tx); goto 10 end {:967} until r = q; {970:} setuptrans(c); if curtype = 16 then begin {973:} makeexpcopy(p); r := mem[curexp + 1].int; if curtype = 13 then begin bilin3(r + 10, tyy, mem[q + 7].int, tyx, 0); bilin3(r + 8, tyy, mem[q + 5].int, tyx, 0); bilin3(r + 6, txx, mem[q + 11].int, txy, 0); bilin3(r + 4, txx, mem[q + 9].int, txy, 0) end; bilin3(r + 2, tyy, mem[q + 1].int, tyx, ty); bilin3(r, txx, mem[q + 3].int, txy, tx) end else begin {:973} pp := stashcurexp; qq := mem[pp + 1].int; makeexpcopy(p); r := mem[curexp + 1].int; if curtype = 13 then begin bilin2(r + 10, qq + 10, mem[q + 7].int, qq + 8, -30000); bilin2(r + 8, qq + 10, mem[q + 5].int, qq + 8, -30000); bilin2(r + 6, qq + 4, mem[q + 11].int, qq + 6, -30000); bilin2(r + 4, qq + 4, mem[q + 9].int, qq + 6, -30000) end; bilin2(r + 2, qq + 10, mem[q + 1].int, qq + 8, qq + 2); bilin2(r, qq + 4, mem[q + 3].int, qq + 6, qq); recyclevalue(pp); freenode(pp, 2) end; {:970} 10: null end; {:966} {976:} procedure cat(p: halfword); var a, b: strnumber; k: poolpointer; begin a := mem[p + 1].int; b := curexp; begin if ((poolptr + (strstart[a + 1] - strstart[a])) + (strstart[b + 1] - strstart[b])) > maxpoolptr then begin if ((poolptr + (strstart[a + 1] - strstart[a])) + (strstart[b + 1] - strstart[b])) > poolsize then overflow(129, poolsize - initpoolptr); maxpoolptr := (poolptr + (strstart[a + 1] - strstart[a])) + (strstart[b + 1] - strstart[b]) end end; for k := strstart[a] to strstart[a + 1] - 1 do begin strpool[poolptr] := strpool[k]; poolptr := poolptr + 1 end; for k := strstart[b] to strstart[b + 1] - 1 do begin strpool[poolptr] := strpool[k]; poolptr := poolptr + 1 end; curexp := makestring; begin if strref[b] < 127 then if strref[b] > 1 then strref[b] := strref[b] - 1 else flushstring(b) end end; {:976} {977:} procedure chopstring(p: halfword); var a, b: integer; l: integer; k: integer; s: strnumber; reversed: boolean; begin a := roundunscaled(mem[p + 1].int); b := roundunscaled(mem[p + 3].int); if a <= b then reversed := false else begin reversed := true; k := a; a := b; b := k end; s := curexp; l := strstart[s + 1] - strstart[s]; if a < 0 then begin a := 0; if b < 0 then b := 0 end; if b > l then begin b := l; if a > l then a := l end; begin if ((poolptr + b) - a) > maxpoolptr then begin if ((poolptr + b) - a) > poolsize then overflow(129, poolsize - initpoolptr); maxpoolptr := (poolptr + b) - a end end; if reversed then for k := (strstart[s] + b) - 1 downto strstart[s] + a do begin strpool[poolptr] := strpool[k]; poolptr := poolptr + 1 end else for k := strstart[s] + a to (strstart[s] + b) - 1 do begin strpool[poolptr] := strpool[k]; poolptr := poolptr + 1 end; curexp := makestring; begin if strref[s] < 127 then if strref[s] > 1 then strref[s] := strref[s] - 1 else flushstring(s) end end; {:977} {978:} procedure choppath(p: halfword); var q: halfword; pp, qq, rr, ss: halfword; a, b, k, l: scaled; reversed: boolean; begin l := pathlength; a := mem[p + 1].int; b := mem[p + 3].int; if a <= b then reversed := false else begin reversed := true; k := a; a := b; b := k end; {979:} if a < 0 then if mem[curexp].hh.b0 = 0 then begin a := 0; if b < 0 then b := 0 end else repeat a := a + l; b := b + l until a >= 0; if b > l then if mem[curexp].hh.b0 = 0 then begin b := l; if a > l then a := l end else while a >= l do begin a := a - l; b := b - l end {:979}; q := curexp; while a >= 65536 do begin q := mem[q].hh.rh; a := a - 65536; b := b - 65536 end; if b = a then begin {981:} if a > 0 then begin qq := mem[q].hh.rh; splitcubic(q, a * 4096, mem[qq + 1].int, mem[qq + 2].int); q := mem[q].hh.rh end; pp := copyknot(q); qq := pp end else begin {:981} {980:} pp := copyknot(q); qq := pp; repeat q := mem[q].hh.rh; rr := qq; qq := copyknot(q); mem[rr].hh.rh := qq; b := b - 65536 until b <= 0; if a > 0 then begin ss := pp; pp := mem[pp].hh.rh; splitcubic(ss, a * 4096, mem[pp + 1].int, mem[pp + 2].int); pp := mem[ss].hh.rh; freenode(ss, 7); if rr = ss then begin b := makescaled(b, 65536 - a); rr := pp end end; if b < 0 then begin splitcubic(rr, (b + 65536) * 4096, mem[qq + 1].int, mem[qq + 2].int); freenode(qq, 7); qq := mem[rr].hh.rh end end {:980}; mem[pp].hh.b0 := 0; mem[qq].hh.b1 := 0; mem[qq].hh.rh := pp; tossknotlist(curexp); if reversed then begin curexp := mem[htapypoc(pp)].hh.rh; tossknotlist(pp) end else curexp := pp end; {:978} {982:} procedure pairvalue(x, y: scaled); var p: halfword; begin p := getnode(2); flushcurexp(p); curtype := 14; mem[p].hh.b0 := 14; mem[p].hh.b1 := 11; initbignode(p); p := mem[p + 1].int; mem[p].hh.b0 := 16; mem[p + 1].int := x; mem[p + 2].hh.b0 := 16; mem[p + 3].int := y end; { pairvalue } {:982} {984:} procedure setupoffset(p: halfword); begin findoffset(mem[p + 1].int, mem[p + 3].int, curexp); pairvalue(curx, cury) end; procedure setupdirectiontime(p: halfword); begin flushcurexp(finddirectiontime(mem[p + 1].int, mem[p + 3].int, curexp)) end; {:984} {985:} procedure findpoint(v: scaled; c: quarterword); var p: halfword; n: scaled; vv: scaled; q: halfword; begin vv := v; p := curexp; if mem[p].hh.b0 = 0 then n := -65536 else n := 0; repeat p := mem[p].hh.rh; n := n + 65536 until p = curexp; if n = 0 then v := 0 else if v < 0 then if mem[p].hh.b0 = 0 then v := 0 else v := (n - 1) - (((-v) - 1) mod n) else if v > n then if mem[p].hh.b0 = 0 then v := n else v := v mod n; p := curexp; while v >= 65536 do begin p := mem[p].hh.rh; v := v - 65536 end; if v <> 0 then begin {986:} q := mem[p].hh.rh; splitcubic(p, v * 4096, mem[q + 1].int, mem[q + 2].int); p := mem[p].hh.rh end {:986}; {987:} case c of 97: pairvalue(mem[p + 1].int, mem[p + 2].int); 98: if mem[p].hh.b0 = 0 then pairvalue(mem[p + 1].int, mem[p + 2].int) else pairvalue(mem[p + 3].int, mem[p + 4].int); 99: if mem[p].hh.b1 = 0 then pairvalue(mem[p + 1].int, mem[p + 2].int) else pairvalue(mem[p + 5].int, mem[p + 6].int) end {:987} end; {:985} procedure dobinary(p: halfword; c: quarterword); label 30, 31, 10; var q, r, rr: halfword; oldp, oldexp: halfword; v: integer; begin begin if aritherror then cleararith end; if internal[7] > 131072 then begin {924:} begindiagnostic; printnl(714); printexp(p, 0); printchar(41); printop(c); printchar(40); printexp(-30000, 0); print(706); enddiagnostic(false) end {:924}; {926:} if mem[p].hh.b0 in [13, 14, 19] then case mem[p].hh.b0 of 13, 14: oldp := tarnished(p); 19: oldp := -29999 end else oldp := -30000; if oldp <> (-30000) then begin q := stashcurexp; oldp := p; makeexpcopy(oldp); p := stashcurexp; unstashcurexp(q) end; {:926} {927:} if curtype in [13, 14, 19] then case curtype of 13, 14: oldexp := tarnished(curexp); 19: oldexp := -29999 end else oldexp := -30000; if oldexp <> (-30000) then begin oldexp := curexp; makeexpcopy(oldexp) end {:927}; case c of 69, 70: {929:} if (curtype < 14) or (mem[p].hh.b0 < 14) then if (curtype = 11) and (mem[p].hh.b0 = 11) then begin if c = 70 then negateedges(curexp); curedges := curexp; mergeedges(mem[p + 1].int) end else badbinary(p, c) else if curtype = 14 then if mem[p].hh.b0 <> 14 then badbinary(p, c) else begin q := mem[p + 1].int; r := mem[curexp + 1].int; addorsubtract(q, r, c); addorsubtract(q + 2, r + 2, c) end else if mem[p].hh.b0 = 14 then badbinary(p, c) else addorsubtract(p, -30000, c) {:929}; {936:} 77, 78, 79, 80, 81, 82: begin if (curtype > 14) and (mem[p].hh.b0 > 14) then addorsubtract(p, -30000, 70) else if curtype <> mem[p].hh.b0 then begin badbinary(p, c); goto 30 end else if curtype = 4 then flushcurexp(strvsstr(mem[p + 1].int, curexp)) else if (curtype = 5) or (curtype = 3) then begin {938:} q := mem[curexp + 1].int; while (q <> curexp) and (q <> p) do q := mem[q + 1].int; if q = p then flushcurexp(0) end else if (curtype = 14) or (curtype = 13) then begin {:938} {939:} q := mem[p + 1].int; r := mem[curexp + 1].int; rr := (r + bignodesize[curtype]) - 2; while true do begin addorsubtract(q, r, 70); if mem[r].hh.b0 <> 16 then goto 31; if mem[r + 1].int <> 0 then goto 31; if r = rr then goto 31; q := q + 2; r := r + 2 end; 31: takepart(53 + ((r - mem[curexp + 1].int) div 2)) end else if curtype = 2 then {:939} flushcurexp(curexp - mem[p + 1].int) else begin badbinary(p, c); goto 30 end; {937:} if curtype <> 16 then begin if curtype < 16 then begin disperr(p, 155); begin helpptr := 1; helpline[0] := 715 end end else begin helpptr := 2; helpline[1] := 716; helpline[0] := 717 end; disperr(-30000, 718); putgetflusherror(31) end else case c of 77: if curexp < 0 then curexp := 30 else curexp := 31; 78: if curexp <= 0 then curexp := 30 else curexp := 31; 79: if curexp > 0 then curexp := 30 else curexp := 31; 80: if curexp >= 0 then curexp := 30 else curexp := 31; 81: if curexp = 0 then curexp := 30 else curexp := 31; 82: if curexp <> 0 then curexp := 30 else curexp := 31 end; curtype := 2 {:937}; 30: null end; {:936} {940:} 76, 75: if (mem[p].hh.b0 <> 2) or (curtype <> 2) then badbinary(p, c) else if mem[p + 1].int = (c - 45) then curexp := mem[p + 1].int; {:940} {941:} 71: if (curtype < 14) or (mem[p].hh.b0 < 14) then badbinary(p, 71) else if (curtype = 16) or (mem[p].hh.b0 = 16) then begin {942:} if mem[p].hh.b0 = 16 then begin v := mem[p + 1].int; freenode(p, 2) end else begin v := curexp; unstashcurexp(p) end; if curtype = 16 then curexp := takescaled(curexp, v) else if curtype = 14 then begin p := mem[curexp + 1].int; depmult(p, v, true); depmult(p + 2, v, true) end else depmult(-30000, v, true); goto 10 end else if (nicepair(p, mem[p].hh.b0) and (curtype > 14)) or (nicepair(curexp, curtype) and (mem[p].hh.b0 > 14)) then begin {:942} hardtimes(p); goto 10 end else badbinary(p, 71); {:941} {948:} 72: if (curtype <> 16) or (mem[p].hh.b0 < 14) then badbinary(p, 72) else begin v := curexp; unstashcurexp(p); if v = 0 then begin {950:} disperr(-30000, 648); begin helpptr := 2; helpline[1] := 720; helpline[0] := 721 end; putgeterror end else begin {:950} if curtype = 16 then curexp := makescaled(curexp, v) else if curtype = 14 then begin p := mem[curexp + 1].int; depdiv(p, v); depdiv(p + 2, v) end else depdiv(-30000, v) end; goto 10 end; {:948} {951:} 73, 74: if (curtype = 16) and (mem[p].hh.b0 = 16) then if c = 73 then curexp := pythadd(mem[p + 1].int, curexp) else curexp := pythsub(mem[p + 1].int, curexp) else badbinary(p, c); {:951} {952:} 84, 85, 86, 87, 88, 89, 90, 91: if ((mem[p].hh.b0 = 9) or (mem[p].hh.b0 = 8)) or (mem[p].hh.b0 = 6) then begin pathtrans(p, c); goto 10 end else if (mem[p].hh.b0 = 14) or (mem[p].hh.b0 = 13) then bigtrans(p, c) else if mem[p].hh.b0 = 11 then begin edgestrans(p, c); goto 10 end else badbinary(p, c); {:952} {975:} 83: if (curtype = 4) and (mem[p].hh.b0 = 4) then cat(p) else badbinary(p, 83); 94: if nicepair(p, mem[p].hh.b0) and (curtype = 4) then chopstring(mem[p + 1].int) else badbinary(p, 94); 95: begin if curtype = 14 then pairtopath; if nicepair(p, mem[p].hh.b0) and (curtype = 9) then choppath(mem[p + 1].int) else badbinary(p, 95) end; {:975} {983:} 97, 98, 99: begin if curtype = 14 then pairtopath; if (curtype = 9) and (mem[p].hh.b0 = 16) then findpoint(mem[p + 1].int, c) else badbinary(p, c) end; 100: begin if curtype = 8 then materializepen; if (curtype = 6) and nicepair(p, mem[p].hh.b0) then setupoffset(mem[p + 1].int) else badbinary(p, 100) end; 96: begin if curtype = 14 then pairtopath; if (curtype = 9) and nicepair(p, mem[p].hh.b0) then setupdirectiontime(mem[p + 1].int) else badbinary(p, 96) end; {:983} {988:} 92: begin if mem[p].hh.b0 = 14 then begin q := stashcurexp; unstashcurexp(p); pairtopath; p := stashcurexp; unstashcurexp(q) end; if curtype = 14 then pairtopath; if (curtype = 9) and (mem[p].hh.b0 = 9) then begin pathintersection(mem[p + 1].int, curexp); pairvalue(curt, curtt) end else badbinary(p, 92) end end {:988}; recyclevalue(p); freenode(p, 2); 10: begin if aritherror then cleararith end; {925:} if oldp <> (-30000) then begin recyclevalue(oldp); freenode(oldp, 2) end; if oldexp <> (-30000) then begin recyclevalue(oldexp); freenode(oldexp, 2) end {:925} end; {:922} {944:} procedure fracmult(n, d: scaled); var p: halfword; oldexp: halfword; v: fraction; begin if internal[7] > 131072 then begin {945:} begindiagnostic; printnl(714); printscaled(n); printchar(47); printscaled(d); print(719); printexp(-30000, 0); print(706); enddiagnostic(false) end {:945}; if curtype in [13, 14, 19] then case curtype of 13, 14: oldexp := tarnished(curexp); 19: oldexp := -29999 end else oldexp := -30000; if oldexp <> (-30000) then begin oldexp := curexp; makeexpcopy(oldexp) end; v := makefraction(n, d); if curtype = 16 then curexp := takefraction(curexp, v) else if curtype = 14 then begin p := mem[curexp + 1].int; depmult(p, v, false); depmult(p + 2, v, false) end else depmult(-30000, v, false); if oldexp <> (-30000) then begin recyclevalue(oldexp); freenode(oldexp, 2) end end; {:944} {989:} {1155:} procedure gfswap; begin if gflimit = gfbufsize then begin bwritebuf(gffile, gfbuf, 0, halfbuf - 1); gflimit := halfbuf; gfoffset := gfoffset + gfbufsize; gfptr := 0 end else begin bwritebuf(gffile, gfbuf, halfbuf, gfbufsize - 1); gflimit := gfbufsize end end; {:1155} {1157:} procedure gffour(x: integer); begin if x >= 0 then begin gfbuf[gfptr] := x div 16777216; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end else begin x := x + 1073741824; x := x + 1073741824; begin gfbuf[gfptr] := (x div 16777216) + 128; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end end; x := x mod 16777216; begin gfbuf[gfptr] := x div 65536; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; x := x mod 65536; begin gfbuf[gfptr] := x div 256; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := x mod 256; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end end; {:1157} {1158:} procedure gftwo(x: integer); begin begin gfbuf[gfptr] := x div 256; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := x mod 256; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end end; procedure gfthree(x: integer); begin begin gfbuf[gfptr] := x div 65536; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := (x mod 65536) div 256; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := x mod 256; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end end; {:1158} {1159:} procedure gfpaint(d: integer); begin if d < 64 then begin gfbuf[gfptr] := 0 + d; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end else if d < 256 then begin begin gfbuf[gfptr] := 64; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := d; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end end else begin begin gfbuf[gfptr] := 65; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gftwo(d) end end; {:1159} {1160:} procedure gfstring(s, t: strnumber); var k: poolpointer; l: integer; begin if s <> 0 then begin l := strstart[s + 1] - strstart[s]; if t <> 0 then l := l + (strstart[t + 1] - strstart[t]); if l <= 255 then begin begin gfbuf[gfptr] := 239; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := l; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end end else begin begin gfbuf[gfptr] := 241; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gfthree(l) end; for k := strstart[s] to strstart[s + 1] - 1 do begin gfbuf[gfptr] := strpool[k]; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end end; if t <> 0 then for k := strstart[t] to strstart[t + 1] - 1 do begin gfbuf[gfptr] := strpool[k]; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end end; {:1160} {1161:} procedure gfboc(minm, maxm, minn, maxn: integer); label 10; begin if minm < gfminm then gfminm := minm; if maxn > gfmaxn then gfmaxn := maxn; if bocp = (-1) then if bocc >= 0 then if bocc < 256 then if (maxm - minm) >= 0 then if (maxm - minm) < 256 then if maxm >= 0 then if maxm < 256 then if (maxn - minn) >= 0 then if (maxn - minn) < 256 then if maxn >= 0 then if maxn < 256 then begin begin gfbuf[gfptr] := 68; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := bocc; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := maxm - minm; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := maxm; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := maxn - minn; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := maxn; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; goto 10 end; begin gfbuf[gfptr] := 67; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gffour(bocc); gffour(bocp); gffour(minm); gffour(maxm); gffour(minn); gffour(maxn); 10: null end; {:1161} {1163:} procedure initgf; var k: eightbits; t: integer; begin gfminm := 4096; gfmaxm := -4096; gfminn := 4096; gfmaxn := -4096; for k := 0 to 255 do charptr[k] := -1; {1164:} if internal[27] <= 0 then gfext := 908 else begin oldsetting := selector; selector := 5; printchar(46); printint(makescaled(internal[27], 59429463)); print(909); gfext := makestring; selector := oldsetting end {:1164}; begin if jobname = 0 then openlogfile; packjobname(gfext); while not bopenout(gffile, nameoffile) do promptfilename(620, gfext); outputfilename := bmakenamestring(gffile) end; begin gfbuf[gfptr] := 247; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := 131; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; oldsetting := selector; selector := 5; print(907); printint(roundunscaled(internal[14])); printchar(46); printdd(roundunscaled(internal[15])); printchar(46); printdd(roundunscaled(internal[16])); printchar(58); t := roundunscaled(internal[17]); printdd(t div 60); printdd(t mod 60); selector := oldsetting; begin gfbuf[gfptr] := poolptr - strstart[strptr]; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; strstart[strptr + 1] := poolptr; gfstring(0, strptr); poolptr := strstart[strptr]; gfprevptr := gfoffset + gfptr end; {:1163} {1165:} procedure shipout(c: eightbits); label 30; var f: integer; prevm, m, mm: integer; prevn, n: integer; p, q: halfword; prevw, w, ww: integer; d: integer; delta: integer; curminm: integer; xoff, yoff: integer; begin if outputfilename = 0 then initgf; f := roundunscaled(internal[19]); xoff := roundunscaled(internal[29]); yoff := roundunscaled(internal[30]); if termoffset > (maxprintline - 9) then println else if (termoffset > 0) or (fileoffset > 0) then printchar(32); printchar(91); printint(c); if f <> 0 then begin printchar(46); printint(f) end; flush(output); bocc := (256 * f) + c; bocp := charptr[c]; charptr[c] := gfprevptr; if internal[34] > 0 then begin {1166:} if xoff <> 0 then begin gfstring(308, 0); begin gfbuf[gfptr] := 243; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gffour(xoff * 65536) end; if yoff <> 0 then begin gfstring(309, 0); begin gfbuf[gfptr] := 243; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gffour(yoff * 65536) end end {:1166}; {1167:} prevn := 4096; p := mem[curedges].hh.lh; n := mem[curedges + 1].hh.rh - 4096; while p <> curedges do begin {1169:} if mem[p + 1].hh.lh > (-29999) then sortedges(p); q := mem[p + 1].hh.rh; w := 0; prevm := -268435456; ww := 0; prevw := 0; m := prevm; repeat if q = 30000 then mm := 268435456 else begin d := mem[q].hh.lh + 32768; mm := d div 8; ww := (ww + (d mod 8)) - 4 end; if mm <> m then begin if prevw <= 0 then begin if w > 0 then begin {1170:} if prevm = (-268435456) then begin {1172:} if prevn = 4096 then begin gfboc((mem[curedges + 2].hh.lh + xoff) - 4096, (mem[curedges + 2].hh.rh + xoff) - 4096, (mem[curedges + 1].hh.lh + yoff) - 4096, n + yoff); curminm := (mem[curedges + 2].hh.lh - 4096) + mem[curedges + 3].hh.lh end else if prevn > (n + 1) then begin {1174:} delta := (prevn - n) - 1; if delta < 256 then if delta = 0 then begin gfbuf[gfptr] := 70; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end else begin begin gfbuf[gfptr] := 71; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := delta; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end end else begin begin gfbuf[gfptr] := 72; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gftwo(delta) end end else begin {:1174} {1173:} delta := m - curminm; if delta > 164 then begin gfbuf[gfptr] := 70; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end else begin begin gfbuf[gfptr] := 74 + delta; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; goto 30 end end {:1173}; gfpaint(m - curminm); 30: prevn := n end else {:1172} gfpaint(m - prevm); prevm := m; prevw := w end {:1170} end else if w <= 0 then begin {1171:} gfpaint(m - prevm); prevm := m; prevw := w end {:1171}; m := mm end; w := ww; q := mem[q].hh.rh until mm = 268435456; if w <> 0 then printnl(911); if ((prevm - mem[curedges + 3].hh.lh) + xoff) > gfmaxm then gfmaxm := (prevm - mem[curedges + 3].hh.lh) + xoff {:1169}; p := mem[p].hh.lh; n := n - 1 end; if prevn = 4096 then begin {1168:} gfboc(0, 0, 0, 0); if gfmaxm < 0 then gfmaxm := 0; if gfminn > 0 then gfminn := 0 end else if (prevn + yoff) < gfminn then {:1168} gfminn := prevn + yoff {:1167}; begin gfbuf[gfptr] := 69; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gfprevptr := gfoffset + gfptr; totalchars := totalchars + 1; printchar(93); flush(output); if internal[11] > 0 then printedges(910, true, xoff, yoff) end; { shipout } {:1165} {995:} {1006:} procedure tryeq(l, r: halfword); label 30, 31; var p: halfword; t: 16..19; q: halfword; pp: halfword; tt: 17..19; copied: boolean; {1007:} begin t := mem[l].hh.b0; if t = 16 then begin t := 17; p := constdependency(-mem[l + 1].int); q := p end else if t = 19 then begin t := 17; p := singledependency(l); mem[p + 1].int := -mem[p + 1].int; q := depfinal end else begin p := mem[l + 1].hh.rh; q := p; while true do begin mem[q + 1].int := -mem[q + 1].int; if mem[q].hh.lh = (-30000) then goto 30; q := mem[q].hh.rh end; 30: mem[mem[l + 1].hh.lh].hh.rh := mem[q].hh.rh; mem[mem[q].hh.rh + 1].hh.lh := mem[l + 1].hh.lh; mem[l].hh.b0 := 16 end {:1007}; {1009:} if r = (-30000) then if curtype = 16 then begin mem[q + 1].int := mem[q + 1].int + curexp; goto 31 end else begin tt := curtype; if tt = 19 then pp := singledependency(curexp) else pp := mem[curexp + 1].hh.rh end else if mem[r].hh.b0 = 16 then begin mem[q + 1].int := mem[q + 1].int + mem[r + 1].int; goto 31 end else begin tt := mem[r].hh.b0; if tt = 19 then pp := singledependency(r) else pp := mem[r + 1].hh.rh end; if tt <> 19 then copied := false else begin copied := true; tt := 17 end; {1010:} watchcoefs := false; if t = tt then p := pplusq(p, pp, t) else if t = 18 then p := pplusfq(p, 65536, pp, 18, 17) else begin q := p; while mem[q].hh.lh <> (-30000) do begin mem[q + 1].int := roundfraction(mem[q + 1].int); q := mem[q].hh.rh end; t := 18; p := pplusq(p, pp, t) end; watchcoefs := true; {:1010} if copied then flushnodelist(pp); 31: {:1009} null; if mem[p].hh.lh = (-30000) then begin {1008:} if abs(mem[p + 1].int) > 64 then begin begin if interaction = 3 then null; printnl(133); print(761) end; print(763); printscaled(mem[p + 1].int); printchar(41); begin helpptr := 2; helpline[1] := 762; helpline[0] := 760 end; putgeterror end else if r = (-30000) then begin {623:} begin if interaction = 3 then null; printnl(133); print(465) end; begin helpptr := 2; helpline[1] := 466; helpline[0] := 467 end; putgeterror end {:623}; freenode(p, 2) end else begin {:1008} lineareq(p, t); if r = (-30000) then if curtype <> 16 then if mem[curexp].hh.b0 = 16 then begin pp := curexp; curexp := mem[curexp + 1].int; curtype := 16; freenode(pp, 2) end end end; {:1006} {1001:} procedure makeeq(lhs: halfword); label 20, 30, 45; var t: smallnumber; v: integer; p, q: halfword; begin 20: t := mem[lhs].hh.b0; if t <= 14 then v := mem[lhs + 1].int; case t of {1003:} 2, 4, 6, 9, 11: if curtype = (t + 1) then begin nonlineareq(v, curexp, false); goto 30 end else if curtype = t then begin {1004:} if curtype <= 4 then begin if curtype = 4 then begin if strvsstr(v, curexp) <> 0 then goto 45 end else if v <> curexp then goto 45; {623:} begin begin if interaction = 3 then null; printnl(133); print(465) end; begin helpptr := 2; helpline[1] := 466; helpline[0] := 467 end; putgeterror end {:623}; goto 30 end; begin if interaction = 3 then null; printnl(133); print(758) end; begin helpptr := 2; helpline[1] := 759; helpline[0] := 760 end; putgeterror; goto 30; 45: begin if interaction = 3 then null; printnl(133); print(761) end; begin helpptr := 2; helpline[1] := 762; helpline[0] := 760 end; putgeterror; goto 30 end {:1004}; 3, 5, 7, 12, 10: if curtype = (t - 1) then begin nonlineareq(curexp, lhs, true); goto 30 end else if curtype = t then begin ringmerge(lhs, curexp); goto 30 end else if curtype = 14 then if t = 10 then begin pairtopath; goto 20 end; 13, 14: if curtype = t then begin {1005:} p := v + bignodesize[t]; q := mem[curexp + 1].int + bignodesize[t]; repeat p := p - 2; q := q - 2; tryeq(p, q) until p = v; goto 30 end {:1005}; 16, 17, 18, 19: if curtype >= 16 then begin tryeq(lhs, -30000); goto 30 end; 1: null end {:1003}; {1002:} disperr(lhs, 155); disperr(-30000, 755); if mem[lhs].hh.b0 <= 14 then printtype(mem[lhs].hh.b0) else print(211); printchar(61); if curtype <= 14 then printtype(curtype) else print(211); printchar(41); begin helpptr := 2; helpline[1] := 756; helpline[0] := 757 end; {:1002} putgeterror; 30: begin if aritherror then cleararith end; recyclevalue(lhs); freenode(lhs, 2) end; {:1001} procedure doassignment; forward; procedure doequation; var lhs: halfword; p: halfword; begin lhs := stashcurexp; getxnext; varflag := 77; scanexpression; if curcmd = 51 then doequation else if curcmd = 77 then doassignment; if internal[7] > 131072 then begin {997:} begindiagnostic; printnl(714); printexp(lhs, 0); print(750); printexp(-30000, 0); print(706); enddiagnostic(false) end {:997}; if curtype = 10 then if mem[lhs].hh.b0 = 14 then begin p := stashcurexp; unstashcurexp(lhs); lhs := p end; makeeq(lhs) end; {:995} {996:} procedure doassignment; var lhs: halfword; p: halfword; q: halfword; begin if curtype <> 20 then begin disperr(-30000, 747); begin helpptr := 2; helpline[1] := 748; helpline[0] := 749 end; error; doequation end else begin lhs := curexp; curtype := 1; getxnext; varflag := 77; scanexpression; if curcmd = 51 then doequation else if curcmd = 77 then doassignment; if internal[7] > 131072 then begin {998:} begindiagnostic; printnl(123); if mem[lhs].hh.lh > 2241 then print(intname[mem[lhs].hh.lh - 2241]) else showtokenlist(lhs, -30000, 1000, 0); print(329); printexp(-30000, 0); printchar(125); enddiagnostic(false) end {:998}; if mem[lhs].hh.lh > 2241 then {999:} if curtype = 16 then internal[mem[lhs].hh.lh - 2241] := curexp else begin disperr(-30000, 751); print(intname[mem[lhs].hh.lh - 2241]); print(752); begin helpptr := 2; helpline[1] := 753; helpline[0] := 754 end; putgeterror end {:999} {1000:} else begin p := findvariable(lhs); if p <> (-30000) then begin q := stashcurexp; curtype := undtype(p); recyclevalue(p); mem[p].hh.b0 := curtype; mem[p + 1].int := -30000; makeexpcopy(p); p := stashcurexp; unstashcurexp(q); makeeq(p) end else begin obliterated(lhs); putgeterror end end {:1000}; flushnodelist(lhs) end end; {:996} {1015:} procedure dotypedeclaration; var t: smallnumber; p: halfword; q: halfword; begin if curmod >= 13 then t := curmod else t := curmod + 1; repeat p := scandeclaredvariable; flushvariable(eqtb[mem[p].hh.lh].rh, mem[p].hh.rh, false); q := findvariable(p); if q <> (-30000) then begin mem[q].hh.b0 := t; mem[q + 1].int := -30000 end else begin begin if interaction = 3 then null; printnl(133); print(764) end; begin helpptr := 2; helpline[1] := 765; helpline[0] := 766 end; putgeterror end; flushlist(p); if curcmd < 79 then begin {1016:} begin if interaction = 3 then null; printnl(133); print(767) end; begin helpptr := 5; helpline[4] := 768; helpline[3] := 769; helpline[2] := 770; helpline[1] := 771; helpline[0] := 772 end; if curcmd = 42 then helpline[2] := 773; putgeterror; scannerstatus := 2; repeat getnext; {743:} if curcmd = 39 then begin if strref[curmod] < 127 then if strref[curmod] > 1 then strref[curmod] := strref[curmod] - 1 else flushstring(curmod) end {:743} until curcmd >= 79; scannerstatus := 0 end {:1016} until curcmd > 79 end; { dotypedeclaration } {:1015} {1021:} procedure dorandomseed; begin getxnext; if curcmd <> 77 then begin missingerr(329); begin helpptr := 1; helpline[0] := 778 end; backerror end; getxnext; scanexpression; if curtype <> 16 then begin disperr(-30000, 779); begin helpptr := 2; helpline[1] := 780; helpline[0] := 781 end; putgetflusherror(0) end else begin {1022:} initrandoms(curexp); if selector >= 2 then begin oldsetting := selector; selector := 2; printnl(782); printscaled(curexp); printchar(125); printnl(155); selector := oldsetting end end {:1022} end; {:1021} {1029:} procedure doprotection; var m: 0..1; t: halfword; begin m := curmod; repeat getsymbol; t := eqtb[cursym].lh; if m = 0 then begin if t >= 83 then eqtb[cursym].lh := t - 83 end else if t < 83 then eqtb[cursym].lh := t + 83; getxnext until curcmd <> 79 end; {:1029} {1031:} procedure defdelims; var ldelim, rdelim: halfword; begin getclearsymbol; ldelim := cursym; getclearsymbol; rdelim := cursym; eqtb[ldelim].lh := 31; eqtb[ldelim].rh := rdelim; eqtb[rdelim].lh := 62; eqtb[rdelim].rh := ldelim; getxnext end; {:1031} {1034:} procedure dostatement; forward; procedure dointerim; begin getxnext; if curcmd <> 40 then begin begin if interaction = 3 then null; printnl(133); print(788) end; if cursym = 0 then print(793) else print(hash[cursym].rh); print(794); begin helpptr := 1; helpline[0] := 795 end; backerror end else begin saveinternal(curmod); backinput end; dostatement end; { dointerim } {:1034} {1035:} procedure dolet; var l: halfword; begin getsymbol; l := cursym; getxnext; if curcmd <> 51 then if curcmd <> 77 then begin missingerr(61); begin helpptr := 3; helpline[2] := 796; helpline[1] := 538; helpline[0] := 797 end; backerror end; getsymbol; if curcmd in [10, 53, 44, 49] then case curcmd of 10, 53, 44, 49: mem[curmod].hh.lh := mem[curmod].hh.lh + 1 end else null; clearsymbol(l, false); eqtb[l].lh := curcmd; if curcmd = 41 then eqtb[l].rh := -30000 else eqtb[l].rh := curmod; getxnext end; {:1035} {1036:} procedure donewinternal; begin repeat if intptr = maxinternal then overflow(798, maxinternal); getclearsymbol; intptr := intptr + 1; eqtb[cursym].lh := 40; eqtb[cursym].rh := intptr; intname[intptr] := hash[cursym].rh; internal[intptr] := 0; getxnext until curcmd <> 79 end; {:1036} {1040:} procedure doshow; begin repeat getxnext; scanexpression; printnl(629); printexp(-30000, 2); flushcurexp(0) until curcmd <> 79 end; {:1040} {1041:} procedure disptoken; begin printnl(804); if cursym = 0 then begin {1042:} if curcmd = 42 then printscaled(curmod) else if curcmd = 38 then begin gpointer := curmod; printcapsule end else begin printchar(34); print(curmod); printchar(34); begin if strref[curmod] < 127 then if strref[curmod] > 1 then strref[curmod] := strref[curmod] - 1 else flushstring(curmod) end end end else begin {:1042} print(hash[cursym].rh); printchar(61); if eqtb[cursym].lh >= 83 then print(805); printcmdmod(curcmd, curmod); if curcmd = 10 then begin println; showmacro(curmod, -30000, 100000) end end end; {:1041} {1044:} procedure doshowtoken; begin repeat getnext; disptoken; getxnext until curcmd <> 79 end; {:1044} {1045:} procedure doshowstats; {printint(varused);printchar(38);printint(dynused); if false then} begin printnl(814); print(228); print(425); printint((himemmin - lomemmax) - 1); print(815); println; printnl(816); printint(strptr - initstrptr); printchar(38); printint(poolptr - initpoolptr); print(425); printint(maxstrings - maxstrptr); printchar(38); printint(poolsize - maxpoolptr); print(815); println; getxnext end; {:1045} {1046:} procedure dispvar(p: halfword); var q: halfword; n: 0..maxprintline; begin if mem[p].hh.b0 = 21 then begin {1047:} q := mem[p + 1].hh.lh; repeat dispvar(q); q := mem[q].hh.rh until q = (-29983); q := mem[p + 1].hh.rh; while mem[q].hh.b1 = 3 do begin dispvar(q); q := mem[q].hh.rh end end else if mem[p].hh.b0 >= 22 then begin {:1047} {1048:} printnl(155); printvariablename(p); if mem[p].hh.b0 > 22 then print(530); print(817); if fileoffset >= (maxprintline - 20) then n := 5 else n := (maxprintline - fileoffset) - 15; showmacro(mem[p + 1].int, -30000, n) end else if mem[p].hh.b0 <> 0 then begin {:1048} printnl(155); printvariablename(p); printchar(61); printexp(p, 0) end end; {:1046} {1049:} procedure doshowvar; label 30; begin repeat getnext; if cursym > 0 then if cursym <= 2241 then if curcmd = 41 then if curmod <> (-30000) then begin dispvar(curmod); goto 30 end; disptoken; 30: getxnext until curcmd <> 79 end; {:1049} {1050:} procedure doshowdependencies; var p: halfword; begin p := mem[-29987].hh.rh; while p <> (-29987) do begin if interesting(p) then begin printnl(155); printvariablename(p); if mem[p].hh.b0 = 17 then printchar(61) else print(632); printdependency(mem[p + 1].hh.rh, mem[p].hh.b0) end; p := mem[p + 1].hh.rh; while mem[p].hh.lh <> (-30000) do p := mem[p].hh.rh; p := mem[p].hh.rh end; getxnext end; {:1050} {1051:} procedure doshowwhatever; begin if interaction = 3 then null; case curmod of 0: doshowtoken; 1: doshowstats; 2: doshow; 3: doshowvar; 4: doshowdependencies end; if internal[32] > 0 then begin begin if interaction = 3 then null; printnl(133); print(818) end; if interaction < 3 then begin helpptr := 0; errorcount := errorcount - 1 end else begin helpptr := 1; helpline[0] := 819 end; if curcmd = 80 then error else putgeterror end end; {:1051} {1054:} function scanwith: boolean; var t: smallnumber; result: boolean; begin t := curmod; curtype := 1; getxnext; scanexpression; result := false; if curtype <> t then begin {1055:} disperr(-30000, 827); begin helpptr := 2; helpline[1] := 828; helpline[0] := 829 end; if t = 6 then helpline[1] := 830; putgetflusherror(0) end else if curtype = 6 then {:1055} result := true {1056:} else begin curexp := roundunscaled(curexp); if (abs(curexp) < 4) and (curexp <> 0) then result := true else begin begin if interaction = 3 then null; printnl(133); print(831) end; begin helpptr := 1; helpline[0] := 829 end; putgetflusherror(0) end end {:1056}; scanwith := result end; {:1054} {1057:} procedure findedgesvar(t: halfword); var p: halfword; begin p := findvariable(t); curedges := -30000; if p = (-30000) then begin obliterated(t); putgeterror end else if mem[p].hh.b0 <> 11 then begin begin if interaction = 3 then null; printnl(133); print(654) end; showtokenlist(t, -30000, 1000, 0); print(832); printtype(mem[p].hh.b0); printchar(41); begin helpptr := 2; helpline[1] := 833; helpline[0] := 834 end; putgeterror end else curedges := mem[p + 1].int; flushnodelist(t) end; {:1057} {1059:} procedure doaddto; label 30, 45; var lhs, rhs: halfword; t: smallnumber; w: integer; p: halfword; q: halfword; begin getxnext; varflag := 68; scanprimary; if curtype <> 20 then begin {1060:} disperr(-30000, 835); begin helpptr := 4; helpline[3] := 836; helpline[2] := 837; helpline[1] := 838; helpline[0] := 834 end; putgetflusherror(0) end else begin {:1060} lhs := curexp; curpathtype := curmod; curtype := 1; getxnext; scanexpression; if curpathtype = 2 then begin {1061:} findedgesvar(lhs); if curedges = (-30000) then flushcurexp(0) else if curtype <> 11 then begin disperr(-30000, 839); begin helpptr := 2; helpline[1] := 840; helpline[0] := 834 end; putgetflusherror(0) end else begin mergeedges(curexp); flushcurexp(0) end end else begin {:1061} {1062:} if curtype = 14 then pairtopath; if curtype <> 9 then begin disperr(-30000, 839); begin helpptr := 2; helpline[1] := 841; helpline[0] := 834 end; putgetflusherror(0); flushtokenlist(lhs) end else begin rhs := curexp; w := 1; curpen := -29997; { 1063:} while curcmd = 66 do if scanwith then if curtype = 16 then w := curexp else begin if mem[curpen].hh.lh = (-30000) then tosspen(curpen) else mem[curpen].hh.lh := mem[curpen].hh.lh - 1; curpen := curexp end {:1063}; {1064:} findedgesvar(lhs); if curedges = (-30000) then tossknotlist(rhs) else begin lhs := -30000; if mem[rhs].hh.b0 = 0 then if curpathtype = 0 then {1065:} if mem[rhs].hh.rh = rhs then begin {1066:} mem[rhs + 5].int := mem[rhs + 1].int; mem[rhs + 6].int := mem[rhs + 2].int; mem[rhs + 3].int := mem[rhs + 1].int; mem[rhs + 4].int := mem[rhs + 2].int; mem[rhs].hh.b0 := 1; mem[rhs].hh.b1 := 1 end else begin {:1066} p := htapypoc(rhs); q := mem[p].hh.rh; mem[pathtail + 5].int := mem[q + 5].int; mem[pathtail + 6].int := mem[q + 6].int; mem[pathtail].hh.b1 := mem[q].hh.b1; mem[pathtail].hh.rh := mem[q].hh.rh; freenode(q, 7); mem[p + 5].int := mem[rhs + 5].int; mem[p + 6].int := mem[rhs + 6].int; mem[p].hh.b1 := mem[rhs].hh.b1; mem[p].hh.rh := mem[rhs].hh.rh; freenode(rhs, 7); rhs := p end {:1065} {1067:} else begin begin if interaction = 3 then null; printnl(133); print(842) end; begin helpptr := 2; helpline[1] := 843; helpline[0] := 834 end; putgeterror; tossknotlist(rhs); goto 45 end {:1067} else if curpathtype = 0 then lhs := htapypoc(rhs); curwt := w; rhs := makespec(rhs, mem[curpen + 9].int, internal[5]); {1068:} if turningnumber <= 0 then if curpathtype <> 0 then if internal[39] > 0 then if (turningnumber < 0) and (mem[curpen].hh.rh = (-30000)) then curwt := -curwt else begin if turningnumber = 0 then if (internal[39] <= 65536) and (mem[curpen].hh.rh = (-30000)) then goto 30 else printstrange(844) else printstrange(845); begin helpptr := 3; helpline[2] := 846; helpline[1] := 847; helpline[0] := 848 end; putgeterror end; 30: {:1068} null; if mem[curpen + 9].int = 0 then fillspec(rhs) else fillenvelope(rhs); if lhs <> (-30000) then begin revturns := true; lhs := makespec(lhs, mem[curpen + 9].int, internal[5]); revturns := false; if mem[curpen + 9].int = 0 then fillspec(lhs) else fillenvelope(lhs) end; 45: {:1064} null end; if mem[curpen].hh.lh = (-30000) then tosspen(curpen) else mem[curpen].hh.lh := mem[curpen].hh.lh - 1 end end {:1062} end end; {:1059} {1070:} {1098:} function tfmcheck(m: smallnumber): scaled; begin if abs(internal[m]) >= 134217728 then begin begin if interaction = 3 then null; printnl(133); print(865) end; print(intname[m]); print(866); begin helpptr := 1; helpline[0] := 867 end; putgeterror; if internal[m] > 0 then tfmcheck := 134217727 else tfmcheck := -134217727 end else tfmcheck := internal[m] end; {:1098} procedure doshipout; label 10; var c: integer; begin getxnext; varflag := 80; scanexpression; {1060: } if curtype <> 20 then if curtype = 11 then curedges := curexp else begin begin disperr(-30000, 835); begin helpptr := 4; helpline[3] := 836; helpline[2] := 837; helpline[1] := 838; helpline[0] := 834 end; putgetflusherror(0) end {:1060}; goto 10 end else begin findedgesvar(curexp); curtype := 1 end; if curedges <> (-30000) then begin c := roundunscaled(internal[18]) mod 256; if c < 0 then c := c + 256; {1099:} if c < bc then bc := c; if c > ec then ec := c; charexists[c] := true; gfdx[c] := internal[24]; gfdy[c] := internal[25]; tfmwidth[c] := tfmcheck(20); tfmheight[c] := tfmcheck(21); tfmdepth[c] := tfmcheck(22); tfmitalcorr[c] := tfmcheck(23) {:1099}; if internal[34] >= 0 then shipout(c) end; flushcurexp(0); 10: null end; {:1070} {1071:} procedure dodisplay; label 45, 50, 10; var e: halfword; begin getxnext; varflag := 73; scanprimary; if curtype <> 20 then begin {1060:} disperr(-30000, 835); begin helpptr := 4; helpline[3] := 836; helpline[2] := 837; helpline[1] := 838; helpline[0] := 834 end; putgetflusherror(0) end else begin {:1060} e := curexp; curtype := 1; getxnext; scanexpression; if curtype <> 16 then goto 50; curexp := roundunscaled(curexp); if curexp < 0 then goto 45; if curexp > 15 then goto 45; if not windowopen[curexp] then goto 45; findedgesvar(e); if curedges <> (-30000) then dispedges(curexp); goto 10; 45: curexp := curexp * 65536; 50: disperr(-30000, 849); begin helpptr := 1; helpline[0] := 850 end; putgetflusherror(0); flushtokenlist(e) end; 10: null end; { dodisplay } {:1071} {1072:} function getpair(c: commandcode): boolean; var p: halfword; b: boolean; begin if curcmd <> c then getpair := false else begin getxnext; scanexpression; if nicepair(curexp, curtype) then begin p := mem[curexp + 1].int; curx := mem[p + 1].int; cury := mem[p + 3].int; b := true end else b := false; flushcurexp(0); getpair := b end end; {:1072} {1073:} procedure doopenwindow; label 45, 10; var k: integer; r0, c0, r1, c1: scaled; begin getxnext; scanexpression; if curtype <> 16 then goto 45; k := roundunscaled(curexp); if k < 0 then goto 45; if k > 15 then goto 45; if not getpair(70) then goto 45; r0 := curx; c0 := cury; if not getpair(71) then goto 45; r1 := curx; c1 := cury; if not getpair(72) then goto 45; openawindow(k, r0, c0, r1, c1, curx, cury); goto 10; 45: begin if interaction = 3 then null; printnl(133); print(851) end; begin helpptr := 2; helpline[1] := 852; helpline[0] := 853 end; putgeterror; 10: null end; {:1073} {1074:} procedure docull; label 45, 10; var e: halfword; keeping: 0..1; w, win, wout: integer; begin w := 1; getxnext; varflag := 67; scanprimary; if curtype <> 20 then begin {1060:} disperr(-30000, 835); begin helpptr := 4; helpline[3] := 836; helpline[2] := 837; helpline[1] := 838; helpline[0] := 834 end; putgetflusherror(0) end else begin {:1060} e := curexp; curtype := 1; keeping := curmod; if not getpair(67) then goto 45; while (curcmd = 66) and (curmod = 16) do if scanwith then w := curexp; {1075:} if curx > cury then goto 45; if keeping = 0 then begin if (curx > 0) or (cury < 0) then goto 45; wout := w; win := 0 end else begin if (curx <= 0) and (cury >= 0) then goto 45; wout := 0; win := w end {:1075}; findedgesvar(e); if curedges <> (-30000) then culledges(floorunscaled(curx + 65535), floorunscaled(cury), wout, win); goto 10; 45: begin if interaction = 3 then null; printnl(133); print(854) end; begin helpptr := 1; helpline[0] := 855 end; putgeterror; flushtokenlist(e) end; 10: null end; {:1074} {1082:} procedure domessage; var m: 0..2; begin m := curmod; getxnext; scanexpression; if curtype <> 4 then begin disperr(-30000, 565); begin helpptr := 1; helpline[0] := 859 end; putgeterror end else case m of 0: begin printnl(155); slowprint(curexp) end; 1: begin {1086:} begin if interaction = 3 then null; printnl(133); print(155) end; slowprint(curexp); if errhelp <> 0 then useerrhelp := true else if longhelpseen then begin helpptr := 1; helpline[0] := 860 end else begin if interaction < 3 then longhelpseen := true; begin helpptr := 4; helpline[3] := 861; helpline[2] := 862; helpline[1] := 863; helpline[0] := 864 end end; putgeterror; useerrhelp := false end; {:1086} 2: begin {1083:} if errhelp <> 0 then begin if strref[errhelp] < 127 then if strref[errhelp] > 1 then strref[errhelp] := strref[errhelp] - 1 else flushstring(errhelp) end; if (strstart[curexp + 1] - strstart[curexp]) = 0 then errhelp := 0 else begin errhelp := curexp; begin if strref[errhelp] < 127 then strref[errhelp] := strref[errhelp] + 1 end end end end {:1083}; flushcurexp(0) end; {:1082} {1103:} function getcode: eightbits; label 40; var c: integer; begin getxnext; scanexpression; if curtype = 16 then begin c := roundunscaled(curexp); if c >= 0 then if c < 256 then goto 40 end else if curtype = 4 then if (strstart[curexp + 1] - strstart[curexp]) = 1 then begin c := strpool[strstart[curexp]]; goto 40 end; disperr(-30000, 873); begin helpptr := 2; helpline[1] := 874; helpline[0] := 875 end; putgetflusherror(0); c := 0; 40: getcode := c end; {:1103} {1104:} procedure settag(c: eightbits; t: smallnumber; r: eightbits); begin if chartag[c] = 0 then begin chartag[c] := t; charremainder[c] := r end else begin {1105:} begin if interaction = 3 then null; printnl(133); print(876) end; if (c > 32) and (c < 128) then print(c) else begin print(877); printint(c) end; print(878); case chartag[c] of 1: print(879); 2: print(880); 3: print(870) end; begin helpptr := 2; helpline[1] := 881; helpline[0] := 834 end; putgeterror end {:1105} end; {:1104} {1106:} procedure dotfmcommand; label 22; var c, cc: eightbits; k: 0..256; j: integer; begin case curmod of 0: begin {1107:} c := getcode; while curcmd = 78 do begin cc := getcode; settag(c, 2, cc); c := cc end end; {:1107} 1: begin {1108:} 22: c := getcode; if curcmd = 78 then begin {1111:} if nl < 256 then settag(c, 1, nl) else begin begin if interaction = 3 then null; printnl(133); print(891) end; begin helpptr := 1; helpline[0] := 892 end; error end; goto 22 end {:1111}; if curcmd = 76 then begin {1112:} ligkern[nl].b1 := c - 128; ligkern[nl].b2 := curmod - 128; ligkern[nl].b0 := -128; if curmod = 0 then ligkern[nl].b3 := getcode - 128 else begin getxnext; scanexpression; if curtype <> 16 then begin disperr(-30000, 893); begin helpptr := 2; helpline[1] := 894; helpline[0] := 179 end; putgetflusherror(0) end; kern[nk] := curexp; k := 0; while kern[k] <> curexp do k := k + 1; if k = nk then begin if nk = 256 then overflow(890, 256); nk := nk + 1 end; ligkern[nl].b3 := k - 128 end {:1112}; if nl = ligtablesize then overflow(886, ligtablesize); nl := nl + 1; if curcmd = 79 then goto 22 end else begin begin if interaction = 3 then null; printnl(133); print(887) end; begin helpptr := 1; helpline[0] := 888 end; backerror end; if nl > 0 then ligkern[nl - 1].b0 := 0 end; {:1108} 2: begin {1113:} if ne = 256 then overflow(870, 256); c := getcode; settag(c, 3, ne); if curcmd <> 78 then begin missingerr(58); begin helpptr := 1; helpline[0] := 895 end; backerror end; exten[ne].b0 := getcode - 128; if curcmd <> 79 then begin missingerr(44); begin helpptr := 1; helpline[0] := 895 end; backerror end; exten[ne].b1 := getcode - 128; if curcmd <> 79 then begin missingerr(44); begin helpptr := 1; helpline[0] := 895 end; backerror end; exten[ne].b2 := getcode - 128; if curcmd <> 79 then begin missingerr(44); begin helpptr := 1; helpline[0] := 895 end; backerror end; exten[ne].b3 := getcode - 128; ne := ne + 1 end; {:1113} 3, 4: begin c := curmod; getxnext; scanexpression; if (curtype <> 16) or (curexp < 32768) then begin disperr(-30000, 882); begin helpptr := 2; helpline[1] := 883; helpline[0] := 884 end; putgeterror end else begin j := roundunscaled(curexp); if curcmd <> 78 then begin missingerr(58); begin helpptr := 1; helpline[0] := 885 end; backerror end; if c = 3 then {1114:} repeat if j > headersize then overflow(871, headersize); headerbyte[j] := getcode; j := j + 1 until curcmd <> 79 {:1114} {1115:} else repeat if j > maxfontdimen then overflow(872, maxfontdimen); while j > np do begin np := np + 1; param[np] := 0 end; getxnext; scanexpression; if curtype <> 16 then begin disperr(-30000, 896); begin helpptr := 1; helpline[0] := 179 end; putgetflusherror(0) end; param[j] := curexp; j := j + 1 until curcmd <> 79 {:1115} end end end end; {:1106} {1177:} procedure dospecial; var m: smallnumber; begin m := curmod; getxnext; scanexpression; if internal[34] >= 0 then if curtype <> m then begin {1178:} disperr(-30000, 914); begin helpptr := 1; helpline[0] := 915 end; putgeterror end else begin {:1178} if outputfilename = 0 then initgf; if m = 4 then gfstring(curexp, 0) else begin begin gfbuf[gfptr] := 243; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gffour(curexp) end end; flushcurexp(0) end; {:1177} {1186:} {procedure storebasefile;var k:integer; p,q:halfword;x:integer;w:fourquarters;begin[1200:]selector:=5; print(925);print(jobname);printchar(32); printint(roundunscaled(internal[14])mod 100);printchar(46); printint(roundunscaled(internal[15]));printchar(46); printint(roundunscaled(internal[16]));printchar(41); if interaction=0 then selector:=2 else selector:=3; begin if poolptr+1>maxpoolptr then begin if poolptr+1>poolsize then overflow(129,poolsize-initpoolptr);maxpoolptr:=poolptr+1;end;end; baseident:=makestring;strref[baseident]:=127;packjobname(926); while not wopenout(basefile)do promptfilename(927,926);printnl(928); print(wmakenamestring(basefile));flushstring(strptr-1); printnl(baseident)[:1200];[1190:]begin basefile^.int:=503742536; put(basefile);end;begin basefile^.int:=-30000;put(basefile);end; begin basefile^.int:=30000;put(basefile);end;begin basefile^.int:=2100; put(basefile);end;begin basefile^.int:=1777;put(basefile);end; begin basefile^.int:=6;put(basefile);end[:1190]; [1192:]begin basefile^.int:=poolptr;put(basefile);end; begin basefile^.int:=strptr;put(basefile);end; for k:=0 to strptr do begin basefile^.int:=strstart[k];put(basefile); end;k:=0;while k+4-30000 do begin dynused:=dynused-1;p:=mem[p].hh.rh;end; begin basefile^.int:=varused;put(basefile);end; begin basefile^.int:=dynused;put(basefile);end;println;printint(x); print(923);printint(varused);printchar(38);printint(dynused)[:1194]; [1196:]begin basefile^.int:=hashused;put(basefile);end; stcount:=2228-hashused; for p:=1 to hashused do if hash[p].rh<>0 then begin begin basefile^.int :=p;put(basefile);end;begin basefile^.hh:=hash[p];put(basefile);end; begin basefile^.hh:=eqtb[p];put(basefile);end;stcount:=stcount+1;end; for p:=hashused+1 to 2241 do begin begin basefile^.hh:=hash[p]; put(basefile);end;begin basefile^.hh:=eqtb[p];put(basefile);end;end; begin basefile^.int:=stcount;put(basefile);end;println; printint(stcount);print(924)[:1196];[1198:]begin basefile^.int:=intptr; put(basefile);end; for k:=1 to intptr do begin begin basefile^.int:=internal[k]; put(basefile);end;begin basefile^.int:=intname[k];put(basefile);end;end; begin basefile^.int:=startsym;put(basefile);end; begin basefile^.int:=interaction;put(basefile);end; begin basefile^.int:=baseident;put(basefile);end; begin basefile^.int:=bgloc;put(basefile);end;begin basefile^.int:=egloc; put(basefile);end;begin basefile^.int:=serialno;put(basefile);end; begin basefile^.int:=69069;put(basefile);end;internal[12]:=0[:1198]; [1201:]wclose(basefile)[:1201];end;} {:1186} procedure dostatement; begin curtype := 1; getxnext; if curcmd > 43 then begin {990:} if curcmd < 80 then begin begin if interaction = 3 then null; printnl(133); print(733) end; printcmdmod(curcmd, curmod); printchar(39); begin helpptr := 5; helpline[4] := 734; helpline[3] := 735; helpline[2] := 736; helpline[1] := 737; helpline[0] := 738 end; backerror; getxnext end end else if curcmd > 30 then begin {:990} {993:} varflag := 77; scanexpression; if curcmd < 81 then begin if curcmd = 51 then doequation else if curcmd = 77 then doassignment else if curtype = 4 then begin {994:} if internal[1] > 0 then begin printnl(155); slowprint(curexp); {---------------------} auxprintnl(155); auxslowprint(curexp); {---------------------} flush(output) end; if internal[34] > 0 then begin {1179:} if outputfilename = 0 then initgf; gfstring(916, curexp) end {:1179} end else if curtype <> 1 then begin {:994} disperr(-30000, 743); begin helpptr := 3; helpline[2] := 744; helpline[1] := 745; helpline[0] := 746 end; putgeterror end; flushcurexp(0); curtype := 1 end end else begin {:993} {992:} if internal[7] > 0 then showcmdmod(curcmd, curmod); case curcmd of 30: dotypedeclaration; 16: if curmod > 2 then makeopdef else if curmod > 0 then scandef; {1020:} 24: dorandomseed; {:1020} {1023:} 23: begin println; interaction := curmod; {70:} if interaction = 0 then selector := 0 else selector := 1 {:70}; if jobname <> 0 then selector := selector + 2; getxnext end; {:1023} {1026:} 21: doprotection; {:1026} {1030:} 27: defdelims; {:1030} {1033:} 12: repeat getsymbol; savevariable(cursym); getxnext until curcmd <> 79; 13: dointerim; 14: dolet; 15: donewinternal; {:1033} {1039:} 22: doshowwhatever; {:1039} {1058:} 18: doaddto; {:1058} {1069:} 17: doshipout; 11: dodisplay; 28: doopenwindow; 19: docull; {:1069} {1076:} 26: begin getsymbol; startsym := cursym; getxnext end; {:1076} {1081:} 25: domessage; {:1081} {1100:} 20: dotfmcommand; {:1100} {1175:} 29: dospecial end {:1175}; curtype := 1 end {:992}; if curcmd < 80 then begin {991:} begin if interaction = 3 then null; printnl(133); print(739) end; begin helpptr := 6; helpline[5] := 740; helpline[4] := 741; helpline[3] := 742; helpline[2] := 736; helpline[1] := 737; helpline[0] := 738 end; backerror; scannerstatus := 2; repeat getnext; {743:} if curcmd = 39 then begin if strref[curmod] < 127 then if strref[curmod] > 1 then strref[curmod] := strref[curmod] - 1 else flushstring(curmod) end {:743} until curcmd > 79; scannerstatus := 0 end {:991}; errorcount := 0 end; {:989} {1017:} procedure maincontrol; begin repeat dostatement; if curcmd = 81 then begin begin if interaction = 3 then null; printnl(133); print(774) end; begin helpptr := 2; helpline[1] := 775; helpline[0] := 555 end; flusherror(0) end until curcmd = 82 end; {:1017} {1117:} function sortin(v: scaled): halfword; label 40; var p, q, r: halfword; begin p := 29999; while true do begin q := mem[p].hh.rh; if v <= mem[q + 1].int then goto 40; p := q end; 40: if v < mem[q + 1].int then begin r := getnode(2); mem[r + 1].int := v; mem[r].hh.rh := q; mem[p].hh.rh := r end; sortin := mem[p].hh.rh end; {:1117} {1118:} function mincover(d: scaled): integer; var p: halfword; l: scaled; m: integer; begin m := 0; p := mem[29999].hh.rh; perturbation := 2147483647; while p <> (-29981) do begin m := m + 1; l := mem[p + 1].int; repeat p := mem[p].hh.rh until mem[p + 1].int > (l + d); if (mem[p + 1].int - l) < perturbation then perturbation := mem[p + 1].int - l end; mincover := m end; {:1118} {1120:} function threshold(m: integer): scaled; var d: scaled; begin if mincover(0) <= m then threshold := 0 else begin repeat d := perturbation until mincover(d + d) <= m; while mincover(d) > m do d := perturbation; threshold := d end end; {:1120} {1121:} function skimp(m: integer): integer; var d: scaled; p, q, r: halfword; l: scaled; v: scaled; begin d := threshold(m); perturbation := 0; q := 29999; m := 0; p := mem[29999].hh.rh; while p <> (-29981) do begin m := m + 1; l := mem[p + 1].int; mem[p].hh.lh := m; if mem[mem[p].hh.rh + 1].int <= (l + d) then begin {1122:} repeat p := mem[p].hh.rh; mem[p].hh.lh := m until mem[mem[p].hh.rh + 1].int > (l + d); v := (l + mem[p + 1].int) div 2; if (mem[p + 1].int - v) > perturbation then perturbation := mem[p + 1].int - v; r := q; repeat r := mem[r].hh.rh; mem[r + 1].int := v until r = p; mem[q].hh.rh := p end {:1122}; q := p; p := mem[p].hh.rh end; skimp := m end; {:1121} {1123:} procedure tfmwarning(m: smallnumber); begin printnl(897); print(intname[m]); print(898); printscaled(perturbation); print(899) end; { tfmwarning } {:1123} {1128:} procedure fixdesignsize; var d: scaled; begin d := internal[26]; if (d < 65536) or (d >= 134217728) then begin if d <> 0 then printnl(900); d := 8388608; internal[26] := d end; if headerbyte[5] < 0 then if headerbyte[6] < 0 then if headerbyte[7] < 0 then if headerbyte[8] < 0 then begin headerbyte[5] := d div 1048576; headerbyte[6] := (d div 4096) mod 256; headerbyte[7] := (d div 16) mod 256; headerbyte[8] := (d mod 16) * 16 end; maxtfmdimen := (16 * internal[26]) - (internal[26] div 2097152); if maxtfmdimen >= 134217728 then maxtfmdimen := 134217727 end; {:1128} {1129:} function dimenout(x: scaled): integer; begin if abs(x) > maxtfmdimen then begin tfmchanged := tfmchanged + 1; if x > 0 then x := 16777215 else x := -16777215 end else x := makescaled(x * 16, internal[26]); dimenout := x end; {:1129} {1131:} procedure fixchecksum; label 10; var k: eightbits; b1, b2, b3, b4: eightbits; x: integer; begin if headerbyte[1] < 0 then if headerbyte[2] < 0 then if headerbyte[3] < 0 then if headerbyte[4] < 0 then begin {1132:} b1 := bc; b2 := ec; b3 := bc; b4 := ec; tfmchanged := 0; for k := bc to ec do if charexists[k] then begin x := dimenout(mem[tfmwidth[k] + 1].int) + ((k + 4) * 4194304); b1 := ((b1 + b1) + x) mod 255; b2 := ((b2 + b2) + x) mod 253; b3 := ((b3 + b3) + x) mod 251; b4 := ((b4 + b4) + x) mod 247 end {:1132}; headerbyte[1] := b1; headerbyte[2] := b2; headerbyte[3] := b3; headerbyte[4] := b4; goto 10 end; for k := 1 to 4 do if headerbyte[k] < 0 then headerbyte[k] := 0; 10: null end; {:1131} {1133:} procedure tfmqqqq(x: fourquarters); begin bwritebyte(tfmfile, x.b0 + 128); bwritebyte(tfmfile, x.b1 + 128); bwritebyte(tfmfile, x.b2 + 128); bwritebyte(tfmfile, x.b3 + 128) end; {:1133} {1187:} {779:} function openbasefile: boolean; label 40, 10; var j: 0..bufsize; begin j := curinput.locfield; if buffer[curinput.locfield] = 38 then begin curinput.locfield := curinput.locfield + 1; j := curinput.locfield; buffer[last] := 32; while buffer[j] <> 32 do j := j + 1; packbufferedname(0, curinput.locfield, j - 1); if wopenin(basefile) then goto 40; writeln(output, 'Sorry, I can''t find that base;', ' will try PLAIN.'); flush(output) end; packbufferedname(5, 1, 0); if not wopenin(basefile) then begin writeln(output, 'I can''t find the PLAIN base file!'); openbasefile := false; goto 10 end; 40: curinput.locfield := j; openbasefile := true; 10: null end; {:779} function loadbasefile: boolean; label 6666, 10; var k: integer; p, q: halfword; x: integer; w: fourquarters; {1191:} begin x := basefile^.int; if x <> 503742536 then goto 6666; begin get(basefile); x := basefile^.int end; if x <> (-30000) then goto 6666; begin get(basefile); x := basefile^.int end; if x <> 30000 then goto 6666; begin get(basefile); x := basefile^.int end; if x <> 2100 then goto 6666; begin get(basefile); x := basefile^.int end; if x <> 1777 then goto 6666; begin get(basefile); x := basefile^.int end; if x <> 6 then goto 6666 {:1191}; {1193:} begin begin get(basefile); x := basefile^.int end; if x < 0 then goto 6666; if x > poolsize then begin writeln(output, '---! Must increase the ', 'string pool size'); goto 6666 end else poolptr := x end; begin begin get(basefile); x := basefile^.int end; if x < 0 then goto 6666; if x > maxstrings then begin writeln(output, '---! Must increase the ', 'max strings'); goto 6666 end else strptr := x end; for k := 0 to strptr do begin begin begin get(basefile); x := basefile^.int end; if (x < 0) or (x > poolptr) then goto 6666 else strstart[k] := x end; strref[k] := 127 end; k := 0; while (k + 4) < poolptr do begin begin get(basefile); w := basefile^.qqqq end; strpool[k] := w.b0; strpool[k + 1] := w.b1; strpool[k + 2] := w.b2; strpool[k + 3] := w.b3; k := k + 4 end; k := poolptr - 4; begin get(basefile); w := basefile^.qqqq end; strpool[k] := w.b0; strpool[k + 1] := w.b1; strpool[k + 2] := w.b2; strpool[k + 3] := w.b3 {:1193}; {1195:} begin begin get(basefile); x := basefile^.int end; if (x < (-28978)) or (x > 29997) then goto 6666 else lomemmax := x end; begin begin get(basefile); x := basefile^.int end; if (x < (-29977)) or (x > lomemmax) then goto 6666 else rover := x end; p := -30000; q := rover; x := 0; repeat for k := p to q + 1 do begin get(basefile); mem[k] := basefile^ end; p := q + mem[q].hh.lh; if (p > lomemmax) or ((q >= mem[q + 1].hh.rh) and (mem[q + 1].hh.rh <> rover)) then goto 6666; q := mem[q + 1].hh.rh until q = rover; for k := p to lomemmax do begin get(basefile); mem[k] := basefile^ end; begin begin get(basefile); x := basefile^.int end; if (x < (lomemmax + 1)) or (x > 29998) then goto 6666 else himemmin := x end; begin begin get(basefile); x := basefile^.int end; if (x < (-30000)) or (x > 30000) then goto 6666 else avail := x end; memend := 30000; for k := himemmin to memend do begin get(basefile); mem[k] := basefile^ end; begin get(basefile); varused := basefile^.int end; begin get(basefile); dynused := basefile^.int end {:1195}; {1197:} begin begin get(basefile); x := basefile^.int end; if (x < 1) or (x > 2229) then goto 6666 else hashused := x end; p := 0; repeat begin begin get(basefile); x := basefile^.int end; if (x < (p + 1)) or (x > hashused) then goto 6666 else p := x end; begin get(basefile); hash[p] := basefile^.hh end; begin get(basefile); eqtb[p] := basefile^.hh end until p = hashused; for p := hashused + 1 to 2241 do begin begin get(basefile); hash[p] := basefile^.hh end; begin get(basefile); eqtb[p] := basefile^.hh end end; begin get(basefile); stcount := basefile^.int end {:1197}; {1199:} begin begin get(basefile); x := basefile^.int end; if (x < 40) or (x > maxinternal) then goto 6666 else intptr := x end; for k := 1 to intptr do begin begin get(basefile); internal[k] := basefile^.int end; begin begin get(basefile); x := basefile^.int end; if (x < 0) or (x > strptr) then goto 6666 else intname[k] := x end end; begin begin get(basefile); x := basefile^.int end; if (x < 0) or (x > 2229) then goto 6666 else startsym := x end; begin begin get(basefile); x := basefile^.int end; if (x < 0) or (x > 3) then goto 6666 else interaction := x end; begin begin get(basefile); x := basefile^.int end; if (x < 0) or (x > strptr) then goto 6666 else baseident := x end; begin begin get(basefile); x := basefile^.int end; if (x < 1) or (x > 2241) then goto 6666 else bgloc := x end; begin begin get(basefile); x := basefile^.int end; if (x < 1) or (x > 2241) then goto 6666 else egloc := x end; begin get(basefile); serialno := basefile^.int end; begin get(basefile); x := basefile^.int end; if (x <> 69069) or eof(basefile) then goto 6666 {:1199}; loadbasefile := true; goto 10; 6666: null; writeln(output, '(Fatal base file error; I''m stymied)'); loadbasefile := false; 10: null end; {:1187} {1202:} {823:} procedure scanprimary; label 20, 30, 31, 32; var p, q, r: halfword; c: quarterword; myvarflag: 0..82; ldelim, rdelim: halfword; {831:} groupline: integer; {:831} {836:} num, denom: scaled; {:836} {843:} prehead, posthead, tail: halfword; tt: smallnumber; t: halfword; macroref: halfword; {:843} begin myvarflag := varflag; varflag := 0; 20: begin if aritherror then cleararith end; {825:} {if panicking then checkmem(false);} if interrupt <> 0 then if OKtointerrupt then begin backinput; begin if interrupt <> 0 then pauseforinstructions end; getxnext end {:825}; if curcmd in [31, 32, 39, 42, 33, 34, 30, 36, 43, 37, 35, 40, 38, 41] then case curcmd of 31: begin {826:} ldelim := cursym; rdelim := curmod; getxnext; scanexpression; if (curcmd = 79) and (curtype >= 16) then begin {830:} p := getnode(2); mem[p].hh.b0 := 14; mem[p].hh.b1 := 11; initbignode(p); q := mem[p + 1].int; stashin(q); getxnext; scanexpression; if curtype < 16 then begin disperr(-30000, 639); begin helpptr := 4; helpline[3] := 640; helpline[2] := 641; helpline[1] := 642; helpline[0] := 643 end; putgetflusherror(0) end; stashin(q + 2); checkdelimiter(ldelim, rdelim); curtype := 14; curexp := p end else {:830} checkdelimiter(ldelim, rdelim) end; {:826} 32: begin {832:} groupline := line; if internal[7] > 0 then showcmdmod(curcmd, curmod); begin p := getavail; mem[p].hh.lh := 0; mem[p].hh.rh := saveptr; saveptr := p end; repeat dostatement until curcmd <> 80; if curcmd <> 81 then begin begin if interaction = 3 then null; printnl(133); print(644) end; printint(groupline); print(645); begin helpptr := 2; helpline[1] := 646; helpline[0] := 647 end; backerror; curcmd := 81 end; unsave; if internal[7] > 0 then showcmdmod(curcmd, curmod) end; {:832} 39: begin {833:} curtype := 4; curexp := curmod end; {:833} 42: begin {837:} curexp := curmod; curtype := 16; getxnext; if curcmd <> 54 then begin num := 0; denom := 0 end else begin getxnext; if curcmd <> 42 then begin backinput; curcmd := 54; curmod := 72; cursym := 2233; goto 30 end; num := curexp; denom := curmod; if denom = 0 then begin {838:} begin if interaction = 3 then null; printnl(133); print(648) end; begin helpptr := 1; helpline[0] := 649 end; error end else {:838} curexp := makescaled(num, denom); begin if aritherror then cleararith end; getxnext end; if curcmd >= 30 then if curcmd < 42 then begin p := stashcurexp; scanprimary; if (abs(num) >= abs(denom)) or (curtype < 14) then dobinary(p, 71) else begin fracmult(num, denom); freenode(p, 2) end end; goto 30 end; {:837} 33: {834:} donullary(curmod) {:834}; 34, 30, 36, 43: begin {835:} c := curmod; getxnext; scanprimary; dounary(c); goto 30 end; {:835} 37: begin {839:} c := curmod; getxnext; scanexpression; if curcmd <> 69 then begin missingerr(347); print(581); printcmdmod(37, c); begin helpptr := 1; helpline[0] := 582 end; backerror end; p := stashcurexp; getxnext; scanprimary; dobinary(p, c); goto 30 end; {:839} 35: begin {840:} getxnext; scansuffix; oldsetting := selector; selector := 5; showtokenlist(curexp, -30000, 100000, 0); flushtokenlist(curexp); curexp := makestring; selector := oldsetting; curtype := 4; goto 30 end; {:840} 40: begin {841:} q := curmod; if myvarflag = 77 then begin getxnext; if curcmd = 77 then begin curexp := getavail; mem[curexp].hh.lh := q + 2241; curtype := 20; goto 30 end; backinput end; curtype := 16; curexp := internal[q] end; {:841} 38: makeexpcopy(curmod); 41: begin {844:} begin prehead := avail; if prehead = (-30000) then prehead := getavail else begin avail := mem[prehead].hh.rh; mem[prehead].hh.rh := -30000 end {dynused:=dynused+1;} end; tail := prehead; posthead := -30000; tt := 1; while true do begin t := curtok; mem[tail].hh.rh := t; if tt <> 0 then begin {850:} begin p := mem[prehead].hh.rh; q := mem[p].hh.lh; tt := 0; if (eqtb[q].lh mod 83) = 41 then begin q := eqtb[q].rh; if q = (-30000) then goto 32; while true do begin p := mem[p].hh.rh; if p = (-30000) then begin tt := mem[q].hh.b0; goto 32 end; if mem[q].hh.b0 <> 21 then goto 32; q := mem[mem[q + 1].hh.lh].hh.rh; if p >= himemmin then begin repeat q := mem[q].hh.rh until mem[q + 2].hh.lh >= mem[p].hh.lh; if mem[q + 2].hh.lh > mem[p].hh.lh then goto 32 end end end; 32: {:850} null end; if tt >= 22 then begin {845:} mem[tail].hh.rh := -30000; if tt > 22 then begin posthead := getavail; tail := posthead; mem[tail].hh.rh := t; tt := 0; macroref := mem[q + 1].int; mem[macroref].hh.lh := mem[macroref].hh.lh + 1 end else begin {853:} p := getavail; mem[prehead].hh.lh := mem[prehead].hh.rh; mem[prehead].hh.rh := p; mem[p].hh.lh := t; macrocall(mem[q + 1].int, prehead, -30000); getxnext; goto 20 end {:853} end {:845} end; getxnext; tail := t; if curcmd = 63 then begin {846:} getxnext; scanexpression; if curcmd <> 64 then begin {847:} backinput; backexpr; curcmd := 63; curmod := 0; cursym := 2232 end else begin {:847} if curtype <> 16 then badsubscript; curcmd := 42; curmod := curexp; cursym := 0 end end {:846}; if curcmd > 42 then goto 31; if curcmd < 40 then goto 31 end; 31: {852:} if posthead <> (-30000) then begin {854:} backinput; p := getavail; q := mem[posthead].hh.rh; mem[prehead].hh.lh := mem[prehead].hh.rh; mem[prehead].hh.rh := posthead; mem[posthead].hh.lh := q; mem[posthead].hh.rh := p; mem[p].hh.lh := mem[q].hh.rh; mem[q].hh.rh := -30000; macrocall(macroref, prehead, -30000); mem[macroref].hh.lh := mem[macroref].hh.lh - 1; getxnext; goto 20 end {:854}; q := mem[prehead].hh.rh; begin mem[prehead].hh.rh := avail; avail := prehead end {dynused:=dynused-1;}; if curcmd = myvarflag then begin curtype := 20; curexp := q; goto 30 end; p := findvariable(q); if p <> (-30000) then makeexpcopy(p) else begin obliterated(q); helpline[2] := 661; helpline[1] := 662; helpline[0] := 663; putgetflusherror(0) end; flushnodelist(q); goto 30 {:852} end end else begin {:844} badexp(633); goto 20 end; getxnext; 30: if curcmd = 63 then if curtype >= 16 then begin {859:} p := stashcurexp; getxnext; scanexpression; if curcmd <> 79 then begin {847:} begin backinput; backexpr; curcmd := 63; curmod := 0; cursym := 2232 end {:847}; unstashcurexp(p) end else begin q := stashcurexp; getxnext; scanexpression; if curcmd <> 64 then begin missingerr(93); begin helpptr := 3; helpline[2] := 665; helpline[1] := 666; helpline[0] := 563 end; backerror end; r := stashcurexp; makeexpcopy(q); dobinary(r, 70); dobinary(p, 71); dobinary(q, 69); getxnext end end {:859} end; {:823} {860:} procedure scansuffix; label 30; var h, t: halfword; p: halfword; begin h := getavail; t := h; while true do begin if curcmd = 63 then begin {861:} getxnext; scanexpression; if curtype <> 16 then badsubscript; if curcmd <> 64 then begin missingerr(93); begin helpptr := 3; helpline[2] := 667; helpline[1] := 666; helpline[0] := 563 end; backerror end; curcmd := 42; curmod := curexp end {:861}; if curcmd = 42 then p := newnumtok(curmod) else if (curcmd = 41) or (curcmd = 40) then begin p := getavail; mem[p].hh.lh := cursym end else goto 30; mem[t].hh.rh := p; t := p; getxnext end; 30: curexp := mem[h].hh.rh; begin mem[h].hh.rh := avail; avail := h end {dynused:=dynused-1;}; curtype := 20 end; {:860} {862:} procedure scansecondary; label 20, 22; var p, q, r: halfword; c, d: halfword; macname: halfword; begin 20: if (curcmd < 30) or (curcmd > 43) then badexp(668); scanprimary; 22: if curcmd <= 55 then if curcmd >= 52 then begin p := stashcurexp; c := curmod; d := curcmd; if d = 53 then begin macname := cursym; mem[c].hh.lh := mem[c].hh.lh + 1 end; getxnext; scanprimary; if d <> 53 then dobinary(p, c) else begin backinput; binarymac(p, c, macname); mem[c].hh.lh := mem[c].hh.lh - 1; getxnext; goto 20 end; goto 22 end end; {:862} {864:} procedure scantertiary; label 20, 22; var p: halfword; c, d: halfword; macname: halfword; begin 20: if (curcmd < 30) or (curcmd > 43) then badexp(669); scansecondary; if curtype = 8 then materializepen; 22: if curcmd <= 45 then if curcmd >= 43 then begin p := stashcurexp; c := curmod; d := curcmd; if d = 44 then begin macname := cursym; mem[c].hh.lh := mem[c].hh.lh + 1 end; getxnext; scansecondary; if d <> 44 then dobinary(p, c) else begin backinput; binarymac(p, c, macname); mem[c].hh.lh := mem[c].hh.lh - 1; getxnext; goto 20 end; goto 22 end end; {:864} {868:} procedure scanexpression; label 20, 30, 22, 25, 26, 10; var p, q, r, pp, qq: halfword; c, d: halfword; myvarflag: 0..82; macname: halfword; cyclehit: boolean; x, y: scaled; t: 0..4; begin myvarflag := varflag; 20: if (curcmd < 30) or (curcmd > 43) then badexp(672); scantertiary; 22: if curcmd <= 51 then if curcmd >= 46 then if (curcmd <> 51) or (myvarflag <> 77) then begin p := stashcurexp; c := curmod; d := curcmd; if d = 49 then begin macname := cursym; mem[c].hh.lh := mem[c].hh.lh + 1 end; if (d < 48) or ((d = 48) and ((mem[p].hh.b0 = 14) or (mem[p].hh.b0 = 9))) then begin {869:} cyclehit := false; {870:} begin unstashcurexp(p); if curtype = 14 then p := newknot else if curtype = 9 then p := curexp else goto 10; q := p; while mem[q].hh.rh <> p do q := mem[q].hh.rh; if mem[p].hh.b0 <> 0 then begin r := copyknot(p); mem[q].hh.rh := r; q := r end; mem[p].hh.b0 := 4; mem[q].hh.b1 := 4 end {:870}; 25: {874:} if curcmd = 46 then begin {879:} t := scandirection; if t <> 4 then begin mem[q].hh.b1 := t; mem[q + 5].int := curexp; if mem[q].hh.b0 = 4 then begin mem[q].hh.b0 := t; mem[q + 3].int := curexp end end end {:879}; d := curcmd; if d = 47 then begin {881:} getxnext; if curcmd = 58 then begin {882:} getxnext; y := curcmd; if curcmd = 59 then getxnext; scanprimary; {883:} if (curtype <> 16) or (curexp < 49152) then begin disperr(-30000, 690); begin helpptr := 1; helpline[0] := 691 end; putgetflusherror(65536) end {:883}; if y = 59 then curexp := -curexp; mem[q + 6].int := curexp; if curcmd = 52 then begin getxnext; y := curcmd; if curcmd = 59 then getxnext; scanprimary; {883:} if (curtype <> 16) or (curexp < 49152) then begin disperr(-30000, 690); begin helpptr := 1; helpline[0] := 691 end; putgetflusherror(65536) end {:883}; if y = 59 then curexp := -curexp end; y := curexp end else if curcmd = 57 then begin {:882} {884:} mem[q].hh.b1 := 1; t := 1; getxnext; scanprimary; knownpair; mem[q + 5].int := curx; mem[q + 6].int := cury; if curcmd <> 52 then begin x := mem[q + 5].int; y := mem[q + 6].int end else begin getxnext; scanprimary; knownpair; x := curx; y := cury end end else begin {:884} mem[q + 6].int := 65536; y := 65536; backinput; goto 30 end; if curcmd <> 47 then begin missingerr(279); begin helpptr := 1; helpline[0] := 689 end; backerror end; 30: {:881} null end else if d <> 48 then goto 26; getxnext; if curcmd = 46 then begin {880:} t := scandirection; if mem[q].hh.b1 <> 1 then x := curexp else t := 1 end else if mem[q].hh.b1 <> 1 then begin {:880} t := 4; x := 0 end {:874}; if curcmd = 36 then begin {886:} cyclehit := true; getxnext; pp := p; qq := p; if d = 48 then if p = q then begin d := 47; mem[q + 6].int := 65536; y := 65536 end end else begin {:886} scantertiary; {885:} begin if curtype <> 9 then pp := newknot else pp := curexp; qq := pp; while mem[qq].hh.rh <> pp do qq := mem[qq].hh.rh; if mem[pp].hh.b0 <> 0 then begin r := copyknot(pp); mem[qq].hh.rh := r; qq := r end; mem[pp].hh.b0 := 4; mem[qq].hh.b1 := 4 end {:885} end; {887:} begin if d = 48 then if (mem[q + 1].int <> mem[pp + 1].int) or (mem[q + 2].int <> mem[pp + 2].int) then begin begin if interaction = 3 then null; printnl(133); print(692) end; begin helpptr := 3; helpline[2] := 693; helpline[1] := 694; helpline[0] := 695 end; putgeterror; d := 47; mem[q + 6].int := 65536; y := 65536 end; {889:} if mem[pp].hh.b1 = 4 then if (t = 3) or (t = 2) then begin mem[pp].hh.b1 := t; mem[pp + 5].int := x end {:889}; if d = 48 then begin {890:} if mem[q].hh.b0 = 4 then if mem[q].hh.b1 = 4 then begin mem[q].hh.b0 := 3; mem[q + 3].int := 65536 end; if mem[pp].hh.b1 = 4 then if t = 4 then begin mem[pp].hh.b1 := 3; mem[pp + 5].int := 65536 end; mem[q].hh.b1 := mem[pp].hh.b1; mem[q].hh.rh := mem[pp].hh.rh; mem[q + 5].int := mem[pp + 5].int; mem[q + 6].int := mem[pp + 6].int; freenode(pp, 7); if qq = pp then qq := q end else begin {:890} {888:} if mem[q].hh.b1 = 4 then if (mem[q].hh.b0 = 3) or (mem[q].hh.b0 = 2) then begin mem[q].hh.b1 := mem[q].hh.b0; mem[q + 5].int := mem[q + 3].int end {:888}; mem[q].hh.rh := pp; mem[pp + 4].int := y; if t <> 4 then begin mem[pp + 3].int := x; mem[pp].hh.b0 := t end end; q := qq end {:887}; if curcmd >= 46 then if curcmd <= 48 then if not cyclehit then goto 25; 26: {891:} if cyclehit then begin if d = 48 then p := q end else begin mem[p].hh.b0 := 0; if mem[p].hh.b1 = 4 then begin mem[p].hh.b1 := 3; mem[p + 5].int := 65536 end; mem[q].hh.b1 := 0; if mem[q].hh.b0 = 4 then begin mem[q].hh.b0 := 3; mem[q + 3].int := 65536 end; mem[q].hh.rh := p end; makechoices(p); curtype := 9; curexp := p {:891} end else begin {:869} getxnext; scantertiary; if d <> 49 then dobinary(p, c) else begin backinput; binarymac(p, c, macname); mem[c].hh.lh := mem[c].hh.lh - 1; getxnext; goto 20 end end; goto 22 end; 10: null end; {:868} {892:} procedure getboolean; begin getxnext; scanexpression; if curtype <> 2 then begin disperr(-30000, 696); begin helpptr := 2; helpline[1] := 697; helpline[0] := 698 end; putgetflusherror(31); curtype := 2 end end; {:892} {224:} procedure printcapsule; begin printchar(40); printexp(gpointer, 0); printchar(41) end; procedure tokenrecycle; begin recyclevalue(gpointer) end; {:224} {1205:} procedure closefilesandtermina; var k: integer; lh: integer; p: halfword; x: scaled; {if internal[12]>0 then[1208:]if jobname>0 then begin writeln( logfile,' '); writeln(logfile,'Here is how much of METAFONT''s memory',' you used:'); write(logfile,' ',maxstrptr-initstrptr:1,' string'); if maxstrptr<>initstrptr+1 then write(logfile,'s'); writeln(logfile,' out of ',maxstrings-initstrptr:1); writeln(logfile,' ',maxpoolptr-initpoolptr:1, ' string characters out of ',poolsize-initpoolptr:1); writeln(logfile,' ',lomemmax+30000+memend-himemmin+2:1, ' words of memory out of ',memend+30001:1); writeln(logfile,' ',stcount:1,' symbolic tokens out of ',2100:1); writeln(logfile,' ',maxinstack:1,'i,',intptr:1,'n,',maxroundingptr:1, 'r,',maxparamstack:1,'p,',maxbufstack+1:1,'b stack positions out of ', stacksize:1,'i,',maxinternal:1,'n,',maxwiggle:1,'r,',150:1,'p,',bufsize: 1,'b');end[:1208];} begin {1206:} if (gfprevptr > 0) or (internal[33] > 0) then begin {1207:} rover := -29977; mem[rover].hh.rh := 32767; lomemmax := himemmin - 1; if (lomemmax - rover) > 32767 then lomemmax := 32767 + rover; mem[rover].hh.lh := lomemmax - rover; mem[rover + 1].hh.lh := rover; mem[rover + 1].hh.rh := rover; mem[lomemmax].hh.rh := -30000; mem[lomemmax].hh.lh := -30000 {:1207}; {1124:} mem[29999].hh.rh := -29981; for k := bc to ec do if charexists[k] then tfmwidth[k] := sortin(tfmwidth[k]); nw := skimp(255) + 1; dimenhead[1] := mem[29999].hh.rh; if perturbation >= 4096 then tfmwarning(20) {:1124}; fixdesignsize; fixchecksum; if internal[33] > 0 then begin {1126:} mem[29999].hh.rh := -29981; for k := bc to ec do if charexists[k] then if tfmheight[k] = 0 then tfmheight[k] := -29985 else tfmheight[k] := sortin(tfmheight[k]); nh := skimp(15) + 1; dimenhead[2] := mem[29999].hh.rh; if perturbation >= 4096 then tfmwarning(21); mem[29999].hh.rh := -29981; for k := bc to ec do if charexists[k] then if tfmdepth[k] = 0 then tfmdepth[k] := -29985 else tfmdepth[k] := sortin(tfmdepth[k]); nd := skimp(15) + 1; dimenhead[3] := mem[29999].hh.rh; if perturbation >= 4096 then tfmwarning(22); mem[29999].hh.rh := -29981; for k := bc to ec do if charexists[k] then if tfmitalcorr[k] = 0 then tfmitalcorr[k] := -29985 else tfmitalcorr[k] := sortin(tfmitalcorr[k]); ni := skimp(63) + 1; dimenhead[4] := mem[29999].hh.rh; if perturbation >= 4096 then tfmwarning(23) {:1126}; {1134:} if jobname = 0 then openlogfile; packjobname(901); while not bopenout(tfmfile, nameoffile) do promptfilename(902, 901); metricfilename := bmakenamestring(tfmfile); {1135:} k := headersize; while headerbyte[k] < 0 do k := k - 1; lh := (k + 3) div 4; if bc > ec then bc := 1; bwrite2bytes(tfmfile, (((((((((6 + lh) + ((ec - bc) + 1)) + nw) + nh) + nd) + ni) + nl) + nk) + ne) + np); bwrite2bytes(tfmfile, lh); bwrite2bytes(tfmfile, bc); bwrite2bytes(tfmfile, ec); bwrite2bytes(tfmfile, nw); bwrite2bytes(tfmfile, nh); bwrite2bytes(tfmfile, nd); bwrite2bytes(tfmfile, ni); bwrite2bytes(tfmfile, nl); bwrite2bytes(tfmfile, nk); bwrite2bytes(tfmfile, ne); bwrite2bytes(tfmfile, np); for k := 1 to 4 * lh do begin if headerbyte[k] < 0 then headerbyte[k] := 0; bwritebyte(tfmfile, headerbyte[k]) end {:1135}; {1137:} for k := bc to ec do if not charexists[k] then bwrite4bytes(tfmfile, 0) else begin bwritebyte(tfmfile, mem[tfmwidth[k]].hh.lh); bwritebyte(tfmfile, (mem[tfmheight[k]].hh.lh * 16) + mem[tfmdepth[k]].hh.lh); bwritebyte(tfmfile, (mem[tfmitalcorr[k]].hh.lh * 4) + chartag[k]); bwritebyte(tfmfile, charremainder[k]) end {:1137}; {1138:} tfmchanged := 0; for k := 1 to 4 do begin bwrite4bytes(tfmfile, 0); p := dimenhead[k]; while p <> (-29981) do begin bwrite4bytes(tfmfile, dimenout(mem[p + 1].int)); p := mem[p].hh.rh end end {:1138}; {1139:} for k := 0 to nl - 1 do tfmqqqq(ligkern[k]); for k := 0 to nk - 1 do bwrite4bytes(tfmfile, dimenout(kern[k])) {:1139}; {1140:} for k := 0 to ne - 1 do tfmqqqq(exten[k]) {:1140}; {1141:} for k := 1 to np do if k = 1 then if abs(param[1]) < 134217728 then bwrite4bytes(tfmfile, param[1] * 16) else begin tfmchanged := tfmchanged + 1; if param[1] > 0 then bwrite4bytes(tfmfile, 2147483647) else bwrite4bytes(tfmfile, -2147483647) end else bwrite4bytes(tfmfile, dimenout(param[k])); if tfmchanged > 0 then begin if tfmchanged = 1 then printnl(904) else begin printnl(40); printint(tfmchanged); print(905) end; print(906) end {:1141}; {if internal[12]>0 then[1136:]begin writeln(logfile,' '); writeln(logfile,'(You used ',nw:1,'w,',nh:1,'h,',nd:1,'d,',ni:1,'i,',nl: 1,'l,',nk:1,'k,',ne:1,'e,',np:1,'p metric file positions'); writeln(logfile,' out of ','256w,16h,16d,64i,',ligtablesize:1, 'l,256k,256e,',maxfontdimen:1,'p)');end[:1136];} printnl(903); print(metricfilename); bclose(tfmfile) {:1134} end; if gfprevptr > 0 then begin {1182:} begin gfbuf[gfptr] := 248; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gffour(gfprevptr); gfprevptr := (gfoffset + gfptr) - 5; gffour(internal[26] * 16); for k := 1 to 4 do begin gfbuf[gfptr] := headerbyte[k]; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gffour(internal[27]); gffour(internal[28]); gffour(gfminm); gffour(gfmaxm); gffour(gfminn); gffour(gfmaxn); for k := 0 to 255 do if charexists[k] then begin x := gfdx[k] div 65536; if (((gfdy[k] = 0) and (x >= 0)) and (x < 256)) and (gfdx[k] = (x * 65536)) then begin begin gfbuf[gfptr] := 246; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := k; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := x; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end end else begin begin gfbuf[gfptr] := 245; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; begin gfbuf[gfptr] := k; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gffour(gfdx[k]); gffour(gfdy[k]) end; x := mem[tfmwidth[k] + 1].int; if abs(x) > maxtfmdimen then if x > 0 then x := 16777215 else x := -16777215 else x := makescaled(x * 16, internal[26]); gffour(x); gffour(charptr[k]) end; begin gfbuf[gfptr] := 249; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; gffour(gfprevptr); begin gfbuf[gfptr] := 131; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; k := 4 + ((gfbufsize - gfptr) mod 4); while k > 0 do begin begin gfbuf[gfptr] := 223; gfptr := gfptr + 1; if gfptr = gflimit then gfswap end; k := k - 1 end; {1156:} if gflimit = halfbuf then bwritebuf(gffile, gfbuf, halfbuf, gfbufsize - 1); if gfptr > 0 then bwritebuf(gffile, gfbuf, 0, gfptr - 1) {:1156}; printnl(917); print(outputfilename); print(425); printint(totalchars); print(918); if totalchars <> 1 then printchar(115); print(919); printint(gfoffset + gfptr); print(920); bclose(gffile) end {:1182} end {:1206}; if jobname > 0 then begin writeln(logfile); aclose(logfile); selector := selector - 2; if selector = 1 then begin printnl(929); print(logname); printchar(46) end end; println; if (editnamestart <> 0) and (interaction > 0) then calledit(strpool[editnamestart], editnamelength, editline) end; {:1205} {1209:} procedure finalcleanup; label 10; var c: smallnumber; begin c := curmod; if jobname = 0 then openlogfile; while condptr <> (-30000) do begin printnl(930); printcmdmod(2, curif); if ifline <> 0 then begin print(931); printint(ifline) end; print(932); ifline := mem[condptr + 1].int; curif := mem[condptr].hh.b1; condptr := mem[condptr].hh.rh end; if history <> 0 then if (history = 1) or (interaction < 3) then if selector = 3 then begin selector := 1; printnl(933); selector := 3 end; if c = 1 then begin {storebasefile;goto 10;} printnl(934); goto 10 end; 10: null end; {:1209} {1210:} {procedure initprim;begin[192:]primitive(280,40,1); primitive(281,40,2);primitive(282,40,3);primitive(283,40,4); primitive(284,40,5);primitive(285,40,6);primitive(286,40,7); primitive(287,40,8);primitive(288,40,9);primitive(289,40,10); primitive(290,40,11);primitive(291,40,12);primitive(292,40,13); primitive(293,40,14);primitive(294,40,15);primitive(295,40,16); primitive(296,40,17);primitive(297,40,18);primitive(298,40,19); primitive(299,40,20);primitive(300,40,21);primitive(301,40,22); primitive(302,40,23);primitive(303,40,24);primitive(304,40,25); primitive(305,40,26);primitive(306,40,27);primitive(307,40,28); primitive(308,40,29);primitive(309,40,30);primitive(310,40,31); primitive(311,40,32);primitive(312,40,33);primitive(313,40,34); primitive(314,40,35);primitive(315,40,36);primitive(316,40,37); primitive(317,40,38);primitive(318,40,39);primitive(319,40,40); [:192][211:]primitive(279,47,0);primitive(91,63,0); eqtb[2232]:=eqtb[cursym];primitive(93,64,0);primitive(125,65,0); primitive(123,46,0);primitive(58,78,0);eqtb[2234]:=eqtb[cursym]; primitive(329,77,0);primitive(44,79,0);primitive(59,80,0); eqtb[2235]:=eqtb[cursym];primitive(92,7,0);primitive(330,18,0); primitive(331,72,0);primitive(332,59,0);primitive(333,32,0); bgloc:=cursym;primitive(334,57,0);primitive(335,19,0); primitive(336,60,0);primitive(337,27,0);primitive(338,11,0); primitive(323,81,0);eqtb[2239]:=eqtb[cursym];egloc:=cursym; primitive(339,26,0);primitive(340,6,0);primitive(341,9,0); primitive(342,70,0);primitive(343,73,0);primitive(344,13,0); primitive(345,14,0);primitive(346,15,0);primitive(347,69,0); primitive(348,28,0);primitive(349,24,0);primitive(350,12,0); primitive(351,8,0);primitive(352,17,0);primitive(353,74,0); primitive(354,35,0);primitive(355,58,0);primitive(356,71,0); primitive(357,75,0);[:211][683:]primitive(520,16,1);primitive(521,16,2); primitive(522,16,53);primitive(523,16,44);primitive(524,16,49); primitive(324,16,0);eqtb[2237]:=eqtb[cursym];primitive(525,4,2242); primitive(526,4,2392);primitive(527,4,1);primitive(325,4,0); eqtb[2236]:=eqtb[cursym];[:683][688:]primitive(528,61,0); primitive(529,61,1);primitive(64,61,2);primitive(530,61,3); [:688][695:]primitive(541,56,2242);primitive(542,56,2392); primitive(543,56,2542);primitive(544,56,1);primitive(545,56,2); primitive(546,56,3);[:695][709:]primitive(556,3,0);primitive(482,3,1); [:709][740:]primitive(583,1,1);primitive(322,2,2); eqtb[2238]:=eqtb[cursym];primitive(584,2,3);primitive(585,2,4); [:740][893:]primitive(218,33,30);primitive(219,33,31); primitive(220,33,32);primitive(221,33,33);primitive(222,33,34); primitive(223,33,35);primitive(224,33,36);primitive(225,33,37); primitive(226,34,38);primitive(227,34,39);primitive(228,34,40); primitive(229,34,41);primitive(230,34,42);primitive(231,34,43); primitive(232,34,44);primitive(233,34,45);primitive(234,34,46); primitive(235,34,47);primitive(236,34,48);primitive(237,34,49); primitive(238,34,50);primitive(239,34,51);primitive(240,34,52); primitive(241,34,53);primitive(242,34,54);primitive(243,34,55); primitive(244,34,56);primitive(245,34,57);primitive(246,34,58); primitive(247,34,59);primitive(248,34,60);primitive(249,34,61); primitive(250,34,62);primitive(251,34,63);primitive(252,34,64); primitive(253,34,65);primitive(254,34,66);primitive(255,34,67); primitive(256,36,68);primitive(43,43,69);primitive(45,43,70); primitive(42,55,71);primitive(47,54,72);eqtb[2233]:=eqtb[cursym]; primitive(257,45,73);primitive(181,45,74);primitive(259,52,76); primitive(258,45,75);primitive(60,50,77);primitive(260,50,78); primitive(62,50,79);primitive(261,50,80);primitive(61,51,81); primitive(262,50,82);primitive(272,37,94);primitive(273,37,95); primitive(274,37,96);primitive(275,37,97);primitive(276,37,98); primitive(277,37,99);primitive(278,37,100);primitive(38,48,83); primitive(263,55,84);primitive(264,55,85);primitive(265,55,86); primitive(266,55,87);primitive(267,55,88);primitive(268,55,89); primitive(269,55,90);primitive(270,55,91);primitive(271,45,92); [:893][1013:]primitive(211,30,15);primitive(197,30,4); primitive(195,30,2);primitive(202,30,9);primitive(199,30,6); primitive(204,30,11);primitive(206,30,13);primitive(207,30,14); [:1013][1018:]primitive(776,82,0);primitive(777,82,1); [:1018][1024:]primitive(143,23,0);primitive(144,23,1); primitive(145,23,2);primitive(783,23,3); [:1024][1027:]primitive(784,21,0);primitive(785,21,1); [:1027][1037:]primitive(799,22,0);primitive(800,22,1); primitive(801,22,2);primitive(802,22,3);primitive(803,22,4); [:1037][1052:]primitive(820,68,1);primitive(821,68,0); primitive(822,68,2);primitive(823,66,6);primitive(824,66,16); primitive(825,67,0);primitive(826,67,1); [:1052][1079:]primitive(856,25,0);primitive(857,25,1); primitive(858,25,2);[:1079][1101:]primitive(868,20,0); primitive(869,20,1);primitive(870,20,2);primitive(871,20,3); primitive(872,20,4);[:1101][1109:]primitive(889,76,0); primitive(890,76,128);[:1109][1176:]primitive(912,29,4); primitive(913,29,16);[:1176];end;procedure inittab;var k:integer; begin[176:]rover:=-29977;mem[rover].hh.rh:=32767;mem[rover].hh.lh:=1000; mem[rover+1].hh.lh:=rover;mem[rover+1].hh.rh:=rover; lomemmax:=rover+1000;mem[lomemmax].hh.rh:=-30000; mem[lomemmax].hh.lh:=-30000; for k:=29998 to 30000 do mem[k]:=mem[lomemmax];avail:=-30000; memend:=30000;himemmin:=29998;varused:=23;dynused:=-1; [:176][193:]intname[1]:=280;intname[2]:=281;intname[3]:=282; intname[4]:=283;intname[5]:=284;intname[6]:=285;intname[7]:=286; intname[8]:=287;intname[9]:=288;intname[10]:=289;intname[11]:=290; intname[12]:=291;intname[13]:=292;intname[14]:=293;intname[15]:=294; intname[16]:=295;intname[17]:=296;intname[18]:=297;intname[19]:=298; intname[20]:=299;intname[21]:=300;intname[22]:=301;intname[23]:=302; intname[24]:=303;intname[25]:=304;intname[26]:=305;intname[27]:=306; intname[28]:=307;intname[29]:=308;intname[30]:=309;intname[31]:=310; intname[32]:=311;intname[33]:=312;intname[34]:=313;intname[35]:=314; intname[36]:=315;intname[37]:=316;intname[38]:=317;intname[39]:=318; intname[40]:=319;[:193][203:]hashused:=2229;stcount:=0; hash[2240].rh:=321;hash[2238].rh:=322;hash[2239].rh:=323; hash[2237].rh:=324;hash[2236].rh:=325;hash[2235].rh:=59; hash[2234].rh:=58;hash[2233].rh:=47;hash[2232].rh:=91;hash[2231].rh:=41; hash[2229].rh:=326;eqtb[2231].lh:=62; [:203][229:]mem[-29981].hh.lh:=2242;mem[-29981].hh.rh:=-30000; [:229][324:]mem[30000].hh.lh:=32767; [:324][475:]mem[-29997].hh.lh:=-30000;mem[-29997].hh.rh:=-30000; mem[-29996].hh.lh:=1;mem[-29996].hh.rh:=-30000; for k:=-29995 to-29989 do mem[k]:=mem[-29996];mem[-29988].int:=0; mem[-30000].hh.rh:=-30000;mem[-30000].hh.lh:=-30000;mem[-29999].int:=0; mem[-29998].int:=0;[:475][587:]serialno:=0;mem[-29987].hh.rh:=-29987; mem[-29986].hh.lh:=-29987;mem[-29987].hh.lh:=-30000; mem[-29986].hh.rh:=-30000;[:587][702:]mem[-29979].hh.b1:=0; mem[-29979].hh.rh:=2240;eqtb[2240].rh:=-29979;eqtb[2240].lh:=41; [:702][759:]eqtb[2230].lh:=88;hash[2230].rh:=600; [:759][911:]mem[-29983].hh.b1:=11; [:911][1116:]mem[-29980].int:=1073741824; [:1116][1127:]mem[-29984].int:=0;mem[-29985].hh.lh:=0; [:1127][1185:]baseident:=921;[:1185]end;} {:1210} {1212:} {procedure debughelp;label 888,10;var k,l,m,n:integer; begin while true do begin;printnl(935);flush(output);read(input,m); if m<0 then goto 10 else if m=0 then begin goto 888; 888:m:=0; ['BREAKPOINT'] end else begin read(input,n);case m of[1213:]1:printword(mem[n]); 2:printint(mem[n].hh.lh);3:printint(mem[n].hh.rh); 4:begin printint(eqtb[n].lh);printchar(58);printint(eqtb[n].rh);end; 5:printvariablename(n);6:printint(internal[n]);7:doshowdependencies; 9:showtokenlist(n,-30000,100000,0);10:print(n);11:checkmem(n>0); 12:searchmem(n);13:begin read(input,l);printcmdmod(n,l);end; 14:for k:=0 to n do print(buffer[k]);15:panicking:=not panicking; [:1213]others:print(63)end;end;end;10:end;} {:1212} {:1202} {1204:} begin {-----------------------------------} init_ps(psfile); {-----------------------------------} history := 3; setpaths; if readyalready = 314159 then goto 1; {14:} bad := 0; if (halferrorline < 30) or (halferrorline > (errorline - 15)) then bad := 1; if maxprintline < 60 then bad := 2; if (gfbufsize mod 8) <> 0 then bad := 3; if (-28900) > 30000 then bad := 4; if 1777 > 2100 then bad := 5; if (headersize mod 4) <> 0 then bad := 6; {:14} {154:} {if memmax<>30000 then bad:=10;} if memmax < 30000 then bad := 10; if ((-128) > 0) or (127 < 127) then bad := 11; if ((-32768) > 0) or (32767 < 32767) then bad := 12; if ((-128) < (-32768)) or (127 > 32767) then bad := 13; if ((-30000) < (-32768)) or (memmax >= 32767) then bad := 14; if maxstrings > 32767 then bad := 15; if bufsize > 32767 then bad := 16; if (255 < 255) or (65535 < 65535) then bad := 17; {:154} {204:} if (2241 + maxinternal) > 32767 then bad := 21; {:204} {214:} if 2692 > 32767 then bad := 22; {:214} {310:} if (15 * 11) > bistacksize then bad := 31; {:310} {553:} if (20 + (17 * 45)) > bistacksize then bad := 32; {:553} {777:} if 10 > filenamesize then bad := 41; {:777} if bad > 0 then begin writeln(output, 'Ouch---my internal constants have been clobbered!', '---case ', bad: 1); {if not getstringsstarted then goto 9999; inittab;initprim;} goto 9999 end; initialize; readyalready := 314159; 1: {55:} selector := 1; tally := 0; termoffset := 0; fileoffset := 0; {:55} {61:} write(output, 'This is METAFONT, Version 1.0 for Berkeley UNIX'); {-----------------------------------------------------------------} writeln(output); writeln(output,'*** embedded METAFONT to PostScript Compiler ***'); {-----------------------------------------------------------------} if baseident = 0 then writeln(output, ' (no base preloaded)') else begin print(baseident); println end; flush(output); {:61} {783:} jobname := 0; {:783} {792:} outputfilename := 0; {:792} {1211:} {657:} begin begin inputptr := 0; maxinstack := 0; inopen := 0; maxbufstack := 0; paramptr := 0; maxparamstack := 0; first := 1; curinput.startfield := 1; curinput.indexfield := 0; line := 0; curinput.namefield := 0; forceeof := false; if not initterminal then goto 9999; curinput.limitfield := last; first := last + 1 end; {:657} {660:} scannerstatus := 0; {:660} if (baseident = 0) or (buffer[curinput.locfield] = 38) then begin if baseident <> 0 then initialize; if not openbasefile then goto 9999; if not loadbasefile then begin wclose(basefile); goto 9999 end; wclose(basefile); while (curinput.locfield < curinput.limitfield) and (buffer[curinput.locfield] = 32) do curinput.locfield := curinput.locfield + 1 end; buffer[curinput.limitfield] := 37; fixdateandtime; initrandoms((internal[17] div 65536) + internal[16]); {70:} if interaction = 0 then selector := 0 else selector := 1 {:70}; if curinput.locfield < curinput.limitfield then if buffer[curinput.locfield] <> 92 then startinput end {:1211}; initstrptr := strptr; initpoolptr := poolptr; maxstrptr := strptr; maxpoolptr := poolptr; history := 0; if startsym > 0 then begin cursym := startsym; backinput end; maincontrol; finalcleanup; 9998: closefilesandtermina; 9999: readyalready := 0; {---------------------------------} tini_ps(g); {---------------------------------} if (history <> 0) and (history <> 1) then exit(1) else exit(0); end. {:1204}