(*---------------------------------------------------------------------------
  :Program.    MegaWB.mod
  :Author.     Fridtjof Siebert
  :Address.    Nobileweg 67, D-7-Stgt-40
  :Phone.      (0)711/822509
  :Shortcut.   [fbs]
  :Version.    1.0
  :Date.       14-Mar-89
  :Copyright.  PD
  :Language.   Modula-II
  :Translator. M2Amiga v3.1d
  :Contents.   Program to create a 1024 x 512 pixels large Workbench!
---------------------------------------------------------------------------*)

MODULE MegaWB;

FROM SYSTEM      IMPORT ADR, ADDRESS, LONGSET, CAST, BITSET, INLINE;
FROM Arts        IMPORT Assert, TermProcedure, Terminate;
FROM Arguments   IMPORT NumArgs, GetArg;
FROM Conversions IMPORT StrToVal;
FROM Exec        IMPORT Forbid, Permit, FindPort, MsgPortPtr, NodeType,
                        Message, MessagePtr, GetMsg, ReplyMsg, PutMsg,
                        WaitPort, OpenLibrary, CloseLibrary, UByte,
                        IOStdReq, Interrupt, IOStdReqPtr, OpenDevice,
                        CloseDevice, DoIO,  AddIntServer, RemIntServer,
                        AllocSignal, FreeSignal, Wait, Signal, FindTask,
                        TaskPtr, Byte, FreeMem, MemReqs, MemReqSet,
                        SetTaskPri;
IMPORT Exec;
FROM ExecSupport IMPORT CreatePort, DeletePort, CreateStdIO, DeleteStdIO;
FROM Graphics    IMPORT BitMap, BltBitMap, SimpleSprite, GetSprite, SetRGB4,
                        ChangeSprite, MoveSprite, FreeSprite, WaitBlit;
FROM Hardware    IMPORT vertb;
FROM Input       IMPORT inputName, addHandler, remHandler;
FROM InputEvent  IMPORT InputEvent, InputEventPtr, Class, lButton;
FROM Intuition   IMPORT ScreenPtr, MakeScreen, RethinkDisplay, NewWindow,
                        WindowFlags, WindowFlagSet, ScreenFlags, CloseWindow,
                        ScreenFlagSet, IDCMPFlagSet, OpenWindow, WindowPtr,
                        IntuitionBase, LockIBase, UnlockIBase, GetPrefs,
                        Preferences;
FROM Heap        IMPORT AllocMem;

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

CONST
  WindowTitle = "MegaWB © Fridtjof Siebert / AMOK Stuttgart";
  PortName    = "NewWBPlanes[fbs].Port";
  ReplyName   = "NewWBPlanes[fbs].ReplyPort";
  Usage       = "Usage: MegaWB [x-Size y-Size]";
  MOVEMS = 48E7H;
  MOVEML = 4CDFH;

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

TYPE
  SprData = POINTER TO ARRAY[0..255] OF LONGINT;

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

VAR
  WBScreen: ScreenPtr;
  Window: WindowPtr;
  NuWindow: NewWindow;
  w: WindowPtr;
  MyMsg: Message;
  QuitMessage: MessagePtr;
  MyPort, OldPort: MsgPortPtr;
  bm,oldbm: BitMap;
  EmptySprite,GetSpr: SprData;
  SpriteImg: ARRAY[0..1] OF SprData;
  ActSprImg: INTEGER;
  sprite: SimpleSprite;
  sprID: INTEGER;
  oldmaxx,oldmaxy: INTEGER;
  lastx,lasty,mx,my,i: INTEGER;
  mxm,mym: INTEGER;
  lastmy: INTEGER;
  oldw,oldh: INTEGER;
  mousePressed: BOOLEAN;
  SizeX,SizeY: LONGINT;
  arg: ARRAY[0..79] OF CHAR;
  ilock: LONGCARD;
  intuiBase: POINTER TO IntuitionBase;
  pref: Preferences;
  InputDevPort: MsgPortPtr;
  InputRequestBlock: IOStdReqPtr;
  HandlerStuff: Interrupt;
  HandlerActive, InputOpen: BOOLEAN;
  TraceEv: InputEventPtr;
  VertBIntr: Interrupt;
  IntActive: BOOLEAN;
  MySig: INTEGER;
  MyTask: TaskPtr;
  err,b: BOOLEAN;
  l: LONGINT;

(*------  InputHandler:  ------*)

PROCEDURE MyHandler(Ev{8}: InputEventPtr): InputEventPtr; (* $S- *)

