path: root/systems/msdos/jemtex2/jis2mf.pas

{$A-,B-,D-,E-,F-,I+,L-,N-,O-,R-,S-,V-}
{Compile with Turbo-Pascal 5.0}
Program JIS2MF(Input,Output);
{
  This program generates METAFONT code from a Bitmaps file JIS24

  Author: Francois Jalbert
              '
  Date: November 1990

  Version: 1.0

  Date: April 1991

  Version: 2.00

  Modifications: - Added four kanjis.
                 - Fixed incorrect VGA resolution.
                 - Command line parameter now supported.
                 - Added automatic mode.
                 - Added batch mode.
                 - Updated and improved run-time messages.
                 - Long triangles added by Mr. Masatoshi Watanabe. Fantastic!
                 - Fixed and proportional parameters added.
                 - Standard and dictionary parameters added.
                 - JIS24 now accessed through low-level I/O channel for speed.

  Error Levels: 0 - Normal termination.
                1 - Error.
                2 - All fonts generated (batch).
}
Const
  {Number of Bitmaps in JIS24}
  BitmapMax=7806;
  {Size of each square Bitmap}
  SizeMax=24;
  SizeMax1=25;
  {DOS Record Size}
  RecSize=72; {SizeMax*SizeMax/8}
  {Parameter flag}
  Flag1='/'; {DOS style}
  Flag2='-'; {UNIX style}
  {Parameter keywords}
  FixedX1:String[10]='FIXEDWIDTH';
  FixedX2:String[6]='FIXEDX';
  FixedX3:String[19]='NOPROPORTIONALWIDTH';
  FixedX4:String[15]='NOPROPORTIONALX';
  NoFixedX1:String[12]='NOFIXEDWIDTH';
  NoFixedX2:String[8]='NOFIXEDX';
  NoFixedX3:String[17]='PROPORTIONALWIDTH';
  NoFixedX4:String[13]='PROPORTIONALX';
  FixedY1:String[11]='FIXEDHEIGHT';
  FixedY2:String[6]='FIXEDY';
  FixedY3:String[20]='NOPROPORTIONALHEIGHT';
  FixedY4:String[15]='NOPROPORTIONALY';
  NoFixedY1:String[13]='NOFIXEDHEIGHT';
  NoFixedY2:String[8]='NOFIXEDY';
  NoFixedY3:String[18]='PROPORTIONALHEIGHT';
  NoFixedY4:String[13]='PROPORTIONALY';
  Standard1:String[8]='STANDARD';
  NoStandard1:String[10]='DICTIONARY';
  Batch1:String[5]='BATCH';

Type
  InFileType=File; {Low-level I/O channel}
  OutFileType=Text;
  BitmapRange=1..BitmapMax;
  Bitmap0Range=0..BitmapMax;
  SizeRange=1..SizeMax;
  Size0Range=0..SizeMax1;
  {Buffer for the Bitmap Data}
  ColumnType=Record Data1,Data2,Data3:Byte End;
  BufferType=Array [SizeRange] Of ColumnType;
  {The Bitmap array is defined larger to simplify the forthcoming code}
  BitmapType=Array [Size0Range,Size0Range] Of Boolean;
  BitmapsType=Record
                Bitmap:BitmapType;
                XMin,XMax,YMin,YMax:Size0Range
              End;
  {Run time parameters}
  RunTimeType=Record
                FileName:String;
                {Batch mode}
                Batch:Boolean;
                {Automatic mode for JemTeX fonts only}
                Automatic:Boolean;
                {Fixed or proportional fonts}
                FixedX,FixedY:Boolean;
                {Standard or dictionary fonts}
                Standard:Boolean
              End;

Var
  {JIS24 and METAFONT file names}
  InFile:InFileType;
  OutFile:OutFileType;
  {Current METAFONT character number}
  Number:Integer;
  {Run time parameters}
  RunTime:RunTimeType;

{-------------------------------- GetParameters ------------------------------}

Procedure SimpleQuery(Title,ChoiceA,ChoiceB:String; Var Answer:Boolean);
Var
  JChar:Char;
  Valid:Boolean;
Begin
Repeat
  Valid:=True;
  Writeln(Title+':');
  Writeln('   a)  '+ChoiceA);
  Writeln('   b)  '+ChoiceB);
  Write('Your choice? ');
  Readln(JChar);
  JChar:=UpCase(JChar);
  If JChar='A' Then Answer:=True
  Else
    If JChar='B' Then Answer:=False
    Else
      Begin Valid:=False; Write(Chr(7)) End
Until Valid;
Writeln
End;

Procedure GetMode(Var RunTime:RunTimeType);
{Determines if the desired font is a JemTeX font}
Begin
With RunTime Do
  Begin
  Automatic:=False;
  If UpCase(FileName[1])='K' Then
  If UpCase(FileName[2])='A' Then
  If UpCase(FileName[3])='N' Then
  If UpCase(FileName[4])='J' Then
  If UpCase(FileName[5])='I' Then
  If ('A'<=UpCase(FileName[6])) And (UpCase(FileName[6])<='H') Then
  If ('A'<=UpCase(FileName[7])) And (UpCase(FileName[7])<='H') Then
  If Length(FileName)=7 Then
  If UpCase(FileName[6])<='G' Then Automatic:=True
  Else
  If UpCase(FileName[7])<='E' Then Automatic:=True
  End
