(*-------------------------------------------------------------------------
:Program.       MUGiff
:Contents.      IFF-Viewer for any ILBM plus 24bit preview-support
:Author.        Mark Rose [mug]
:Copyright.     Freely distributable copyrighted software
:Language.      Modula-2
:Translator.    M2Amiga 4.1
:Imports.            iff.library - Christian A. Weber
:Imports.       reqtools.library - Nico François
:Imports.       ReqTFileReq      - Frank Lömker (customized by me)
:History.       see file 'History.DEF'
:Usage.         MUGiff [IFFfile1 .. IFFfileN]
-------------------------------------------------------------------------*)
(*$ NilChk      := FALSE ReturnChk   := FALSE CaseChk     := FALSE *)
(*$ Volatile    := FALSE StackParms  := FALSE LargeVars   := FALSE *)
(*$ StackChk    := FALSE RangeChk    := FALSE OverflowChk := FALSE *)

MODULE MUGiff;


FROM Arguments   IMPORT GetArg         , NumArgs        ;
FROM Arts        IMPORT Exit           , kickVersion    , returnVal      ;
FROM Break       IMPORT GetBreak       ;
                 IMPORT d  : DosD      , ed : ExecD     , el : ExecL     ,
                        gd : GraphicsD , gl : GraphicsL , id : IntuitionD,
                        il : IntuitionL, R              , rt : ReqTools  ;
FROM GraphicsD   IMPORT BitMap         , BitMapPtr      , ViewModes      ,
                        ViewModeSet    ;
FROM History     IMPORT AUTHOR         , REVDATE        , REVISION       ,
                        REVTIME        ;
FROM IFFLib      IMPORT BitMapHeaderPtr, ChunkPtr       , CloseIFF       ,
                        comprNone      , DecodePic      , errorOpen      ,
                        errorNotIff    , errorNoILBM    , FindChunk      ,
                        GetBMHD        , GetColorTab    , GetViewModes   ,
                        HandlePtr      , idANIM         , idFORM         ,
                        IffError       , modeRead       , ModifyFrame    ,
                        OpenIFF        , SaveBitMap     ;
FROM IntuitionD  IMPORT IDCMPFlags     , IDCMPFlagSet   , ScreenFlags    ,
                        ScreenFlagSet  , WindowFlags    , WindowFlagSet  ;
FROM String      IMPORT Concat         , Length         ;
FROM SYSTEM      IMPORT ADDRESS        , ADR            , ASSEMBLE       ,
                        CAST           , LONGSET        , SHIFT          ,
                        TAG            ;
FROM Terminal    IMPORT WriteString    , Format         ;


TYPE
      str110        = ARRAY [0..110] OF CHAR;
      str110Ptr     = POINTER TO str110;
      colorPtr      = POINTER TO colorType;
      colorType     = ARRAY [0 .. 256] OF CARDINAL;

CONST
      version       =  "MUGiff " + REVISION + " (" + REVDATE + ") " +
                                                  REVTIME + " © " + AUTHOR;
      versionStr    =  ADR ("$VER: " + version);
      HAM           =  080H;

VAR
      bmhd          :  BitMapHeaderPtr;
      colorCount    :  CARDINAL;
      colorTab      :  colorType;
      iff           :  HandlePtr;
      i, len        :  INTEGER;
      myArg, dirDum :  str110;
      bigBitMap     :  gd.BitMap;
      bigBitMapPtr  :  gd.BitMapPtr;
      maxX0, maxY0  :  INTEGER;
      ns            :  id.NewScreen;
      nw            :  id.NewWindow;
      screen,
      screen2       :  id.ScreenPtr;
      tBuf          :  ARRAY [0 ..   2] OF LONGINT;
      window        :  id.WindowPtr;
      filereq       :  rt.FileRequesterPtr;
      myFileList    :  rt.FileListPtr;
      dir           :  str110Ptr;


(*$ CopyDyn := FALSE *)
(*-----------------------------------------------------------------------*)
PROCEDURE MUGerror (error : ARRAY OF CHAR);
(*-----------------------------------------------------------------------*)

BEGIN
  WriteString (error);
  Exit (d.fail);
END MUGerror;


