home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 559b.lha / FFEX / source / IlbmInOut.mod < prev    next >
Encoding:
Modula Implementation  |  1991-09-19  |  10.0 KB  |  354 lines
  1. IMPLEMENTATION MODULE IlbmInOut;
  2.  
  3. FROM Request    IMPORT Request;
  4. FROM Arts       IMPORT TermProcedure,Assert,BreakPoint;
  5. FROM SYSTEM     IMPORT ADR,ADDRESS,CAST,INLINE;
  6. FROM Graphics   IMPORT ViewModes,ViewModeSet,BitMapPtr;
  7. FROM Exec       IMPORT AllocMem,MemReqSet,MemReqs,FreeMem,CopyMem;
  8. FROM Intuition  IMPORT ScreenPtr,NewScreen,customScreen,ScreenFlags,
  9.                ScreenFlagSet,OpenScreen,WindowPtr;
  10. FROM Dos        IMPORT DeleteFile,Open,Close,Read,Write,Lock,FileHandlePtr,
  11.                FileLockPtr,oldFile,newFile,sharedLock,UnLock,
  12.                exclusiveLock;
  13. FROM Str        IMPORT Concat,Copy;
  14.  
  15. TYPE
  16.   BitMapHeader=RECORD
  17.     w,h,x,y    : CARDINAL;
  18.     planes,
  19.     masking,
  20.     compression,
  21.     pad1       : CHAR;
  22.     transpcolor: CARDINAL;
  23.     xasp,yasp  : CHAR;
  24.     pagewidth,
  25.     pageheight : CARDINAL;
  26.   END;
  27.  
  28.   ILBMFileHeader=RECORD
  29.     form     : ARRAY[0..3] OF CHAR;
  30.     formlen  : LONGINT;
  31.     ilbmbmhd : ARRAY[0..7] OF CHAR;
  32.     bmhdlen  : LONGINT;
  33.     bmhd     : BitMapHeader;
  34.     cmapchunk: ARRAY[0..3] OF CHAR;
  35.     cmaplen  : LONGINT;
  36.     cmap     : ARRAY[0..31],[0..2] OF CHAR;
  37.     camgchunk: ARRAY[0..3] OF CHAR;
  38.     camglen  : LONGINT;
  39.     pad1     : INTEGER;
  40.     camg     : ViewModeSet;
  41.     ffexchunk: ARRAY[0..3] OF CHAR;       (* FFEX-spezifischer Chunk *)
  42.     ffexlen  : LONGINT;
  43.     ffex1    : ARRAY[0..3] OF LONGREAL;   (* Limits als LONGREALS    *)
  44.     ffex2    : LONGINT;                   (* #Iterations als LONGINT *)
  45.     bodychunk: ARRAY[0..3] OF CHAR;
  46.     bodylen  : LONGINT;
  47.   END;
  48.  
  49. VAR
  50.   ilbmheader: ILBMFileHeader;
  51.   f         : FileHandlePtr;
  52.   lock      : FileLockPtr;
  53.   req       : BOOLEAN;
  54.   bodymem   : ADDRESS;
  55.   act,
  56.   bodybytes : LONGINT;
  57.   message   : ARRAY[0..255] OF CHAR;
  58.   yes,no    : ARRAY[0..9] OF CHAR;
  59.  
  60. PROCEDURE GetByte(s: ADDRESS): LONGINT;
  61.   BEGIN RETURN LONGINT(CAST(CHAR, s^)) END GetByte;
  62.  
  63. PROCEDURE PutByte(v: LONGINT; s: ADDRESS);
  64.   BEGIN s^:=CHAR(v)  END PutByte;
  65.  
  66. (*** Prozeduren zum Laden von IFF-ILBM Bildern ***********************)
  67.  
  68. PROCEDURE UnPackRow(VAR source,dest:ADDRESS;bpr:INTEGER);
  69.   VAR count,i,a,b:LONGINT;
  70.   BEGIN
  71.     count:=0;
  72.     WHILE count<bpr DO
  73.       a:=GetByte(source); INC(source);
  74.       IF a<128 THEN
  75.         CopyMem(source,dest,a+1);
  76.         INC(source,a+1); INC(dest,a+1); INC(count,a+1);
  77.       ELSIF a>128 THEN
  78.         b:=GetByte(source); INC(source);
  79.         FOR i:=1 TO 257-a DO
  80.           dest^:=CHAR(b); INC(dest);
  81.         END;
  82.         INC(count,257-a);
  83.       END;
  84.     END;
  85.   END UnPackRow;
  86.  
  87. (*** Es wird ein Screen erzeugt, in den das Bild geladen wird. ***)
  88. (*** Ein Zeiger darauf wird in scr zurückgegeben. ****************)
  89.  
  90. PROCEDURE LoadILBM(fname:ARRAY OF CHAR; win:WindowPtr;
  91.                    VAR scr:ScreenPtr;
  92.            VAR rmin,imin,rmax,imax:LONGREAL;
  93.            VAR maxiter:LONGINT):BOOLEAN;
  94.   VAR
  95.     source : ADDRESS;
  96.     pl : ARRAY[0..7] OF ADDRESS;
  97.     i,j : INTEGER;
  98.     ns : NewScreen;
  99.  
  100.   BEGIN
  101.     lock:=Lock(ADR(fname),sharedLock);
  102.     IF lock=NIL THEN
  103.       Copy(message,fname); Concat(message,"|not found!");
  104.       yes:=""; no:="CANCEL";
  105.       IF Request(win,message,yes,no) THEN END;
  106.       RETURN FALSE;
  107.     END;
  108.     f:=Open(ADR(fname),oldFile);
  109.     act:=Read(f,ADR(ilbmheader),SIZE(ilbmheader));
  110.     IF act#SIZE(ilbmheader) THEN
  111.       Close(f); UnLock(lock); lock:=NIL; f:=NIL;
  112.       message:="Load Error!"; yes:=""; no:="CANCEL";
  113.       IF Request(win,message,yes,no) THEN END;
  114.       RETURN FALSE
  115.     END;
  116.     IF CAST(LONGINT,ilbmheader.ffexchunk) # CAST(LONGINT,"FFEX") THEN
  117.       Close(f); UnLock(lock); lock:=NIL; f:=NIL;
  118.       message:="Sorry, no FFEX-Picture"; yes:=""; no:="CANCEL";
  119.       IF Request(win,message,yes,no) THEN END;
  120.       RETURN FALSE;
  121.     END;
  122.  
  123.     bodybytes:=ilbmheader.bodylen;
  124.  
  125.     bodymem := AllocMem(bodybytes, MemReqSet{public,memClear});
  126.     IF bodymem=NIL THEN
  127.       Close(f); UnLock(lock); lock:=NIL; f:=NIL;
  128.       message:="Not enough memory!"; yes:=""; no:="CANCEL";
  129.       IF Request(win,message,yes,no) THEN END;
  130.       RETURN FALSE;
  131.     END;
  132.  
  133.     source := bodymem;
  134.     act:=Read(f,source,bodybytes); (* Body laden *)
  135.     Close(f); UnLock(lock); lock:=NIL; f:=NIL;
  136.     IF act#bodybytes THEN
  137.       message:="Load Error!"; yes:=""; no:="CANCEL";
  138.       IF Request(win,message,yes,no) THEN END;
  139.       RETURN FALSE
  140.     END;
  141.  
  142.     WITH ns DO
  143.       width:=ilbmheader.bmhd.w; height:=ilbmheader.bmhd.h;
  144.       depth:=INTEGER(ilbmheader.bmhd.planes);
  145.       viewModes:=ilbmheader.camg;
  146.       type:=customScreen+ScreenFlagSet{screenBehind};
  147.       font:=NIL; defaultTitle:=NIL;
  148.       gadgets:=NIL; customBitMap:=NIL;
  149.     END;
  150.  
  151.     scr:=OpenScreen(ns);
  152.     IF scr=NIL THEN
  153.       FreeMem(bodymem,bodybytes); bodymem:=NIL;
  154.       message:="Not enough memory!"; yes:=""; no:="CANCEL";
  155.       IF Request(win,message,yes,no) THEN END;
  156.       RETURN FALSE;
  157.     END;
  158.  
  159.     FOR i:=0 TO 7 DO pl[i]:=scr^.bitMap.planes[i] END;
  160.  
  161.     FOR i:=0 TO scr^.height-1 DO
  162.       FOR j:=0 TO INTEGER(scr^.bitMap.depth)-1 DO
  163.         UnPackRow(source,pl[j],scr^.bitMap.bytesPerRow);
  164.       END;
  165.     END;
  166.  
  167.     FreeMem(bodymem,bodybytes); bodymem:=NIL;
  168.  
  169.     rmin:=ilbmheader.ffex1[0];
  170.     imin:=ilbmheader.ffex1[1];
  171.     rmax:=ilbmheader.ffex1[2];
  172.     imax:=ilbmheader.ffex1[3];
  173.     maxiter:=ilbmheader.ffex2;
  174.     RETURN TRUE;
  175.   END LoadILBM;
  176.  
  177.  
  178. (*** Prozeduren zum Speichern von IFF-ILBM Bildern *******************)
  179.  
  180. PROCEDURE PackRow(VAR source,buff:ADDRESS; bpr:INTEGER);
  181.   VAR
  182.     count,a,b,c,i,pc:LONGINT;
  183.     help:ADDRESS;
  184.   BEGIN
  185.     count:=0;
  186.     REPEAT
  187.       a:=GetByte(source);
  188.       INC(count); INC(source);
  189.       IF count=bpr THEN
  190.         PutByte(0,buff); INC(buff);
  191.         PutByte(a,buff); INC(buff);
  192.         RETURN
  193.       END;
  194.       b:=GetByte(source);
  195.       IF a=b THEN
  196.         pc:=256;
  197.         WHILE (count<bpr) AND (a=b) DO
  198.           INC(count); INC(source);
  199.           DEC(pc);
  200.           b:=GetByte(source);
  201.         END;
  202.         PutByte(pc,buff); INC(buff);
  203.         PutByte(a,buff); INC(buff);
  204.       ELSE
  205.         pc:=-1;
  206.         help:=source-1;
  207.         WHILE (count<bpr) AND (a#b) DO
  208.           a:=b;
  209.           INC(count); INC(source);
  210.           INC(pc);
  211.           b:=GetByte(source);
  212.         END;
  213.         IF count=bpr THEN INC(pc) ELSE DEC(count); DEC(source) END;
  214.         PutByte(pc,buff); INC(buff);
  215.         FOR i:=0 TO pc DO
  216.           c:=GetByte(help); INC(help);
  217.           PutByte(c,buff); INC(buff);
  218.         END;
  219.       END;
  220.     UNTIL count>=bpr;
  221.   END PackRow;
  222.  
  223. PROCEDURE SaveILBM(fname:ARRAY OF CHAR;scr:ScreenPtr;
  224.                    rmin,imin,rmax,imax:LONGREAL;maxiter:LONGINT):BOOLEAN;
  225.   VAR
  226.     buffer:ADDRESS;
  227.     len:LONGINT;
  228.     i,j:INTEGER;
  229.     bm:BitMapPtr;
  230.     colormap:POINTER TO ARRAY[0..31] OF INTEGER;
  231.     pl:ARRAY[0..7] OF ADDRESS;
  232.  
  233.   BEGIN
  234.     bm:=ADR(scr^.bitMap);
  235.     bodybytes:=bm^.bytesPerRow*bm^.rows;
  236.     bodybytes:=bodybytes*INTEGER(bm^.depth);
  237.  
  238.     lock:=Lock(ADR(fname),exclusiveLock);
  239.     IF lock#NIL THEN
  240.       Copy(message,fname);
  241.       Concat(message,"|already exists!|Shall I overwrite it?");
  242.       yes:="OK"; no:="CANCEL";
  243.       IF NOT Request(scr^.firstWindow,message,yes,no) THEN
  244.         UnLock(lock); lock:=NIL;
  245.         RETURN FALSE;
  246.       END;
  247.       UnLock(lock); lock:=NIL;
  248.       IF NOT DeleteFile(ADR(fname)) THEN
  249.         message:="Cannot overwrite|";Concat(message,fname);
  250.         yes:=""; no:="CANCEL";
  251.         IF Request(scr^.firstWindow,message,yes,no) THEN END;
  252.         RETURN FALSE;
  253.       END;
  254.     END;
  255.     f:=Open(ADR(fname),newFile);
  256.     IF f=NIL THEN
  257.       UnLock(lock); lock:=NIL;
  258.       message:="Cannot open file|"; Concat(message,fname);
  259.       yes:=""; no:="CANCEL";
  260.       IF Request(scr^.firstWindow,message,yes,no) THEN END;
  261.       RETURN FALSE;
  262.     END;
  263.  
  264.     bodymem:=AllocMem(bodybytes,MemReqSet{public,memClear});
  265.  
  266.     IF bodymem=NIL THEN
  267.       Close(f); UnLock(lock); lock:=NIL; f:=NIL;
  268.       message:="Not enough memory!"; yes:=""; no:="CANCEL";
  269.       IF Request(scr^.firstWindow,message,yes,no) THEN END;
  270.       RETURN FALSE;
  271.     END;
  272.  
  273.     WITH ilbmheader.bmhd DO
  274.       w:=bm^.bytesPerRow*8;h:=bm^.rows;
  275.       x:=0;y:=0;planes:=CHAR(bm^.depth);masking:=CHAR(0);
  276.       compression:=CHAR(1);pad1:=CHAR(0);
  277.       transpcolor:=0;
  278.       xasp:=CHAR(1);yasp:=CHAR(1);
  279.       pagewidth:=bm^.bytesPerRow*8;pageheight:=bm^.rows;
  280.     END;
  281.  
  282.     WITH ilbmheader DO
  283.       form     := "FORM";
  284.       ilbmbmhd := "ILBMBMHD";
  285.       bmhdlen  := SIZE(bmhd);
  286.       cmapchunk:= "CMAP";
  287.       cmaplen  := 96;                 (* 32 Farben á 3 Byte *)
  288.       colormap := scr^.viewPort.colorMap^.colorTable;
  289.       FOR i:=0 TO 31 DO
  290.         cmap[i,0]:=CHAR((colormap^[i] DIV 256)*16);
  291.         cmap[i,1]:=CHAR(((colormap^[i] MOD 256) DIV 16)*16);
  292.         cmap[i,2]:=CHAR((colormap^[i] MOD 16)*16);
  293.       END;
  294.       camgchunk:= "CAMG";
  295.       camglen  := 4;
  296.       pad1     := 0;
  297.       camg     := scr^.viewPort.modes-ViewModeSet{vpHide};
  298.       ffexchunk:= "FFEX";
  299.       ffexlen  := 36;
  300.       ffex1[0] := rmin;
  301.       ffex1[1] := imin;
  302.       ffex1[2] := rmax;
  303.       ffex1[3] := imax;
  304.       ffex2    := maxiter;
  305.       bodychunk:= "BODY";
  306.     END; (* WITH *)
  307.  
  308.     buffer:=bodymem;
  309.  
  310.     FOR i:=0 TO 4 DO pl[i]:=bm^.planes[i] END;
  311.  
  312.     FOR i:=0 TO bm^.rows-1 DO
  313.       FOR j:=0 TO INTEGER(bm^.depth)-1 DO
  314.         PackRow(pl[j],buffer,bm^.bytesPerRow);
  315.       END
  316.     END;
  317.  
  318.     len:=buffer-bodymem; IF ODD(len) THEN INC(len) END;
  319.     ilbmheader.bodylen:=len;
  320.     len:=len+SIZE(ilbmheader);
  321.     ilbmheader.formlen:=len-8;
  322.  
  323.     act:=Write(f,ADR(ilbmheader),SIZE(ilbmheader));
  324.  
  325.     IF act#SIZE(ilbmheader) THEN
  326.       Close(f); UnLock(lock); lock:=NIL; f:=NIL;
  327.       message:="Write Error!"; yes:=""; no:="CANCEL";
  328.       IF Request(scr^.firstWindow,message,yes,no) THEN END;
  329.       RETURN FALSE
  330.     END;
  331.     act:=Write(f,bodymem,ilbmheader.bodylen);
  332.     Close(f); UnLock(lock); lock:=NIL; f:=NIL;
  333.     IF act#ilbmheader.bodylen THEN
  334.       message:="Write Error!"; yes:=""; no:="CANCEL";
  335.       IF Request(scr^.firstWindow,message,yes,no) THEN END;
  336.       RETURN FALSE
  337.     END;
  338.  
  339.     FreeMem(bodymem,bodybytes); bodymem:=NIL;
  340.     RETURN TRUE;
  341.   END SaveILBM;
  342.  
  343. PROCEDURE CleanUp;
  344.   BEGIN
  345.     IF bodymem#NIL THEN FreeMem(bodymem,bodybytes); bodymem:=NIL; END;
  346.     IF lock#NIL THEN UnLock(lock) END;
  347.     IF f#NIL THEN Close(f); f:=NIL; END;
  348.   END CleanUp;
  349.  
  350. BEGIN
  351.   TermProcedure(CleanUp);
  352. END IlbmInOut.mod
  353.  
  354.