(*---------------------------------------------------------------------------
    :Program.    XHair.mod
    :Author.     Fridtjof Siebert
    :Address.    Nobileweg 67, D-7-Stgt-40
    :Phone.      (0)711/822509
    :Shortcut.   [fbs]
    :Version.    1.0
    :Date.       02-Jan-89
    :Copyright.  PD
    :Language.   Modula-II
    :Translator. M2Amiga v3.1d
    :Imports.    arp.library
    :Contents.   Program to replace Mousepointer by a Crosshair
    :Remark.     Same principle as WBPic.mod
    :Usage.      XHair [HELP] [QUIT] [COL HHH] [OLDPTR]
---------------------------------------------------------------------------*)

MODULE XHair;

FROM SYSTEM     IMPORT ADR, ADDRESS;
FROM Arts       IMPORT Assert, TermProcedure, wbStarted, dosCmdBuf, dosCmdLen,
                       Terminate;

FROM Intuition  IMPORT GetPrefs, ScreenPtr, MakeScreen,
                       RethinkDisplay, Preferences, NewWindow, WindowFlags,
                       WindowFlagSet, ScreenFlags, CloseWindow, ScreenFlagSet,
                       IDCMPFlags, IDCMPFlagSet, OpenWindow, WindowPtr,
                       SetPrefs;
FROM ARP        IMPORT ArpAlloc, CreatePort, Puts, GADS, ArpAllocMem, Delay,
                       DeletePort;
FROM Dos        IMPORT ctrlC;
FROM Exec       IMPORT Forbid, Permit, FindPort, MsgPortPtr, NodeType,
                       Message, MessagePtr, GetMsg, ReplyMsg, PutMsg, Wait,
                       MemReqs, MemReqSet, WaitPort, SetTaskPri, FindTask;
FROM Graphics   IMPORT WaitBOVP, RastPort, BitMap, Move, Draw, InitRastPort,
                       SetDrMd, DrawModes, DrawModeSet, WaitTOF;

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

CONST
  WindowTitle = "XHair © Fridtjof Siebert";
  PortName    = "NewWBPlanes[fbs].Port";
  ReplyName   = "NewWBPlanes[fbs].ReplyPort";
  TPlate      = "HELP/S,QUIT/S,COL/K,OLDPTR/S";
  LTRUE  = -1;
  LFALSE = 0;

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

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

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

VAR
  WBScreen: ScreenPtr;
  NewPlane: ADDRESS;
  Prefs, NewPrefs: Preferences;
  CMap: ColorMap;
  OldColTable: POINTER TO ColorMap;
  XHairColor: INTEGER;
  Window: WindowPtr;
  NuWindow: NewWindow;
  MyMsg: Message;
  QuitMessage,Msg: MessagePtr;
  MyPort, OldPort: MsgPortPtr;
  Args: RECORD
          help: LONGBOOL;
          quit: LONGBOOL;
          col: POINTER TO ARRAY[0..79] OF CHAR;
          oldptr: LONGBOOL;
        END;
  OldPtr: BOOLEAN;
  NumArgs: INTEGER;
  i: INTEGER;
  oldx,oldy,x,y: INTEGER;
  rp: RastPort;
  bm: BitMap;
  count: CARDINAL;
  in,lastin: BOOLEAN;
  dmacon[0DFF096H]: CARDINAL;

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

PROCEDURE CleanUp();

BEGIN

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

  IF WBScreen#NIL THEN
    Forbid();
      IF OldColTable#NIL THEN
        WBScreen^.viewPort.colorMap^.colorTable := OldColTable;
      END;
      WITH WBScreen^.bitMap DO
        depth := 2;
        planes[2] := NIL;
      END;
      MakeScreen(WBScreen);
    Permit();
    RethinkDisplay();
  END;

(*------  Reset Preferences:  ------*)

  IF NOT(OldPtr) AND (Prefs.fontHeight>0) THEN
    SetPrefs(ADR(Prefs),SIZE(Preferences),TRUE);
    WaitPort(Window^.userPort);
  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; OldColTable := NIL; Window := NIL; MyPort := NIL;
  Prefs.fontHeight := 0;
  TermProcedure(CleanUp);
  IF SetTaskPri(FindTask(NIL),5)=0 THEN END;

