IMPLEMENTATION MODULE SpiroDetails;

              (* * * * * * * * * * * * * * * * * * * * * * *)
              (* Various graphics and Intuition-related    *)
              (* routines, plus a few odds and ends.       *)
	      (*                                           *)
	      (* This was coded for the Oxxi M2 compiler,  *)
	      (* but porting it to the TDI compiler should *)
	      (* be trivial.                               *)
	      (*                                           *)
	      (* (c) Copyright 1987 by Steve Faiwiszewski. *)
	      (* This program may be freely distributed,   *)
	      (* but it is not to be sold.                 *)
	      (* Please leave this notice intact.          *)
              (* * * * * * * * * * * * * * * * * * * * * * *)

FROM IntuiCommon IMPORT ReleaseAllocations, InitMenuRec, InitItemRec,
                      InitTextRec, InitBorder, InitReq, AddGadgetToList,
		      AllocateStandardBorder, AllocateReqBorder, RKey;
FROM SYSTEM    IMPORT ADR, ADDRESS, BYTE, TSIZE;
FROM Terminal  IMPORT WriteString, WriteLn;
FROM MathLib0  IMPORT MathTransName, MathTransBase;
FROM Drawing   IMPORT Move, Draw, SetAPen,PolyDraw, SetDrMd, RectFill;
FROM Libraries IMPORT OpenLibrary, CloseLibrary;
FROM Views     IMPORT ColorMap, ColorMapPtr, ViewModesSet, Hires, SetRGB4;
FROM Ports     IMPORT GetMsg, MessagePtr, ReplyMsg, WaitPort;
FROM Rasters   IMPORT SetRast, Jam1, Jam2, Complement, RastPortPtr;
FROM Memory    IMPORT MemReqSet;
FROM Intuition IMPORT Screen, ScreenFlagsSet, ScreenPtr, ScreenFlags, NewScreen,
                      CustomScreen, WindowPtr, OpenWindow, CloseWindow,
		      NewWindow, WindowFlags, WindowFlagsSet, IDCMPFlags,
		      GadgetFlagsSet, GadgetActivationSet, GadgetFlags,
		      GadgetActivation, ReqGadget, BoolGadget,
		      IDCMPFlagsSet, IntuiMessagePtr, IntuiText, IntuiTextPtr,
		      InitRequester, Request, MenuNull, Menu, MenuPtr,
		      MenuItem, AllocRemember, Requester, GadgetPtr,
		      SetMenuStrip, ClearMenuStrip, MENUNUM, ITEMNUM,
		      OpenScreen, CloseScreen;

CONST
    LetterWidth = 8;
    GadHeight = 9;
    OkGadWidth =  LetterWidth * 4;
    ReqHeight = GadHeight * 5;
    AboutReqWidth = LetterWidth * 35;
    AboutReqHeight = GadHeight * 15;
    ReqLeftLoc = (320 - AboutReqWidth) DIV 2;
    ReqTopLoc = (200 - AboutReqHeight) DIV 2;
    OkGadID = 1;
    MenuWidth = 140;

TYPE
   AboutArrayType = RECORD
                        First,
                        Last   : IntuiTextPtr;
                    END;

VAR
   newScr : NewScreen;
   MyScreen : ScreenPtr;
   MyWindow : WindowPtr;
   CurrentColor : CARDINAL;
   MyMenu : Menu;
   MyMenuItems : ARRAY[0..3] OF MenuItem;
   MyMenuText : ARRAY[0..3] OF IntuiText;
   AboutArray : AboutArrayType;
   AboutLines : CARDINAL;
   AboutRequester : Requester;


    (* =============== Various rendering routines ================= *)

PROCEDURE Position(x,y: CARDINAL);
BEGIN
    Move(MyWindow^.RPort^,x,y);
END Position;


PROCEDURE PlotTo(x,y: CARDINAL);
BEGIN
    Draw(MyWindow^.RPort^,x,y);
END PlotTo;

PROCEDURE EraseScreen(ColorReg,W,H : CARDINAL);
BEGIN
    SetAPen(MyWindow^.RPort^,ColorReg);
    RectFill(MyWindow^.RPort^,0,0,W-1,H-1);
    SetAPen(MyWindow^.RPort^,CurrentColor);
END EraseScreen;

PROCEDURE SetColor(ColorReg : CARDINAL);
BEGIN
    CurrentColor := ColorReg;
    SetAPen(MyWindow^.RPort^,ColorReg);
END SetColor;

PROCEDURE ChangeColorReg(ColorReg, red, green, blue : CARDINAL);
BEGIN
    SetRGB4(MyScreen^.ViewPort,ColorReg,red,green,blue);
END ChangeColorReg;

