#include "mf2ps1.h" #include "mf2ps2.h" procedure makemoves; label 22, 30, 10; var x1, x2, x3, m, r, y1, y2, y3, n, s, l: integer; q, t, u, x2a, x3a, y2a, y3a: integer; begin {---------------------------------------------------------} if (CurveSource=465) { from fillspec - no offset } or (CurveSource=512) { from fillenvelope - with offset } or (CurveSource=518) { -------- " -------- } then sendcurve(xx0,xx1,xx2,xx3,yy0,yy1,yy2,yy3,oc); {---------------------------------------------------------} if (xx3 < xx0) or (yy3 < yy0) then confusion(109); l := 16; bisectptr := 0; x1 := xx1 - xx0; x2 := xx2 - xx1; x3 := xx3 - xx2; if xx0 >= xicorr then r := (xx0 - xicorr) mod 65536 else r := 65535 - ((((-xx0) + xicorr) - 1) mod 65536); m := ((xx3 - xx0) + r) div 65536; y1 := yy1 - yy0; y2 := yy2 - yy1; y3 := yy3 - yy2; if yy0 >= etacorr then s := (yy0 - etacorr) mod 65536 else s := 65535 - ((((-yy0) + etacorr) - 1) mod 65536); n := ((yy3 - yy0) + s) div 65536; if ((xx3 - xx0) >= 268435456) or ((yy3 - yy0) >= 268435456) then begin {313:} x1 := (x1 + xicorr) div 2; x2 := (x2 + xicorr) div 2; x3 := (x3 + xicorr) div 2; r := (r + xicorr) div 2; y1 := (y1 + etacorr) div 2; y2 := (y2 + etacorr) div 2; y3 := (y3 + etacorr) div 2; s := (s + etacorr) div 2; l := 15 end {:313}; while true do begin 22: {314:} if m = 0 then {315:} while n > 0 do begin moveptr := moveptr + 1; move[moveptr] := 1; n := n - 1 end {:315} else if n = 0 then {316:} move[moveptr] := move[moveptr] + m {:316} else if (m + n) = 2 then begin {317:} r := twotothe[l] - r; s := twotothe[l] - s; while l < 30 do begin x3a := x3; x2a := ((x2 + x3) + xicorr) div 2; x2 := ((x1 + x2) + xicorr) div 2; x3 := ((x2 + x2a) + xicorr) div 2; t := (x1 + x2) + x3; r := (r + r) - xicorr; y3a := y3; y2a := ((y2 + y3) + etacorr) div 2; y2 := ((y1 + y2) + etacorr) div 2; y3 := ((y2 + y2a) + etacorr) div 2; u := (y1 + y2) + y3; s := (s + s) - etacorr; if t < r then if u < s then begin {318:} x1 := x3; x2 := x2a; x3 := x3a; r := r - t; y1 := y3; y2 := y2a; y3 := y3a; s := s - u end else begin {:318} {320:} begin moveptr := moveptr + 1; move[moveptr] := 2 end {:320}; goto 30 end else if u < s then begin {319:} begin move[moveptr] := move[moveptr] + 1; moveptr := moveptr + 1; move[moveptr] := 1 end {:319}; goto 30 end; l := l + 1 end; r := r - xicorr; s := s - etacorr; if (abvscd((x1 + x2) + x3, s, (y1 + y2) + y3, r) - xicorr) >= 0 then begin {319:} move[moveptr] := move[moveptr] + 1; moveptr := moveptr + 1; move[moveptr] := 1 end else begin {:319} {320:} moveptr := moveptr + 1; move[moveptr] := 2 end {:320}; 30: {:317} null end else begin l := l + 1; bisectstack[bisectptr + 10] := l; bisectstack[bisectptr + 2] := x3; bisectstack[bisectptr + 1] := ((x2 + x3) + xicorr) div 2; x2 := ((x1 + x2) + xicorr) div 2; x3 := ((x2 + bisectstack[bisectptr + 1]) + xicorr) div 2; bisectstack[bisectptr] := x3; r := (r + r) + xicorr; t := ((x1 + x2) + x3) + r; q := t div twotothe[l]; bisectstack[bisectptr + 3] := t mod twotothe[l]; bisectstack[bisectptr + 4] := m - q; m := q; bisectstack[bisectptr + 7] := y3; bisectstack[bisectptr + 6] := ((y2 + y3) + etacorr) div 2; y2 := ((y1 + y2) + etacorr) div 2; y3 := ((y2 + bisectstack[bisectptr + 6]) + etacorr) div 2; bisectstack[bisectptr + 5] := y3; s := (s + s) + etacorr; u := ((y1 + y2) + y3) + s; q := u div twotothe[l]; bisectstack[bisectptr + 8] := u mod twotothe[l]; bisectstack[bisectptr + 9] := n - q; n := q; bisectptr := bisectptr + 11; goto 22 end {:314}; if bisectptr = 0 then goto 10; {312:} bisectptr := bisectptr - 11; x1 := bisectstack[bisectptr]; x2 := bisectstack[bisectptr + 1]; x3 := bisectstack[bisectptr + 2]; r := bisectstack[bisectptr + 3]; m := bisectstack[bisectptr + 4]; y1 := bisectstack[bisectptr + 5]; y2 := bisectstack[bisectptr + 6]; y3 := bisectstack[bisectptr + 7]; s := bisectstack[bisectptr + 8]; n := bisectstack[bisectptr + 9]; l := bisectstack[bisectptr + 10] {:312} end; 10: null end; {:311} {321:} procedure dump(var f,g:text;ignore:boolean;addy:integer); { dumps file named f to file named g. if ignore=true then @ sign won't be copied to g. addy=1, means this is "erase" path lower than 300 so 0.8 is subtracted from all y-s. if addy=2 it is higher than 300, and 0.8 is added. } var c : char; even_n : boolean; begin reset(f); while not eof(f) do begin even_n := true; read(f,c); case c of ' ' : repeat while c = ' ' do begin write(g,c); read(f,c); end; even_n := not even_n; while (c<>' ') and (c<>'@') do begin write(g,c); read(f,c); end; if even_n then if addy = 2 then write(g,' 0.8 add') else if addy = 1 then write(g,' 0.8 sub'); until c = '@'; otherwise while c<>'@' do begin write(g,c); read(f,c); end; end; (* case *) readln(f); if ignore then writeln(g) else writeln(g,'@'); end; end; function checkerase(var efile:text) : integer; { this function checks files that contains "erase" paths. if the path is higher than 300 its value is 2 else 1. this value goes to 'dump' procedure, to determine if 0.8 should be added or substracted. } const limit = 300; var no : real; c : char; begin reset(efile); checkerase := 1; while not eof(efile) do begin read(efile,c); case c of ' ' : begin read(efile,no); read(efile,no); if no > limit then checkerase := 2; end; otherwise ; end; readln(efile); end; end; procedure doarrange(var f,g:text); { gets file named f whose "fill" and "stroke" paths are mixed together with "erase" paths, and gives back file named g which has "erase" paths on top in order to determine the clip path, and afterward the rest paths. } var c : char; tmp,fills : text; erase_top : integer; begin if not erasein then begin writeln(g,'newpath'); dump(f,g,true,0); end else begin rewrite(fills); writeln(g,'gsave'); writeln(g,'initclip'); writeln(g,'newpath'); writeln(g,'0 0 M'); writeln(g,'0 1000 L'); writeln(g,'1000 1000 L'); writeln(g,'1000 0 L'); writeln(g,'0 0 L'); rewrite(tmp); reset(f); while not eof(f) do begin read(f,c); while (c<>'*') and (c<>'f') and (c<>'e') do begin while c<>'@' do begin write(tmp,c); read(f,c); end; readln(f); writeln(tmp,'@'); read(f,c); end; case c of '*' : begin erase_top := checkerase(tmp); dump(tmp,g,true,erase_top); writeln(g,'%erase'); end; 'f' : begin dump(tmp,fills,false,0); writeln(fills,'fill@'); end; 'e' : begin dump(tmp,fills,false,0); writeln(fills,'eofill@'); end; end; rewrite(tmp); readln(f); end; writeln(g,'eoclip'); writeln(g,'newpath'); dump(fills,g,true,0); writeln(g,'grestore'); end; end; procedure print_start; { print_start is called when a new cyclic path is identified. it checks if drawing status was kept, else it changes it respectively. the values are changed when getting into another drawing macro. it is also resets values of lastx0 lasty0 for not being horizonable, because we need a 'moveto' move in the PostScript file in the beginning of the new path. } begin if (internal[14]<>lastyearval) or (internal[15]<>lastmonthval) then begin if lastyearval<>internal[14] then begin if internal[14] = -65536 then begin writeln(f,'eofill@'); lastfill := 's'; end else begin writeln(f,'*erase@'); lastfill := 'e'; erasein := true; end; internal[14] := lastyearval ; end else begin internal[15] := lastmonthval ; if lastfill <> 'i' then writeln(f,'fill@'); lastfill := 'f'; end; end; writeln(f,'%new path@'); new := true; lastx0 := -99999999; lasty0 := -99999999; { unhorizonable values } end; procedure print_end; { print_end is called when end of cyclic path is identified. it takes out the buffer values which were kept there for optimization purposes. In addition it writes 'closepath' in order to close the current cyclic path. } begin if lastwasline then writeln(f,lastx3-prevtox3:3:0,' ',lasty3-prevtoy3:3:0,' l@'); if not new then writeln(f,'closepath@'); writeln(f,'%end path@'); end; procedure init_ps; { this procedure is called, right after entering the main loop in METAFONT, and this is the place to give initial values to variables, to open new files and ... to ask questions } var i:integer; begin rewrite(f); no_of_letter := 0; ascii_on := false; lastfill := 'i'; { i=init , no last fill } erasein := false; foundnew := false; { for new letter defs } minbox[x] := 9999; { initial min. value of x } minbox[y] := 9999; { -----"------- y } maxbox[x] := -9999; { initial max. value of x } maxbox[y] := -9999; { -----"------- y } prevtox3 := -9999; prevtoy3 := -9999; write('Enter name of OUTPUT file: '); i := 1; while not eoln do begin read(fout[i]); i := i+1; end; readln; writeln; write('Are you creating the whole dictionary (y/n) ?'); readln(ans); if (ans='y') or (ans='Y') then dict := 1 else dict := 0; writeln; rewrite(g,fout); if dict = 1 then begin writeln(g,'%! Simon font'); writeln(g,'%0 serverdict begin exitserver'); writeln(g,'/TBuildCharDict 10 dict def'); writeln(g,'/SimonFont 10 dict def'); writeln(g,'/fudge 110 def'); writeln(g,'SimonFont begin'); writeln(g,'%%'); writeln(g,' /FontType 3 def'); writeln(g,' /FontMatrix [0.001 0 0 0.001 0 0] def'); writeln(g,' /Encoding 256 array def'); writeln(g); writeln(g,' 0 1 255 {Encoding exch /.notdef put} for'); writeln(g); writeln(g,'% Character definitions'); writeln(g); writeln(g,'/Metrics 130 dict def'); writeln(g); writeln(g,'/CharDefs 130 dict def'); writeln(g,' '); writeln(g,'CharDefs begin'); writeln(g); writeln(g,'/.notdef'); writeln(g,' () def'); writeln(g); end; end; procedure makenewdef; { in case of several letters proccessing, while start working on a new letter a few initials should be done } var i : integer; begin rewrite(psfile); lastfill := 'i'; { i=init , no last fill } erasein := false; if dict = 1 then begin lmin_x := 9999; lmax_x := -9999; writeln(g); write(g,'/'); for i := 1 to ord(curletter[0]) do if curletter[i]<>' ' then write(g,curletter[i]) else write(g,'_'); writeln(g); writeln(g,'('); end; end; procedure closeolddef(sub_n:integer); { after one letter proccessing is finished, it gives the last path the right kind of filling, and then call to doarrange in order to make some order! } begin if internal[15] <> lastmonthval then begin writeln(psfile,'fill@'); internal[15] := lastmonthval; end else if internal[14] <> lastyearval then begin if internal[14] = -65536 then writeln(psfile,'eofill@') else begin writeln(psfile,'*erase@'); erasein := true; end; internal[14] := lastyearval end else case lastfill of 'e' : begin writeln(psfile,'*erase@'); erasein := true; end; 's' : writeln(psfile,'eofill@'); 'f','i' : writeln(psfile,'fill@'); end; doarrange(psfile,g); if dict = 1 then begin writeln(g,') def'); all_metrics[no_of_letter-sub_n] := trunc(lmax_x) + 1; end; end; procedure tini_ps; { prepares to leave... closing the last path, and in case of creating a dictionary, entering all the necessary information needed by the Postscript program } const lowlimit = 50; { if need transform do it to } highlimit = 900; { the box [50,50,900,900] } fix2one = 1.3; { correction to one point size } var j,jj : integer; c_l : currentletter; begin closeolddef(0); if dict = 1 then begin if (minbox[x] < 0) or (minbox[y] < 0) or (maxbox[x] > 1000) or (maxbox[y] > 1000) then begin needtransform := true; doscale[x] := ((highlimit-lowlimit)/(maxbox[x]-minbox[x]))/fix2one; dotranslate[x] := lowlimit - minbox[x]*doscale[x]; doscale[y] := ((highlimit-lowlimit)/(maxbox[y]-minbox[y]))/fix2one; dotranslate[y] := lowlimit - minbox[y]*doscale[y]; end else needtransform := false; writeln(f); writeln(f,'end % of CharDefs dictionary'); writeln(f); for j := 1 to no_of_letter do begin c_l := all_letters[j]; write(f,'Encoding ',all_ascii[j],' /'); for jj := 1 to ord(c_l[0]) do if c_l[jj]<>' ' then write(f,c_l[jj]) else write(f,'_'); writeln(f,' put'); end; writeln(f); writeln(f,'Metrics'); writeln(f,' begin'); for j := 1 to no_of_letter do begin c_l := all_letters[j]; write(f,'/'); for jj := 1 to ord(c_l[0]) do if c_l[jj]<>' ' then write(f,c_l[jj]) else write(f,'_'); if needtransform then writeln(f,' 1000 def') else writeln(f,' ',all_metrics[j]-minbox[x]:3:0,' fudge add def'); end; writeln(f,'/.notdef 0 def'); writeln(f,' end'); writeln(f); writeln(f,' /BuildChar'); writeln(f,' { TBuildCharDict begin'); writeln(f,' %%'); writeln(f,' /char exch def'); writeln(f,' /fontdict exch def'); writeln(f); writeln(f, ' /M {moveto} def'); writeln(f, ' /L {lineto} def'); writeln(f, ' /l {rlineto} def'); writeln(f, ' /C {curveto} def'); writeln(f, ' /c {rcurveto} def'); writeln(f); writeln(f,' /charname fontdict /Encoding get'); writeln(f,' char get def'); writeln(f,' %%'); writeln(f,' /charproc fontdict /CharDefs get'); writeln(f,' charname get def'); writeln(f,' '); writeln(f,' /charwdth fontdict /Metrics get charname get def'); writeln(f,' %%'); writeln(f,' gsave'); writeln(f,' ',fix2one:3:1,fix2one:10:1,' scale'); writeln(f,' 0.2 setflat'); writeln(f,' 0.2 setlinewidth'); writeln(f,' charwdth 0'); writeln(f,' 0 -180'); writeln(f,' charwdth 1000'); writeln(f,' setcachedevice'); if needtransform then begin writeln(f,' ',doscale[x]:7:3,doscale[y]:11:3,' scale'); writeln(f,' ',dotranslate[x]:7:3,dotranslate[y]:11:3,' translate'); end else writeln(f,' -',minbox[x]:3:0,' fudge add 0 translate'); writeln(f,' charproc cvx exec'); writeln(f,' grestore'); writeln(f,' end'); writeln(f,' } def'); if needtransform then writeln(f,' /FontBBox [0 0 1000 1000] def') else writeln(f,' /FontBBox [',minbox[x]:3:0,' fudge sub ',minbox[y]:3:0,' ',maxbox[x]:3:0,' ',maxbox[y]:3:0,'] def'); writeln(f); writeln(f,' end '); writeln(f); writeln(f,' /Simon SimonFont definefont pop'); writeln(f); writeln(f,' /Simon findfont 10 scalefont setfont'); writeln(f,' 100 210 moveto () show'); writeln(f,' showpage'); end; end; procedure auxprintchar(s: ASCIIcode); { puts in string a character whose ascii is s } begin curletter[name_length] := xchr[s]; end; procedure auxprint(s: integer); { equivalent to METAFONT's print, accept changing global variables, and writing is done into a local string. it is also counts the string's length } var j: poolpointer; begin if (s < 0) or (s >= strptr) then s := 131; j := strstart[s]; while j < strstart[s + 1] do begin name_length := name_length + 1; auxprintchar(strpool[j]); j := j + 1 end end; {:59} {60:} procedure auxslowprint; { equivalent to METAFONT's slowprint, accept changing global variables. } var j: poolpointer; begin if dict = 1 then begin name_length := 0; if (s < 0) or (s >= strptr) then s := 131; j := strstart[s]; while j < strstart[s + 1] do begin auxprint(strpool[j]); j := j + 1 end; if name_length>0 then begin curletter[0] := chr(name_length); no_of_letter := no_of_letter + 1; all_letters[no_of_letter] := curletter; if foundnew then closeolddef(1); foundnew := true; makenewdef; end; end; end; {:60} {62:} procedure auxprintnl; begin if dict = 1 then begin name_length := 0; auxprint(s); if name_length>0 then begin curletter[0] := chr(name_length); no_of_letter := no_of_letter + 1; all_letters[no_of_letter] := curletter; if foundnew then closeolddef(1); foundnew := true; makenewdef; end; end; end; {:62} {63:} procedure sendascii; { puts in array of ascii values the ascii of letter whose number is no_of_letter. } begin all_ascii[no_of_letter] := asc; end;