(*------  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;
    IF wbStarted THEN
      Terminate(0);
    ELSE
      IF Puts(ADR("Task signalled"))=0 THEN END;
    END;
  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{newPrefs};
    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
    IF Puts(ADR("There's something strange with your Workbench!"))=0 THEN END;
    Terminate(0);
  END;

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

  XHairColor := -1; OldPtr := FALSE;
  IF NOT wbStarted THEN
    WITH Args DO
      help := LFALSE;
      quit := LFALSE;
      col  := NIL;
      oldptr := LFALSE;
    END;
    NumArgs := GADS(dosCmdBuf,dosCmdLen,NIL,ADR(Args),ADR(TPlate));
    WITH Args DO
      IF (NumArgs=-1) THEN
        IF Puts(ADR("Bad Args"))=0 THEN END;
        Terminate(0);
      END;
      IF help=LTRUE THEN
        IF Puts(ADR("Usage: XHair [HELP] [QUIT] [COL HHH] [OLDPTR]")) +
           Puts(ADR("  HELP    Shows usage")) +
           Puts(ADR("  QUIT    Signals XHair to quit")) +
           Puts(ADR("  COL HHH Set XHair's color to hex # HHH")) +
           Puts(ADR("  OLDPTR  aviods removing pointer"))=0 THEN END;
        Terminate(0);
      END;
      IF quit=LTRUE THEN Terminate(0) END;
      IF (col#NIL) THEN
        XHairColor := 0;
        IF col^[3]#0C THEN
          IF Puts(ADR("Bad Args"))=0 THEN END;
          Terminate(0);
        END;
        FOR i:=0 TO 2 DO
          XHairColor := XHairColor * 16;
          CASE CAP(col^[i]) OF
          "0".."9": INC(XHairColor,ORD(    col^[i] )-ORD("0")   ); |
          "A".."F": INC(XHairColor,ORD(CAP(col^[i]))-ORD("A")+10); |
          ELSE
            IF Puts(ADR("Bad Args"))=0 THEN END;
            Terminate(0);
          END;
        END;
      END;
      OldPtr := (oldptr=LTRUE);
    END;
  END;

(*------  Modify Preferences:  ------*)

  IF NOT OldPtr THEN
    GetPrefs(ADR(Prefs),SIZE(Preferences));
    NewPrefs := Prefs;
    WITH NewPrefs DO
      FOR i:=2 TO 33 DO
        pointerMatrix[i] := 0;
      END;
      color17 := color0;
      color18 := color0;
      color19 := color0;
    END;
    SetPrefs(ADR(NewPrefs),SIZE(Preferences),TRUE);
  END;

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

  Forbid();
  OldColTable := WBScreen^.viewPort.colorMap^.colorTable;
  CMap := OldColTable^;
  IF XHairColor=-1 THEN
    FOR i:=0 TO 3 DO CMap[4+i]:=CMap[3-i] END;
  ELSE
    FOR i:=4 TO 7 DO CMap[i]:=XHairColor END;
  END;
  WBScreen^.viewPort.colorMap^.colorTable := ADR(CMap);
  Permit();

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

  WITH WBScreen^.bitMap DO
    NewPlane := ArpAllocMem(rows*bytesPerRow,MemReqSet{chip,memClear});
    Assert(NewPlane#NIL,ADR("Out of memory"));
    planes[2] := NewPlane;
  END;

(*------  Init dummy RastPort:  ------*)

  InitRastPort(rp);
  rp.bitMap := ADR(bm);
  bm := WBScreen^.bitMap;
  bm.depth := 1;
  bm.planes[0] := NewPlane;
  SetDrMd(ADR(rp),DrawModeSet{complement});

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

  WITH WBScreen^ DO
    WITH bitMap DO
      count := 0; lastin := FALSE;
      REPEAT
        WaitTOF();
        IF NOT OldPtr THEN dmacon := 32 END; (* = GfxMacros.OffSprite *)
        x := mouseX; y := mouseY;
        in := (x>=0) AND (x<width) AND (y>=0) AND (y<height);
        INC(count);
        IF in AND NOT(lastin) OR (count=50) THEN
          Forbid();
            depth := 3;
            MakeScreen(WBScreen);
            depth := 2;
            RethinkDisplay();
          Permit();
          count := 0;
        END;
        IF (oldx#x) OR (in#lastin) THEN
          IF in     THEN Move(ADR(rp),   x,0); Draw(ADR(rp),   x,height-1) END;
          IF lastin THEN Move(ADR(rp),oldx,0); Draw(ADR(rp),oldx,height-1) END;
          oldx := x;
        END;
        IF (oldy#y) OR (in#lastin) THEN
          IF in     THEN Move(ADR(rp),0,y);    Draw(ADR(rp),width-1,y)    END;
          IF lastin THEN Move(ADR(rp),0,oldy); Draw(ADR(rp),width-1,oldy) END;
          oldy := y;
        END;
        lastin := in;
        QuitMessage := GetMsg(MyPort);
      UNTIL QuitMessage#NIL;
    END;
  END;

END XHair.