PROCEDURE SetColors (sp : ScreenPtr);
BEGIN
    WITH sp^ DO
      SetRGB4 (ViewPort, 0, 0, 0, 0);
      SetRGB4 (ViewPort, 1, 5, 13, 13);    (* light blue   *)
      SetRGB4 (ViewPort, 2, 6, 5, 10);     (* purple       *)
      SetRGB4 (ViewPort, 3, 14, 3, 0);     (* red          *)
      SetRGB4 (ViewPort, 4, 13, 11, 8);    (* tan          *)
      SetRGB4 (ViewPort, 5, 5, 13, 0);     (* green        *)
      SetRGB4 (ViewPort, 6, 15, 9, 7);     (* peach        *)
      SetRGB4 (ViewPort, 7, 15, 15,15);    (* white        *)
      SetRGB4 (ViewPort, 8, 12, 0, 14);    (* lavender     *)
    END
END SetColors;

    (* =============== Miscellaneous routines ================= *)

PROCEDURE OpenLibs;
BEGIN
    MathTransBase := OpenLibrary(ADR(MathTransName), 0D);
    IF MathTransBase = NIL THEN
	CleanUp('Could not open MathTrans library!',0)
    END;
END OpenLibs;

PROCEDURE CleanUp(line : ARRAY OF CHAR; n : CARDINAL);
BEGIN
    IF n > 2 THEN ClearMenuStrip(MyWindow^); CloseWindow(MyWindow^) END;
    IF n > 1 THEN CloseScreen(MyScreen^) END;
    IF n > 0 THEN CloseLibrary(MathTransBase^) END;
    ReleaseAllocations;
    WriteString(line); WriteLn;
    HALT;
END CleanUp;


    (* =============== Intuition related routines ================= *)

PROCEDURE OpenMyScreen(W,H,D : CARDINAL);
BEGIN
    WITH newScr DO        (* Setup the Intuition screen *)
	LeftEdge := 0; TopEdge := 0;
	Width := W ; Height := H; Depth := D;
	DetailPen := BYTE(0); BlockPen := BYTE(1);
	IF W > 320 THEN
	    ViewModes := ViewModesSet{Hires};
	ELSE
	    ViewModes := ViewModesSet{};
	END;
	Font := NIL;
	DefaultTitle := ADR('Spirograph 1.0 © Steve Faiwiszewski');
	Gadgets := NIL;
	CustomBitMap := NIL;
    END;
    newScr.Type := CustomScreen;
    MyScreen := ScreenPtr(OpenScreen(newScr));
    IF MyScreen = NIL THEN
        CleanUp('Could not open screen!',1);
    END;
    SetColors(MyScreen);
END OpenMyScreen;

PROCEDURE InitMenus(VAR MenuStrip : MenuPtr);
BEGIN
    MenuStrip := InitMenuRec(MyMenu,3,0,78,10,ADR(" Action"));

    MyMenu.FirstItem :=
      InitItemRec(MyMenuItems[0],0,0,MenuWidth,10,'A',
        InitTextRec(MyMenuText[0],0,1,BYTE(0),BYTE(1),Jam2,ADR("About...")));

    MyMenuItems[0].NextItem :=
      InitItemRec(MyMenuItems[1],0,10,MenuWidth,10,'N',
        InitTextRec(MyMenuText[1],0,1,BYTE(0),BYTE(1),Jam2,ADR("Next Pattern")));

    MyMenuItems[1].NextItem :=
      InitItemRec(MyMenuItems[2],0,20,MenuWidth,10,'P',
        InitTextRec(MyMenuText[2],0,1,BYTE(0),BYTE(1),Jam2,ADR("Prev Pattern")));

    MyMenuItems[2].NextItem :=
      InitItemRec(MyMenuItems[3],0,30,MenuWidth,10,'Q',
        InitTextRec(MyMenuText[3],0,1,BYTE(0),BYTE(1),Jam2,ADR("Quit")));

END InitMenus;

PROCEDURE OpenMyWindow(W,H,D : CARDINAL);
VAR
    MyNewWindow : NewWindow;
    MenuStrip : MenuPtr;
BEGIN
    WITH MyNewWindow DO
	LeftEdge := 0;  TopEdge := 0;
	Height := H;
	Width := W;
	DetailPen := BYTE (0);
	BlockPen := BYTE (1);
	Title := NIL; (* ADR('Spirograph by Steve Faiwiszewski'); *)
	Flags := WindowFlagsSet{Activate,Borderless,BackDrop};
	IDCMPFlags := IDCMPFlagsSet{MenuPick,ReqClear};
	Type := CustomScreen;
	CheckMark := NIL;
	FirstGadget := NIL;
	Screen := MyScreen;
	BitMap := NIL;
	MinWidth := 0; MinHeight := 0;
	MaxWidth := 0; MaxHeight := 0;
    END;
    (* Now open the window *)
    MyWindow := OpenWindow(MyNewWindow);
    IF MyWindow = NIL THEN
        CleanUp('Could not open window!',2)
    END;
    InitMenus(MenuStrip);
    SetMenuStrip(MyWindow^,MenuStrip^);
