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

   Author: Thomas H. Handel, PeopleLink ID -- 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       *)


MODULE Snow;
(******************************************************************************)
(*                                                                            *)
(*  Programm:  S N O W                Version:            1.00                *)
(*                                                                            *)
(*  Datum:     24.01.1988             angepasst von:      Ing. Gerd Platl     *)
(*                                                                            *)
(*  Hardware:  Commodore AMIGA 1000   Betriebssystem:     AMIGA-DOS V 1.2     *)
(*                                                                            *)
(*  Sprache:   ETH MODULA-2           Entwicklungssystem: M2AMIGA, AMSoft     *)
(*                                                                            *)
(*  Compiler:  M2C V 3.1d             Linker:             M2L V 3.1d          *)
(*                                                                            *)
(*  Adaptiert auf 3.2 von Amsoft                                              *)
(*                                                                            *)
(*                                                                            *)
(*  Anmerkung: Diese Programm stammt von der FISH-Disk 69 und wurde           *)
(*             urspruenglich in TDI Modula-2 geschrieben. Diese Version ist   *)
(*             etwas komprimierter und ein wenig beschleunigt worden.         *)
(*                                                                            *)
(*  Inhalt:    Die Bildpunkte des aktuellen Bildes fallen als Schneeflocken   *)
(*             an den unteren Bildschirmrand und bilden dort Schneehaufen.    *)
(*                                                                            *)
(******************************************************************************)
(* $F- Funktionswertrueckgabekontrolle *)
(* $N- Bezeichnerkontrolle globaler Prozedurparameter *)
(* $R- Subrange- und Feldindexueberwachung *)
(* $S- Stackueberlaufskontrolle *)
(* $V- Ueber- und Unterlaufskontrolle *)

(*---------------------- Import aus Standardbibliothek -----------------------*)

FROM  Heap         IMPORT Allocate, Deallocate, Available;
(*FROM  InOut        IMPORT WriteString, WriteCard, WriteInt, WriteLn;*)
FROM  RandomNumber IMPORT RND;
FROM  SYSTEM       IMPORT ADR;
FROM  Arts         IMPORT Assert, TermProcedure;

(*---------------------- Import aus AMIGA-Bibliothek -------------------------*)

FROM  Intuition    IMPORT NewWindow, WindowPtr,
                          IntuitionBase, IntuiMessagePtr,
                          WindowFlags, WindowFlagSet,
                          IDCMPFlags, IDCMPFlagSet,
                          ScreenFlags, ScreenFlagSet,
                          OpenWindow, CloseWindow;
FROM  Graphics     IMPORT ReadPixel, WritePixel, SetAPen, RastPortPtr;
FROM  Exec         IMPORT GetMsg, ReplyMsg, MessagePtr;

(*---------------------- globale Definitionen --------------------------------*)

CONST maxX = 639;

VAR   NWin: NewWindow;
      WPtr: WindowPtr;
      RPortPtr: RastPortPtr;
      MsgPtr : IntuiMessagePtr;

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

