(* ------------------------------------------------------------------------
  :Program.       ImageConvert
  :Author.        Kai Bolay
  :Address.       Hoffmannstraße 168
  :Address.       7250 Leonberg 1
  :Phone.         07152/22135
  :Copyright.     PublicDomain
  :History.       v1.0 25-Nov-89 Initial Version on Amok#29
  :History.       v1.1 14-Feb-90 ColorTable/v3.3 Support
  :Language.      Modula-2
  :Translator.    M2Amiga 3.3d
  :Imports.       IFFSupport1.5 [fbs], InOut2 [Bernd Preusing]
  :Contents.      Umwandlung von IFF-Brushes in M2-Source-Code.
------------------------------------------------------------------------ *)

MODULE ImageConvert;

(* FOLD: IMPORT *)
FROM SYSTEM     IMPORT ADR, ADDRESS;
FROM Arts       IMPORT Assert, TermProcedure, Terminate;
FROM Arguments  IMPORT NumArgs, GetArg;
FROM Str        IMPORT Copy, Concat;
FROM FileNames  IMPORT GetPath;
FROM IFFSupport IMPORT ReadILBM, ReadILBMFlags, ReadILBMFlagSet, IFFInfo;
FROM InOut2     IMPORT SetOutput, WriteString, WriteLn, WriteCard,
                       ReadString, done, CloseOutput, WriteHex, WriteInt;
FROM Graphics   IMPORT RastPortPtr, BitMapPtr, ViewModes, ViewModeSet;
FROM Icon       IMPORT GetDiskObject, PutDiskObject, FreeDiskObject;
FROM Workbench  IMPORT DiskObjectPtr;
FROM Intuition  IMPORT ScreenPtr, CloseScreen, WindowPtr, DisplayBeep;
(* ENDFD *)

VAR num, len         : INTEGER;
    Output, Argument : ARRAY [1..200] OF CHAR;
    ynStr            : ARRAY [1..5] OF CHAR;
    NewCompi, Table  : BOOLEAN;
    DefOpen, ModOpen : BOOLEAN;
    MyScreen         : ScreenPtr;

(* FOLD: MakeIcon *)
PROCEDURE MakeIcon (name : ARRAY OF CHAR);

CONST IconName = "M2:Icons/txt";

VAR Icon : DiskObjectPtr;

BEGIN
   Icon := GetDiskObject (ADR (IconName));
   IF Icon # NIL THEN
      IF PutDiskObject (ADR (name), Icon) THEN END;
      FreeDiskObject (Icon);
   END; (* IF *)
END MakeIcon;
(* ENDFD *)
(* FOLD: WriteName *)
PROCEDURE WriteName (name : ARRAY OF CHAR);

VAR path : ARRAY [0..100] OF CHAR;
    len  : INTEGER;

BEGIN
   GetPath (name, path, len);
   WriteString (name);
END WriteName;
(* ENDFD *)
(* FOLD: CloseDef *)
PROCEDURE CloseDef;

BEGIN
   IF DefOpen THEN
      CloseOutput ();
   END; (* IF *)
END CloseDef;
(* ENDFD *)
(* FOLD: OpenDef *)
PROCEDURE OpenDef;

VAR DefName : ARRAY [1..200] OF CHAR;

BEGIN
   TermProcedure (CloseDef);
   Copy (DefName, Output);
   Concat (DefName, ".def");
   SetOutput (DefName);
   DefOpen := done;
   Assert (DefOpen, ADR ("Can't open DEFINITION-File!"));
   MakeIcon (DefName);
END OpenDef;
(* ENDFD *)
(* FOLD: CloseMod *)
PROCEDURE CloseMod;

BEGIN
   IF ModOpen THEN
      CloseOutput ();
   END; (* IF *)
END CloseMod;
(* ENDFD *)
(* FOLD: OpenMod *)
PROCEDURE OpenMod;

VAR ModName : ARRAY [1..200] OF CHAR;

BEGIN
   TermProcedure (CloseMod);
   Copy (ModName, Output);
   Concat (ModName, ".mod");
   SetOutput (ModName);
   ModOpen := done;
   Assert (ModOpen, ADR ("Can't open IMPLEMENTATION-File!"));
   MakeIcon (ModName);
END OpenMod;
(* ENDFD *)
(* FOLD: WriteModProcs *)
PROCEDURE WriteModProcs (name : ARRAY OF CHAR);

VAR Depth, Width, Height,
    ByteWidth, ScrByteWidth : INTEGER;
    RP                      : RastPortPtr;
    BM                      : BitMapPtr;
    Plane, Line, Step, col  : INTEGER;
    MyWindow                : WindowPtr;
    NewLine                 : BOOLEAN;
    Location                : POINTER TO CARDINAL;
    Num                     : CARDINAL;

   (* FOLD: NumColors *)
   PROCEDURE NumColors() : CARDINAL; (* ColorMap.count will nicht recht! *)

   VAR c, t : CARDINAL;

   BEGIN
      c := 1; t := MyScreen^.bitMap.depth;
      WHILE t > 0 DO c := c * 2; DEC (t); END;
      IF (ham IN MyScreen^.viewPort.modes) THEN c := 16 END;
      IF (extraHalfbrite IN MyScreen^.viewPort.modes) THEN
         c := 32;
      END; (* IF *)
      RETURN c;
   END NumColors;
   (* ENDFD *)

