(*---------------------------------------------------------------------------
  :Program.    RealWBShadow.mod
  :Author.     Fridtjof Siebert
  :Address.    Nobileweg 67, D-7-Stgt-40
  :Shortcut.   [fbs]
  :Version.    1.0
  :Date.       26-Jan-89
  :Copyright.  PD
  :Language.   Modula-II
  :Translator. M2Amiga v3.1d
  :Imports.    arp.library
  :Contents.   Program to create shadows of the things on your Workbench
  :Remark.     It's terrible! Everything I program is senseless!!
---------------------------------------------------------------------------*)

MODULE RealWBShadow;

FROM SYSTEM      IMPORT ADR, ADDRESS, LONGSET, CAST, BITSET;
FROM Arts        IMPORT Assert, TermProcedure, Terminate;
FROM Dos         IMPORT Delay;
FROM Exec        IMPORT Forbid, Permit, FindPort, MsgPortPtr, NodeType,
                        Message, MessagePtr, GetMsg, ReplyMsg, PutMsg,
                        WaitPort;
FROM ExecSupport IMPORT CreatePort, DeletePort;
FROM Intuition   IMPORT ScreenPtr, MakeScreen, RethinkDisplay, NewWindow,
                        WindowFlags, WindowFlagSet, ScreenFlags, CloseWindow,
                        ScreenFlagSet, IDCMPFlagSet, OpenWindow, WindowPtr;
FROM Graphics    IMPORT BitMap, BltBitMap;
FROM Heap        IMPORT AllocMem;

(*------  CONSTS:  ------*)

CONST
  WindowTitle = "WBShadow © Fridtjof Siebert / AMOK Stuttgart";
  PortName    = "NewWBPlanes[fbs].Port";
  ReplyName   = "NewWBPlanes[fbs].ReplyPort";

(*------  TYPES:  ------*)

TYPE
  ColorMap = ARRAY[0..31] OF INTEGER;

(*------  VARS:  ------*)

VAR
  WBScreen: ScreenPtr;
  NewPlane1, NewPlane2, OldPlane1, OldPlane2: ADDRESS;
  OldbPR, OldRows: CARDINAL;
  ColTable: POINTER TO ColorMap;
  Window: WindowPtr;
  NuWindow: NewWindow;
  MyMsg: Message;
  QuitMessage: MessagePtr;
  MyPort, OldPort: MsgPortPtr;
  l: LONGINT;
  bm: BitMap;

(*------  CleanUp:  ------*)

PROCEDURE CleanUp();

BEGIN

(*------  Remove Picture from WB:  ------*)

  IF WBScreen#NIL THEN
    Forbid();
      WITH WBScreen^ DO
        WITH bitMap DO
          depth := 2;
          planes[2] := NIL;
          IF OldPlane1#NIL THEN planes[0] := OldPlane1;
            IF OldPlane2#NIL THEN planes[1] := OldPlane2;
              IF OldRows#0 THEN rows := OldRows;
                IF OldbPR#0 THEN bytesPerRow := OldbPR;
                  l := BltBitMap(ADR(bm),16,8,ADR(bitMap),0,0,
                                 width,height,0C0H,3,NIL);
                END;
              END;
            END;
          END;
        END;
      END;
      MakeScreen(WBScreen);
    Permit();
    RethinkDisplay();
  END;

(*------  Close everything:  ------*)

  IF Window#NIL THEN CloseWindow(Window); END;

(*------  Remove Port:  ------*)

  IF MyPort#NIL THEN
    Forbid();
      IF QuitMessage=NIL THEN QuitMessage := GetMsg(MyPort) END;
      WHILE QuitMessage#NIL DO
        ReplyMsg(QuitMessage);
        QuitMessage := GetMsg(MyPort);
      END;
      DeletePort(MyPort);
    Permit();
  END;

END CleanUp;

(*------  MAIN:  ------*)

