home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 079.lha / SpiroGraph / SpiroDetails.Mod < prev    next >
Encoding:
Modula Implementation  |  1986-11-20  |  10.2 KB  |  341 lines
  1. IMPLEMENTATION MODULE SpiroDetails;
  2.  
  3.               (* * * * * * * * * * * * * * * * * * * * * * *)
  4.               (* Various graphics and Intuition-related    *)
  5.               (* routines, plus a few odds and ends.       *)
  6.           (*                                           *)
  7.           (* This was coded for the Oxxi M2 compiler,  *)
  8.           (* but porting it to the TDI compiler should *)
  9.           (* be trivial.                               *)
  10.           (*                                           *)
  11.           (* (c) Copyright 1987 by Steve Faiwiszewski. *)
  12.           (* This program may be freely distributed,   *)
  13.           (* but it is not to be sold.                 *)
  14.           (* Please leave this notice intact.          *)
  15.               (* * * * * * * * * * * * * * * * * * * * * * *)
  16.  
  17. FROM IntuiCommon IMPORT ReleaseAllocations, InitMenuRec, InitItemRec,
  18.                       InitTextRec, InitBorder, InitReq, AddGadgetToList,
  19.               AllocateStandardBorder, AllocateReqBorder, RKey;
  20. FROM SYSTEM    IMPORT ADR, ADDRESS, BYTE, TSIZE;
  21. FROM Terminal  IMPORT WriteString, WriteLn;
  22. FROM MathLib0  IMPORT MathTransName, MathTransBase;
  23. FROM Drawing   IMPORT Move, Draw, SetAPen,PolyDraw, SetDrMd, RectFill;
  24. FROM Libraries IMPORT OpenLibrary, CloseLibrary;
  25. FROM Views     IMPORT ColorMap, ColorMapPtr, ViewModesSet, Hires, SetRGB4;
  26. FROM Ports     IMPORT GetMsg, MessagePtr, ReplyMsg, WaitPort;
  27. FROM Rasters   IMPORT SetRast, Jam1, Jam2, Complement, RastPortPtr;
  28. FROM Memory    IMPORT MemReqSet;
  29. FROM Intuition IMPORT Screen, ScreenFlagsSet, ScreenPtr, ScreenFlags, NewScreen,
  30.                       CustomScreen, WindowPtr, OpenWindow, CloseWindow,
  31.               NewWindow, WindowFlags, WindowFlagsSet, IDCMPFlags,
  32.               GadgetFlagsSet, GadgetActivationSet, GadgetFlags,
  33.               GadgetActivation, ReqGadget, BoolGadget,
  34.               IDCMPFlagsSet, IntuiMessagePtr, IntuiText, IntuiTextPtr,
  35.               InitRequester, Request, MenuNull, Menu, MenuPtr,
  36.               MenuItem, AllocRemember, Requester, GadgetPtr,
  37.               SetMenuStrip, ClearMenuStrip, MENUNUM, ITEMNUM,
  38.               OpenScreen, CloseScreen;
  39.  
  40. CONST
  41.     LetterWidth = 8;
  42.     GadHeight = 9;
  43.     OkGadWidth =  LetterWidth * 4;
  44.     ReqHeight = GadHeight * 5;
  45.     AboutReqWidth = LetterWidth * 35;
  46.     AboutReqHeight = GadHeight * 15;
  47.     ReqLeftLoc = (320 - AboutReqWidth) DIV 2;
  48.     ReqTopLoc = (200 - AboutReqHeight) DIV 2;
  49.     OkGadID = 1;
  50.     MenuWidth = 140;
  51.  
  52. TYPE
  53.    AboutArrayType = RECORD
  54.                         First,
  55.                         Last   : IntuiTextPtr;
  56.                     END;
  57.  
  58. VAR
  59.    newScr : NewScreen;
  60.    MyScreen : ScreenPtr;
  61.    MyWindow : WindowPtr;
  62.    CurrentColor : CARDINAL;
  63.    MyMenu : Menu;
  64.    MyMenuItems : ARRAY[0..3] OF MenuItem;
  65.    MyMenuText : ARRAY[0..3] OF IntuiText;
  66.    AboutArray : AboutArrayType;
  67.    AboutLines : CARDINAL;
  68.    AboutRequester : Requester;
  69.  
  70.  
  71.     (* =============== Various rendering routines ================= *)
  72.  
  73. PROCEDURE Position(x,y: CARDINAL);
  74. BEGIN
  75.     Move(MyWindow^.RPort^,x,y);
  76. END Position;
  77.  
  78.  
  79. PROCEDURE PlotTo(x,y: CARDINAL);
  80. BEGIN
  81.     Draw(MyWindow^.RPort^,x,y);
  82. END PlotTo;
  83.  
  84. PROCEDURE EraseScreen(ColorReg,W,H : CARDINAL);
  85. BEGIN
  86.     SetAPen(MyWindow^.RPort^,ColorReg);
  87.     RectFill(MyWindow^.RPort^,0,0,W-1,H-1);
  88.     SetAPen(MyWindow^.RPort^,CurrentColor);
  89. END EraseScreen;
  90.  
  91. PROCEDURE SetColor(ColorReg : CARDINAL);
  92. BEGIN
  93.     CurrentColor := ColorReg;
  94.     SetAPen(MyWindow^.RPort^,ColorReg);
  95. END SetColor;
  96.  
  97. PROCEDURE ChangeColorReg(ColorReg, red, green, blue : CARDINAL);
  98. BEGIN
  99.     SetRGB4(MyScreen^.ViewPort,ColorReg,red,green,blue);
  100. END ChangeColorReg;
  101.  
  102. PROCEDURE SetColors (sp : ScreenPtr);
  103. BEGIN
  104.     WITH sp^ DO
  105.       SetRGB4 (ViewPort, 0, 0, 0, 0);
  106.       SetRGB4 (ViewPort, 1, 5, 13, 13);    (* light blue   *)
  107.       SetRGB4 (ViewPort, 2, 6, 5, 10);     (* purple       *)
  108.       SetRGB4 (ViewPort, 3, 14, 3, 0);     (* red          *)
  109.       SetRGB4 (ViewPort, 4, 13, 11, 8);    (* tan          *)
  110.       SetRGB4 (ViewPort, 5, 5, 13, 0);     (* green        *)
  111.       SetRGB4 (ViewPort, 6, 15, 9, 7);     (* peach        *)
  112.       SetRGB4 (ViewPort, 7, 15, 15,15);    (* white        *)
  113.       SetRGB4 (ViewPort, 8, 12, 0, 14);    (* lavender     *)
  114.     END
  115. END SetColors;
  116.  
  117.     (* =============== Miscellaneous routines ================= *)
  118.  
  119. PROCEDURE OpenLibs;
  120. BEGIN
  121.     MathTransBase := OpenLibrary(ADR(MathTransName), 0D);
  122.     IF MathTransBase = NIL THEN
  123.     CleanUp('Could not open MathTrans library!',0)
  124.     END;
  125. END OpenLibs;
  126.  
  127. PROCEDURE CleanUp(line : ARRAY OF CHAR; n : CARDINAL);
  128. BEGIN
  129.     IF n > 2 THEN ClearMenuStrip(MyWindow^); CloseWindow(MyWindow^) END;
  130.     IF n > 1 THEN CloseScreen(MyScreen^) END;
  131.     IF n > 0 THEN CloseLibrary(MathTransBase^) END;
  132.     ReleaseAllocations;
  133.     WriteString(line); WriteLn;
  134.     HALT;
  135. END CleanUp;
  136.  
  137.  
  138.     (* =============== Intuition related routines ================= *)
  139.  
  140. PROCEDURE OpenMyScreen(W,H,D : CARDINAL);
  141. BEGIN
  142.     WITH newScr DO        (* Setup the Intuition screen *)
  143.     LeftEdge := 0; TopEdge := 0;
  144.     Width := W ; Height := H; Depth := D;
  145.     DetailPen := BYTE(0); BlockPen := BYTE(1);
  146.     IF W > 320 THEN
  147.         ViewModes := ViewModesSet{Hires};
  148.     ELSE
  149.         ViewModes := ViewModesSet{};
  150.     END;
  151.     Font := NIL;
  152.     DefaultTitle := ADR('Spirograph 1.0 © Steve Faiwiszewski');
  153.     Gadgets := NIL;
  154.     CustomBitMap := NIL;
  155.     END;
  156.     newScr.Type := CustomScreen;
  157.     MyScreen := ScreenPtr(OpenScreen(newScr));
  158.     IF MyScreen = NIL THEN
  159.         CleanUp('Could not open screen!',1);
  160.     END;
  161.     SetColors(MyScreen);
  162. END OpenMyScreen;
  163.  
  164. PROCEDURE InitMenus(VAR MenuStrip : MenuPtr);
  165. BEGIN
  166.     MenuStrip := InitMenuRec(MyMenu,3,0,78,10,ADR(" Action"));
  167.  
  168.     MyMenu.FirstItem :=
  169.       InitItemRec(MyMenuItems[0],0,0,MenuWidth,10,'A',
  170.         InitTextRec(MyMenuText[0],0,1,BYTE(0),BYTE(1),Jam2,ADR("About...")));
  171.  
  172.     MyMenuItems[0].NextItem :=
  173.       InitItemRec(MyMenuItems[1],0,10,MenuWidth,10,'N',
  174.         InitTextRec(MyMenuText[1],0,1,BYTE(0),BYTE(1),Jam2,ADR("Next Pattern")));
  175.  
  176.     MyMenuItems[1].NextItem :=
  177.       InitItemRec(MyMenuItems[2],0,20,MenuWidth,10,'P',
  178.         InitTextRec(MyMenuText[2],0,1,BYTE(0),BYTE(1),Jam2,ADR("Prev Pattern")));
  179.  
  180.     MyMenuItems[2].NextItem :=
  181.       InitItemRec(MyMenuItems[3],0,30,MenuWidth,10,'Q',
  182.         InitTextRec(MyMenuText[3],0,1,BYTE(0),BYTE(1),Jam2,ADR("Quit")));
  183.  
  184. END InitMenus;
  185.  
  186. PROCEDURE OpenMyWindow(W,H,D : CARDINAL);
  187. VAR
  188.     MyNewWindow : NewWindow;
  189.     MenuStrip : MenuPtr;
  190. BEGIN
  191.     WITH MyNewWindow DO
  192.     LeftEdge := 0;  TopEdge := 0;
  193.     Height := H;
  194.     Width := W;
  195.     DetailPen := BYTE (0);
  196.     BlockPen := BYTE (1);
  197.     Title := NIL; (* ADR('Spirograph by Steve Faiwiszewski'); *)
  198.     Flags := WindowFlagsSet{Activate,Borderless,BackDrop};
  199.     IDCMPFlags := IDCMPFlagsSet{MenuPick,ReqClear};
  200.     Type := CustomScreen;
  201.     CheckMark := NIL;
  202.     FirstGadget := NIL;
  203.     Screen := MyScreen;
  204.     BitMap := NIL;
  205.     MinWidth := 0; MinHeight := 0;
  206.     MaxWidth := 0; MaxHeight := 0;
  207.     END;
  208.     (* Now open the window *)
  209.     MyWindow := OpenWindow(MyNewWindow);
  210.     IF MyWindow = NIL THEN
  211.         CleanUp('Could not open window!',2)
  212.     END;
  213.     InitMenus(MenuStrip);
  214.     SetMenuStrip(MyWindow^,MenuStrip^);
  215. END OpenMyWindow;
  216.  
  217. PROCEDURE PrepareAboutRequester;
  218. VAR
  219.     tp  : IntuiTextPtr;
  220.     AboutGadList,
  221.     tmp : GadgetPtr;
  222. BEGIN
  223.     AboutGadList := NIL;
  224.     tp := AllocRemember(RKey, TSIZE(IntuiText), MemReqSet{});
  225.     tmp := AddGadgetToList(AboutGadList,
  226.                  -(AboutReqWidth DIV 2 + OkGadWidth DIV 2),-15,
  227.                  OkGadWidth+1,
  228.                  GadHeight, GadgetFlagsSet{GRelBottom,GRelRight},
  229.                  GadgetActivationSet{EndGadget,RelVerify},
  230.                  ReqGadget + BoolGadget,
  231.                  AllocateStandardBorder(OkGadWidth+1,GadHeight,
  232.                           BYTE(2),BYTE(0),Jam2),
  233.                  NIL, NIL, OkGadID ,NIL,
  234.                  InitTextRec(tp^,1,1,BYTE(2),BYTE(1),Jam1,ADR("Okay")));
  235.     InitReq(AboutRequester,ReqLeftLoc,ReqTopLoc,AboutReqWidth,AboutReqHeight,
  236.        AboutGadList,
  237.        AllocateReqBorder(AboutReqWidth,AboutReqHeight, BYTE(3),BYTE(1),Jam1),
  238.        NIL,BYTE(7));
  239. END PrepareAboutRequester;
  240.  
  241. PROCEDURE AddToAboutText(line : ADDRESS);
  242. VAR
  243.     dummy,
  244.     tp  : IntuiTextPtr;
  245. BEGIN
  246.     INC(AboutLines);
  247.     tp := AllocRemember(RKey, TSIZE(IntuiText), MemReqSet{});
  248.     WITH AboutArray DO
  249.         IF Last<>NIL THEN Last^.NextText := tp END;
  250.         Last := InitTextRec(tp^,3,(AboutLines*9),BYTE(0),BYTE(1),Jam1,
  251.                                 line);
  252.         IF First = NIL THEN First := Last END;
  253.     END;
  254. END AddToAboutText;
  255.  
  256. PROCEDURE WaitForRequesterResponse;
  257. VAR
  258.     ok : BOOLEAN;
  259.     class : IDCMPFlagsSet;
  260.     NewMsg : IntuiMessagePtr;
  261. BEGIN
  262.     ok := FALSE;
  263.     REPEAT        
  264.         NewMsg := WaitPort(MyWindow^.UserPort^); 
  265.         NewMsg := GetMsg(MyWindow^.UserPort^);
  266.         IF NewMsg <> NIL THEN
  267.             class := NewMsg^.Class;
  268.             ReplyMsg(MessagePtr(NewMsg));
  269.             ok := ReqClear IN class;
  270.         END
  271.     UNTIL ok;
  272. END WaitForRequesterResponse;
  273.  
  274. PROCEDURE ShowAbout;
  275. VAR
  276.     suc : BOOLEAN;
  277.     i   : CARDINAL;
  278.     gad : GadgetPtr;
  279. BEGIN
  280.     AboutRequester.ReqText := AboutArray.First;
  281.     suc := Request(AboutRequester,MyWindow^);
  282.     IF suc THEN
  283.         WaitForRequesterResponse;
  284.     ELSE
  285.         WriteString('ShowAbout: Ooops! Could not open requester!'); WriteLn
  286.     END;
  287. END ShowAbout;
  288.  
  289.  
  290. PROCEDURE ProcessMenus(MenuNum : CARDINAL;
  291.                        VAR Quit, NextPattern, PrevPattern : BOOLEAN);
  292. VAR
  293.     item : CARDINAL;
  294. BEGIN
  295.     IF MENUNUM(MenuNum) = 0 THEN
  296.         item := ITEMNUM(MenuNum);
  297.         IF item = 0 THEN
  298.         ShowAbout;
  299.         ELSIF item = 1 THEN
  300.         NextPattern := TRUE
  301.         ELSIF item = 2 THEN
  302.         PrevPattern := TRUE
  303.         ELSE
  304.             Quit := TRUE
  305.     END;
  306.     END;
  307. END ProcessMenus;
  308.  
  309. PROCEDURE GetMessages(VAR Done, NextPattern,PrevPattern : BOOLEAN);
  310. VAR
  311.     mp     : MessagePtr;
  312.     imp    : IntuiMessagePtr; 
  313.     class  : IDCMPFlagsSet;
  314.     code : CARDINAL;
  315. BEGIN
  316.     NextPattern := FALSE;
  317.     PrevPattern := FALSE;
  318.     mp := GetMsg(MyWindow^.UserPort^);
  319.     WHILE mp <> NIL DO
  320.         imp := IntuiMessagePtr(mp);
  321.         class := imp^.Class;
  322.         code := imp^.Code;
  323.         ReplyMsg(mp);
  324.         IF MenuPick IN class THEN
  325.             IF code <> MenuNull THEN
  326.             ProcessMenus(code,Done,NextPattern,PrevPattern)
  327.         END;
  328.         END;
  329.         mp := GetMsg(MyWindow^.UserPort^);
  330.     END;
  331. END GetMessages;
  332.  
  333. BEGIN
  334.     WITH AboutArray DO
  335.         First := NIL;
  336.         Last  := NIL;
  337.     END;
  338.     AboutLines := 0;
  339.     PrepareAboutRequester;
  340. END SpiroDetails.
  341.