BEGIN
   IF NOT (ReadILBM (name, ReadILBMFlagSet {visible}, MyScreen, MyWindow)) THEN
      DisplayBeep (NIL);
   ELSE
      WITH IFFInfo.BMHD DO
         Depth  := depth;
         Width  := width;
         Height := height;
      END; (* WITH *)
      ByteWidth := Width DIV 8;
      IF (ByteWidth * 8) < Width THEN
         INC (ByteWidth);
      END; (* IF *)
      IF ODD (ByteWidth) THEN
         INC (ByteWidth);
      END; (* IF *)
      WITH MyScreen^ DO
         ScrByteWidth := width DIV 8;
         RP := ADR (rastPort);
         BM := RP^.bitMap;
      END; (* WITH *)

      WriteLn;
      WriteString ("(* $E- *)"); WriteLn;
      WriteString ("PROCEDURE "); WriteName (name); WriteString ("Dat;");
      WriteLn; WriteLn;
      WriteString ("BEGIN"); WriteLn;
      FOR Plane := 0 TO Depth-1 DO
         WriteString ("   (* Plane "); WriteInt (Plane+1, 1);
         WriteString (" *)"); WriteLn;
         NewLine := TRUE;
         FOR Line := 0 TO Height-1 DO
            FOR Step := 0 TO ByteWidth-2 BY 2 DO
               IF NewLine THEN
                  WriteString ("   INLINE (");
                  NewLine := FALSE;
                  Num := 0;
               END; (* IF *)
               WriteString ("0");
               Location := ADDRESS (BM^.planes[Plane] + Step +
                                    ScrByteWidth * Line);
               WriteHex (Location^, 4); WriteString ("H");
               INC (Num);
               IF (Num = 8) OR
                  ((Step = ByteWidth-2) AND (Line = Height-1)) THEN
                  WriteString (");"); WriteLn; NewLine := TRUE;
               ELSE
                  WriteString (", ");
               END; (* IF *)
            END; (* FOR Step *)
         END; (* FOR Line *)
      END; (* FOR Plane *)
      WriteString ("END "); WriteName (name); WriteString ("Dat;"); WriteLn;
      WriteLn; WriteLn;
      IF Table THEN
         WriteString ("(* $E- *)"); WriteLn;
         WriteString ("PROCEDURE "); WriteName (name); WriteString ("Tab;");
         WriteLn; WriteLn;
         WriteString ("BEGIN"); WriteLn;
         NewLine := TRUE;
         FOR col := 0 TO NumColors()-1 DO
            IF NewLine THEN
               WriteString ("   INLINE (");
               NewLine := FALSE;
               Num := 0;
            END; (* IF *)
            WriteString ("0");
            Location := ADDRESS (MyScreen^.viewPort.colorMap^.colorTable +
                                 LONGINT (col) * 2);
            WriteHex (Location^, 4); WriteString ("H");
            INC (Num);
            IF (Num = 8) OR
               (col = INTEGER (NumColors()-1)) THEN
               WriteString (");"); WriteLn; NewLine := TRUE;
            ELSE
               WriteString (", ");
            END; (* IF *)
         END; (* FOR *)
         WriteString ("END "); WriteName (name); WriteString ("Tab;");
         WriteLn; WriteLn; WriteLn;
      END; (* IF *)
      WriteString ("PROCEDURE Init"); WriteName (name); WriteString (";");
      WriteLn; WriteLn;
      IF NOT (NewCompi) THEN
         WriteString ("CONST "); WriteName (name); WriteString ("Size =");
         WriteInt (Height * ByteWidth * Depth, 5); WriteString (";");
         WriteLn; WriteLn;
      END; (* IF *)
      WriteString ("BEGIN"); WriteLn;
      WriteString ("   WITH "); WriteName (name); WriteString (" DO");
      WriteLn;
      WriteString ("      leftEdge   := 0;"); WriteLn;
      WriteString ("      topEdge    := 0;"); WriteLn;
      WriteString ("      width      := "); WriteInt (Width, 3);
      WriteString (";"); WriteLn;
      WriteString ("      height     := "); WriteInt (Height, 3);
      WriteString (";"); WriteLn;
      WriteString ("      depth      := "); WriteInt (Depth, 1);
      WriteString (";"); WriteLn;
      IF NewCompi THEN
         WriteString ("      imageData  := ADR ("); WriteName (name);
         WriteString ("Dat);"); WriteLn;
      END; (* IF *)
      WriteString ("      planePick  := 255;"); WriteLn;
      WriteString ("      planeOnOff := 0;"); WriteLn;
      WriteString ("      nextImage  := NIL;"); WriteLn;
      IF NOT (NewCompi) THEN
         WriteString ("      AllocMem (imageData, "); WriteName (name);
         WriteString ("Size, TRUE);"); WriteLn;
         WriteString ("      CopyMem (ADR ("); WriteName (name);
         WriteString ("Dat), imageData, "); WriteName (name);
         WriteString ("Size);"); WriteLn;
      END; (* IF *)
      WriteString ("   END; (* WITH *)"); WriteLn;
      IF Table THEN
         WriteString ("   WITH "); WriteName (name); WriteString ("Col DO");
         WriteLn;
         WriteString ("      flags      := ");
         WriteCard (MyScreen^.viewPort.colorMap^.flags, 3); WriteString (";");
         WriteLn;
         WriteString ("      type       := ");
         WriteCard (MyScreen^.viewPort.colorMap^.type, 3); WriteString (";");
         WriteLn;
         WriteString ("      count      := ");
         WriteCard (NumColors(), 3); WriteString (";");
         WriteLn;
         WriteString ("      colorTable := ADR ("); WriteName (name);
         WriteString ("Tab);"); WriteLn;
         WriteString ("   END; (* WITH *)"); WriteLn;
      END; (* IF *)
      WriteString ("END Init"); WriteName (name); WriteString (";");
      WriteLn;
      CloseScreen (MyScreen); MyScreen := NIL;
   END; (* IF *)
