IMPLEMENTATION MODULE PicToMeta;
(* Wandelt Graphikfiles in's       *)
(* Metafont-Format                 *)
(* JP 16/11/90 18:30               *)
(* Letzte Žnderung: 01/12/90 14:26 *)
(* Letzte Žnderung: 17/03/91 11:08 *)

FROM Dialoge     IMPORT BusyStart, BusyEnd, ChangePicRes, GetFontRes;
FROM Diverses    IMPORT NumAlert;
FROM FileIO      IMPORT Rewrite, WriteLn, Close, Reset, EOF, ReadChar;
FROM SYSTEM      IMPORT ADDRESS , ADR;
FROM Storage     IMPORT ALLOCATE , DEALLOCATE ;
FROM Types       IMPORT ObjectPtrTyp, sourceformat, targetformat;

IMPORT CommonData;
IMPORT GetFile;
IMPORT MagicStrings ;
IMPORT MagicSys ;
IMPORT mtAlerts;
IMPORT Variablen;
(**
IMPORT RTD;
**)

TYPE LinePtr     = POINTER TO LineRec;
     LineRec     = RECORD
                     start, end, line, depth : INTEGER;
                     Prev, Next : LinePtr;
                   END;
VAR
    RdHandle          : INTEGER;
    WtHandle          : INTEGER;
    OptimizeMode      : BOOLEAN;
    MetafontMode      : targetformat;
    FirstPtr          : LinePtr;
    startx            : INTEGER;
    endx              : INTEGER;
    Xmul, Ymul        : INTEGER;
    XYswap            : BOOLEAN; (* frs PAC-Format ben”tigt *)

    DebugLevel        : CARDINAL;


PROCEDURE ggT(x, y : INTEGER) : INTEGER;
VAR a, b, r : INTEGER;
BEGIN
  a := x;       (* Euklidischer Algorithmus *)
  b := y;
  REPEAT
    r := b MOD a;
    b := a;
    a := r;
  UNTIL r=0;
  RETURN b;
END ggT;

(**
PROCEDURE AppendChar(c : CHAR; VAR target : ARRAY OF CHAR);
VAR temp : ARRAY [0..1] OF CHAR;
BEGIN
  temp[0] := c;
  temp[1] := 0C;
  MagicStrings.Append(temp, target);
END AppendChar;
**)

PROCEDURE GetOutFileName(     input : ARRAY OF CHAR;
                         VAR output : ARRAY OF CHAR);
VAR i : INTEGER;
BEGIN
  MagicStrings.Assign( input, output );
  CASE MetafontMode OF
    metafont: i := 4; |
    tex :     i := 2; |
    gfpk:     i := 10; |
   ELSE
    i := 0;
  END;
  IF i>0 THEN
    GetFile.ReplaceExtension(output, CommonData.Extensions[i]);
  END;
  GetFile.RemovePath(output);
  CASE MetafontMode OF
    metafont : IF CommonData.MetaPath[0]<>0C THEN
             MagicStrings.Insert(CommonData.MetaPath, output, 0);
           END; |
    tex  : IF CommonData.LaTeXPath[0]<>0C THEN
             MagicStrings.Insert(CommonData.LaTeXPath, output, 0);
           END; |
    gfpk : IF CommonData.GFPKPath[0]<>0C THEN
             MagicStrings.Insert(CommonData.GFPKPath, output, 0);
           END; |
   ELSE
  END;
END GetOutFileName;

PROCEDURE WriteMetaProlog(xo, yo, X, Y : INTEGER;
                                  info : ARRAY OF CHAR);
(*  X,  Y : Zahl der Spalten und Zeilen *)
(* xo, yo : Gr”že eines Pixels in æm *)
VAR Line, String : ARRAY [0..127] OF CHAR;
    Comment      : ARRAY [0..1] OF CHAR;
BEGIN
  Comment := '%';
  WriteLn ( WtHandle, Comment ) ;
  WriteLn ( WtHandle, '% Graphic-font-file  (created by TeX-Draw, JP-90)');
  IF OptimizeMode THEN
    WriteLn ( WtHandle,
     '% I tried to minimize the number of commands (not very well I fear).');
   ELSE
    WriteLn ( WtHandle,
     '% There are no optimizations at all (well just one)');
  END;
  WriteLn ( WtHandle, info ) ;
  WriteLn ( WtHandle, Comment ) ;
  WriteLn ( WtHandle, 'mode_setup;' ) ;
  WriteLn ( WtHandle, 'font_identifier:="TeXDraw-Picture";');
  WriteLn ( WtHandle, 'font_coding_scheme:="TeXDraw-Conversion";');

  WriteLn ( WtHandle, Comment ) ;
  WriteLn ( WtHandle, "% This file contains just one graphic, so we don't need to");
  WriteLn ( WtHandle, '% specify values for fontdimen 1..7 (at least I hope so).');
  WriteLn ( WtHandle, Comment ) ;

  Line := 'xu# := ';  Variablen.NumberToStr(xo, String);
  MagicStrings.Append( String, Line);
  MagicStrings.Append( ' * 0.001 * mm#;' , Line);
  WriteLn ( WtHandle, Line);
  Line := 'yu# := ';  Variablen.NumberToStr(yo, String);
  MagicStrings.Append( String, Line);
  MagicStrings.Append( ' * 0.001 * mm#;' , Line);
  WriteLn ( WtHandle, Line);

  Line := 'symb_w#:=';   Variablen.NumberToStr(X, String);
  MagicStrings.Append( String, Line);
  MagicStrings.Append( ' * xu#;', Line);
  WriteLn ( WtHandle, Line);
  Line := 'symb_h#:=';   Variablen.NumberToStr(Y, String);
  MagicStrings.Append( String, Line);
  MagicStrings.Append( ' * yu#;', Line);
  WriteLn ( WtHandle, Line);
  WriteLn ( WtHandle, 'font_size symb_h#;');
  WriteLn ( WtHandle, 'define_pixels(xu, yu);');
  WriteLn ( WtHandle, Comment);

  Line := 'beginchar(';
  Variablen.NumberToStr(CommonData.MetaPAscii, String);
  MagicStrings.Append( String, Line);

  MagicStrings.Append(', symb_w#, symb_h#, 0); "The picture', Line);
  IF (CommonData.MetaPAscii>=32) AND (CommonData.MetaPAscii<127) THEN
    String    := ' (?)';
    String[2] := CHR(CommonData.MetaPAscii);
    MagicStrings.Append( String, Line);
  END;
  MagicStrings.Append('.";', Line);

  WriteLn ( WtHandle, Line );
  WriteLn ( WtHandle, 'pickup pensquare xscaled xu yscaled yu;');
END WriteMetaProlog;

(**********************************************************)

PROCEDURE WriteTeXProlog(xo, yo, X, Y : INTEGER;
                                 info : ARRAY OF CHAR);
(*  X,  Y : Zahl der Spalten und Zeilen *)
(* xo, yo : Gr”že eines Pixels in æm *)
VAR Line, String : ARRAY [0..127] OF CHAR;
    Comment      : ARRAY [0..1] OF CHAR;
    ggTVal       : INTEGER;
BEGIN
  Comment := '%';
  WriteLn ( WtHandle, Comment ) ;
  WriteLn ( WtHandle, '% Graphic-TeX-file  (created by TeX-Draw, JP-90)');
  IF OptimizeMode THEN
    WriteLn ( WtHandle,
     '% I tried to minimize the number of commands (not very well I fear).');
   ELSE
    WriteLn ( WtHandle,
     '% There are no optimizations at all (well just one)');
  END;
  WriteLn ( WtHandle, info ) ;
  WriteLn ( WtHandle, Comment ) ;
  WriteLn ( WtHandle, '\newdimen\mum \mum=0.001mm' ) ;

  ggTVal := ggT(xo, yo);
  Xmul   := xo DIV ggTVal;
  Ymul   := yo DIV ggTVal;

  Line := '\newdimen\xu \xu=';  Variablen.NumberToStr(xo, String);
  MagicStrings.Append( String, Line);
  MagicStrings.Append( '\mum' , Line);
  WriteLn ( WtHandle, Line);

  Line := '\newdimen\yu \yu=';  Variablen.NumberToStr(yo, String);
  MagicStrings.Append( String, Line);
  MagicStrings.Append( '\mum' , Line);
  WriteLn ( WtHandle, Line);

  Line := "\setlength{\unitlength}{";
  Variablen.NumberToStr(ggTVal, String); MagicStrings.Append( String, Line);
  MagicStrings.Append( '\mum}' , Line);
  WriteLn ( WtHandle, Line) ;

  Line := '\begin{picture}(';
  Variablen.NumberToStr(X * Xmul, String); MagicStrings.Append( String, Line);
(*  AppendChar(',', Line);*)
  MagicStrings.Append(',', Line);
  Variablen.NumberToStr(Y * Ymul, String); MagicStrings.Append( String, Line);
(*  AppendChar(')', Line);*)
  MagicStrings.Append(')', Line);
  WriteLn ( WtHandle, Line);
END WriteTeXProlog;

(**********************************************************)

PROCEDURE WriteMetaEpilog;
VAR Line : ARRAY [0..127] OF CHAR;
BEGIN
  WriteLn ( WtHandle, 'endchar;  % Pooh, this was lot of work...');
  WriteLn ( WtHandle, 'end.');
END WriteMetaEpilog;

(**********************************************************)

PROCEDURE WriteTeXEpilog;
BEGIN
  WriteLn ( WtHandle, '\end{picture} % Pooh, this was lot of work...');
END WriteTeXEpilog;

(**********************************************************)

PROCEDURE DoLine(start, end, second, depth : INTEGER);
VAR Start, End, Third : INTEGER;
    LowY, LowX        : INTEGER;
    temp,
    Line, number : ARRAY [0..127] OF CHAR;

  PROCEDURE AddNum(a, b    : INTEGER;
                   REF txt : ARRAY OF CHAR);
  BEGIN
    IF XYswap THEN
      Variablen.NumberToStr(a, number);
     ELSE
      Variablen.NumberToStr(b, number);
    END;
    MagicStrings.Append( number, Line);
    MagicStrings.Append( txt, Line);
  END AddNum;

  PROCEDURE AddFill(a, b    : INTEGER;
                    minus   : BOOLEAN;
                    REF txt : ARRAY OF CHAR);
  VAR i : INTEGER;
  BEGIN
    IF XYswap THEN
      i := a;
     ELSE
      i := b;
    END;
(*
    RTD.ShowVar('AddFill(i)=', i);
*)
    IF minus THEN
      IF i<=0 THEN
        i := ABS(i);
(*        AppendChar('-', Line);*)
        MagicStrings.Append('-', Line);
       ELSE
        DEC(i, 1);
      END;
     ELSE
      IF i<0 THEN
        i := ABS(i);
        DEC(i, 1);
(*        AppendChar('-', Line);*)
        MagicStrings.Append('-', Line);
      END;
    END;
    Variablen.NumberToStr(i, number);
    MagicStrings.Append( number, Line);
    MagicStrings.Append( '.5', Line);
    MagicStrings.Append( txt, Line);
(*
    IF minus THEN
      RTD.ShowVar('AddFill(-)=', i);
     ELSE
      RTD.ShowVar('AddFill(+)=', i);
    END;
    RTD.Message(Line);
*)
  END AddFill;

  PROCEDURE SetCoord(x, y    : INTEGER;
                     VAR txt : ARRAY OF CHAR);
  BEGIN
(*
    RTD.ShowVar('SC x', x);
    RTD.ShowVar('SC y', y);
*)
    Line := '\put(';
    IF XYswap THEN
      Variablen.NumberToStr(x * Xmul, number);
     ELSE
      Variablen.NumberToStr(y * Ymul, number);
    END;
    MagicStrings.Append( number, Line);
(*    AppendChar(',', Line);*)
    MagicStrings.Append(',', Line);
    IF XYswap THEN
      Variablen.NumberToStr(y * Ymul, number);
     ELSE
      Variablen.NumberToStr(x * Xmul, number);
    END;
    MagicStrings.Append(number, Line);
    MagicStrings.Append('){', Line);
    MagicStrings.Append(txt, Line);
(*    AppendChar('}', Line);*)
    MagicStrings.Append('}', Line);
  END SetCoord;

BEGIN
  (*
     M”gliche F„lle :
     - einzelner Pixel, eine Zeile
     - mehrere Pixel lang, aber nur eine Zeile
     - einzelner Pixel, mehrere Zeilen
     - mehrere Pixel, mehrere Zeilen
  *)
  IF start<=end THEN                   (*            second           *)
    Start := start; End := end;        (*        +------------+       *)
   ELSE                                (*  Start |            | End   *)
    Start := end; End := start;        (*        +------------+       *)
  END;                                 (*             Third           *)
  IF XYswap THEN
    Third := second + depth - 1;       (*             Start           *)
   ELSE                                (*        +------------+       *)
    Third := second - depth + 1;       (* second |            | Third *)
  END;                                 (*        +------------+       *)
                                       (*             End             *)
(**
  RTD.ShowVar('start', start);
  RTD.ShowVar('end  ', end);
  RTD.ShowVar('2nd  ', second);
  RTD.ShowVar('depth', depth);
**)
  IF MetafontMode=metafont THEN
    IF Start = End THEN
      IF depth=1 THEN
        Line := 'drawdot(';
        AddNum(second, Start, 'xu,' );
        AddNum(Start, second, 'yu);');
       ELSE
        Line := 'draw(';
        AddNum(second, Start, 'xu,' );
        AddNum(Start, second, 'yu)--(');
        AddNum(Third, Start, 'xu,');
        AddNum(Start, Third, 'yu);');
      END;
     ELSE
      (* mehrere Pixel *)
      IF depth = 1 THEN
        Line := 'draw(';
        AddNum(second, Start, 'xu,');
        AddNum(Start, second, 'yu)--(');
        AddNum(second, End, 'xu,');
        AddNum(End, second, 'yu);');
       ELSE
        Line := 'fill(';
        (* XYswap =    1 --- 2         XYswap =     2 --- 3     *)
        (* FALSE       |     |         TRUE         |     |     *)
        (*             4 --- 3                      1 --- 4     *)
        IF XYswap THEN
          AddFill(second, Start, TRUE, 'xu,');        (* 1 *)
          AddFill(Start, second, TRUE, 'yu)--(');
          AddFill(second, End, TRUE, 'xu,');          (* 2 *)
          AddFill(End, second, FALSE, 'yu)--(');
          AddFill(Third, End, FALSE, 'xu,');          (* 3 *)
          AddFill(End, Third, FALSE, 'yu)--(');
          AddFill(Third, Start, FALSE, 'xu,');        (* 4 *)
          AddFill(Start, Third, TRUE, 'yu)--cycle;');
         ELSE
          AddFill(second, Start, TRUE, 'xu,');        (* 1 *)
          AddFill(Start, second, FALSE, 'yu)--(');
          AddFill(second, End, FALSE, 'xu,');         (* 2 *)
          AddFill(End, second, FALSE, 'yu)--(');
          AddFill(Third, End, FALSE, 'xu,');          (* 3 *)
          AddFill(End, Third, TRUE, 'yu)--(');
          AddFill(Third, Start, TRUE, 'xu,');         (* 4 *)
          AddFill(Start, Third, TRUE, 'yu)--cycle;');
        END;
      END;
    END;
    WriteLn(WtHandle, Line);
   ELSIF MetafontMode = tex THEN
    (* mehrere Pixel *)
    Line := '\rule{';
    IF XYswap THEN
      LowX := Start;
      LowY := second;
      AddNum(depth, depth, '\xu}{');
      AddNum(End-Start+1, End-Start+1, '\yu}');
     ELSE
      LowY := second + 1 - depth;
      LowX := Start;
      AddNum(End-Start+1, End-Start+1, '\xu}{');
      AddNum(depth, depth, '\yu}');
    END;
    MagicStrings.Assign(Line, temp);
    SetCoord(LowY, LowX, temp);
    WriteLn(WtHandle, Line);
   ELSE
  END;
END DoLine;

PROCEDURE AddLine(Start, End, Line : INTEGER);
TYPE posi = (lower, equal, higher);
VAR work, temp : LinePtr;
    inserted   : BOOLEAN;
    flushit    : BOOLEAN;
    lowborder  : posi;
    hiborder   : posi;
    count      : INTEGER;

  PROCEDURE CreateObj(VAR obj : LinePtr; Start, End, Line : INTEGER);
  BEGIN
    NEW(obj);
    obj^.Prev  := NIL;
    obj^.Next  := NIL;
    obj^.start := Start;
    obj^.end   := End;
    obj^.line  := Line;
    obj^.depth := 1;
  END CreateObj;

BEGIN
(**
  RTD.ShowVar('Start:', Start);
  RTD.ShowVar('End  :', End  );
  RTD.ShowVar('Line :', Line );
**)
  (* Zun„chst: sind irgendwelche šberbleibsel vorhanden ? *)
(**
  work := FirstPtr;
  count := 0;
  WHILE work<>NIL DO
    INC(count, 1);
    work := work^.Next;
  END;
  RTD.ShowVar('anz = ', count);
**)
  count := 0;
  work := FirstPtr;
  WHILE work<>NIL DO
    INC(count, 1);
    IF XYswap THEN
      flushit := work^.line + work^.depth < Line;    (* X-CRD *)
(**
      IF flushit THEN
        RTD.ShowVar('w^l=', work^.line);
        RTD.ShowVar('w^d=', work^.depth);
        RTD.ShowVar('lin=', Line);
        INC(DebugLevel, 1);
        IF DebugLevel>20 THEN
          HALT;
        END;
      END;
**)
(**)
(**
      flushit := FALSE;
**)
     ELSE
      flushit := work^.line - work^.depth > Line;
    END;
    IF flushit THEN
      (* Also Schluž *)
      temp := work;
      DoLine(work^.start, work^.end,
             work^.line,  work^.depth);
      IF work^.Prev<>NIL THEN
        work^.Prev^.Next := work^.Next;
       ELSE
        FirstPtr := work^.Next;
      END;
      IF work^.Next<>NIL THEN
        work^.Next^.Prev := work^.Prev;
      END;
      work := work^.Next;
      DISPOSE(temp);
     ELSE
      work := work^.Next;
    END;
  END;
(**
  RTD.ShowVar('tst = ', count);
**)
  IF FirstPtr=NIL THEN
    CreateObj(FirstPtr, Start, End, Line);
   ELSE
    work := FirstPtr;
    inserted := FALSE;
    WHILE (work<>NIL) AND NOT inserted DO
      IF (Start<work^.start) AND (End<work^.start) THEN
        (* einfgen *)
        inserted := TRUE;
        temp := work^.Prev;
        CreateObj(work^.Prev, Start, End, Line);
        work^.Prev^.Next := work;
        IF temp<>NIL THEN
          temp^.Next := work^.Prev;
          work^.Prev^.Prev := temp;
         ELSE
          FirstPtr := work^.Prev;
        END;
       ELSIF (Start=work^.start) AND (End=work^.end) THEN
        (* Prfe auf direkten Anschluž *)
(**
        RTD.ShowVar('w^.s=', work^.start);
        RTD.ShowVar('w^.e=', work^.end);
        RTD.ShowVar('w^.l=', work^.line);
        RTD.ShowVar('w^.d=', work^.depth);
        RTD.ShowVar('s=', Start);
        RTD.ShowVar('e=', End);
        RTD.ShowVar('l=', Line);
**)
        IF XYswap THEN
          (* Line ist die X-Koordinate *)
          inserted := Line = (work^.line + work^.depth);
         ELSE
          (* Line ist die Y-Koordinate *)
          inserted := Line = (work^.line - work^.depth);
        END;
        IF inserted THEN
          INC(work^.depth, 1);
         ELSE
          DoLine(work^.start, work^.end,
                 work^.line,  work^.depth);
          work^.line  := Line;
          work^.depth := 1;
        END;
        inserted := TRUE;
       ELSIF (Start>work^.end) THEN
        (* weitermachen oder Ende erreicht *)
        IF (work^.Next=NIL) THEN
          CreateObj(work^.Next, Start, End, Line);
          work^.Next^.Prev := work;
          inserted := TRUE;
         ELSE
          work := work^.Next;
        END;
       ELSE
        (* teilweise šberlappung *)
        inserted := TRUE;
        DoLine(work^.start, work^.end,
               work^.line,  work^.depth);
        work^.start := Start; work^.end   := End;
        work^.line  := Line;  work^.depth := 1;
      END;
    END;
  END;
END AddLine;

PROCEDURE WriteMetaLine ( bytes : ARRAY OF CHAR; CurrY, count : INTEGER);
VAR bitset      : BITSET;
    i, j, CurrX : INTEGER;
    temp, x, y  : INTEGER;

  PROCEDURE AddPixel(x : INTEGER);
  BEGIN
    IF startx<0 THEN
      startx := x;
      endx   := x;
     ELSE
      endx := x;
    END;
  END AddPixel;

  PROCEDURE endline(XYValue : INTEGER);
  BEGIN
    IF startx>=0 THEN
      IF OptimizeMode THEN
        AddLine(startx, endx, XYValue);
       ELSE
        DoLine(startx, endx, XYValue, 1);
      END;
    END;
    startx := -1;
  END endline;

BEGIN
  startx := -1;
  endx   := -1;
  IF XYswap THEN
    (* Jedes Bit einzeln *)
    temp := CurrY * 8;
    FOR j:=0 TO 7 DO
      startx := -1;
      endx   := -1;
(*
      WriteLn(WtHandle, '% next line...');
*)
      CurrX := 0;
      FOR i:=0 TO count-1 DO

        IF bytes[i]<>0C THEN
          bitset := BITSET(ORD(bytes[i]));
          CASE j OF
           0 : IF MagicSys.Bit7 IN bitset THEN AddPixel(count-1-i); ELSE endline(temp  ); END; |
           1 : IF MagicSys.Bit6 IN bitset THEN AddPixel(count-1-i); ELSE endline(temp+1); END; |
           2 : IF MagicSys.Bit5 IN bitset THEN AddPixel(count-1-i); ELSE endline(temp+2); END; |
           3 : IF MagicSys.Bit4 IN bitset THEN AddPixel(count-1-i); ELSE endline(temp+3); END; |
           4 : IF MagicSys.Bit3 IN bitset THEN AddPixel(count-1-i); ELSE endline(temp+4); END; |
           5 : IF MagicSys.Bit2 IN bitset THEN AddPixel(count-1-i); ELSE endline(temp+5); END; |
           6 : IF MagicSys.Bit1 IN bitset THEN AddPixel(count-1-i); ELSE endline(temp+6); END; |
           7 : IF MagicSys.Bit0 IN bitset THEN AddPixel(count-1-i); ELSE endline(temp+7); END; |
          ELSE
          END;
         ELSE
          endline(temp+j);
        END;
      END;
      endline(temp+j); (* um noch h„ngende Pixel zu schreiben.. *)
    END;
   ELSE
(*
    WriteLn(WtHandle, '% next line...');
*)
    CurrX := 0;
    FOR i:=0 TO count-1 DO

      IF bytes[i]<>0C THEN
        bitset := BITSET(ORD(bytes[i]));
        IF MagicSys.Bit7 IN bitset THEN AddPixel(CurrX  ); ELSE endline(CurrY); END;
        IF MagicSys.Bit6 IN bitset THEN AddPixel(CurrX+1); ELSE endline(CurrY); END;
        IF MagicSys.Bit5 IN bitset THEN AddPixel(CurrX+2); ELSE endline(CurrY); END;
        IF MagicSys.Bit4 IN bitset THEN AddPixel(CurrX+3); ELSE endline(CurrY); END;
        IF MagicSys.Bit3 IN bitset THEN AddPixel(CurrX+4); ELSE endline(CurrY); END;
        IF MagicSys.Bit2 IN bitset THEN AddPixel(CurrX+5); ELSE endline(CurrY); END;
        IF MagicSys.Bit1 IN bitset THEN AddPixel(CurrX+6); ELSE endline(CurrY); END;
        IF MagicSys.Bit0 IN bitset THEN AddPixel(CurrX+7); ELSE endline(CurrY); END;
       ELSE
        endline(CurrY);
      END;
      CurrX := CurrX + 8;
    END;
    endline(CurrY); (* um noch h„ngende Pixel zu schreiben.. *)
  END;
END WriteMetaLine;

(**********************************************************)

PROCEDURE InitMetaBuffer;
BEGIN
  FirstPtr := NIL;
END InitMetaBuffer;

PROCEDURE FlushMetaBuffer;
(* sorgt dafr, daž noch vorhandene Objekte rausgeschrieben werden. *)
VAR work : LinePtr;
BEGIN
  IF OptimizeMode THEN
    WHILE FirstPtr<>NIL DO
      DoLine(FirstPtr^.start, FirstPtr^.end,
             FirstPtr^.line, FirstPtr^.depth);
      IF FirstPtr^.Next<>NIL THEN
        FirstPtr := FirstPtr^.Next;
        DISPOSE(FirstPtr^.Prev);
       ELSE
        FirstPtr := NIL;
      END;
    END;
  END;
END FlushMetaBuffer;
(**********************************************************)

PROCEDURE FinishTranslation;
BEGIN
  IF OptimizeMode THEN
    FlushMetaBuffer;
  END;
  CASE MetafontMode OF
   metafont : WriteMetaEpilog; |
   tex      : WriteTeXEpilog; |
   gfpk     : |
   ELSE
  END;
END FinishTranslation;


PROCEDURE ConvertPACFile(REF input : ARRAY OF CHAR);
VAR output         : ARRAY [0..255] OF CHAR;
    i, j, count    : INTEGER;
    end            : BOOLEAN;
    bytesperline   : INTEGER;
    factor, CurrY  : INTEGER;
    mux, muy, X, Y : INTEGER;
    flag, pack,
    special        : CHAR;
    bytes          : ARRAY [0..2047] OF CHAR;
    create         : ARRAY [0..19] OF INTEGER;

  PROCEDURE ReadPACHeader(VAR flag, pack, special : CHAR) : BOOLEAN;
  VAR c       : CHAR;
  BEGIN
    ReadChar(RdHandle, c);
    IF c='p' THEN
      ReadChar(RdHandle, c);
      IF c='M' THEN
        ReadChar(RdHandle, c);
        IF c='8' THEN
          ReadChar(RdHandle, c);
          IF c='5' THEN
            XYswap := FALSE;  (* horizontal gepackt *)
           ELSIF c='6' THEN
            XYswap := TRUE;   (* vertikal gepackt *)
           ELSE
            RETURN FALSE;
          END;
          ReadChar(RdHandle, flag);
          ReadChar(RdHandle, pack);
          ReadChar(RdHandle, special);
          RETURN NOT EOF;
         ELSE
          RETURN FALSE;
        END;
       ELSE
        RETURN FALSE;
      END;
     ELSE
      RETURN FALSE;
    END;
  END ReadPACHeader;

  PROCEDURE UnpackFile;
  VAR bytesunpacked : INTEGER;
      bytestotal    : INTEGER;
      c, d          : CHAR;
      i, j, count,
      XY            : INTEGER;
  BEGIN
    bytesunpacked := 0;
    bytestotal    := 0;
    CurrY         := 0;
    IF XYswap THEN
      bytesperline := 400;
      XY := X;
     ELSE
      bytesperline := 80;
      XY := Y;
    END;
    WHILE (bytestotal<32000) AND NOT EOF DO
      ReadChar(RdHandle, c);
      IF NOT EOF THEN
        IF c=flag THEN
          ReadChar(RdHandle, d);
          count := ORD(d);

          FOR i := 0 TO count DO
            bytes[bytesunpacked] := pack;
            INC(bytesunpacked, 1);
            INC(bytestotal, 1);
          END;
         ELSIF c=special THEN
          ReadChar(RdHandle, c);
          ReadChar(RdHandle, d);
          count := ORD(d);

          FOR i := 0 TO count DO
            bytes[bytesunpacked] := c;
            INC(bytesunpacked, 1);
            INC(bytestotal, 1);
          END;
         ELSE
          bytes[bytesunpacked] := c;
          INC(bytesunpacked, 1);
          INC(bytestotal, 1);
        END;
        WHILE bytesunpacked>=bytesperline DO
          IF XYswap THEN
            WriteMetaLine(bytes, CurrY,
                          bytesperline);
           ELSE
            WriteMetaLine(bytes, XY-CurrY-1, (* sonst stehts auf dem Kopf *)
                          bytesperline);
          END;
          FOR i:= bytesperline TO bytesunpacked DO
            bytes[i-bytesperline] := bytes[i];
          END;
          INC(CurrY, 1);
          DEC(bytesunpacked, bytesperline);
        END;
      END;
    END;
  END UnpackFile;

BEGIN
  XYswap := FALSE;
  GetOutFileName ( input, output );
  (* ™ffne PAC-Datei *)
  Reset(RdHandle, input);
  mux := +372; (* 68 dpi *)
  muy := +372; (* 68 dpi *)
  X   := 640;  (* Screen-Format *)
  Y   := 400;
  IF ReadPACHeader(flag, pack, special) THEN
    IF GetFile.Check(output) THEN
      IF MetafontMode<>gfpk THEN
        ChangePicRes(mux, muy, X, Y);
       ELSE
        GetFontRes(mux, muy, create);
(**
        i := 0;
        WHILE create[i]<>-1 DO
          RTD.ShowVar('x-res', create[i]);
          RTD.ShowVar('y-res', create[i+1]);
          INC(i, 2);
        END;
**)
      END;
      BusyStart(input, TRUE);
      Rewrite(WtHandle, output);
      CurrY := 0;
      CASE MetafontMode OF
        metafont : 
               IF XYswap THEN
                 WriteMetaProlog(mux, muy, X, Y, '% Origin was a vertically packed STAD-picture.');
                ELSE
                 WriteMetaProlog(mux, muy, X, Y, '% Origin was a horizontally packed STAD-picture.');
               END; |
        tex  : IF XYswap THEN
                 WriteTeXProlog(mux, muy, X, Y, '% Origin was a vertically packed STAD-picture.');
                ELSE
                 WriteTeXProlog(mux, muy, X, Y, '% Origin was a horizontally packed STAD-picture.');
               END; |
        gfpk : IF XYswap THEN
               END; |
       ELSE
      END;
      InitMetaBuffer;
      UnpackFile;
      FinishTranslation;
      Close(WtHandle);
      BusyEnd;
    END;
   ELSE
    mtAlerts.SetIcon(mtAlerts.Graphic);
(**
    i := Alert(1, NoSTADfile);
**)
    i := NumAlert(10, 1);
  END;
  Close(RdHandle);
END ConvertPACFile;

(**********************************************************)

PROCEDURE ConvertIMGFile(REF input : ARRAY OF CHAR);
VAR output         : ARRAY [0..255] OF CHAR;
    i, j, count    : INTEGER;
    end            : BOOLEAN;
    factor, CurrY  : INTEGER;
    mux, muy, X, Y : INTEGER;
    patlen         : INTEGER;
    pattern        : ARRAY [0..19] OF CHAR;
    bytes          : ARRAY [0..2047] OF CHAR;
    create         : ARRAY [0..19] OF INTEGER;

  PROCEDURE ReadWord(VAR w : INTEGER);
  VAR c1, c2 : CHAR;
  BEGIN
    ReadChar(RdHandle, c1);
    ReadChar(RdHandle, c2);
    w := ORD(c1) * 0100H + ORD(c2);
  END ReadWord;

  PROCEDURE ReadImgHeader(VAR resx, resy, cols, lines, patlen : INTEGER) : BOOLEAN;
  VAR i, temp : INTEGER;
      headlen : INTEGER;
      planenum: INTEGER;
  BEGIN
    ReadWord(temp);     (* Versionsnummer    *)
    ReadWord(headlen);  (* Headergr”že       *)
    ReadWord(planenum); (* Anzahl der Planes *)
    ReadWord(patlen);   (* Patternsize       *)
    ReadWord(resx);     (* Pixel size (x)    *)
    ReadWord(resy);     (* Pixel size (y)    *)
    ReadWord(cols);     (* Pixel pro Zeile   *)
    ReadWord(lines);    (* Zeilen pro Bild   *)
    FOR temp := 9 TO headlen DO
      ReadWord(i); (* Rest des Headers berlesen *)
    END;
    RETURN (planenum=1) AND (patlen<19) AND
           ((cols+7) DIV 8<2048);  (* nur monochrom *)
  END ReadImgHeader;

  PROCEDURE GetAndUnpackLine(VAR multiply : INTEGER; ToUnpack : INTEGER);
  VAR bytesunpacked : INTEGER;
      c             : CHAR;
      i, j, count   : INTEGER;
  BEGIN
    multiply := 1;
    bytesunpacked := 0;
    WHILE bytesunpacked<ToUnpack DO
      ReadChar(RdHandle, c);
      CASE c OF
       200C : (* unkomprimiert *)
              ReadChar(RdHandle, c);
              count := ORD(c);
              FOR i:=1 TO count DO
                ReadChar(RdHandle, bytes[bytesunpacked]);
                INC(bytesunpacked, 1);
              END;  |
        00C : (* Zeilekopf oder Pattern-Run *)
              ReadChar(RdHandle, c);
              IF c=0C THEN
                (* Spezialfall des Zeilenkopfes *)
                ReadChar(RdHandle, c);
                (* Sollte FF sein *)
                ReadChar(RdHandle, c);
                multiply := ORD(c);
               ELSE
                (* Anzahl der Musterwiederholungen *)
                count := ORD(c);
                (* So jetzt lese das Muster *)
                FOR i:=0 TO patlen - 1 DO
                  ReadChar(RdHandle, pattern[i]);
                END;
                FOR i := 1 TO count DO
                  FOR j:=0 TO patlen-1 DO
                    bytes[bytesunpacked] := pattern[j];
                    INC(bytesunpacked, 1);
                  END;
                END;
              END;      |
       ELSE
         (* Bit 7 gesetzt ? *)
         count := ORD(c);
         IF count >128 THEN
           count := count - 128;
           j     := 255;
          ELSE
           j     := 0;
         END;
         FOR i:=1 TO count DO
           bytes[bytesunpacked] := CHR(j);
           INC(bytesunpacked, 1);
         END;
      END;
    END;
  END GetAndUnpackLine;

BEGIN
  XYswap := FALSE;
  GetOutFileName ( input, output );
  (* ™ffne IMG-Datei *)
  Reset(RdHandle, input);

  IF ReadImgHeader(mux, muy, X, Y, patlen) THEN
    IF GetFile.Check(output) THEN
      ChangePicRes(mux, muy, X, Y);
      IF MetafontMode=gfpk THEN
        GetFontRes(mux, muy, create);
      END;
      BusyStart(input, TRUE);
      Rewrite(WtHandle, output);
      count := (X + 7) DIV 8; (* aufrunden ! *)
      CurrY := 0;
      CASE MetafontMode OF
        metafont : WriteMetaProlog(mux, muy, X, Y, '% Origin was GEM-IMG-file.'); |
        tex  : WriteTeXProlog(mux, muy, X, Y, '% Origin was GEM-IMG-file.'); |
        gfpk : |
       ELSE
      END;
      InitMetaBuffer;
      WHILE CurrY<Y DO
        GetAndUnpackLine(factor, count);
        FOR i:=1 TO factor DO
          WriteMetaLine(bytes, Y-CurrY-1, (* sonst stehts auf dem Kopf *)
                        count);
          INC(CurrY, 1);
        END;
      END;
      FinishTranslation;
      Close(WtHandle);
      BusyEnd;
    END;
   ELSE
    mtAlerts.SetIcon(mtAlerts.Graphic);
(**
    i := Alert(1, WrongIMGfile);
**)
    i := NumAlert(11, 1);
  END;
  Close(RdHandle);
END ConvertIMGFile;

(**********************************************************)

PROCEDURE ConvertPicture(source : sourceformat;
                         target : targetformat);
(* Liest STAD/GEM-IMG--File ein, und wandelt ins TeX bzw. METAFONT-Format *)
(*
  Fragt nach Dateinamen, l„dt Datei ein, und wandelt sie.
  Wildcard-Angaben erlaubt !!
*)
VAR input, titel : ARRAY [0..255] OF CHAR;
    exist        : BOOLEAN;
    okay         : BOOLEAN;
    result       : BOOLEAN;
    but          : INTEGER;
BEGIN
  CASE source OF
    gem, calamus, postscript :
      okay := target = metafont;
      okay := FALSE;        (* Geht noch nicht *)
   ELSE
    okay := TRUE;
  END;
  IF target=gfpk THEN
    okay := FALSE;
  END;
  IF okay THEN
    CASE source OF
      stad       : titel := '>> STAD -> '; |
      img        : titel := '>> IMG -> '; |
      gem        : titel := '>> GEM -> '; |
      calamus    : titel := '>> CVG -> '; |
      postscript : titel := '>> PS -> '; |
     ELSE
    END;
    CASE target OF
      metafont : MagicStrings.Append('MF <<', titel); |
      tex  : MagicStrings.Append('TeX <<', titel);|
      gfpk : MagicStrings.Append('GF <<', titel); |
     ELSE
    END;
    CASE source OF
      stad       :  result := GetFile.GetFileName(input, titel, '*.PAC', '.PAC',
             CommonData.STADPath, titel, exist, FALSE, TRUE, TRUE, TRUE); |
      img        :  result := GetFile.GetFileName(input, titel, '*.IMG', '.IMG',
             CommonData.IMGPath, titel, exist, FALSE, TRUE, TRUE, TRUE); |
      gem        :  result := GetFile.GetFileName(input, titel, '*.GEM', '.GEM',
             CommonData.GEMPath, titel, exist, FALSE, TRUE, TRUE, TRUE); |
      calamus    :  result := GetFile.GetFileName(input, titel, '*.CVG', '.CVG',
             CommonData.GEMPath, titel, exist, FALSE, TRUE, TRUE, TRUE); |
      postscript :  result := GetFile.GetFileName(input, titel, '*.PS', '.PS',
             CommonData.PostPath, titel, exist, FALSE, TRUE, TRUE, TRUE); |
     ELSE
    END;
    IF result THEN
      IF exist THEN
        MetafontMode := target;
        IF target<>gfpk THEN
(**
          but          := Alert(2, ConvertHow);
**)
          but          := NumAlert(12, 2);
          OptimizeMode := but=2;

          DebugLevel   := 0;
         ELSE
          OptimizeMode := FALSE;
        END;
        IF source = stad THEN
          GetFile.WildcardFile(input, ConvertPACFile);
         ELSE
          GetFile.WildcardFile(input, ConvertIMGFile);
        END;
      END;
    END;
   ELSE
    (* Nicht implementiert ... *)
     mtAlerts.SetIcon(mtAlerts.Graphic);
(**
     but := Alert(1, NotPossible);
**)
     but := NumAlert(13, 1);
  END;
END ConvertPicture;

END PicToMeta.