diff options
Diffstat (limited to 'fonts/utilities/mf2ps/mf2ps/mf2ps3.p')
-rw-r--r-- | fonts/utilities/mf2ps/mf2ps/mf2ps3.p | 657 |
1 files changed, 657 insertions, 0 deletions
diff --git a/fonts/utilities/mf2ps/mf2ps/mf2ps3.p b/fonts/utilities/mf2ps/mf2ps/mf2ps3.p new file mode 100644 index 0000000000..f082b45f4f --- /dev/null +++ b/fonts/utilities/mf2ps/mf2ps/mf2ps3.p @@ -0,0 +1,657 @@ +#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; |