BEGIN
  WITH NWin DO
    leftEdge := 450;
    topEdge := 0;
    width := 120;
    height := 10;
    detailPen := 0;
    blockPen := 1;
    idcmpFlags := IDCMPFlagSet {closeWindow};
    flags := WindowFlagSet {windowDrag, windowDepth, windowClose, activate};
    firstGadget := NIL;
    checkMark := NIL;
    title := ADR ("Snow");
    screen := NIL;
    bitMap := NIL;
    minWidth := 0;
    minHeight := 0;
    maxWidth := 0;
    maxHeight := 0;
    type := ScreenFlagSet {wbenchScreen};
  END;
  WPtr := OpenWindow (NWin);
  Assert (WPtr # NIL, ADR ("can't open screen"));
END InitWindow;

(******************************************************************************)
PROCEDURE Decay; (* Erode the display *)

TYPE ColNodePtr = POINTER TO ColNode;
     ColNode = RECORD
                 Col  : CARDINAL;   (* X-value of column *)
                 Row  : CARDINAL;   (* Y-value of next non-zero pixel *)
                 PClr : CARDINAL;   (* Pixel Pen number *)
                 Next : ColNodePtr; (* Forward pointer *)
                 Prev : ColNodePtr; (* Backward pointer *)
               END;
      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 ScrnTop   : CARDINAL;    (* Screen top *)
    TopEdge   : CARDINAL;    (* Screen top less title bar *)
    Bottom    : CARDINAL;    (* Screen bottom less border *)
    YStrt     : CARDINAL;    (* Four pixels above bottom *)
    ColCount  : CARDINAL;    (* Number of ColNodes in list *)
    ColHead   : ColNodePtr;  (* Pointer to head of ColNode list *)
    CPtr      : ColNodePtr;  (* 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 [0..maxX] OF CARDINAL; (* Depth of snow by col *)



  PROCEDURE InitVars;  (* Initialize Variables *)

  VAR x: CARDINAL;

  BEGIN
    ScrnTop := WPtr^.wScreen^.topEdge;
    TopEdge := ScrnTop + 10;
    Bottom := CARDINAL(WPtr^.wScreen^.height) + ScrnTop - 1;
    YStrt := Bottom - 4;
    RPortPtr := ADR (WPtr^.wScreen^.rastPort);

    FOR x := 0 TO maxX DO   Depth[x] := 0;   END;
    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 := 0 TO maxX DO
       Y := YStrt;
       Pixl := 0;
       WHILE (Y > TopEdge) AND (Pixl = 0) DO
         Pixl := ReadPixel(RPortPtr,X,Y);
         IF Pixl = 0
         THEN DEC (Y);
         ELSE
           INC (ColCount);
           Allocate (CPtr, SIZE(ColNode));     (* Create node for list *)
           CPtr^.Col := X;
           CPtr^.Row := Y;
           CPtr^.PClr := Pixl;
           CPtr^.Prev := NIL;
           IF ColHead = NIL THEN  (* and link it in at head of list *)
             CPtr^.Next := NIL;
           ELSE
             CPtr^.Next := ColHead;
             ColHead^.Prev := CPtr;
           END;
           ColHead := CPtr;
           CPtr := NIL;
         END;
       END;   (* WHILE *)
     END;
   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
        IF CPtr^.Next # NIL THEN
          ColHead := ColHead^.Next;
          ColHead^.Prev := NIL;
        ELSE
          ColHead := NIL;
        END
      ELSE
        IF CPtr^.Next = NIL THEN
          CPtr^.Prev^.Next := NIL;
        ELSE
          CPtr^.Prev^.Next := CPtr^.Next;
          CPtr^.Next^.Prev := CPtr^.Prev;
        END
      END;
      Deallocate (CPtr);                (* DISPOSE *)
      DEC (ColCount);
    END DeleteCol;


  BEGIN  (* NewPixel *)
    RNum := RND(ColCount - 1);   (* 0 <= RNum < ColCount-1 *)
    CPtr := ColHead;
    IF RNum > 0 THEN
      FOR I := 0 TO RNum DO
        CPtr := CPtr^.Next;
      END;
    END;
    Allocate (PPtr,SIZE(PixlNode));   (* NEW *)
    PPtr^.PClr := CPtr^.PClr;
    PPtr^.CurX := CPtr^.Col;
    PPtr^.CurY := CPtr^.Row;
    PPtr^.Prev := NIL;
    IF PixlHead = NIL THEN
      PPtr^.Next := NIL;
    ELSE
      PPtr^.Next := PixlHead;
      PixlHead^.Prev := PPtr;
    END;
    PixlHead := PPtr;
    INC (PixlCount);
    LOOP
      DEC (CPtr^.Row);
      IF CPtr^.Row <= TopEdge THEN
        DeleteCol;
        EXIT;
      ELSE
        Pixl := ReadPixel(RPortPtr,CPtr^.Col,CPtr^.Row);
        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 *)
      DFlag : BOOLEAN;   (* Signals pixel ready for deletion from list *)
      RLFlag: 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
        IF PPtr^.Next # NIL THEN
          PixlHead := PixlHead^.Next;
          PixlHead^.Prev := NIL;
        ELSE
          PixlHead := NIL
        END;
        tPtr := PPtr;
        PPtr := PixlHead;
      ELSE
        IF PPtr^.Next = NIL THEN
          PPtr^.Prev^.Next := NIL;
        ELSE
          PPtr^.Prev^.Next := PPtr^.Next;
          PPtr^.Next^.Prev := PPtr^.Prev
        END;
        tPtr := PPtr;
        PPtr := PPtr^.Prev;
      END;
      Deallocate (tPtr);                (* DISPOSE *)
      DEC (PixlCount);
      DFlag := FALSE;
    END DeletePixel;


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

    VAR x: INTEGER;

    BEGIN
      x := INTEGER (PPtr^.CurX) + 8 - RND(16);
      YDest := PPtr^.CurY + CARDINAL (RND(13));
      IF x <= 0
        THEN x := 3 + RND(5);   END;
      IF x >= maxX
        THEN x := maxX - RND(5);   END;
      XDest := CARDINAL (x);
      IF YDest > Bottom - Depth[x]
      THEN
        YDest := Bottom - Depth[x];
        DFlag := TRUE;
      END;
    END ComputeDest;


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


      PROCEDURE CheckLeft;  (* See if flake should drift left *)

      BEGIN
        IF Depth[XDest] > Depth[XDest - 1] THEN
          DEC (XDest);
          ChgFlag := TRUE;
        END
      END CheckLeft;


      PROCEDURE CheckRight;  (* See if flake should drift right *)

      BEGIN
        IF Depth[XDest] > Depth[XDest + 1] THEN
          INC(XDest);
          ChgFlag := TRUE;
        END
      END CheckRight;


    BEGIN (* Drift *)
      ChgFlag := TRUE;
      WHILE (XDest > 0) AND (XDest < maxX) AND (ChgFlag) DO
        ChgFlag := FALSE;
        IF RLFlag THEN
          CheckLeft;
          CheckRight;
        ELSE
          CheckRight;
          CheckLeft;
        END;
        YDest := Bottom - Depth[XDest];
      END;
      RLFlag := NOT(RLFlag);
    END Drift;


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

    VAR wp: BOOLEAN;

    BEGIN
      WITH PPtr^ DO
        SetAPen (RPortPtr, 0);
        wp := WritePixel (RPortPtr, CurX, CurY);
        SetAPen (RPortPtr, PClr);
        wp := WritePixel (RPortPtr, XDest, YDest);
        CurX := XDest;
        CurY := YDest;
      END;
    END MoveOne;


  BEGIN (* MovePixels *)
    RLFlag := TRUE;
    DFlag := FALSE;
    PPtr := PixlHead;
    WHILE PPtr # NIL DO           (* While there are still flakes *)
      ComputeDest;                (* Find this one a new destination *)
      IF DFlag                    (* If it has landed *)
      THEN Drift; END;            (* See if it should roll R or L *)
      MoveOne;                    (* Actually move it to new dest *)
      IF DFlag THEN               (* If it has landed *)
        INC(Depth[XDest]);        (* increment depth in column *)
        DeletePixel;              (* and remove pixel from list *)
      END;
      IF PPtr # NIL
      THEN PPtr := PPtr^.Next; END;
    END;
  END MovePixels;

BEGIN (* Decay *)
  InitVars;
  FindCols;
  REPEAT
    IF ColCount  > 0 THEN   NewPixel;     END;
    IF PixlCount > 0 THEN   MovePixels;   END;
    MsgPtr := GetMsg (WPtr^.userPort);
    IF MsgPtr # NIL THEN
      ColCount := 0;
      PixlCount := 0;
      ReplyMsg (MsgPtr);
    END;
  UNTIL (ColCount = 0) AND (PixlCount = 0);
END Decay;

PROCEDURE CleanUp;
  BEGIN
    IF WPtr # NIL THEN  CloseWindow (WPtr);  END;
  END CleanUp;

(******************************************************************************)

BEGIN (* Snow *)
  TermProcedure(CleanUp);
  InitWindow;
  IF WPtr # NIL
  THEN
    Decay;
  END;
END Snow.