(*$ EntryExitCode := FALSE *)
(*-----------------------------------------------------------------------*)
PROCEDURE TrueColTab;
(*-----------------------------------------------------------------------*
 * The colours for 24bit preview. Thanks to Christian for the idea...    *
 * But with my method you can preview bigger files (a bit more ugly)     *
 *-----------------------------------------------------------------------*)

BEGIN
  ASSEMBLE(DC.W $000,$001,$002,$003,$004,$005,$006,$007
           DC.W $008,$009,$00A,$00B,$00C,$00D,$00E,$00F
           END);
END TrueColTab;


(*-----------------------------------------------------------------------*)
PROCEDURE Max (i{R.D0}, j{R.D1} : INTEGER) : INTEGER;
(*-----------------------------------------------------------------------*)

BEGIN
  IF (i > j) THEN RETURN i ELSE RETURN j END;
END Max;


(*-----------------------------------------------------------------------*)
PROCEDURE Min (i{R.D0}, j{R.D1} : INTEGER) : INTEGER;
(*-----------------------------------------------------------------------*)

BEGIN
  IF (i < j) THEN RETURN i ELSE RETURN j END;
END Min;


(*-----------------------------------------------------------------------*)
PROCEDURE MUGAllocBitMap (w{R.D4}, h{R.D5} : LONGCARD) : BOOLEAN;
(*-----------------------------------------------------------------------*)

VAR i{R.D2}         : SHORTCARD;
    allocMaps{R.D3} : BOOLEAN;

BEGIN
  i         := 0;
  allocMaps := TRUE;
  gl.InitBitMap (bigBitMap, ns.depth, w, h);
  WHILE (i < SHORTCARD (ns.depth)) AND allocMaps DO
    bigBitMapPtr^.planes[i] := gl.AllocRaster (w, h);
    IF (bigBitMapPtr^.planes[i] = NIL) THEN allocMaps := FALSE; END;
    INC (i);
  END;
  RETURN allocMaps;
END MUGAllocBitMap;


(*-----------------------------------------------------------------------*)
PROCEDURE MUGDeAllocBitMap (w{R.D3}, h{R.D4} : LONGCARD);
(*-----------------------------------------------------------------------*)

VAR i{R.D2} : SHORTCARD;

