home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 1 / GoldFishApril1994_CD1.img / d2xx / d234 / wbpic / wbpic.mod < prev    next >
Text File  |  1989-08-02  |  6KB  |  237 lines
  1. (*---------------------------------------------------------------------------
  2.     :Program.    WPic.mod
  3.     :Author.     Fridtjof Siebert
  4.     :Address.    Nobileweg 67, D-7-Stgt-40
  5.     :Phone.      (0)711/822509
  6.     :Shortcut.   [fbs]
  7.     :Version.    1.0
  8.     :Date.       24-Dec-1988
  9.     :Copyright.  PD
  10.     :Language.   Modula-II
  11.     :Translator. M2Amiga v3.1d
  12.     :Imports.    IFFSupport [fbs].
  13.     :UpDate.     none.
  14.     :Contents.   Replaces Workbench's Color # 0 by a Picture.
  15.     :Remark.     Use Hires-Non-Interlaced Pictures with 2 or 4 colors.
  16.     :Usage.      WPic <IFF-Pic>
  17. ---------------------------------------------------------------------------*)
  18.  
  19. MODULE WBPic;
  20.  
  21. FROM SYSTEM      IMPORT ADR;
  22. FROM Arts        IMPORT Assert, TermProcedure, Terminate, BreakPoint;
  23.  
  24. FROM Arguments   IMPORT NumArgs, GetArg;
  25. FROM Dos         IMPORT Delay;
  26. FROM Exec        IMPORT Forbid, Permit, FreeMem, UByte, MsgPortPtr, MessagePtr,
  27.                         PutMsg, GetMsg, ReplyMsg, FindPort, Message, WaitPort,
  28.                         NodeType;
  29. FROM ExecSupport IMPORT CreatePort, DeletePort;
  30. FROM Graphics    IMPORT BitMap, BitMapPtr, BltBitMap;
  31. FROM Intuition   IMPORT ScreenPtr, MakeScreen, RethinkDisplay, WindowPtr,
  32.                         NewWindow, WindowFlags, WindowFlagSet, ScreenFlags,
  33.                         CloseWindow, ScreenFlagSet, IDCMPFlags, IDCMPFlagSet,
  34.                         OpenWindow;
  35.  
  36. FROM Heap        IMPORT AllocMem;
  37. FROM IFFSupport  IMPORT ReadILBM, ReadILBMFlags, ReadILBMFlagSet, NuScreen,
  38.                         IFFInfo;
  39.  
  40. (*------  CONSTS:  ------*)
  41.  
  42. CONST
  43.   WindowTitle = "WBPic © Fridtjof Siebert";
  44.   PortName    = "NewWBPlanes[fbs].Port";
  45.   ReplyName   = "NewWBPlanes[fbs].ReplyPort";
  46.  
  47. (*------  TYPES:  ------*)
  48.  
  49. TYPE
  50.   ColTable = ARRAY[0..31] OF CARDINAL;
  51.  
  52. (*------  VARS:  ------*)
  53.  
  54. VAR
  55.   WBScreen: ScreenPtr;
  56.   i: CARDINAL;
  57.   ScreenDummy: ScreenPtr;
  58.   WindowDummy: WindowPtr;
  59.   Name: ARRAY[0..79] OF CHAR;
  60.   length: INTEGER;
  61.   MyBitMap: BitMapPtr;
  62.   CMap: ColTable;
  63.   OldColTable: POINTER TO ColTable;
  64.   Window: WindowPtr;
  65.   NuWindow: NewWindow;
  66.   MyPort,OldPort: MsgPortPtr;
  67.   MyMsg: Message;
  68.   QuitMessage: MessagePtr;
  69.   WBBitMap: BitMap;
  70.   w,h: CARDINAL;
  71.  
  72. (*------  CleanUp:  ------*)
  73.  
  74. PROCEDURE CleanUp();
  75.  
  76. BEGIN
  77.  
  78. (*------  Remove Picture from WB:  ------*)
  79.  
  80.   IF WBScreen#NIL THEN
  81.     Forbid();
  82.       IF OldColTable#NIL THEN
  83.         WBScreen^.viewPort.colorMap^.colorTable := OldColTable;
  84.       END;
  85.       MakeScreen(WBScreen);
  86.     Permit();
  87.     RethinkDisplay();
  88.   END;
  89.  
  90. (*------  Free BitMap's Memory:  ------*)
  91.  
  92.   IF MyBitMap#NIL THEN
  93.     WITH MyBitMap^ DO
  94.       FOR i:=0 TO depth-1 DO
  95.         IF planes[i]#NIL THEN
  96.           FreeMem(planes[i],LONGINT(bytesPerRow)*LONGINT(rows));
  97.         END;
  98.       END;
  99.     END;
  100.     FreeMem(MyBitMap,SIZE(BitMap));
  101.   END;
  102.  
  103. (*------  Close Window:  ------*)
  104.  
  105.   IF Window#NIL THEN CloseWindow(Window) END;
  106.  
  107. (*------  Remove Port:  ------*)
  108.  
  109.   IF MyPort#NIL THEN
  110.     Forbid();
  111.       IF QuitMessage=NIL THEN QuitMessage := GetMsg(MyPort) END;
  112.       WHILE QuitMessage#NIL DO
  113.         ReplyMsg(QuitMessage);
  114.         QuitMessage := GetMsg(MyPort);
  115.       END;
  116.       DeletePort(MyPort);
  117.     Permit();
  118.   END;
  119.  
  120. END CleanUp;
  121.  
  122. (*------  MAIN:  ------*)
  123.  
  124. BEGIN
  125.  
  126. (*------  Initialization:  ------*)
  127.  
  128.   WBScreen := NIL; MyBitMap := NIL; OldColTable := NIL; Window := NIL;
  129.   MyPort := NIL; QuitMessage := NIL;
  130.   TermProcedure(CleanUp);
  131.  
  132. (*------  Have we already been started?  ------*)
  133.  
  134.   OldPort := FindPort(ADR(PortName));
  135.   IF OldPort#NIL THEN
  136.     MyPort := CreatePort(ADR(ReplyName),0);
  137.     Assert(MyPort#NIL,ADR("CreatePort failed"));
  138.     MyMsg.node.type := message;
  139.     MyMsg.replyPort := MyPort;
  140.     PutMsg(OldPort,ADR(MyMsg)); (* Signal task to quit *)
  141.     WaitPort(MyPort);
  142.     DeletePort(MyPort);
  143.     MyPort := NIL;
  144.   END;
  145.   MyPort := CreatePort(ADR(PortName),0);
  146.   Assert(MyPort#NIL,ADR("CreatePort failed"));
  147.  
  148. (*------  Open Window:  ------*)
  149.  
  150.   WITH NuWindow DO
  151.     leftEdge    := 0; topEdge  := 0;
  152.     width       := 1; height   := 1;
  153.     detailPen   := 0; blockPen := 1;
  154.     idcmpFlags  := IDCMPFlagSet{closeWindow};
  155.     flags       := WindowFlagSet{windowClose,backDrop};
  156.     firstGadget := NIL;
  157.     checkMark   := NIL; title    := ADR(WindowTitle);
  158.     screen      := NIL; bitMap   := NIL;
  159.     type        := ScreenFlagSet{wbenchScreen};
  160.   END;
  161.   Window := OpenWindow(NuWindow);
  162.   Assert(Window#NIL,ADR("Cnt'pnWndw!!!"));
  163.   WBScreen := Window^.wScreen;
  164.  
  165. (*------  Get Name:  ------*)
  166.  
  167.   IF NumArgs()#0 THEN GetArg(1,Name,length) ELSE Terminate(0) END;
  168.  
  169. (*------  Read ILBM:  ------*)
  170.  
  171.   Assert(ReadILBM(Name,ReadILBMFlagSet{front,visible,dontopen},ScreenDummy,
  172.               WindowDummy),ADR("Can't Load Pic!"));
  173.  
  174. (*------  Get BitMap:  ------*)
  175.  
  176.   MyBitMap := NuScreen.customBitMap;
  177.  
  178. (*------  Set Colors:  ------*)
  179.  
  180.   OldColTable := WBScreen^.viewPort.colorMap^.colorTable;
  181.   CMap := OldColTable^;
  182.   WITH IFFInfo.CMAP DO
  183.     FOR i:=0 TO 3 DO
  184.       CMap[  4*i] :=   256*ORD(red[i]) + 16*ORD(green[i]) + ORD(blue[i]);
  185.       CMap[1+4*i] := CMap[1];
  186.       CMap[2+4*i] := CMap[2];
  187.       CMap[3+4*i] := CMap[3];
  188.     END;
  189.   END;
  190.   WBScreen^.viewPort.colorMap^.colorTable := ADR(CMap);
  191.  
  192. (*------  Put Picture on WBScreen:  ------*)
  193.  
  194.   WBBitMap := WBScreen^.bitMap;
  195.   WITH WBBitMap DO
  196.     IF MyBitMap^.depth>1 THEN depth := 2 ELSE depth := 1 END;
  197.     FOR i:=0 TO depth-1 DO
  198.       AllocMem(planes[i],LONGINT(rows)*LONGINT(bytesPerRow),TRUE);
  199.     END;
  200.     w := bytesPerRow; h := rows;
  201.     WITH MyBitMap^ DO
  202.       IF w>bytesPerRow THEN w := bytesPerRow END;
  203.       IF h>rows THEN h := rows END;
  204.     END;
  205.     i := BltBitMap(MyBitMap,0,0,ADR(WBBitMap),0,0,w*8,h,0C0H,3,NIL);
  206.   END;
  207.  
  208. (*------  Free IFF's Memory:  ------*)
  209.  
  210.   WITH MyBitMap^ DO
  211.     FOR i:=0 TO depth-1 DO
  212.       FreeMem(planes[i],LONGINT(bytesPerRow)*LONGINT(rows));
  213.       planes[i] := NIL;
  214.     END;
  215.   END;
  216.   FreeMem(MyBitMap,SIZE(BitMap));
  217.   MyBitMap := NIL;
  218.  
  219. (*------  Wait to Quit:  ------*)
  220.  
  221.   REPEAT
  222.     Forbid();
  223.       WITH WBScreen^.bitMap DO
  224.         depth := 2 + WBBitMap.depth;
  225.         planes[2] := WBBitMap.planes[0];
  226.         planes[3] := WBBitMap.planes[1];
  227.         MakeScreen(WBScreen);
  228.         depth := 2;
  229.       END;
  230.     Permit();
  231.     RethinkDisplay();
  232.     Delay(25);
  233.     QuitMessage := GetMsg(MyPort);
  234.   UNTIL QuitMessage#NIL;
  235.  
  236. END WBPic.
  237.