BEGIN
  TraceEv := Ev;
  WITH intuiBase^ DO
    IF activeScreen=WBScreen THEN
      WHILE TraceEv#NIL DO
        WITH TraceEv^ DO
          IF class=rawmouse THEN
            IF code=lButton+128 THEN   (* LMB released *)
              mxm := SizeX - 1;
              mym := SizeY * 2 - 1;
              mousePressed := FALSE;
            ELSIF code=lButton THEN    (* LMB pressed *)
              IF activeWindow#NIL THEN
                IF (WBScreen^.mouseY-activeWindow^.topEdge>10) THEN
                  mxm := SizeX - 19;
                  IF mxm<mouseX THEN mxm := mouseX END;
                  mym := SizeY * 2 - 19;
                  IF mym<mouseY THEN mym := mouseY END;
                ELSE mxm := -1; mym := -1 END;
              ELSE mxm := -1; mym := -1 END;
              mousePressed := TRUE;
            END;
          END;
          TraceEv := nextEvent;
        END;
      END;
    END;
    IF mxm#-1 THEN maxXMouse := mxm END;
    IF mym#-1 THEN maxYMouse := mym END;
  END;
  RETURN Ev;
END MyHandler; (* $S+ *)

(*------  VertB-Interrupt:  ------*)

PROCEDURE MyIntProc(); (* $S- *)

BEGIN
  INLINE(MOVEMS,3F3EH); (* this is MOVEM d2-d7/a2-a6,-(sp) *)

  IF (intuiBase^.activeScreen = WBScreen) AND (WBScreen^.mouseY>=0) THEN
    WITH intuiBase^ DO