BEGIN
  FOR i := 0 TO bigBitMap.depth DO
    IF (bigBitMapPtr^.planes[i] # NIL) THEN
      gl.FreeRaster (bigBitMapPtr^.planes[i], w, h);
      bigBitMapPtr^.planes[i] := NIL;
    END;
  END;
END MUGDeAllocBitMap;


(*$ CopyDyn := FALSE *) (* is faster and shorter *)
(*-----------------------------------------------------------------------*)
PROCEDURE FileReq (VAR fName : ADDRESS; title : ARRAY OF CHAR);
(*-----------------------------------------------------------------------*)
(* This is an adapted  version  of  ReqTFileReq by Frank Lömker.  Please *
 * note that  I  had  to  correct  ReqTools.def  to  allow  MultiSelect. *
 * rt.FileRequest returned BOOLEAN (which is normally quite true) but in *
 * MultiSelect mode it is in fact a FileListPtr...                       *
 *-----------------------------------------------------------------------*)

VAR len{R.D7} : INTEGER;

BEGIN
  filereq    := rt.AllocRequestA (rt.TypeFileReq, NIL);
  IF (filereq # NIL) THEN
    INCL (filereq^.flags, rt.fReqMultiSelect);
    myFileList := rt.FileRequest (filereq, fName, ADR(title), NIL);
    IF (myFileList # NIL) THEN
      fName := filereq^.dir;
    END;
  END;
END FileReq;


(*-----------------------------------------------------------------------*)
PROCEDURE SavePic (fName{R.D2} : str110Ptr) : BOOLEAN;
(*-----------------------------------------------------------------------*)

BEGIN
  IF (ham IN screen^.viewPort.modes) THEN
    RETURN SaveBitMap(fName, bigBitMapPtr, ADR(colorTab), comprNone + HAM)
  ELSE
    RETURN SaveBitMap(fName, bigBitMapPtr, ADR(colorTab), comprNone      )
  END;
END SavePic;


(*-----------------------------------------------------------------------*)
PROCEDURE MakeOverscan ();
(*-----------------------------------------------------------------------*
 * This is a tricky one.  I "borrowed" it from ShowIFF.c.  If you know a *
 * better way (that is more compatible) feel free to contact me...       *
 *-----------------------------------------------------------------------*)

VAR x{R.D0}, y{R.D1} : INTEGER;
    gfxBasePtr{R.D2} : gd.GfxBasePtr;

BEGIN
  gfxBasePtr := ADR (gl);
  x := gfxBasePtr^.normalDisplayColumns;
  y := gfxBasePtr^.normalDisplayRows;
  IF NOT (hires IN screen^.viewPort.modes) THEN x := SHIFT (x, -1); END;
  IF     (lace  IN screen^.viewPort.modes) THEN y := SHIFT (y,  1); END;
  x := SHIFT ( (x - screen^.width ), -1);
  y := SHIFT ( (y - screen^.height), -1);
  IF (y > 0) THEN y := 0; END;
  IF ( (gfxBasePtr^.actiView^.dyOffset + y) < 0) THEN
    y := 0 - gfxBasePtr^.actiView^.dyOffset;
  END;
  (* Avoid OverScan HAM fringes *)
  IF (ham IN screen^.viewPort.modes) THEN
    IF ( (gfxBasePtr^.actiView^.dxOffset + x < 96)) THEN
      x := 96 - gfxBasePtr^.actiView^.dxOffset;
    END;
  END;
  screen^.viewPort.dxOffset := x;
  screen^.viewPort.dyOffset := y;
  il.MakeScreen (screen);
  il.RethinkDisplay ();
END MakeOverscan;


(*-----------------------------------------------------------------------*)
PROCEDURE ClosePicture ();
(*-----------------------------------------------------------------------*)

BEGIN
  IF (window # NIL) THEN
    il.CloseWindow (window);
    window  := NIL;
  END;
  IF (screen # NIL) THEN
    il.CloseScreen (screen);
    screen  := NIL;
  END;
  IF (screen2 # NIL) THEN
    il.CloseScreen (screen2);
    screen2 := NIL;
  END;
  IF (bigBitMapPtr # NIL) AND (bmhd # NIL) THEN
    MUGDeAllocBitMap (bmhd^.w, bmhd^.h);
    bigBitMapPtr := ADR (bigBitMap);
  END;
END ClosePicture;


(*-----------------------------------------------------------------------*)
PROCEDURE OpenPicture () : BOOLEAN;
(*-----------------------------------------------------------------------*)

VAR
    dum{R.D2}        : INTEGER;
    dummyPtr{R.D3}   : colorPtr;
    gfxBasePtr{R.D4} : gd.GfxBasePtr;

BEGIN
  gfxBasePtr       := ADR (gl);
  ClosePicture();
  ns.width         := gfxBasePtr^.normalDisplayColumns;
  ns.height        := gfxBasePtr^.normalDisplayRows;
  ns.depth         := Max (1, bmhd^.nPlanes);
  IF (ns.depth > 8) THEN ns.depth := 4; END;
  ns.viewModes     := GetViewModes (iff);
  IF (bmhd^.nPlanes = 24) THEN
    EXCL (ns.viewModes, ham);
  END;
  ns.type          := id.customScreen + ScreenFlagSet {customBitMap,
                                                screenQuiet, screenBehind};
  ns.customBitMap  := bigBitMapPtr;
  IF (NOT (hires IN ns.viewModes)) THEN
    ns.width       := SHIFT (ns.width , -1);
  END;
  IF     (lace  IN ns.viewModes) THEN
    ns.height      := SHIFT (ns.height,  1);
  END;
  ns.height        := Min (bmhd^.h, ns.height);
  ns.width         := Min (bmhd^.w, ns.width );
  ns.width         := Max (128    , ns.width );
  ns.height        := Max (128    , ns.height);
  IF (hires IN ns.viewModes) THEN dum := 768 ELSE dum := 384 END;
  IF ( (CAST (INTEGER, bmhd^.w) > ns.width) AND
                                     (CAST (INTEGER, bmhd^.w) <= dum)) THEN
    ns.width := bmhd^.w;
  END;
  IF (lace  IN ns.viewModes) THEN dum :=  80 ELSE dum :=  40 END;
  IF ( CAST (INTEGER, bmhd^.h) > ns.height) AND
                        (CAST (INTEGER, bmhd^.h) <= (ns.height + dum)) THEN
    ns.height  := bmhd^.h;
  END;
  IF MUGAllocBitMap (Max (bmhd^.w,ns.width), Max (bmhd^.h, ns.height)) THEN
    screen           := il.OpenScreen (ns);
    IF (screen # NIL) THEN
      nw.screen      := screen;
      nw.width       := ns.width;
      nw.height      := ns.height;
      nw.idcmpFlags  := id.IDCMPFlagSet  {mouseMove, deltaMove,
                                                 mouseButtons, vanillaKey};
      nw.flags       := id.WindowFlagSet {backDrop, simpleRefresh,
                borderless, activate, reportMouse, noCareRefresh, rmbTrap};
      nw.type        := id.customScreen;
      window         := il.OpenWindow (nw);
      IF (window # NIL) THEN
        maxX0 := CAST (INTEGER, bmhd^.w) - ns.width;
        (*
        **  ^--  Why this?  Because the generated code gives you a overflow
        **  v--  with (bmhd^.w < ns.width). In C this won't happen :(
        *)
        maxY0 := CAST (INTEGER, bmhd^.h) - ns.height;
        (*
        ** In 2.0 is a RasInfo scrolling bug.  C= said they would fix it in
        ** newer ROMs so an explicit version check is done
        *)
        IF (hires IN ns.viewModes) THEN
          IF (gfxBasePtr^.libNode.version >= 36) AND
                                   (gfxBasePtr^.libNode.version <= 38) THEN
            maxX0 := SHIFT (maxX0, -1);
          END;
        END;
        IF (bmhd^.nPlanes = 24) THEN
          dummyPtr   := ADR (TrueColTab);
          (*
          ** Not  using  a  dummy  results  in a compiler error 7032:  Gea:
          ** adrtoload (Compilerfehler)    Very nice ?!
          *)
          colorTab   := dummyPtr^;
          colorCount := 16
        ELSE
          colorCount := GetColorTab (iff, ADR (colorTab));
          IF (colorCount = 0) THEN (* Provide colors for pix w/o CMAP *)
            colorCount   := 2;
            colorTab [0] := 0ECAH;
            colorTab [1] := 000H;
          END;
        END;
        gl.LoadRGB4 (ADR (screen^.viewPort), ADR (colorTab), colorCount);
        MakeOverscan ();
        RETURN TRUE;
      END;
    END;
  END;
  ClosePicture ();
  RETURN FALSE;
END OpenPicture;


(*-----------------------------------------------------------------------*)
PROCEDURE MUGidcmp (name : str110Ptr) : BOOLEAN;
(*-----------------------------------------------------------------------*)

VAR
    signals        : LONGSET;
    msg            : id.IntuiMessagePtr;
    xOff{R.D2}    ,
    yOff{R.D3}     : INTEGER;
    class{R.D5}    : IDCMPFlagSet;
    mouseX, mouseY : INTEGER;
    code           : CARDINAL;
    moved{R.D4}    : BOOLEAN;

BEGIN
  moved := FALSE;
  xOff  := 0;
  yOff  := 0;
  LOOP
    (*
    ** In  2.0  is  a bug in WaitPort.  If used without FastMem (like stock
    ** A500+)  it doesn't work!  Thanks to Andreas Krebs for information on
    ** this.
    *)
    signals := el.Wait (CAST (LONGSET, (
                                    SHIFT (1, window^.userPort^.sigBit))));
    (*
    ** ^-- That's how elegant Modula-2 is compared to C... :^((
    *)
    msg := el.GetMsg (window^.userPort);
    WHILE (msg # NIL) DO
      class  := msg^.class;
      code   := msg^.code;
      mouseX := msg^.mouseX;
      mouseY := msg^.mouseY;
      el.ReplyMsg (msg);
      IF (vanillaKey IN class) THEN
        IF (code = CAST (CARDINAL, 's')) THEN
          IF SavePic (name) THEN
            WriteString (" written");
            RETURN TRUE;
          ELSE
            Format ("Could not write %s ! IffError: %ld",
                                            TAG (tBuf, name, IffError ()));
            RETURN FALSE;
          END;
        ELSE
          RETURN TRUE;
        END;
      END;
      IF (mouseButtons IN class) THEN
        IF (msg^.code = id.menuDown) THEN
          RETURN FALSE;
        ELSE
          RETURN TRUE;
        END;
      END;
      IF (mouseMove IN class) THEN
        moved := TRUE;
      END;
    msg := el.GetMsg (window^.userPort)
    END; (* WHILE *)
    IF moved THEN
      moved := FALSE;
      INC (xOff, mouseX);
      INC (yOff, mouseY);
      IF (xOff > maxX0) THEN xOff := maxX0; END;
      IF (xOff < 0    ) THEN xOff := 0    ; END;
      IF (yOff > maxY0) THEN yOff := maxY0; END;
      IF (yOff < 0    ) THEN yOff := 0    ; END;
      screen^.viewPort.rasInfo^.rxOffset := xOff;
      screen^.viewPort.rasInfo^.ryOffset := yOff;
      il.MakeScreen (screen);
      il.RethinkDisplay();
    END;
  END; (* LOOP *)
END MUGidcmp;


(*-----------------------------------------------------------------------*)
PROCEDURE ShowAnim() : BOOLEAN;
(*-----------------------------------------------------------------------*
 * This  procedure  does  some  VERY  dangerous  pointer  shifting  with *
 * undocumented iff.library features.   Since  the author of iff.library *
 * uses this way of programming in his own examples it seems to be legal *
 *-----------------------------------------------------------------------*)

VAR scrDummy{R.D3} : id.ScreenPtr;
    form    {R.D4},
    loopform{R.D5} : HandlePtr;

BEGIN
  form := CAST (HandlePtr, CAST (LONGCARD, iff) + 12);
  (*
  ** ^- Regarding   the   definition  of  IFFL_HANDLE  this  is  completely
  **    senseless.   I've  got  the  suspicion  the  the  library  makes an
  **    internal  list of all chunks and that this construct results in the
  **    next item
  *)
  bmhd := GetBMHD (form);
  IF (bmhd = NIL) THEN
    WriteString ("- no bitmap header!\n");
    RETURN FALSE;
  END;
  ns.type      := id.customScreen + ScreenFlagSet {screenQuiet,
                                                              screenBehind};
  ns.width     := bmhd^.w;
  ns.height    := bmhd^.h;
  ns.depth     := bmhd^.nPlanes;
  ns.viewModes := GetViewModes (form);
  screen       := il.OpenScreen (ns);
  screen2      := il.OpenScreen (ns);
  IF (screen # NIL) AND (screen2 # NIL) THEN
    colorCount   := GetColorTab (form, ADR (colorTab));
    gl.LoadRGB4 (ADR (screen^.viewPort ), ADR (colorTab), colorCount);
    gl.LoadRGB4 (ADR (screen2^.viewPort), ADR (colorTab), colorCount);
    IF NOT DecodePic(form, screen^.rastPort.bitMap) THEN
      WriteString("Can't decode picture!\n");
      RETURN FALSE;
    END;
    IF DecodePic(form, screen2^.rastPort.bitMap) THEN
      il.ScreenToFront (screen2);
      gl.WaitTOF();
      form := CAST (HandlePtr, FindChunk (form, 0));
      (*
      ** ^- This  one  "converts"  a  *IFFL_HANDLE  to  a *IFFL_Chunk.  Not
      **    recommended!  Children:  Do not try this at home!
      *)
      IF NOT ModifyFrame(form, screen^.rastPort.bitMap) THEN
        WriteString ("Can't decode frame 1!\n");
        RETURN FALSE;
      END;
      il.ScreenToFront (screen);
      gl.WaitTOF();
      loopform := CAST (HandlePtr, FindChunk (form, 0));
      LOOP
        form := loopform;
        WHILE (CAST (LONGINT, form^.file) = idFORM) DO
          (*
          ** ^- Remember: this  is  not  a  IFFL_HANDLE anymore!  The first
          **    entry in a IFFL_Chunk is ckID!
          *)
          IF (GetBreak() # LONGSET{}) THEN EXIT; END; (* CtrlC ??? *)
          IF ModifyFrame(form, screen2^.rastPort.bitMap) THEN
            scrDummy := screen;
            screen   := screen2;
            screen2  := scrDummy;
            il.ScreenToFront (screen);
            gl.WaitTOF();
          ELSE
            WriteString ("Can't Decode Frame\n");
            RETURN FALSE;
          END;
          form := CAST (HandlePtr, FindChunk (form, 0));
        END;
      END;
    ELSE
      WriteString ("Can't decode picture\n");
      RETURN FALSE;
    END;
  ELSE
    WriteString ("Couldn't open screens\n");
    RETURN FALSE;
  END;
  WriteString ("- Done");
  RETURN TRUE;
END ShowAnim;


(*-----------------------------------------------------------------------*)
PROCEDURE ShowPicture (name : str110Ptr) : BOOLEAN;
(*-----------------------------------------------------------------------*
 * This  is  the main thing.  Display the picture and scroll around with *
 * the mouse (if it is larger than screen).  LMB = continue, RMB = abort.*
 *-----------------------------------------------------------------------*)

BEGIN
  ClosePicture ();
  Format ("\nShowing %-40s : ", ADR (name));
  IF (iff # NIL) THEN CloseIFF (iff); END;
  iff := OpenIFF (name, modeRead);
  IF (iff = NIL) THEN
    CASE IffError() OF
      errorOpen  : WriteString ("Can't open file!\n"); RETURN TRUE;
    | errorNotIff: WriteString ("- not IFF!\n"      ); RETURN TRUE;
    ELSE
      WriteString ("- not ILBM\n");
      RETURN TRUE;
    END;
  END;
  IF (iff^.chunkId = idANIM) THEN
    WriteString (" ANIM ");
    RETURN ShowAnim();
  END;
  bmhd := GetBMHD (iff);
  IF (bmhd = NIL) THEN
    Format ("- Mangled IFF file (Error %ld)\n", IffError());
    Exit (20);
  END;
  Format ("%4ld × %4ld × %2ld ", TAG (tBuf, bmhd^.w, bmhd^.h,
                                                           bmhd^.nPlanes));
  IF OpenPicture () THEN
    IF DecodePic (iff, screen^.rastPort.bitMap) THEN
      il.ScreenToFront (screen);
      WriteString ("- Done");
      RETURN MUGidcmp (name);
    ELSE
      ClosePicture ();
      Format ("- Decode error: %ld\n", IffError());
      Exit (d.fail);
    END;
  ELSE
    MUGerror ("- Can't open screen!\n");
  END;
END ShowPicture;

(*-----------------------------------------------------------------------*)
PROCEDURE ChkBreakMsg();
(*-----------------------------------------------------------------------*)
BEGIN
  IF NOT ShowPicture (ADR (myArg)) THEN
    MUGerror ("*** BREAK\n");
  END;
END ChkBreakMsg;


(*=========================================================================
                          M a i n   p r o g r a m
=========================================================================*)

BEGIN
  dir := ADR (dirDum);
  bigBitMapPtr := ADR (bigBitMap);
  GetArg (1, myArg, len);
  IF (NumArgs() = 0) THEN
    IF (rt.reqToolsBase # NIL) THEN
      FileReq (dir, "MUGiff " + REVISION + " - Choose Picture");
      IF (Length (dir^) > 0) AND (dir^[Length (dir^) - 1] # ':') THEN
        Concat(dir^, '/');
      END;
      WHILE (myFileList # NIL) DO
        myArg := dir^;
        Concat(myArg, CAST (str110Ptr, (myFileList^.name))^);
          ChkBreakMsg();
        ClosePicture();
        myFileList := myFileList^.next;
      END;
      Exit (0);
    ELSE
      MUGerror ("Couldn't open 'reqtools.library' V38\n");
    END;
  END;
  IF (myArg [0] = "?") THEN
    MUGerror (version + "\nUsage: MUGiff [<file1> .. <fileN>]\n");
  END;
  FOR i := 1 TO NumArgs() DO
    GetArg (i, myArg, len);
    ChkBreakMsg();
  END;
  returnVal := IffError();
CLOSE
  WriteString ("\nAll done\n");
  ClosePicture ();
  rt.FreeRequest (filereq);
  IF (iff        # NIL) THEN CloseIFF        (iff)       ; END;
  IF (myFileList # NIL) THEN rt.FreeFileList (myFileList); END;
END MUGiff.