summaryrefslogtreecommitdiff
path: root/fonts/utilities/mf2ps/mf2ps/mf2ps3.p
diff options
context:
space:
mode:
Diffstat (limited to 'fonts/utilities/mf2ps/mf2ps/mf2ps3.p')
-rw-r--r--fonts/utilities/mf2ps/mf2ps/mf2ps3.p657
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;