(* Why does Intuition always set this to 555??? Gruuuummmpfffl! *)
      IF mousePressed THEN
        IF activeWindow#NIL THEN
          IF (maxXMouse>SizeX-30) AND (maxYMouse>2*SizeY-30) THEN
            IF mxm=-1 THEN
              mxm := SizeX - activeWindow^.width;
              IF mxm<mouseX THEN mxm := mouseX END;
            END;
            IF mym=-1 THEN
              mym := 2 * (SizeY-activeWindow^.height) - 1;
              IF mym<mouseY THEN mym := mouseY END;
            END;
          END;
        END;
        IF (maxYMouse=555) AND (mym<555) THEN
          IF lastmy>555 THEN mym := lastmy END;
            IF (activeWindow#NIL) AND (2*(SizeY-activeWindow^.height)-1>maxYMouse) THEN
             mym := 2*(SizeY-activeWindow^.height)-1;
          END;
        END;
      END;
      lastmy := mouseY;
      IF mxm#-1 THEN maxXMouse := mxm END;
      IF mym#-1 THEN maxYMouse := mym END;
      IF aPointer#GetSpr THEN
        ActSprImg := 1-ActSprImg;
        GetSpr := aPointer;
        SpriteImg[ActSprImg]^ := GetSpr^;
        sprite.height := aPtrHeight;
(*        ChangeSprite(ADR(WBScreen^.viewPort),ADR(sprite),SpriteImg[ActSprImg]); *)
      END;
    END;
    IF (intuiBase^.mouseX#lastx) OR (intuiBase^.mouseY#lasty) THEN
      lastx := intuiBase^.mouseX; lasty := intuiBase^.mouseY;
      WITH WBScreen^.viewPort.rasInfo^ DO
        rxOffset := LONGINT(lastx) * LONGINT(SizeX+2 - oldw) DIV SizeX;
        ryOffset := LONGINT(lasty-WBScreen^.topEdge*2) * LONGINT(SizeY - oldh) DIV SizeY DIV 2;
        mx := lastx       - rxOffset + 2*ORD(CAST(Byte,intuiBase^.aXOffset));
        my := lasty DIV 2 - ryOffset + ORD(CAST(Byte,intuiBase^.aYOffset)) - WBScreen^.topEdge;
        Signal(MyTask,LONGSET{MySig});
      END;
    END;
  ELSE
    sprite.height := 0;
(*    ChangeSprite(ADR(WBScreen^.viewPort),ADR(sprite),ADR(SpriteImg[ActSprImg])) *)
  END;

  INLINE(MOVEML,7CFCH); (* this is MOVEM (sp)+,d2-d7/a2-a6 *)
END MyIntProc; (* $S+ *)

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

PROCEDURE CleanUp();

BEGIN

(*------  Remove Inputhandler:  ------*)

  IF HandlerActive THEN
    WITH InputRequestBlock^ DO
      command := remHandler;
      data := ADR(HandlerStuff);
    END;
    DoIO(InputRequestBlock);
  END;
  IF InputRequestBlock#NIL THEN DeleteStdIO(InputRequestBlock) END;
  IF InputDevPort#NIL THEN DeletePort(InputDevPort) END;

(*------  Remove Interrupt:  ------*)

  IF IntActive THEN RemIntServer(vertb,ADR(VertBIntr)) END;

(*------  Reset Workbench:  ------*)

  IF WBScreen#NIL THEN
    WITH oldbm DO
      l := 0;
      WHILE l<LONGINT(depth) DO
        IF planes[l]=NIL THEN
          planes[l] := Exec.AllocMem(LONGINT(rows)*LONGINT(bytesPerRow),MemReqSet{chip,memClear});
          IF planes[l]=NIL THEN depth := l END;
        END;
        INC(l);
      END;
    END;
    Forbid();
      WITH WBScreen^ DO
        width := oldw;
        height := oldh;
        bitMap := oldbm;
        l := BltBitMap(ADR(bm),0,0,ADR(bitMap),0,0,oldw,oldh,0C0H,3,NIL);
        WITH viewPort.rasInfo^ DO
          rxOffset := NIL;
          ryOffset := NIL;
        END;
      END;
      WITH intuiBase^ DO
        maxXMouse := oldmaxx;
        maxYMouse := oldmaxy;
      END;
      MakeScreen(WBScreen);
    Permit();
    RethinkDisplay();
  END;

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

  IF Window#NIL THEN CloseWindow(Window) END;
  IF sprID#-1 THEN FreeSprite(sprID) END;
  IF MySig#-1 THEN FreeSignal(MySig) END;
  CloseLibrary(ADDRESS(intuiBase));

(*------  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;
  sprID := -1; InputDevPort := NIL; InputRequestBlock := NIL;
  HandlerActive := FALSE; InputOpen := FALSE; MySig := -1;
  SizeX := 1024; SizeY := 512;

  intuiBase := ADDRESS(OpenLibrary(ADR("intuition.library"),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"));

(*------  Get Arguments:  ------*)

  CASE NumArgs() OF
  0: |
  1: Assert(FALSE,ADR(Usage)) |
  2: GetArg(1,arg,i); StrToVal(arg,SizeX,b,10,err); Assert(NOT err,ADR(Usage));
     GetArg(2,arg,i); StrToVal(arg,SizeY,b,10,err); Assert(NOT err,ADR(Usage))|
  ELSE Assert(FALSE,ADR(Usage)) END;

(*------  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!!!"));

(*------  Allocate Sprite:  ------*)

  AllocMem(SpriteImg[0],SIZE(GetSpr^),TRUE);
  AllocMem(SpriteImg[1],SIZE(GetSpr^),TRUE);
  Assert((SpriteImg[0]#NIL) AND (SpriteImg[1]#NIL),ADR("Out of memory!"));
  ActSprImg := 0;
  sprID := GetSprite(ADR(sprite),-1);
  Assert(sprID#-1,ADR("Keine Sprites mehr frei!"));

(*------  Signal:  ------*)

  MySig := AllocSignal(-1);
  Assert(MySig#-1,ADR("No free Signalbit"));
  MyTask := FindTask(NIL);
  IF SetTaskPri(MyTask,2)=0 THEN END; (* I'm responsible for quick WBDisplay! *)

(*------  Resize Workbench:  ------*)

  GetPrefs(ADR(pref),SIZE(Preferences));
  ilock := LockIBase(0);
  WaitBlit();
  WBScreen := Window^.wScreen;
  oldbm := WBScreen^.bitMap;
  bm := WBScreen^.bitMap;
  WITH bm DO
    rows := SizeY;
    bytesPerRow := ((SizeX+15) DIV 16) * 2;
    FOR l:=0 TO depth-1 DO
      AllocMem(planes[l],LONGINT(rows)*LONGINT(bytesPerRow),TRUE);
      IF planes[l]=NIL THEN
        WBScreen := NIL;
        Permit;
        Assert(TRUE,ADR("Out of memory"));
      END;
    END;
  END;
  WITH WBScreen^ DO
    l := BltBitMap(ADR(oldbm),0,0,ADR(bm),0,0,width,height,0C0H,3,NIL);
    bitMap := bm;
    oldw := width; oldh := height; width := SizeX; height := SizeY;
    MakeScreen(WBScreen);
    WITH oldbm DO
      l := 0;
      WHILE l<LONGINT(depth) DO
        FreeMem(planes[l],LONGINT(rows)*LONGINT(bytesPerRow));
        planes[l] := NIL;
        INC(l);
      END;
    END;
    WITH intuiBase^ DO
      oldmaxx := maxXMouse;
      oldmaxy := maxYMouse;
      maxXMouse := SizeX - 1;
      maxYMouse := SizeY * 2 - 1;
      IF sprID>1 THEN
        l := (sprID DIV 2) * 4 + 16;
        WITH pref DO
          SetRGB4(ADR(viewPort),l+1,
            CAST(INTEGER,CAST(BITSET,color17)*{0.. 3}),
            CAST(INTEGER,CAST(BITSET,color17)*{4.. 7}) DIV 16,
            CAST(INTEGER,CAST(BITSET,color17)*{8..11}) DIV 256);
          SetRGB4(ADR(viewPort),l+2,
            CAST(INTEGER,CAST(BITSET,color18)*{0.. 3}),
            CAST(INTEGER,CAST(BITSET,color18)*{4.. 7}) DIV 16,
            CAST(INTEGER,CAST(BITSET,color18)*{8..11}) DIV 256);
          SetRGB4(ADR(viewPort),l+3,
            CAST(INTEGER,CAST(BITSET,color19)*{0.. 3}),
            CAST(INTEGER,CAST(BITSET,color19)*{4.. 7}) DIV 16,
            CAST(INTEGER,CAST(BITSET,color19)*{8..11}) DIV 256);
        END;
      END;
      sprite.x := 0;
      sprite.y := 0;
      sprite.height := aPtrHeight;
      GetSpr := aPointer;
      SpriteImg[ActSprImg]^ := GetSpr^;
    END;
    ChangeSprite(ADR(viewPort),ADR(sprite),SpriteImg[ActSprImg]);
  END;
  UnlockIBase(ilock);

(*------  Add Inputhandler:  ------*)

  InputDevPort := CreatePort(NIL,0);
  Assert(InputDevPort#NIL,ADR("CreatePort failed"));

  InputRequestBlock := CreateStdIO(InputDevPort);
  Assert(InputRequestBlock#NIL,ADR("CreateStdIO failed"));

  WITH HandlerStuff DO
    data := NIL;
    code := ADR(MyHandler);
    node.pri := 51;
  END;
  OpenDevice(ADR(inputName),0,InputRequestBlock,LONGSET{});
  IF InputRequestBlock^.error#0 THEN Terminate(0) END;
  InputOpen := TRUE;

  WITH InputRequestBlock^ DO
    command := addHandler;
    data := ADR(HandlerStuff);
  END;
  DoIO(InputRequestBlock);
  HandlerActive := TRUE;

(*------  Interrupt starten:  ------*)

  WITH VertBIntr DO
    node.type := interrupt;
    node.pri  := 0;
    node.name := ADR("MegaWB.interrupt");
    data := NIL;
    code := MyIntProc;
  END;
  AddIntServer(vertb,ADR(VertBIntr));
  IntActive := TRUE;

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

  lastx := -1; lasty := -1; mxm := SizeX - 1; mym := SizeY * 2 - 1;
  lastmy := intuiBase^.mouseY;
  LOOP
    REPEAT
      IF MySig IN Wait(LONGSET{MyPort^.sigBit,MySig}) THEN
        MoveSprite(ADR(WBScreen^.viewPort),ADR(sprite),mx,my);
        MakeScreen(WBScreen);
        RethinkDisplay();
      END;
      QuitMessage := GetMsg(MyPort);
    UNTIL QuitMessage#NIL;

    ilock := LockIBase(0);
    w := WBScreen^.firstWindow;
    WHILE LONGCARD(w)>1 DO
      WITH w^ DO
        IF (width+leftEdge>oldw) OR (height+topEdge>oldh) THEN
          w := WindowPtr(1);
        ELSE
          w := nextWindow;
        END;
      END;
    END;
    UnlockIBase(ilock);

    IF w=NIL THEN
      WITH oldbm DO
        IF planes[0]=NIL THEN
          planes[0] := Exec.AllocMem(LONGINT(rows)*LONGINT(bytesPerRow),MemReqSet{chip,memClear});
          IF planes[0]#NIL THEN EXIT END;
        END;
      END;
    END;

    ReplyMsg(QuitMessage);
  END;

END MegaWB.