END WriteModProcs;
(* ENDFD *)
(* FOLD: CleanUp *)
PROCEDURE CleanUp;

BEGIN
   IF MyScreen # NIL THEN
      CloseScreen (MyScreen);
      MyScreen := NIL;
   END; (* IF *)
END CleanUp;
(* ENDFD *)

BEGIN
   TermProcedure (CleanUp);
   WriteString ("Image Convert 1.1.  © 1989-90 by Kai Bolay"); WriteLn;
   WriteLn;
   IF NumArgs() = 0 THEN
      WriteString ("No Input!"); WriteLn;
      Terminate (0);
   END; (* IF *)
   REPEAT
      WriteString ("Compiler-Version >3.2 (y/n) ? ");
      ReadString (ynStr);
   UNTIL (ynStr[1] = 'y') OR (ynStr[1] = 'n');
   NewCompi := ynStr[1] = 'y';
   REPEAT
      WriteString ("Generate Colortable ? ");
      ReadString (ynStr);
   UNTIL (ynStr[1] = 'y') OR (ynStr[1] = 'n');
   Table := (ynStr[1] = 'y');
   WriteString ("Name of Module to be generated (without Suffix): ");
   ReadString (Output);
   (* FOLD: DEFINITION *)
   OpenDef;
   WriteString ("DEFINITION MODULE ");
   WriteName (Output); WriteString (";"); WriteLn;
   WriteLn;
   WriteString ("FROM Intuition IMPORT Image;"); WriteLn;
   IF Table THEN
      WriteString ("FROM Graphics  IMPORT ColorMap;"); WriteLn;
   END; (* IF *)
   WriteLn;
   FOR num := 1 TO NumArgs() DO
      GetArg (num, Argument, len);
      IF num = 1 THEN
         WriteString ("VAR ");
      ELSE
         WriteString ("    ");
      END; (* IF *)
      WriteName (Argument); WriteString (" : Image;"); WriteLn;
      IF Table THEN
         WriteString ("    "); WriteName (Argument);
         WriteString ("Col : ColorMap;"); WriteLn;
      END; (* IF *)
   END; (* FOR *)
   WriteLn;
   WriteString ("END "); WriteName (Output); WriteString ("."); WriteLn;
   CloseDef;
   (* ENDFD *)
   (* FOLD: IMPLEMENTATION *)
   OpenMod;
   WriteString ("IMPLEMENTATION MODULE ");
   WriteName (Output); WriteString (";"); WriteLn;
   WriteLn;
   WriteString ("FROM SYSTEM   IMPORT ADR, INLINE;"); WriteLn;
   IF NOT (NewCompi) THEN
      WriteString ("FROM Heap     IMPORT AllocMem;"); WriteLn;
      WriteString ("FROM Exec     IMPORT CopyMem;"); WriteLn;
   END; (* IF *)
   FOR num := 1 TO NumArgs() DO
      GetArg (num, Argument, len);
      WriteModProcs (Argument);
   END; (* FOR *)
   WriteLn; WriteString ("BEGIN"); WriteLn;
   FOR num := 1 TO NumArgs() DO
      GetArg (num, Argument, len);
      WriteString ("  Init"); WriteName (Argument); WriteString (";");
      WriteLn;
   END; (* FOR *)
   WriteString ("END "); WriteName (Output); WriteString ("."); WriteLn;
   CloseMod;
   (* ENDFD *)
   WriteLn;
   WriteString ("Done. Have Fun!"); WriteLn;
END ImageConvert.