End;

Procedure EchoParameters(Var RunTime:RunTimeType);
{Echoes the current parameters}
Begin
With RunTime Do
  Begin
  Write('Font='+FileName);
  If FixedX Then Write('  Fixed Width')
  Else Write('  Prop. Width');
  If FixedY Then Write('  Fixed Height')
  Else Write('  Prop. Height');
  If Standard Then Write('  Standard')
  Else Write('  Dictionary');
  If Automatic Then Write('  Automatic')
  Else Write('  Manual');
  If Batch Then Write('  Batch');
  Writeln('.')
  End
End;

Procedure Manual(Var RunTime:RunTimeType);
{Get parameters from user}
Begin
With RunTime Do
  Begin
  Write('METAFONT file name? ');
  Readln(FileName);
  Writeln;
  SimpleQuery('Fixed or proportional font width','Fixed','Proportional',FixedX);
  SimpleQuery('Fixed or proportional font height','Fixed','Proportional',FixedY);
  SimpleQuery('Standard or dictionary font','Standard','Dictionary',Standard);
  {Batch mode intrinsically isn't manual}
  Batch:=False
  End
End;

Procedure FindBefore(Var FileName:String);
{No check for before kanjiaa}
Begin
If FileName[7]='a' Then
  Begin
  FileName[7]:='h';
  FileName[6]:=Pred(FileName[6])
  End
Else
  FileName[7]:=Pred(FileName[7])
End;

Procedure FindAfter(Var FileName:String);
{No check for above kanjihe}
Begin
If FileName[7]='h' Then
  Begin
  FileName[7]:='a';
  FileName[6]:=Succ(FileName[6])
  End
Else
  FileName[7]:=Succ(FileName[7])
End;

Procedure ScanMF(Var FileName:String);
{Scans backwards for the last JemTeX font generated}
{Looks first for a .TFM and then for an .MF}
{If no more fonts to generate, stops with error level 2}
Var 
  TestFile:Text;
  Found:Boolean;
Begin
FileName:='kanjihf';
Repeat
  FindBefore(FileName);
  Assign(TestFile,FileName+'.tfm');
  {$I-}Reset(TestFile);{$I+}
  {IOResult must be immediately used once only}
  Found:=(IOResult=0);
  If Not Found Then 
    Begin
    Assign(TestFile,FileName+'.mf');
    {$I-}Reset(TestFile);{$I+}
    {IOResult must be immediately used once only}
    Found:=(IOResult=0)
    End;
Until Found Or (FileName='kanjiaa');
If Found Then
  Begin
  Close(TestFile);
  If FileName='kanjihe' Then
    Begin
    Writeln(Chr(7)+'All JemTeX fonts generated!');
    Halt(2)
    End
  Else FindAfter(FileName)
  End
End;

Procedure Automate(Var RunTime:RunTimeType);
{Get parameters from command line}
{Finds the next font to be generated if in batch mode}
Var
  ParamIndex,Index:Integer;
  Param:String;
Begin
With RunTime Do
  Begin
  {Defaults}
  FileName:='kanjiaa';
  FixedX:=False;
  FixedY:=False;
  Standard:=True;
  Batch:=False;
  {Scan command line parameters}
  For ParamIndex:=1 To ParamCount Do
    Begin
    Param:=ParamStr(ParamIndex);
    If (Param[1]=Flag1) Or (Param[1]=Flag2) Then
      {Not a font name}
      Begin
      {Delete 1 char at the 1st position}
      Delete(Param,1,1);
      {Convert to upper case}
      For Index:=1 To Length(Param) Do 
        Param[Index]:=UpCase(Param[Index]);
      {Scan known keywords}
      If (Param=FixedX1) Or (Param=FixedX2) Or (Param=FixedX3) Or 
         (Param=FixedX4) Then FixedX:=True
      Else
      If (Param=NoFixedX1) Or (Param=NoFixedX2) Or (Param=NoFixedX3) Or 
         (Param=NoFixedX4) Then FixedX:=False
      Else
      If (Param=FixedY1) Or (Param=FixedY2) Or (Param=FixedY3) Or 
         (Param=FixedY4) Then FixedY:=True
      Else
      If (Param=NoFixedY1) Or (Param=NoFixedY2) Or (Param=NoFixedY3) Or 
         (Param=NoFixedY4) Then FixedY:=False
      Else
      If Param=Standard1 Then Standard:=True
      Else
      If Param=NoStandard1 Then Standard:=False
      Else
      If Param=Batch1 Then Batch:=True
      Else
        {Unknown keyword}
        Begin
        Writeln(Chr(7)+'Invalid command line parameter: '+Param+'...');
        Halt(1)
        End
      End
    Else
      {Must be a font name}
      FileName:=Param
    End;
  If Batch Then ScanMF(FileName)
  End
End;

Procedure GetParameters(Var RunTime:RunTimeType);
{Get parameters from user or command line}
Begin
If ParamCount=0 Then Manual(RunTime)
Else Automate(RunTime);
GetMode(RunTime);
EchoParameters(RunTime);
Writeln
End;

{----------------------------------- Output ----------------------------------}

Procedure BeginOut(Var OutFile:OutFileType; Var RunTime:RunTimeType);
{Writes initial METAFONT header}
{Co-author is Mr. Masatoshi Watanabe}
Begin
Writeln(OutFile,'%JIS2MF Version 2.00 of 14 April 1991.');
Writeln(OutFile);
Writeln(OutFile,'% Font='+RunTime.FileName);
If RunTime.FixedX Then Writeln(OutFile,'% Fixed Width')
Else Writeln(OutFile,'% Proportional Width');
If RunTime.FixedY Then Writeln(OutFile,'% Fixed Height')
Else Writeln(OutFile,'% Proportional Height');
If RunTime.Standard Then Writeln(OutFile,'% Standard Positioning')
Else Writeln(OutFile,'% Dictionary Positioning');
Writeln(OutFile);
Writeln(OutFile,'tracingstats:=1;');
Writeln(OutFile,'screen_cols:=640; %VGA');
Writeln(OutFile,'screen_rows:=480; %VGA');
Writeln(OutFile,'font_size 10pt#;');
If RunTime.Standard Then
  Begin
  Writeln(OutFile,'u#:=12.7/36pt#;');
  Writeln(OutFile,'body_height#:=23.25u#;');
  Writeln(OutFile,'desc_depth#:=4.75u#;')
  End
Else
  Begin
  Writeln(OutFile,'u#:=13/36pt#;');
  Writeln(OutFile,'body_height#:=21u#;');
  Writeln(OutFile,'desc_depth#:=7u#;')
  End;
Writeln(OutFile);
Writeln(OutFile,'letter_fit#:=0pt#;');
Writeln(OutFile,'asc_height#:=0pt#;');
Writeln(OutFile,'cap_height#:=0pt#;');
Writeln(OutFile,'fig_height#:=0pt#;');
Writeln(OutFile,'x_height#:=0pt#;');
Writeln(OutFile,'math_axis#:=0pt#;');
Writeln(OutFile,'bar_height#:=0pt#;');
Writeln(OutFile,'comma_depth#:=0pt#;');
Writeln(OutFile,'crisp#:=0pt#;');
Writeln(OutFile,'tiny#:=0pt#;');
Writeln(OutFile,'fine#:=0pt#;');
Writeln(OutFile,'thin_join#:=0pt#;');
Writeln(OutFile,'hair#:=1pt#;');
Writeln(OutFile,'stem#:=1pt#;');
Writeln(OutFile,'curve#:=1pt#;');
Writeln(OutFile,'flare#:=1pt#;');
Writeln(OutFile,'dot_size#:=0pt#;');
Writeln(OutFile,'cap_hair#:=1pt#;');
Writeln(OutFile,'cap_stem#:=1pt#;');
Writeln(OutFile,'cap_curve#:=1pt#;');
Writeln(OutFile,'rule_thickness#:=0pt#;');
Writeln(OutFile,'vair#:=0pt#;');
Writeln(OutFile,'notch_cut#:=0pt#;');
Writeln(OutFile,'bar#:=1pt#;');
Writeln(OutFile,'slab#:=1pt#;');
Writeln(OutFile,'cap_bar#:=1pt#;');
Writeln(OutFile,'cap_band#:=1pt#;');
Writeln(OutFile,'cap_notch_cut#:=0pt#;');
Writeln(OutFile,'serif_drop#:=0pt#;');
Writeln(OutFile,'stem_corr#:=0pt#;');
Writeln(OutFile,'vair_corr#:=0pt#;');
Writeln(OutFile,'o#:=0pt#;');
Writeln(OutFile,'apex_o#:=0pt#;');
Writeln(OutFile,'hefty:=true;');
Writeln(OutFile,'serifs:=true;');
Writeln(OutFile,'monospace:=false;');
Writeln(OutFile,'math_fitting:=false;');
Writeln(OutFile);
Writeln(OutFile,'mode_setup;');
Writeln(OutFile,'font_setup;');
Writeln(OutFile);
Writeln(OutFile,'pair z;');
Writeln(OutFile);
Writeln(OutFile,'def s(expr col,row)= %square');
Writeln(OutFile,' z:=((col*u),(row*u));');
Writeln(OutFile,' fill unitsquare scaled u shifted z;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def sul(expr col,row)= %upper left square');
Writeln(OutFile,' z:=((col*u),(row*u)+.5u);');
Writeln(OutFile,' fill unitsquare scaled .5u shifted z;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def sur(expr col,row)= %upper right square');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+.5u);');
Writeln(OutFile,' fill unitsquare scaled .5u shifted z;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def sbr(expr col,row)= %bottom right square');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u));');
Writeln(OutFile,' fill unitsquare scaled .5u shifted z;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def sbl(expr col,row)= %bottom left square');
Writeln(OutFile,' z:=((col*u),(row*u));');
Writeln(OutFile,' fill unitsquare scaled .5u shifted z;');
Writeln(OutFile,'enddef;');
Writeln(OutFile);
Writeln(OutFile,'def c(expr col,row)= %circle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+.5u);');
Writeln(OutFile,' fill fullcircle scaled u shifted z;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def cul(expr col,row)= %upper left circle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+.5u);');
Writeln(OutFile,' fill z--quartercircle rotated 90 scaled u shifted z--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def cur(expr col,row)= %upper right circle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+.5u);');
Writeln(OutFile,' fill z--quartercircle scaled u shifted z--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def cbr(expr col,row)= %bottom right circle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+.5u);');
Writeln(OutFile,' fill z--quartercircle rotated 270 scaled u shifted z--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def cbl(expr col,row)= %bottom left circle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+.5u);');
Writeln(OutFile,' fill z--quartercircle rotated 180 scaled u shifted z--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile);
Writeln(OutFile,'def tul(expr col,row)= %upper left triangle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+.5u);');
Writeln(OutFile,' fill z--z+(0,.5u)--z-(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def tur(expr col,row)= %upper right triangle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+.5u);');
Writeln(OutFile,' fill z--z+(0,.5u)--z+(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def tbr(expr col,row)= %bottom right triangle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+.5u);');
Writeln(OutFile,' fill z--z-(0,.5u)--z+(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def tbl(expr col,row)= %bottom left triangle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+.5u);');
Writeln(OutFile,' fill z--z-(0,.5u)--z-(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile);
Writeln(OutFile,'def rul(expr col,row)= %upper left reverse triangle');
Writeln(OutFile,' z:=((col*u),(row*u)+u);');
Writeln(OutFile,' fill z--z-(0,.5u)--z+(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def rur(expr col,row)= %upper right reverse triangle');
Writeln(OutFile,' z:=((col*u)+u,(row*u)+u);');
Writeln(OutFile,' fill z--z-(0,.5u)--z-(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def rbr(expr col,row)= %bottom right reverse triangle');
Writeln(OutFile,' z:=((col*u)+u,(row*u));');
Writeln(OutFile,' fill z--z+(0,.5u)--z-(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def rbl(expr col,row)= %bottom left reverse triangle');
Writeln(OutFile,' z:=((col*u),(row*u));');
Writeln(OutFile,' fill z--z+(0,.5u)--z+(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile);
Writeln(OutFile,'def tuul(expr col,row)= %upper left long triangle');
Writeln(OutFile,' z:=((col*u)+u,(row*u)+.5u);');
Writeln(OutFile,' fill z--z+(0,.5u)--z-(u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def tull(expr col,row)= %upper left long triangle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u));');
Writeln(OutFile,' fill z--z+(0,u)--z-(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def tuur(expr col,row)= %upper right long triangle');
Writeln(OutFile,' z:=((col*u),(row*u)+.5u);');
Writeln(OutFile,' fill z--z+(0,.5u)--z+(u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def turr(expr col,row)= %upper right long triangle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u));');
Writeln(OutFile,' fill z--z+(0,u)--z+(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def tbbr(expr col,row)= %bottom right long triangle');
Writeln(OutFile,' z:=((col*u),(row*u)+.5u);');
Writeln(OutFile,' fill z--z-(0,.5u)--z+(u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def tbrr(expr col,row)= %bottom right long triangle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+u);');
Writeln(OutFile,' fill z--z-(0,u)--z+(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def tbbl(expr col,row)= %bottom left long triangle');
Writeln(OutFile,' z:=((col*u)+u,(row*u)+.5u);');
Writeln(OutFile,' fill z--z-(0,.5u)--z-(u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def tbll(expr col,row)= %bottom left long triangle');
Writeln(OutFile,' z:=((col*u)+.5u,(row*u)+u);');
Writeln(OutFile,' fill z--z-(0,u)--z-(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile);
Writeln(OutFile,'def ruul(expr col,row)= %upper left reverse long triangle');
Writeln(OutFile,' z:=((col*u),(row*u)+u);');
Writeln(OutFile,' fill z--z-(0,u)--z+(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def rull(expr col,row)= %upper left reverse long triangle');
Writeln(OutFile,' z:=((col*u),(row*u)+u);');
Writeln(OutFile,' fill z--z-(0,.5u)--z+(u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def ruur(expr col,row)= %upper right reverse long triangle');
Writeln(OutFile,' z:=((col*u)+u,(row*u)+u);');
Writeln(OutFile,' fill z--z-(0,u)--z-(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def rurr(expr col,row)= %upper right reverse long triangle');
Writeln(OutFile,' z:=((col*u)+u,(row*u)+u);');
Writeln(OutFile,' fill z--z-(0,.5u)--z-(u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def rbbr(expr col,row)= %bottom right reverse long triangle');
Writeln(OutFile,' z:=((col*u)+u,(row*u));');
Writeln(OutFile,' fill z--z+(0,u)--z-(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def rbrr(expr col,row)= %bottom right reverse long triangle');
Writeln(OutFile,' z:=((col*u)+u,(row*u));');
Writeln(OutFile,' fill z--z+(0,.5u)--z-(u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def rbbl(expr col,row)= %bottom left reverse long triangle');
Writeln(OutFile,' z:=((col*u),(row*u));');
Writeln(OutFile,' fill z--z+(0,u)--z+(.5u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile,'def rbll(expr col,row)= %bottom left reverse long triangle');
Writeln(OutFile,' z:=((col*u),(row*u));');
Writeln(OutFile,' fill z--z+(0,.5u)--z+(u,0)--cycle;');
Writeln(OutFile,'enddef;');
Writeln(OutFile)
End;

Procedure ActiveBitmap(Var OutFile:OutFileType; Var Bitmap:BitmapType; 
                       X,Y:SizeRange; XX:Integer; YY:Real);
{Writes METAFONT code for an active cell}
{Co-author is Mr. Masatoshi Watanabe}
Var
  SquareUR,SquareUL,SquareBR,SquareBL:Boolean;
  CircleUR,CircleUL,CircleBR,CircleBL:Boolean;
  LTryUUR,LTryURR,LTryUUL,LTryULL:Boolean;
  LTryBBR,LTryBRR,LTryBBL,LTryBLL:Boolean;
Begin
SquareUL:=(Bitmap[X-1,Y] Or Bitmap[X-1,Y+1] Or Bitmap[X,Y+1]);
SquareUR:=(Bitmap[X+1,Y] Or Bitmap[X+1,Y+1] Or Bitmap[X,Y+1]);
SquareBL:=(Bitmap[X-1,Y] Or Bitmap[X-1,Y-1] Or Bitmap[X,Y-1]);
SquareBR:=(Bitmap[X+1,Y] Or Bitmap[X+1,Y-1] Or Bitmap[X,Y-1]);
CircleUL:=(Not Bitmap[X-1,Y-1] And Not Bitmap[X-1,Y] And Not Bitmap[X-1,Y+1] And
           Not Bitmap[X,Y+1] And Not Bitmap[X+1,Y+1]);
CircleUR:=(Not Bitmap[X+1,Y-1] And Not Bitmap[X+1,Y] And Not Bitmap[X+1,Y+1] And
           Not Bitmap[X,Y+1] And Not Bitmap[X-1,Y+1]);
CircleBL:=(Not Bitmap[X-1,Y+1] And Not Bitmap[X-1,Y] And Not Bitmap[X-1,Y-1] And
           Not Bitmap[X,Y-1] And Not Bitmap[X+1,Y-1]);
CircleBR:=(Not Bitmap[X+1,Y+1] And Not Bitmap[X+1,Y] And Not Bitmap[X+1,Y-1] And
           Not Bitmap[X,Y-1] And Not Bitmap[X-1,Y-1]);
LTryUUL:=(Bitmap[X-1,Y-1] And Not Bitmap[X-1,Y] And Not Bitmap[X-1,Y+1] And
          Not Bitmap[X,Y+1] And Not Bitmap[X+1,Y+1] And Bitmap[X+1,Y]);
LTryUUR:=(Bitmap[X+1,Y-1] And Not Bitmap[X+1,Y] And Not Bitmap[X+1,Y+1] And
          Not Bitmap[X,Y+1] And Not Bitmap[X-1,Y+1] And Bitmap[X-1,Y]);
LTryBBL:=(Bitmap[X-1,Y+1] And Not Bitmap[X-1,Y] And Not Bitmap[X-1,Y-1] And
          Not Bitmap[X,Y-1] And Not Bitmap[X+1,Y-1] And Bitmap[X+1,Y]);
LTryBBR:=(Bitmap[X+1,Y+1] And Not Bitmap[X+1,Y] And Not Bitmap[X+1,Y-1] And
          Not Bitmap[X,Y-1] And Not Bitmap[X-1,Y-1] And Bitmap[X-1,Y]);
LTryULL:=(Not Bitmap[X-1,Y-1] And Not Bitmap[X-1,Y] And Not Bitmap[X-1,Y+1] And
          Not Bitmap[X,Y+1] And Bitmap[X+1,Y+1] And Bitmap[X,Y-1]);
LTryURR:=(Not Bitmap[X+1,Y-1] And Not Bitmap[X+1,Y] And Not Bitmap[X+1,Y+1] And
          Not Bitmap[X,Y+1] And Bitmap[X-1,Y+1] And Bitmap[X,Y-1]);
LTryBLL:=(Not Bitmap[X-1,Y+1] And Not Bitmap[X-1,Y] And Not Bitmap[X-1,Y-1] And
          Not Bitmap[X,Y-1] And Bitmap[X+1,Y-1] And Bitmap[X,Y+1]);
LTryBRR:=(Not Bitmap[X+1,Y+1] And Not Bitmap[X+1,Y] And Not Bitmap[X+1,Y-1] And
          Not Bitmap[X,Y-1] And Bitmap[X-1,Y-1] And Bitmap[X,Y+1]);
If LTryUUL Then Write(OutFile,'tuul(',XX,',',YY:4:2,');');
If LTryULL Then Write(OutFile,'tull(',XX,',',YY:4:2,');');
If LTryUUR Then Write(OutFile,'tuur(',XX,',',YY:4:2,');');
If LTryURR Then Write(OutFile,'turr(',XX,',',YY:4:2,');');
If LTryBBL Then Write(OutFile,'tbbl(',XX,',',YY:4:2,');');
If LTryBLL Then Write(OutFile,'tbll(',XX,',',YY:4:2,');');
If LTryBBR Then Write(OutFile,'tbbr(',XX,',',YY:4:2,');');
If LTryBRR Then Write(OutFile,'tbrr(',XX,',',YY:4:2,');');
If SquareUL And SquareUR And SquareBL And SquareBR Then
  Write(OutFile,'s(',XX,',',YY:4:2,');')
Else
  If CircleUL And CircleUR And CircleBL And CircleBR Then
    Write(OutFile,'c(',XX,',',YY:4:2,');')
  Else
    Begin
    If Not LTryUUL And Not LTryULL And Not LTryUUR And Not LTryBLL Then
      If SquareUL Then Write(OutFile,'sul(',XX,',',YY:4:2,');')
      Else
        If CircleUL Then Write(OutFile,'cul(',XX,',',YY:4:2,');')
        Else Write(OutFile,'tul(',XX,',',YY:4:2,');');
    If Not LTryUUL And Not LTryURR And Not LTryUUR And Not LTryBRR Then
      If SquareUR Then Write(OutFile,'sur(',XX,',',YY:4:2,');')
      Else
        If CircleUR Then Write(OutFile,'cur(',XX,',',YY:4:2,');')
        Else Write(OutFile,'tur(',XX,',',YY:4:2,');');
    If Not LTryBBL And Not LTryULL And Not LTryBBR And Not LTryBLL Then
      If SquareBL Then Write(OutFile,'sbl(',XX,',',YY:4:2,');')
      Else
        If CircleBL Then Write(OutFile,'cbl(',XX,',',YY:4:2,');')
        Else Write(OutFile,'tbl(',XX,',',YY:4:2,');');
    If Not LTryBBL And Not LTryURR And Not LTryBBR And Not LTryBRR Then
      If SquareBR Then Write(OutFile,'sbr(',XX,',',YY:4:2,');')
      Else
        If CircleBR Then Write(OutFile,'cbr(',XX,',',YY:4:2,');')
        Else Write(OutFile,'tbr(',XX,',',YY:4:2,');')
    End
End;

Procedure InactiveBitmap(Var OutFile:OutFileType; Var Bitmap:BitmapType;
                         X,Y:SizeRange; XX:Integer; YY:Real; Var Active:Boolean);
{Writes METAFONT code for an inactive cell}
{Co-author is Mr. Masatoshi Watanabe}
Begin
If Bitmap[X-1,Y] And Bitmap[X,Y+1] Then
  If Bitmap[X-1,Y-1] And Not Bitmap[X+1,Y+1] Then
    Begin Active:=True; Write(OutFile,'ruul(',XX,',',YY:4:2,');') End
  Else
    If Bitmap[X+1,Y+1] And Not Bitmap[X-1,Y-1] Then
      Begin Active:=True; Write(OutFile,'rull(',XX,',',YY:4:2,');') End
    Else
      Begin Active:=True; Write(OutFile,'rul(',XX,',',YY:4:2,');') End;
If Bitmap[X+1,Y] And Bitmap[X,Y+1] Then
  If Bitmap[X+1,Y-1] And Not Bitmap[X-1,Y+1] Then
    Begin Active:=True; Write(OutFile,'ruur(',XX,',',YY:4:2,');') End
  Else
    If Bitmap[X-1,Y+1] And Not Bitmap[X+1,Y-1] Then
      Begin Active:=True; Write(OutFile,'rurr(',XX,',',YY:4:2,');') End
    Else
      Begin Active:=True; Write(OutFile,'rur(',XX,',',YY:4:2,');') End;
If Bitmap[X-1,Y] And Bitmap[X,Y-1] Then
  If Bitmap[X-1,Y+1] And Not Bitmap[X+1,Y-1] Then
    Begin Active:=True; Write(OutFile,'rbbl(',XX,',',YY:4:2,');') End
  Else
    If Bitmap[X+1,Y-1] And Not Bitmap[X-1,Y+1] Then
      Begin Active:=True; Write(OutFile,'rbll(',XX,',',YY:4:2,');') End
    Else
      Begin Active:=True; Write(OutFile,'rbl(',XX,',',YY:4:2,');') End;
If Bitmap[X+1,Y] And Bitmap[X,Y-1] Then
  If Bitmap[X+1,Y+1] And Not Bitmap[X-1,Y-1] Then
    Begin Active:=True; Write(OutFile,'rbbr(',XX,',',YY:4:2,');') End
  Else
    If Bitmap[X-1,Y-1] And Not Bitmap[X+1,Y+1] Then
      Begin Active:=True; Write(OutFile,'rbrr(',XX,',',YY:4:2,');') End
    Else
      Begin Active:=True; Write(OutFile,'rbr(',XX,',',YY:4:2,');') End
End;

Procedure MiddleOut(Var OutFile:OutFileType; Var Bitmaps:BitmapsType; 
                    Number:Integer; Standard:Boolean);
{Writes METAFONT code for a given Bitmap}
Var 
  X,Y:SizeRange;
  Active:Boolean;
Begin
With Bitmaps Do
  Begin
  Write(OutFile,'beginchar(',Number,',',XMax-XMin+1,'u#,');
  If Standard Then
    Begin
    If YMax>0.75 Then Write(OutFile,(YMax-0.75):4:2,'u#,')
    Else Write(OutFile,'0,');
    If 5.75>YMin Then Writeln(OutFile,(5.75-YMin):4:2,'u#);')
    Else Writeln(OutFile,'0);')
    End
  Else
    Begin
    If YMax>3 Then Write(OutFile,YMax-3,'u#,')
    Else Write(OutFile,'0,');
    If 8>YMin Then Writeln(OutFile,8-YMin,'u#);')
    Else Writeln(OutFile,'0);')
    End;
  Writeln(OutFile,'normal_adjust_fit(2u#,2u#);');
  For X:=XMin To XMax Do
    For Y:=1 To SizeMax Do
      Begin
      Active:=Bitmap[X,Y];
      If Active Then
        {Current pixel is on}
        If Standard Then ActiveBitmap(OutFile,Bitmap,X,Y,X-XMin,Y-3.75)
        Else ActiveBitmap(OutFile,Bitmap,X,Y,X-XMin,Y-6)
      Else
        {Current pixel is off}
        If Standard Then InactiveBitmap(OutFile,Bitmap,X,Y,X-XMin,Y-3.75,Active)
        Else InactiveBitmap(OutFile,Bitmap,X,Y,X-XMin,Y-6,Active);
      {Avoid METAFONT buffer overflow}
      If Active Then Writeln(OutFile)
      End;
  Writeln(OutFile,'endchar;');
  Writeln(OutFile)
  End
End; 

Procedure EndOut(Var OutFile:OutFileType; Var RunTime:RunTimeType);
{Writes final METAFONT header}
Begin
Writeln(OutFile,'font_identifier "'+RunTime.FileName+'";');
If RunTime.Standard Then 
  Writeln(OutFile,'font_coding_scheme "JemTeX Standard";')
Else Writeln(OutFile,'font_coding_scheme "JemTeX Dictionary";');
Writeln(OutFile,'font_slant slant;');
Writeln(OutFile,'font_normal_space 8u#;');
Writeln(OutFile,'font_normal_stretch 4u#;');
Writeln(OutFile,'font_normal_shrink 3u#;');
Writeln(OutFile,'font_x_height 24u#; %ex');
Writeln(OutFile,'font_quad 24u#; %em');
Writeln(OutFile,'font_extra_space 0u#;');
Writeln(OutFile);
{Must end with CR/LF because of a bug(?) in emTeX METAFONT}
Writeln(OutFile,'bye')
End;

{---------------------------------- Generate ---------------------------------}

Procedure FindWantedBitmap(Automatic:Boolean; Var First:Boolean;
                           Var WantedBitmap:Bitmap0Range; Var Number:Integer);
{Finds the number of the next desired Bitmap either automatically or manually}
{The characters 0 and 1 in the first font kanjiaa are both set to Bitmap 1}
Var Valid:Boolean;
Begin
If Automatic Then
  {Find automatically}
  If First Then
    {Early in font kanjiaa}
    If WantedBitmap=-1 Then WantedBitmap:=1
    Else
      Begin
      WantedBitmap:=1;
      First:=False
      End
  Else
    If (Number=128) Or (WantedBitmap=BitmapMax) Then WantedBitmap:=0
    Else WantedBitmap:=WantedBitmap+1
Else
  {Find manually}
  Repeat
    Write('Bitmap number? ');
    Readln(WantedBitmap);
    Writeln;
    Valid:=( (0<=WantedBitmap) And (WantedBitmap<=BitmapMax) );
    If Not Valid Then Writeln(Chr(7)+'Bitmap ',WantedBitmap,' out of range...')
  Until Valid;
Writeln('Bitmap number ',WantedBitmap,'.')
End;

Procedure ScanBitmap(Var InFile:InFileType; Var Bitmap:BitmapType;
                     Var Empty:Boolean);
{Reads the Bitmap in a logical grid}
{(0,0) is the lower left corner of the Bitmap}
Label 1;
Var
  Y:SizeRange;
  Buffer:BufferType;
Begin
{Read the Bitmap}
BlockRead(InFile,Buffer,1);
{Find if the Bitmap is empty}
Empty:=True;
For Y:=1 To SizeMax Do
  With Buffer[Y] Do
    If (Data1<>$00) Or (Data2<>$00) Or (Data3<>$00) Then
      Begin
      Empty:=False;
      Goto 1
      End;
{Update logical grid}
1:If Not Empty Then
  For Y:=1 To SizeMax Do 
    With Buffer[SizeMax1-Y] Do
      Begin
      Bitmap[ 1,Y]:=((Data1 And $80)<>0);
      Bitmap[ 2,Y]:=((Data1 And $40)<>0);
      Bitmap[ 3,Y]:=((Data1 And $20)<>0);
      Bitmap[ 4,Y]:=((Data1 And $10)<>0);
      Bitmap[ 5,Y]:=((Data1 And $08)<>0);
      Bitmap[ 6,Y]:=((Data1 And $04)<>0);
      Bitmap[ 7,Y]:=((Data1 And $02)<>0);
      Bitmap[ 8,Y]:=((Data1 And $01)<>0);
      Bitmap[ 9,Y]:=((Data2 And $80)<>0);
      Bitmap[10,Y]:=((Data2 And $40)<>0);
      Bitmap[11,Y]:=((Data2 And $20)<>0);
      Bitmap[12,Y]:=((Data2 And $10)<>0);
      Bitmap[13,Y]:=((Data2 And $08)<>0);
      Bitmap[14,Y]:=((Data2 And $04)<>0);
      Bitmap[15,Y]:=((Data2 And $02)<>0);
      Bitmap[16,Y]:=((Data2 And $01)<>0);
      Bitmap[17,Y]:=((Data3 And $80)<>0);
      Bitmap[18,Y]:=((Data3 And $40)<>0);
      Bitmap[19,Y]:=((Data3 And $20)<>0);
      Bitmap[20,Y]:=((Data3 And $10)<>0);
      Bitmap[21,Y]:=((Data3 And $08)<>0);
      Bitmap[22,Y]:=((Data3 And $04)<>0);
      Bitmap[23,Y]:=((Data3 And $02)<>0);
      Bitmap[24,Y]:=((Data3 And $01)<>0)
      End
End;

Procedure ScanSides(Var Bitmaps:BitmapsType; FixedX,FixedY:Boolean);
{Determines the minimal size of the Bitmap for proportional spacing}
Var X,Y:SizeRange;
Begin
With Bitmaps Do
  Begin
  If FixedX Then
    Begin 
    XMin:=1; 
    XMax:=SizeMax 
    End
  Else
    Begin
    XMin:=SizeMax1;
    For X:=SizeMax DownTo 1 Do 
      For Y:=1 To SizeMax Do 
        If Bitmap[X,Y] Then XMin:=X;
    XMax:=0;
    For X:=1 To SizeMax Do 
      For Y:=1 To SizeMax Do 
        If Bitmap[X,Y] Then XMax:=X
    End;
  If FixedY Then
    Begin 
    YMin:=1; 
    YMax:=SizeMax 
    End
  Else
    Begin
    YMin:=SizeMax1;
    For Y:=SizeMax DownTo 1 Do
      For X:=1 To SizeMax Do
        If Bitmap[X,Y] Then YMin:=Y;
    YMax:=0;
    For Y:=1 To SizeMax Do
      For X:=1 To SizeMax Do
        If Bitmap[X,Y] Then YMax:=Y
    End
  End
End;

Procedure Generate(Var InFile:InFileType; Var OutFile:OutFileType;
                   Var Number:Integer; Var RunTime:RunTimeType);
{Generates the METAFONT code for the selected font}
Var
  {Bitmap pointers}
  CurrentBitmap,WantedBitmap:Bitmap0Range;
  {Current Bitmap}
  Bitmaps:BitmapsType;
  X,Y:Size0Range;
  {Indicates early in font kanjiaa}
  First:Boolean;
  {Indicates current Bitmap is empty}
  Empty:Boolean;
Begin
{Clear the area outside the Bitmap once and for all}
With Bitmaps Do
  Begin
  For X:=0 To SizeMax1 Do 
    Begin Bitmap[X,0]:=False; Bitmap[X,SizeMax1]:=False End;
  For Y:=1 To SizeMax Do 
    Begin Bitmap[0,Y]:=False; Bitmap[SizeMax1,Y]:=False End
  End;
{Number of the Bitmap ready to be read}
CurrentBitmap:=1;
{First METAFONT character number}
Number:=0;
{First Bitmap wanted}
If RunTime.Automatic Then
  Begin
  WantedBitmap:=1024 * ( Ord(UpCase(RunTime.FileName[6]))-Ord('A') ) +
                128 * ( Ord(UpCase(RunTime.FileName[7]))-Ord('A') ) - 1;
  First:=(WantedBitmap=-1)
  End;
Repeat
  FindWantedBitmap(RunTime.Automatic,First,WantedBitmap,Number);
  If WantedBitmap<>0 Then
    Begin
    {Position pointer}
    If WantedBitmap<>CurrentBitmap Then 
      Begin
      Seek(InFile,WantedBitmap-1);
      CurrentBitmap:=WantedBitmap
      End;
    Write('Reading Bitmap');
    ScanBitmap(InFile,Bitmaps.Bitmap,Empty);
    CurrentBitmap:=CurrentBitmap+1;
    Writeln('.');
    {Process Bitmap}
    If Empty Then Writeln('Bitmap is empty, no METAFONT code ',Number,'.')
    Else
      Begin
      Write('Writing METAFONT code ',Number);
      ScanSides(Bitmaps,RunTime.FixedX,RunTime.FixedY);
      MiddleOut(OutFile,Bitmaps,Number,RunTime.Standard);
      Writeln('.')
      End;
    Writeln;
    {Ready to generate next METAFONT character}
    Number:=Number+1
    End;
Until WantedBitmap=0
End;

{------------------------------------ Main -----------------------------------}

Begin
Writeln;
Writeln('Bitmaps to METAFONT Conversion Program.');   {To make Borland happy}
Writeln('Version 2.00 Copyright F. Jalbert 1991.');
Writeln;

Write('Opening Bitmap file JIS24');
Assign(InFile,'JIS24');
Reset(InFile,RecSize);
Writeln('.');
Writeln;

GetParameters(RunTime);
Write('Creating METAFONT file '+RunTime.FileName+'.mf');
Assign(OutFile,RunTime.FileName+'.mf');
Rewrite(OutFile);
Writeln('.');
Writeln;

Write('Writing initial METAFONT header');
BeginOut(OutFile,RunTime);
Writeln('.');
Writeln;
Generate(InFile,OutFile,Number,RunTime);
Writeln;

Write('Writing final METAFONT header');
EndOut(OutFile,RunTime);
Writeln('.');
Write('Closing METAFONT file '+RunTime.FileName+'.mf');
Close(OutFile);
Writeln('.');
Write('Closing Bitmap file JIS24');
Close(InFile);
Writeln('.');
Writeln;

Writeln('METAFONT code for ',Number,' Bitmap(s) generated.');
Writeln
End.