home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 311.lha / XHair / Gummi.mod < prev    next >
Encoding:
Text File  |  1980-12-05  |  8.9 KB  |  324 lines
  1. (*---------------------------------------------------------------------------
  2.     :Program.    Gummi.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.       03-Jan-89
  9.     :Copyright.  PD
  10.     :Language.   Modula-II
  11.     :Translator. M2Amiga v3.1d
  12.     :Imports.    arp.library
  13.     :Contents.   Program to replace Mousepointer by some lines
  14.     :Usage.      Gummi [HELP] [QUIT] [COL HHH] [OLDPTR]
  15. ---------------------------------------------------------------------------*)
  16.  
  17. MODULE Gummi;
  18.  
  19. FROM SYSTEM     IMPORT ADR, ADDRESS, LONGSET;
  20. FROM Arts       IMPORT Assert, TermProcedure, wbStarted, dosCmdBuf, dosCmdLen,
  21.                        Terminate;
  22.  
  23. FROM Intuition  IMPORT GetPrefs, ScreenPtr, MakeScreen,
  24.                        RethinkDisplay, Preferences, NewWindow, WindowFlags,
  25.                        WindowFlagSet, ScreenFlags, CloseWindow, ScreenFlagSet,
  26.                        IDCMPFlags, IDCMPFlagSet, OpenWindow, WindowPtr,
  27.                        SetPrefs;
  28. FROM ARP        IMPORT ArpAlloc, CreatePort, Puts, GADS, ArpAllocMem, Delay,
  29.                        DeletePort;
  30. FROM Dos        IMPORT ctrlC;
  31. FROM Exec       IMPORT Forbid, Permit, FindPort, MsgPortPtr, NodeType,
  32.                        Message, MessagePtr, GetMsg, ReplyMsg, PutMsg, Wait,
  33.                        MemReqs, MemReqSet, WaitPort, FindTask, SetTaskPri;
  34. FROM Graphics   IMPORT WaitBOVP, BitMap, Move, Draw, SetDrMd, DrawModes,
  35.                        DrawModeSet, WaitTOF, LayerInfoPtr, RastPortPtr,
  36.                        LayerPtr;
  37. FROM Layers     IMPORT NewLayerInfo, CreateUpfrontLayer, DeleteLayer,
  38.                        DisposeLayerInfo;
  39.  
  40. (*------  CONSTS:  ------*)
  41.  
  42. CONST
  43.   WindowTitle = "XHair © Fridtjof Siebert";
  44.   PortName    = "NewWBPlanes[fbs].Port";
  45.   ReplyName   = "NewWBPlanes[fbs].ReplyPort";
  46.   TPlate      = "HELP/S,QUIT/S,COL/K,OLDPTR/S";
  47.   LTRUE  = -1;
  48.   LFALSE = 0;
  49.  
  50. (*------  TYPES:  ------*)
  51.  
  52. TYPE
  53.   ColorMap =  ARRAY[0..31] OF INTEGER;
  54.   LONGBOOL = LONGINT;
  55.  
  56. (*------  VARS:  ------*)
  57.  
  58. VAR
  59.   WBScreen: ScreenPtr;
  60.   NewPlane: ADDRESS;
  61.   Prefs, NewPrefs: Preferences;
  62.   CMap: ColorMap;
  63.   OldColTable: POINTER TO ColorMap;
  64.   XHairColor: INTEGER;
  65.   Window: WindowPtr;
  66.   NuWindow: NewWindow;
  67.   MyMsg: Message;
  68.   QuitMessage,Msg: MessagePtr;
  69.   MyPort, OldPort: MsgPortPtr;
  70.   Args: RECORD
  71.           help: LONGBOOL;
  72.           quit: LONGBOOL;
  73.           col: POINTER TO ARRAY[0..79] OF CHAR;
  74.           oldptr: LONGBOOL;
  75.         END;
  76.   OldPtr: BOOLEAN;
  77.   NumArgs: INTEGER;
  78.   i: INTEGER;
  79.   oldx,oldy,x,y: INTEGER;
  80.   rp: RastPortPtr;
  81.   bm: BitMap;
  82.   count: CARDINAL;
  83.   dmacon[0DFF096H]: CARDINAL;
  84.   li: LayerInfoPtr;
  85.   layer: LayerPtr;
  86.  
  87. (*------  CleanUp:  ------*)
  88.  
  89. PROCEDURE CleanUp();
  90.  
  91. BEGIN
  92.  
  93. (*------  Remove Layer:  ------*)
  94.  
  95.   IF layer#NIL THEN IF DeleteLayer(layer)=NIL THEN END END;
  96.   IF li#NIL    THEN DisposeLayerInfo(li) END;
  97.  
  98. (*------  Remove Picture from WB:  ------*)
  99.  
  100.   IF WBScreen#NIL THEN
  101.     Forbid();
  102.       IF OldColTable#NIL THEN
  103.         WBScreen^.viewPort.colorMap^.colorTable := OldColTable;
  104.       END;
  105.       WITH WBScreen^.bitMap DO
  106.         depth := 2;
  107.         planes[2] := NIL;
  108.       END;
  109.       MakeScreen(WBScreen);
  110.     Permit();
  111.     RethinkDisplay();
  112.   END;
  113.  
  114. (*------  Reset Preferences:  ------*)
  115.  
  116.   IF NOT(OldPtr) AND (Prefs.fontHeight>0) THEN
  117.     SetPrefs(ADR(Prefs),SIZE(Preferences),TRUE);
  118.     WaitPort(Window^.userPort);
  119.   END;
  120.  
  121. (*------  Close everything:  ------*)
  122.  
  123.   IF Window#NIL THEN CloseWindow(Window); END;
  124.  
  125. (*------  Remove Port:  ------*)
  126.  
  127.   IF MyPort#NIL THEN
  128.     Forbid();
  129.       IF QuitMessage=NIL THEN QuitMessage := GetMsg(MyPort) END;
  130.       WHILE QuitMessage#NIL DO
  131.         ReplyMsg(QuitMessage);
  132.         QuitMessage := GetMsg(MyPort);
  133.       END;
  134.       DeletePort(MyPort);
  135.     Permit();
  136.   END;
  137.  
  138. END CleanUp;
  139.  
  140. (*------  MAIN:  ------*)
  141.  
  142. BEGIN
  143.  
  144. (*------  Initialization:  ------*)
  145.  
  146.   WBScreen := NIL; OldColTable := NIL; Window := NIL; MyPort := NIL;
  147.   Prefs.fontHeight := 0; layer := NIL; li := NIL;
  148.   TermProcedure(CleanUp);
  149.   IF SetTaskPri(FindTask(NIL),5)=0 THEN END;
  150.  
  151. (*------  Have we already been started?  ------*)
  152.  
  153.   OldPort := FindPort(ADR(PortName));
  154.   IF OldPort#NIL THEN
  155.     MyPort := CreatePort(ADR(ReplyName),0);
  156.     Assert(MyPort#NIL,ADR("CreatePort failed"));
  157.     MyMsg.node.type := message;
  158.     MyMsg.replyPort := MyPort;
  159.     PutMsg(OldPort,ADR(MyMsg)); (* Signal task to quit *)
  160.     WaitPort(MyPort);
  161.     DeletePort(MyPort);
  162.     MyPort := NIL;
  163.     IF wbStarted THEN
  164.       Terminate(0);
  165.     ELSE
  166.       IF Puts(ADR("Task signalled"))=0 THEN END;
  167.     END;
  168.   END;
  169.   MyPort := CreatePort(ADR(PortName),0);
  170.   Assert(MyPort#NIL,ADR("CreatePort failed"));
  171.  
  172. (*------  Open Window:  ------*)
  173.  
  174.   WITH NuWindow DO
  175.     leftEdge   := 0; topEdge     := 0;
  176.     width      := 1; height      := 1;
  177.     detailPen  := 0; blockPen    := 1;
  178.     idcmpFlags := IDCMPFlagSet{newPrefs};
  179.     flags      := WindowFlagSet{backDrop};
  180.     firstGadget:= NIL; checkMark := NIL;
  181.     title      := ADR(WindowTitle);
  182.     screen     := NIL; bitMap    := NIL;
  183.     type       := ScreenFlagSet{wbenchScreen};
  184.   END;
  185.   Window := OpenWindow(NuWindow);
  186.   Assert(Window#NIL,ADR("Can't open Window!!!"));
  187.   WBScreen := Window^.wScreen;
  188.   IF WBScreen^.bitMap.depth>2 THEN
  189.     IF Puts(ADR("There's something strange with your Workbench!"))=0 THEN END;
  190.     Terminate(0);
  191.   END;
  192.  
  193. (*------  Get Arguments:  ------*)
  194.  
  195.   XHairColor := -1; OldPtr := FALSE;
  196.   IF NOT wbStarted THEN
  197.     WITH Args DO
  198.       help := LFALSE;
  199.       quit := LFALSE;
  200.       col  := NIL;
  201.       oldptr := LFALSE;
  202.     END;
  203.     NumArgs := GADS(dosCmdBuf,dosCmdLen,NIL,ADR(Args),ADR(TPlate));
  204.     WITH Args DO
  205.       IF (NumArgs=-1) THEN
  206.         IF Puts(ADR("Bad Args"))=0 THEN END;
  207.         Terminate(0);
  208.       END;
  209.       IF help=LTRUE THEN
  210.         IF Puts(ADR("Usage: Gummi [HELP] [QUIT] [COL HHH] [OLDPTR]")) +
  211.            Puts(ADR("  HELP    Shows usage")) +
  212.            Puts(ADR("  QUIT    Signals Gummi to quit")) +
  213.            Puts(ADR("  COL HHH Set pointer's color to hex # HHH")) +
  214.            Puts(ADR("  OLDPTR  Aviods removing pointer"))=0 THEN END;
  215.         Terminate(0);
  216.       END;
  217.       IF quit=LTRUE THEN Terminate(0) END;
  218.       IF (col#NIL) THEN
  219.         XHairColor := 0;
  220.         IF col^[3]#0C THEN
  221.           IF Puts(ADR("Bad Args"))=0 THEN END;
  222.           Terminate(0);
  223.         END;
  224.         FOR i:=0 TO 2 DO
  225.           XHairColor := XHairColor * 16;
  226.           CASE CAP(col^[i]) OF
  227.           "0".."9": INC(XHairColor,ORD(    col^[i] )-ORD("0")   ); |
  228.           "A".."F": INC(XHairColor,ORD(CAP(col^[i]))-ORD("A")+10); |
  229.           ELSE
  230.             IF Puts(ADR("Bad Args"))=0 THEN END;
  231.             Terminate(0);
  232.           END;
  233.         END;
  234.       END;
  235.       OldPtr := (oldptr=LTRUE);
  236.     END;
  237.   END;
  238.  
  239. (*------  Modify Preferences:  ------*)
  240.  
  241.   IF NOT OldPtr THEN
  242.     GetPrefs(ADR(Prefs),SIZE(Preferences));
  243.     NewPrefs := Prefs;
  244.     WITH NewPrefs DO
  245.       FOR i:=2 TO 33 DO
  246.         pointerMatrix[i] := 0;
  247.       END;
  248.       color17 := color0;
  249.       color18 := color0;
  250.       color19 := color0;
  251.     END;
  252.     SetPrefs(ADR(NewPrefs),SIZE(Preferences),TRUE);
  253.   END;
  254.  
  255. (*------  Set Colors:  ------*)
  256.  
  257.   Forbid();
  258.   OldColTable := WBScreen^.viewPort.colorMap^.colorTable;
  259.   CMap := OldColTable^;
  260.   IF XHairColor=-1 THEN
  261.     FOR i:=0 TO 3 DO CMap[4+i]:=CMap[3-i] END;
  262.   ELSE
  263.     FOR i:=4 TO 7 DO CMap[i]:=XHairColor END;
  264.   END;
  265.   WBScreen^.viewPort.colorMap^.colorTable := ADR(CMap);
  266.   Permit();
  267.  
  268. (*------  Add Plane to WBScreen:  ------*)
  269.  
  270.   WITH WBScreen^.bitMap DO
  271.     NewPlane := ArpAllocMem(rows*bytesPerRow,MemReqSet{chip,memClear});
  272.     Assert(NewPlane#NIL,ADR("Out of memory"));
  273.     planes[2] := NewPlane;
  274.   END;
  275.  
  276. (*------  Init Layer:  ------*)
  277.  
  278.   WITH WBScreen^ DO
  279.     bm := WBScreen^.bitMap;
  280.     bm.depth := 1;
  281.     bm.planes[0] := NewPlane;
  282.     li := NewLayerInfo();
  283.     Assert(li#NIL,ADR("NewLayerInfo() failed."));
  284.     layer := CreateUpfrontLayer(li,ADR(bm),0,0,width-1,height-1,LONGSET{0},NIL);
  285.     Assert(li#NIL,ADR("CreateUpfrontLayer() failed."));
  286.     rp := layer^.rp;
  287.     SetDrMd(rp,DrawModeSet{complement});
  288.  
  289. (*------  Do it:  ------*)
  290.  
  291.     WITH bitMap DO
  292.       count := 0; oldx := -1000;
  293.       REPEAT
  294.         WaitTOF();
  295.         IF NOT OldPtr THEN dmacon := 32 END;
  296.         x := mouseX; y := mouseY;
  297.         INC(count);
  298.         IF (count=50) THEN
  299.           Forbid();
  300.             depth := 3;
  301.             MakeScreen(WBScreen);
  302.             depth := 2;
  303.             RethinkDisplay();
  304.           Permit();
  305.           count := 0;
  306.         END;
  307.         IF (oldx#x) OR (oldy#y) THEN
  308.           WITH WBScreen^ DO
  309.             Move(rp,0,0); Draw(rp,   x,   y); Draw(rp,width-1,height-1);
  310.             Move(rp,width-1,0); Draw(rp,   x,   y); Draw(rp,0,height-1);
  311.             IF oldx#-1000 THEN
  312.               Move(rp,0,0); Draw(rp,oldx,oldy); Draw(rp,width-1,height-1);
  313.               Move(rp,width-1,0); Draw(rp,oldx,oldy); Draw(rp,0,height-1);
  314.             END;
  315.           END;
  316.         END;
  317.         oldx := x; oldy := y;
  318.         QuitMessage := GetMsg(MyPort);
  319.       UNTIL QuitMessage#NIL;
  320.     END;
  321.   END;
  322.  
  323. END Gummi.
  324.