home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_disks / 300-399 / ff308.lzh / StarBlanker / src / StarBlanker.mod < prev   
Text File  |  1990-01-18  |  9KB  |  350 lines
  1. IMPLEMENTATION MODULE StarBlanker;
  2.  
  3. FROM SYSTEM        IMPORT    ADR, ADDRESS, BYTE, SHIFT, SHORT;
  4. FROM Blitter        IMPORT    BltClearFlagSet, BltClear,StraightCopy,
  5.                 BltBitMap;
  6. FROM RunTime        IMPORT    GfxBase;
  7. FROM Ports        IMPORT    GetMsg, ReplyMsg, WaitPort;
  8. FROM EasyWindows    IMPORT    CreateWindow;
  9. FROM EasyScreens    IMPORT    CreateScreen, SetScreenColor;
  10. FROM RandomNumbers    IMPORT    Random, seed;
  11. FROM Intuition        IMPORT    CurrentTime, CloseWindow, CloseScreen,
  12.                 WindowFlagSet, WindowFlags, IDCMPFlagSet,
  13.                 IDCMPFlags, WindowPtr, ScreenPtr,
  14.                 SmartRefresh, ReportMouse, SetPointer,
  15.                 IntuiMessagePtr;
  16. FROM GfxBase        IMPORT    GfxBaseRecPtr;
  17. FROM Rasters        IMPORT    RastPortPtr, AllocRaster, FreeRaster;
  18. FROM Graphics        IMPORT    BitMapPtr, BitMap, InitBitMap, RASSIZE;
  19. FROM Memory        IMPORT    AllocMem, FreeMem, MemReqSet, MemReqs;
  20.  
  21. CONST MaxStars = 128;    (* looks good *)
  22.       MaxDepth = 3;
  23.  
  24.       MAGIC = 256;    (* For Function2() *) 
  25.       INCR  = 4;    (* "Speed" of stars in function2() *)
  26.  
  27.       Offset = 1;    (* "Speed" of stars in Function()  *)
  28.  
  29. TYPE StarType = RECORD
  30.       x, y, z : INTEGER;   (* Position of this "star"  *)
  31.      END;
  32.  
  33.      (* For our blank mouse pointer *)
  34. TYPE PointerPtr = POINTER TO PointerType;
  35.      PointerType = ARRAY[0..1] OF CARDINAL;
  36.  
  37. VAR stars : ARRAY[0..MaxStars-1] OF StarType;
  38.  
  39.     Width, Height : INTEGER;    (* Width, height of our display *)
  40.  
  41.     StarScreen : ScreenPtr;    (* Pointer to our screen        *)
  42.     StarWindow : WindowPtr;    (* Pointer to our window        *)
  43.     bm : BitMap;        (* Offscreen bitmap for quick blitting    *)
  44.     ptr: PointerPtr;        (* Blank pointer definition        *)
  45.  
  46.     method : CARDINAL;
  47.  
  48. (*
  49.  * InitGlobals - Initialize some global variables, namely :
  50.  * 
  51.  * Width, Height - Optimum width/height of lo-res display, considering
  52.  *           morerows/PAL/what have you
  53.  * seed         - For slightly more random numbers
  54.  * Stars     - Pick random locations and "depth"s for the stars
  55.  *)
  56.  
  57. PROCEDURE InitGlobals;
  58. VAR dummy : LONGCARD;
  59.     gb : GfxBaseRecPtr;
  60.     i : CARDINAL;
  61. BEGIN
  62.   gb := GfxBase;
  63.   Width := gb^.NormalDisplayColumns DIV 2;
  64.   Height:= gb^.NormalDisplayRows;
  65.   CurrentTime(dummy,seed);
  66.   i := 0;
  67.   REPEAT
  68.     stars[i].x := Random(Width);
  69.     stars[i].y := Random(Height);
  70.     stars[i].z := Random(MaxDepth)+1;
  71.     INC(i);  
  72.   UNTIL (i = MaxStars);
  73. END InitGlobals;
  74.  
  75. (*
  76.  * MyWritePixel - Write a pixel into offscreen display memory, so we can 
  77.  * blit it in really quick
  78.  *
  79.  * Note - This routine is, I believe, generic enough to use elsewhere.
  80.  *      I wrote it after finding out how slow WritePixel() is.
  81.  *      Obviously, this routine does no clipping.
  82.  *)
  83.  
  84. PROCEDURE MyWritePixel(bmap : BitMapPtr; x, y : INTEGER; color : INTEGER);
  85. TYPE Bits = [0..7];
  86.      BitSet = SET OF Bits;    (* like a short BITSET *)
  87. VAR  val : POINTER TO BitSet;
  88.      Offset : ADDRESS;
  89.      i : CARDINAL;
  90. BEGIN
  91.   (* Find correct Y offset *)
  92.   Offset := ADDRESS(bmap^.BytesPerRow * CARDINAL(y));
  93.   (* Move to beginning of x *)
  94.   INC(Offset,x DIV 8);
  95.  
  96.   (* Now Offset is on the right byte. *)
  97.  
  98.   i := 0;
  99.   REPEAT
  100.     IF i IN BITSET(color) THEN
  101.       val := bmap^.Planes[i];
  102.       INC(val,Offset);
  103.       INCL(val^,7-Bits(x MOD 8));  (* Set the proper bit *)
  104.     END;
  105.     INC(i);
  106.   UNTIL(i = CARDINAL(bmap^.Depth));
  107.  
  108. END MyWritePixel;
  109.  
  110. (*
  111.  * Function (yeah, I know, it's really a procedure)
  112.  *
  113.  * Clear the offscreen bitmap, plot the next frame of stars into it,
  114.  * and blit it onto the visible display
  115.  *)
  116.  
  117. PROCEDURE Function();
  118. VAR err : LONGCARD;
  119.     i : CARDINAL;
  120. BEGIN
  121.   (* Clear our display memory *)
  122.   i := 0;
  123.   REPEAT
  124.     BltClear(bm.Planes[i],RASSIZE(Width,Height),BltClearFlagSet{0});
  125.     INC(i);
  126.   UNTIL(i = 2);
  127.  
  128.   (* Plot the next generation of stars *)
  129.   i := 0;
  130.   REPEAT
  131.     IF stars[i].x+(stars[i].z*Offset) >= Width THEN (* Wrap *)
  132.       stars[i].x := 0;
  133.       INC(stars[i].y);
  134.       IF stars[i].y >= Height THEN
  135.         stars[i].y := 0;
  136.       END;
  137.     ELSE
  138.       INC(stars[i].x,stars[i].z*Offset);
  139.     END;
  140.     MyWritePixel(ADR(bm),stars[i].x,stars[i].y,stars[i].z);
  141.     INC(i);
  142.   UNTIL i = MaxStars;
  143.  
  144.   (* Now blit in the new bitmap *)
  145.   err := BltBitMap(ADR(bm),0,0,
  146.              ADR(StarScreen^.BMap),0,0,
  147.              Width, Height,
  148.              BYTE(0C0H),
  149.              BITSET(BYTE(0FFH)),NIL);
  150. END Function;
  151.  
  152. (*
  153.  * See below
  154.  *)
  155.  
  156. PROCEDURE MkPoint(point : INTEGER);
  157. BEGIN
  158.   stars[point].x := Random(256);
  159.   DEC(stars[point].x,128);
  160.   stars[point].y := Random(150);
  161.   DEC(stars[point].y,75);
  162.   stars[point].z := 255;
  163. END MkPoint;
  164.  
  165. (*
  166.  * Function2 (yeah, I know, it's still a procedure)
  167.  *
  168.  * This came from Leo Schwab's "Stars" program from a couple of years
  169.  * ago.  I slightly modified it to work on a 4-color screen and so it
  170.  * would use my format for holding the stars.  Also, saving the old
  171.  * star locations isn't necessary because the screen gets cleared
  172.  * every time through.
  173.  *)
  174.  
  175. PROCEDURE Function2();
  176. VAR i : CARDINAL;
  177.     err, xs, ys : INTEGER;
  178.  
  179. BEGIN
  180.   (* Clear our display memory *)
  181.   i := 0;
  182.   REPEAT
  183.     BltClear(bm.Planes[i],RASSIZE(Width,Height),BltClearFlagSet{0});
  184.     INC(i);
  185.   UNTIL(i = 2);
  186.  
  187.   i := 0;
  188.   REPEAT
  189.     DEC(stars[i].z,INCR);
  190.     IF stars[i].z <= 0 THEN
  191.       MkPoint(i);
  192.     END;
  193.     xs := stars[i].x * MAGIC DIV stars[i].z + 160;
  194.     ys := stars[i].y * MAGIC DIV stars[i].z + 100;
  195.     IF (xs < 0) OR (xs >= Width) OR (ys < 0) OR (ys >= Height) THEN
  196.       MkPoint(i);
  197.     ELSE            
  198.       MyWritePixel(ADR(bm),xs,ys,SHIFT(256-stars[i].z,-6));
  199.     END;
  200.     INC(i);
  201.   UNTIL i = MaxStars;
  202.  
  203.   (* Now blit in the new bitmap *)
  204.   err := BltBitMap(ADR(bm),0,0,
  205.              ADR(StarScreen^.BMap),0,0,
  206.              Width, Height,
  207.              BYTE(0C0H),
  208.              BITSET(BYTE(0FFH)),NIL);
  209.  
  210. END Function2;
  211.  
  212. (*
  213.  * AllocBitMap - Allocate the temporary bitmap in Chip memory (so
  214.  *  the blitter can get to it).  Also, allocate the image for the
  215.  *  blank pointer while we're here.
  216.  *
  217.  * Note - Pointer definition has to be in CHIP memory, which is why
  218.  *      we're using AllocMem
  219.  *)
  220.  
  221. PROCEDURE AllocBitMap() : BOOLEAN;
  222. BEGIN
  223.   InitBitMap(ADR(bm),2,Width,Height);
  224.   bm.Planes[0]:=AllocRaster(Width,Height);
  225.   IF bm.Planes[0] # NIL THEN
  226.     bm.Planes[1]:=AllocRaster(Width,Height);
  227.     IF bm.Planes[1] # NIL THEN
  228.       (* Alloc the blank pointer while we're here *)
  229.       ptr := AllocMem(SIZE(PointerType),MemReqSet{MemClear,MemPublic,MemChip});
  230.       IF ptr # NIL THEN
  231.         RETURN(TRUE);  (* whew, we made it *)
  232.       END;
  233.       FreeRaster(bm.Planes[1],Width,Height);
  234.     END;
  235.     FreeRaster(bm.Planes[0],Width,Height);
  236.   END;
  237.   RETURN(FALSE);
  238. END AllocBitMap;
  239.  
  240. (*
  241.  * FreeBitMap - free stuff created by AllocBitMap()
  242.  *)
  243.  
  244. PROCEDURE FreeBitMap();
  245. BEGIN
  246.   FreeMem(ptr,SIZE(PointerType));
  247.   FreeRaster(bm.Planes[1],Width,Height);
  248.   FreeRaster(bm.Planes[0],Width,Height);
  249. END FreeBitMap;
  250.  
  251. (*
  252.  * OpenDisplay - Does the following :
  253.  *
  254.  *  - Opens the screen
  255.  *  - Allocates temporary bitmap (using above procedure)
  256.  *  - Opens the window
  257.  *  - Starts mouse event report
  258.  *  - Blanks the pointer
  259.  *  - Sets the colors
  260.  *)
  261.  
  262. PROCEDURE OpenDisplay() : BOOLEAN;
  263. BEGIN
  264.   StarScreen  := CreateScreen(Width,Height,2,"");
  265.   IF StarScreen # NIL THEN
  266.     IF AllocBitMap() THEN
  267.       StarWindow := CreateWindow(0,0,Width,Height,"",
  268.                      IDCMPFlagSet{IntuiTicks,MouseButtons,MouseMove,RawKey,InactiveWindow},
  269.                      WindowFlagSet{Borderless,Activate,NoCareRefresh}+SmartRefresh,
  270.                      StarScreen,NIL);
  271.       IF StarWindow # NIL THEN
  272.         ReportMouse(StarWindow,TRUE);
  273.  
  274.         (* Blank the pointer - note - this is the only way I could think of to do this *)
  275.         SetPointer(StarWindow,ptr,1,1,0,0);
  276.         SetScreenColor(StarScreen,0,0,0,0);
  277.         SetScreenColor(StarScreen,1,5,5,5);
  278.         SetScreenColor(StarScreen,2,10,10,10);
  279.         SetScreenColor(StarScreen,3,15,15,15);
  280.         RETURN(TRUE);
  281.       END;
  282.       FreeBitMap();
  283.     END;
  284.     CloseScreen(StarScreen);
  285.   END;
  286.   RETURN(FALSE);
  287. END OpenDisplay;
  288.  
  289. (*
  290.  * CloseDisplay - Closes everything opened by the above
  291.  *)
  292.  
  293. PROCEDURE CloseDisplay();
  294. BEGIN
  295.   FreeBitMap();
  296.   CloseWindow(StarWindow);
  297.   CloseScreen(StarScreen);
  298. END CloseDisplay;
  299.  
  300. (*
  301.  * DoStarBlank - does the actual blanking.
  302.  *
  303.  * Note - if any allocations fail, nothing happens, and this
  304.  *      will return immediately
  305.  *)
  306.  
  307. PROCEDURE DoStarBlank();
  308. VAR i   : CARDINAL;
  309.     msg : IntuiMessagePtr;
  310.     finished : BOOLEAN;
  311. BEGIN
  312.   method := Random(2);
  313.   IF method = 1 THEN
  314.     i := 0;
  315.     REPEAT
  316.       MkPoint(i);
  317.       INC(i);
  318.     UNTIL (i = MaxStars);
  319.   ELSE
  320.     InitGlobals();
  321.   END;
  322.   IF OpenDisplay() THEN
  323.     finished := FALSE;
  324.     REPEAT
  325.       msg := WaitPort(StarWindow^.UserPort);
  326.       LOOP
  327.         msg := GetMsg(StarWindow^.UserPort);
  328.         IF msg = NIL THEN EXIT; END;
  329.         IF msg^.Class = IDCMPFlagSet{IntuiTicks} THEN
  330.           IF method = 1 THEN
  331.             Function2();
  332.           ELSE
  333.             Function();
  334.           END;
  335.           ReplyMsg(msg);
  336.         ELSE
  337.           finished := TRUE; EXIT;
  338.         END;
  339.       END; (* loop *)
  340.     UNTIL(finished);    
  341.     CloseDisplay();
  342.   END;
  343. END DoStarBlank;
  344.  
  345. BEGIN
  346.  
  347.   InitGlobals();
  348.  
  349. END StarBlanker.
  350.