END OpenMyWindow;

PROCEDURE PrepareAboutRequester;
VAR
    tp  : IntuiTextPtr;
    AboutGadList,
    tmp : GadgetPtr;
BEGIN
    AboutGadList := NIL;
    tp := AllocRemember(RKey, TSIZE(IntuiText), MemReqSet{});
    tmp := AddGadgetToList(AboutGadList,
                 -(AboutReqWidth DIV 2 + OkGadWidth DIV 2),-15,
                 OkGadWidth+1,
                 GadHeight, GadgetFlagsSet{GRelBottom,GRelRight},
                 GadgetActivationSet{EndGadget,RelVerify},
                 ReqGadget + BoolGadget,
                 AllocateStandardBorder(OkGadWidth+1,GadHeight,
                          BYTE(2),BYTE(0),Jam2),
                 NIL, NIL, OkGadID ,NIL,
                 InitTextRec(tp^,1,1,BYTE(2),BYTE(1),Jam1,ADR("Okay")));
    InitReq(AboutRequester,ReqLeftLoc,ReqTopLoc,AboutReqWidth,AboutReqHeight,
       AboutGadList,
       AllocateReqBorder(AboutReqWidth,AboutReqHeight, BYTE(3),BYTE(1),Jam1),
       NIL,BYTE(7));
END PrepareAboutRequester;

PROCEDURE AddToAboutText(line : ADDRESS);
VAR
    dummy,
    tp  : IntuiTextPtr;
BEGIN
    INC(AboutLines);
    tp := AllocRemember(RKey, TSIZE(IntuiText), MemReqSet{});
    WITH AboutArray DO
        IF Last<>NIL THEN Last^.NextText := tp END;
        Last := InitTextRec(tp^,3,(AboutLines*9),BYTE(0),BYTE(1),Jam1,
                                line);
        IF First = NIL THEN First := Last END;
    END;
END AddToAboutText;

PROCEDURE WaitForRequesterResponse;
VAR
    ok : BOOLEAN;
    class : IDCMPFlagsSet;
    NewMsg : IntuiMessagePtr;
BEGIN
    ok := FALSE;
    REPEAT        
        NewMsg := WaitPort(MyWindow^.UserPort^); 
        NewMsg := GetMsg(MyWindow^.UserPort^);
        IF NewMsg <> NIL THEN
            class := NewMsg^.Class;
            ReplyMsg(MessagePtr(NewMsg));
            ok := ReqClear IN class;
        END
    UNTIL ok;
END WaitForRequesterResponse;

PROCEDURE ShowAbout;
VAR
    suc : BOOLEAN;
    i   : CARDINAL;
    gad : GadgetPtr;
BEGIN
    AboutRequester.ReqText := AboutArray.First;
    suc := Request(AboutRequester,MyWindow^);
    IF suc THEN
        WaitForRequesterResponse;
    ELSE
        WriteString('ShowAbout: Ooops! Could not open requester!'); WriteLn
    END;
END ShowAbout;


PROCEDURE ProcessMenus(MenuNum : CARDINAL;
                       VAR Quit, NextPattern, PrevPattern : BOOLEAN);
VAR
    item : CARDINAL;
BEGIN
    IF MENUNUM(MenuNum) = 0 THEN
        item := ITEMNUM(MenuNum);
        IF item = 0 THEN
	    ShowAbout;
        ELSIF item = 1 THEN
	    NextPattern := TRUE
        ELSIF item = 2 THEN
	    PrevPattern := TRUE
        ELSE
            Quit := TRUE
	END;
    END;
END ProcessMenus;

PROCEDURE GetMessages(VAR Done, NextPattern,PrevPattern : BOOLEAN);
VAR
    mp     : MessagePtr;
    imp    : IntuiMessagePtr; 
    class  : IDCMPFlagsSet;
    code : CARDINAL;
BEGIN
    NextPattern := FALSE;
    PrevPattern := FALSE;
    mp := GetMsg(MyWindow^.UserPort^);
    WHILE mp <> NIL DO
        imp := IntuiMessagePtr(mp);
        class := imp^.Class;
        code := imp^.Code;
        ReplyMsg(mp);
        IF MenuPick IN class THEN
            IF code <> MenuNull THEN
	        ProcessMenus(code,Done,NextPattern,PrevPattern)
	    END;
        END;
        mp := GetMsg(MyWindow^.UserPort^);
    END;
END GetMessages;

BEGIN
    WITH AboutArray DO
        First := NIL;
        Last  := NIL;
    END;
    AboutLines := 0;
    PrepareAboutRequester;
END SpiroDetails.