BEGIN

(*------  Initialization:  ------*)

  WBScreen := NIL; Window := NIL; MyPort := NIL;
  OldPlane1 := NIL; OldPlane2 := NIL; OldbPR := 0; OldRows := 0;
  TermProcedure(CleanUp);

(*------  Have we already been started?  ------*)

  OldPort := FindPort(ADR(PortName));
  IF OldPort#NIL THEN
    MyPort := CreatePort(ADR(ReplyName),0);
    Assert(MyPort#NIL,ADR("CreatePort failed"));
    MyMsg.node.type := message;
    MyMsg.replyPort := MyPort;
    PutMsg(OldPort,ADR(MyMsg)); (* Signal task to quit *)
    WaitPort(MyPort);
    DeletePort(MyPort);
    MyPort := NIL;
    Terminate(0);
  END;
  MyPort := CreatePort(ADR(PortName),0);
  Assert(MyPort#NIL,ADR("CreatePort failed"));

(*------  Open Window:  ------*)

  WITH NuWindow DO
    leftEdge   := 0; topEdge     := 0;
    width      := 1; height      := 1;
    detailPen  := 0; blockPen    := 1;
    idcmpFlags := IDCMPFlagSet{};
    flags      := WindowFlagSet{backDrop};
    firstGadget:= NIL; checkMark := NIL;
    title      := ADR(WindowTitle);
    screen     := NIL; bitMap    := NIL;
    type       := ScreenFlagSet{wbenchScreen};
  END;
  Window := OpenWindow(NuWindow);
  Assert(Window#NIL,ADR("Can't open Window!!!"));
  WBScreen := Window^.wScreen;
  IF WBScreen^.bitMap.depth>2 THEN Terminate(0) END; (* thers sth. strange ! *)

(*------  Set Colors:  ------*)

  ColTable := WBScreen^.viewPort.colorMap^.colorTable;
  FOR l:=4 TO 12 BY 4 DO
    ColTable^[l] := CAST(INTEGER,CAST(BITSET,ColTable^[0] DIV 2)*{0..2,4..6,8..10});
    ColTable^[1+l] := ColTable^[1];
    ColTable^[2+l] := ColTable^[2];
    ColTable^[3+l] := ColTable^[3];
  END;

(*------  Add Plane to WBScreen:  ------*)

  bm := WBScreen^.bitMap;
  WITH bm DO
    INC(rows,8);
    INC(bytesPerRow,2);
    AllocMem(NewPlane1,rows*bytesPerRow+8*bytesPerRow+2,TRUE);
    AllocMem(NewPlane2,rows*bytesPerRow+8*bytesPerRow+2,TRUE);
    Assert((NewPlane1#NIL) AND (NewPlane2#NIL),ADR("Out of memory"));
    planes[0] := NewPlane1;
    planes[1] := NewPlane2;
  END;
  WITH WBScreen^ DO
    l := BltBitMap(ADR(bitMap),0,0,ADR(bm),16,8,width,height,0C0H,3,NIL);
    WITH bitMap DO
      Forbid();
        OldPlane1 := planes[0];
        OldPlane2 := planes[1];
        planes[0] := NewPlane1;
        planes[1] := NewPlane2;
        planes[2] := NewPlane1;
        planes[3] := NewPlane2;
        OldRows   := rows; OldbPR := bytesPerRow;
        INC(rows,8); INC(bytesPerRow,2);
        INC(planes[0],8*bytesPerRow+2);
        INC(planes[1],8*bytesPerRow+2);
      Permit();

(*------  Do it:  ------*)

      REPEAT
        Forbid();
          depth := 4;
          MakeScreen(WBScreen);
          depth := 2;
        Permit();
        RethinkDisplay();
        Delay(10);
        QuitMessage := GetMsg(MyPort);
      UNTIL QuitMessage#NIL;
    END;
  END;

END RealWBShadow.