(*$Q*)

MODULE DK; (* DECAY *)

(* A little fun, inspired by Leo Schwab's TILT *)

(* Author: 3/29/87, Thomas H. Handel, PeopleLink ID -- THH -- *)
(* Modifd: 5/29/87, Richard A. DeVenezia, Genie ID -- R.DeVenezia --
                    Added close gadget and command line qualifier (N),
                    removed some redundant statements *)

(* THH: I'm still learning Modula-2 and programming on Amy, so this may
   not be the tidiest or best way to do what the program does.  Also, it
   is probably not the most elegant example of structured programming ever
   created.  Finally, I am certain that there are many enhancements that
   more experienced programmers will be able to add (like maybe a close
   gadget and the wherewithall to respond to it).  Please fiddle at will.
   If you have comments or suggestions, please contact me on
   PeopleLink
      or
   by U.S. Snail at:
   628 Harberts Ct.
   Annapolis, MD 21401

   Thanks in advance. *)

(* Placed in the Public Domain, 29 March 1987 *)

(* RAD: Bad problem with program. When the close gadget is hit
        and the window is closed the linked lists are disposed but not
        all memory is returned to the system for some unknown reason.
        It would be nice if there was some gadget or menu to change N
        while the program is running.
        Also need to clean up workbench screen when done, but that's for
        the future.
*)

FROM SYSTEM IMPORT ADR, BYTE, NULL;
FROM Intuition IMPORT
     NewWindow, WindowPtr, IntuitionName, IntuitionBase,
     WindowFlags, WindowFlagSet,
     IDCMPFlags, IDCMPFlagSet,
     ScreenFlagSet, WBenchScreen, SmartRefresh;
FROM Libraries IMPORT OpenLibrary, CloseLibrary;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM Windows IMPORT OpenWindow, CloseWindow, SetWindowTitles;
FROM Strings IMPORT String;
FROM Pens IMPORT ReadPixel, WritePixel, SetAPen;
FROM GraphicsLibrary IMPORT GraphicsName, GraphicsBase;
FROM Rasters IMPORT RastPortPtr;
FROM RandomNumbers IMPORT Random;
FROM Ports IMPORT MessagePtr, GetMsg, ReplyMsg;
FROM CommandLine IMPORT CLStrings, GetCL;


VAR WPtr: WindowPtr;
    NWin: NewWindow;
    WNam: String;
    RprtPtr: RastPortPtr;


PROCEDURE Initialize(): BOOLEAN;  (* Open the libraries *)

BEGIN
   IntuitionBase := OpenLibrary(IntuitionName,0);
   GraphicsBase := OpenLibrary(GraphicsName,0);
   IF ((IntuitionBase = 0) OR (GraphicsBase = 0))
      THEN RETURN FALSE
      ELSE RETURN TRUE
   END;
END Initialize;


PROCEDURE InitWindow;  (* Set up and open the window *)

BEGIN
   WNam := "DK!";
   WITH NWin DO
      LeftEdge := 425;
      TopEdge := 0;
      Width := 130;
      Height := 10;
      DetailPen := BYTE(0);
      BlockPen := BYTE(1);
      IDCMPFlags := IDCMPFlagSet{CloseWindowFlag};
      Flags := SmartRefresh + WindowFlagSet{Activate, WindowDepth, WindowClose};
      FirstGadget := NULL;
      CheckMark := NULL;
      Title := ADR(WNam);
      Screen := NULL;
      BitMap := NULL;
      MinWidth := 0;
      MinHeight := 0;
      MaxWidth := 0;
      MaxHeight := 0;
      Type := ScreenFlagSet{WBenchScreen};
   END;
   WPtr := OpenWindow (NWin); 
END InitWindow;


PROCEDURE Decay; (* Erode the display *)

   TYPE PixlNodePtr = POINTER TO PixlNode;
        PixlNode = RECORD
                     PClr : CARDINAL; (* Pixel color *)
                     CurX : CARDINAL; (* Current location, X-value *)
                     CurY : CARDINAL; (* Current location, Y-value *)
                     Next : PixlNodePtr; (* Forward pointer *)
                     Prev : PixlNodePtr (* Backward pointer *)
                   END;

   VAR TopEdge   : CARDINAL;  (* Screen top less title bar *)
       Bottom    : CARDINAL;  (* Screen bottom less border *)
       ColCount  : CARDINAL;  (* Number of ColNodes in list *)
       ColHead   : PixlNodePtr; (* Pointer to head of ColNode list *)
       CPtr      : PixlNodePtr; (* Utility pointer for list traversal *)
       PixlCount : CARDINAL;  (* Number of PixlNodes in list *)
       PixlHead  : PixlNodePtr; (* Pointer to head of PixlNode list *)
       PPtr      : PixlNodePtr; (* Utility pointer for list traversal *)
       Depth     : ARRAY [2..637] OF CARDINAL; (* Depth of snow by col *)
       msgptr    : MessagePtr;
       i,N       : CARDINAL;


   PROCEDURE CheckCommandLine; (* Check for > DK n *)

   VAR count : CARDINAL;
       value : ARRAY [1..1] OF CLStrings;
       ok    : BOOLEAN;

   BEGIN
      ok := GetCL (count, value);
      IF count > 0 THEN
         N := ORD (value[1][0]) - 48;
         IF (N < 1) OR (N > 9) THEN N := 1 END;
      ELSE
         N := 1
      END;
      WNam[2] := CHR(48+N);
      SetWindowTitles (WPtr, WNam, "");
   END CheckCommandLine;


   PROCEDURE ComputeParms;  (* Get some basic parameters *)

   BEGIN
      TopEdge := WPtr^.WScreen^.TopEdge + 10;
      Bottom := CARDINAL(WPtr^.WScreen^.Height) + TopEdge - 11;
   END ComputeParms;


   PROCEDURE InitVars;  (* Initialize Variables *)

   VAR I : INTEGER; (* Counter *)

   BEGIN
      FOR I := 2 TO 637 DO
         Depth[I] := 0
      END;
      RprtPtr := ADR(WPtr^.WScreen^.RPort);
      ColCount := 0;
      PixlCount := 0;
      ColHead := NIL;
      PixlHead := NIL
   END InitVars;


   PROCEDURE FindCols;  (* Create list of cols containing non-zero pixls *)
   VAR X    : CARDINAL; (* Column Counter *)
       Y    : CARDINAL; (* Row Counter *)
       Pixl : CARDINAL; (* Pen number of pixel *)

   BEGIN
      FOR X := 2 TO 637 DO
         (* Decay begins a minimum of four pixels from bottom of screen *)
         Y := Bottom - 4;
         LOOP (* Find first non-zero pixel (from bottom) in column X *)
            Pixl := ReadPixel (RprtPtr, X, Y);
            IF Pixl <> 0 THEN
               NEW (CPtr);            (* Create node for list *)
               CPtr^.CurX := X;
               CPtr^.CurY := Y;
               CPtr^.PClr := Pixl;
               CPtr^.Prev := NIL;     (* and link it in at head of list *)
               IF ColHead = NIL THEN
                  CPtr^.Next := NIL
               ELSE
                  CPtr^.Next := ColHead;
                  ColHead^.Prev := CPtr
               END;
               ColHead := CPtr;
               CPtr := NIL;
               INC (ColCount);
               EXIT
            ELSE (* Haven't found that pixel yet *)
               DEC(Y);
               IF Y < TopEdge THEN
                  EXIT (* No non-zero pixels in column X *)
               END
            END (* IF Pixl *)
         END (* LOOP *)
      END; (* FOR *)
   END FindCols;


   PROCEDURE NewPixel;  (* Get a new pixel at random for snowflake ops *)

   VAR RNum : CARDINAL;  (* Random Number *)
       I    : CARDINAL;  (* Counter *)
       Pixl : CARDINAL;  (* Pen number of pixel *)


      PROCEDURE DeleteCol;  (* Remove an empty column from the list *)

      BEGIN
         IF CPtr = ColHead THEN
            ColHead := ColHead^.Next;
            IF CPtr^.Next <> NIL THEN
               ColHead^.Prev := NIL
            END
         ELSE
            CPtr^.Prev^.Next := CPtr^.Next;
            IF CPtr^.Next <> NIL THEN
               CPtr^.Next^.Prev := CPtr^.Prev
            END
         END;
         DISPOSE (CPtr);
         DEC (ColCount);
      END DeleteCol;


   BEGIN  (* NewPixel *)
      CPtr := ColHead;
      (* Pick a random column to get a new snowflake pixel *)
      RNum := Random(ColCount - 1);     (* 0 <= RNum <= [ColCount-1] *)
      WHILE RNum > 0 DO
         CPtr := CPtr^.Next;
         DEC(RNum)
      END;
      NEW (PPtr);
      PPtr^.CurX := CPtr^.CurX;
      PPtr^.CurY := CPtr^.CurY;
      PPtr^.PClr := CPtr^.PClr;
      PPtr^.Prev := NIL;           (* insert new flake at head of list *)
      IF PixlHead = NIL THEN
         PPtr^.Next := NIL
      ELSE
         PPtr^.Next := PixlHead;
         PixlHead^.Prev := PPtr
      END;
      PixlHead := PPtr;
      INC (PixlCount);
   (* Find next pixel up in column *)
      LOOP
         DEC( CPtr^.CurY );
         IF CPtr^.CurY < TopEdge THEN
            DeleteCol;
            EXIT
         ELSE
            Pixl := ReadPixel (RprtPtr, CPtr^.CurX, CPtr^.CurY);
            IF Pixl <> 0 THEN
               CPtr^.PClr := Pixl;
               EXIT 
            END
         END
      END;
   END NewPixel;


   PROCEDURE MovePixels;  (* Make the snow fall *)

   VAR XDest : CARDINAL;  (* Pixel destination, X-value *)
       YDest : CARDINAL;  (* Pixel destination, Y-value *)
       Landed : BOOLEAN; (* Signals pixel ready for deletion from list *)
       LandedRollingRight: BOOLEAN;  (* Direction of snow drift *)


      PROCEDURE DeletePixel;  (* Remove a pixel from the list *)

      VAR tPtr : PixlNodePtr;  (* Utility pointer *)

      BEGIN
         tPtr := PPtr;
         IF PPtr = PixlHead THEN
            PixlHead := PixlHead^.Next;
            IF PPtr^.Next <> NIL THEN
               PixlHead^.Prev := NIL
            END;
            PPtr := PixlHead
         ELSE
            PPtr^.Prev^.Next := PPtr^.Next;
            IF PPtr^.Next <> NIL THEN
               PPtr^.Next^.Prev := PPtr^.Prev
            END;
            PPtr := PPtr^.Next
         END;
         DISPOSE (tPtr);
         DEC (PixlCount);
         Landed := FALSE;
      END DeletePixel;


      PROCEDURE ComputeDest;  (* Compute a random destination for pixel *)

      BEGIN
         XDest := PPtr^.CurX + 8 - Random(16);
         YDest := PPtr^.CurY + Random(13);
         IF XDest <= 2 THEN
            XDest := 3 + Random(5)
         END;
         IF XDest >= 637 THEN
            XDest := 636 - Random(5)
         END;
         IF YDest > Bottom - Depth[XDest] THEN
            YDest := Bottom - Depth[XDest];
            Landed := TRUE
         END;
      END ComputeDest;


      PROCEDURE Drift;  (* Keep the snow from stacking up in tall towers *)
      VAR FlakeRolled : BOOLEAN;  (* Flags change in XDest *)

         PROCEDURE CheckLeft();  (* See if flake should drift left *)
         BEGIN
            IF Depth[XDest] > Depth[XDest-1] THEN
               DEC (XDest);
               IF FlakeRolled THEN (* fix if drifted in CheckRight *)
                  DEC (XDest)
               END;
               FlakeRolled := TRUE
            END
         END CheckLeft;

         PROCEDURE CheckRight();  (* See if flake should drift right *)
         BEGIN
            IF Depth[XDest] > Depth[XDest+1] THEN
               INC (XDest);
               IF FlakeRolled THEN (* fix if drifted in CheckLeft *)
                  INC (XDest)
               END;
               FlakeRolled := TRUE
            END
         END CheckRight;

      BEGIN (* Drift *)
         FlakeRolled := TRUE;
         WHILE FlakeRolled AND (XDest > 2) AND (XDest < 637) DO
            FlakeRolled := FALSE;
            (* Check if flake can roll anymore *)
            IF LandedRollingRight THEN
               CheckLeft;
               CheckRight
            ELSE
               CheckRight;
               CheckLeft
            END;
            YDest := Bottom - Depth[XDest]
         END;
      (* Next time the flake will roll the other way (if possible) *)
         LandedRollingRight := NOT(LandedRollingRight)
      END Drift;


      PROCEDURE MoveOne;  (* Move one pixel to new destination *)

      BEGIN
         SetAPen (RprtPtr, 0);
         WritePixel (RprtPtr, PPtr^.CurX, PPtr^.CurY);
         SetAPen (RprtPtr, PPtr^.PClr);
         WritePixel (RprtPtr, XDest, YDest);
         PPtr^.CurX := XDest;
         PPtr^.CurY := YDest;
      END MoveOne;
 
   BEGIN (* MovePixels *)
      Landed := FALSE;
      LandedRollingRight := TRUE; (* Direction to roll if there's a choice *)
      PPtr := PixlHead;
      WHILE PPtr <> NIL DO           (* While there are still flakes *)
         ComputeDest;                (* Find this one a new destination *)
         IF Landed THEN              (* If it has landed *)
            Drift                    (* See if it should roll R or L *)
         END;
         MoveOne;                    (* Actually move it to new dest *)
         IF Landed THEN              (* If it has landed *)
            INC (Depth[XDest]);      (* increment depth in column *)
            DeletePixel              (* and remove pixel from list *)
         ELSE
            PPtr := PPtr^.Next
         END
      END
   END MovePixels;

BEGIN (* Decay *)
   CheckCommandLine;
   ComputeParms;
   InitVars;
   FindCols;
   REPEAT
      msgptr := GetMsg (WPtr^.UserPort);
      IF msgptr <> NULL THEN
      (* IDCMP has a message for us and it can only be WindowClose *)
         ReplyMsg (MessagePtr(msgptr));
         ColCount := 0;
         PixlCount := 0;
      (* Free up memory in linked lists *)
         PPtr := ColHead;
         WHILE PPtr <> NIL DO
            CPtr := PPtr;
            PPtr := PPtr^.Next;
            DISPOSE (CPtr)
         END;
         PPtr := PixlHead;
         WHILE PPtr <> NIL DO
            CPtr := PPtr;
            PPtr := PPtr^.Next;
            DISPOSE (CPtr)
         END
      END;

      IF ColCount <> 0 THEN
         FOR i := 1 TO N DO
           NewPixel
         END
      END;

      IF PixlCount <> 0 THEN
         MovePixels
      END

   UNTIL (ColCount = 0) AND (PixlCount = 0);
END Decay;


PROCEDURE DanceOff;  (* Clean things up *)

BEGIN
   CloseWindow(WPtr);
   CloseLibrary(GraphicsBase);
   CloseLibrary(IntuitionBase);
END DanceOff;

BEGIN (* DK *)
   IF Initialize() THEN
     InitWindow;
     IF WPtr <> NULL THEN
        Decay
     END;
     DanceOff
   END;
END DK.