home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / Pascal / Snippets / Campfire 1.1 / CampFire.p < prev    next >
Encoding:
Text File  |  1996-03-25  |  10.4 KB  |  373 lines  |  [TEXT/PJMM]
  1. program CampFire;
  2.  
  3. {This program is a Pascal port of CAMP FIRE 1.1 by Brian Stone.}
  4. {Ported by Ingemar Ragnemalm 1996.}
  5.  
  6. {Possible improvements:}
  7. {• Change the calculations to work with 127..-128 rather than 0..255.}
  8. {That would simplify and speed up the code.}
  9. {The BASE# pointers should really be pointers to bytes (Ptr), to avoid the}
  10. {overhead of looking up in arrays. The best solution I can think of is to}
  11. {use *signed* bytes, normal Ptrs, so all calculations are made with the range}
  12. {127..-128 in mind rather than 0..255. Well, let's fix that for another}
  13. {version.}
  14. {• Move as many global variables to be local. (I have moved some.)}
  15. {That makes the code more readable.}
  16.  
  17. {NOTE FOR THINK PASCAL USERS: If debug it turned on for this file, it will run VERY slow.}
  18. {That's normal – don't blame Think for it. It is something like 100 times faster with D/V/R}
  19. {turned off.}
  20.  
  21.     uses
  22. {$IFC UNDEFINED THINK_PASCAL}
  23.         Types, QuickDraw, OSUtils, Memory, Events, Resources, Fonts, TextEdit, Dialogs, Processes, ToolUtils, 
  24. {$ENDC}
  25.         Palettes, QDOffScreen;
  26.  
  27.     type
  28.         ByteArr = packed array[0..100000] of Byte;
  29.         ByteArrPtr = ^ByteArr;
  30. { Global rectangles.}
  31.     var
  32.         WindowRect, OffscreenRect: Rect;
  33.  
  34. { Graphics world vars, and PixMap stuff.}
  35.         saveWorld: GWorldPtr;
  36.         saveDevice: GDHandle;
  37.         MyWindow: CWindowPtr;
  38.         OffscreenWorldP: GWorldPtr;
  39.         err: QDErr;
  40.  
  41. { Pix Map stuff}
  42.         OffscreenPixMapH, windowPixMapH: PixMapHandle;
  43.         OffscreenPixMapP, windowPixMapP: PixMapPtr;
  44.         endbyte: Ptr;
  45.         base: ByteArrPtr;
  46.         rb, start: LongInt;
  47.  
  48. { Misc Vars}
  49.         Resx, Resy: LongInt;
  50.         MaxBlockSize: LongInt;
  51.         resfileID: Integer;
  52.  
  53. { Vars used for Frame Rate Calculation}
  54.         StartTime, EndTime, TotalTime: LongInt;
  55.         finalTicks: Longint;
  56.         Frames: Longint; {was double}
  57.         FPS: Integer;
  58.  
  59.  
  60. (****************************)
  61.  
  62. { Function RangedRdm from THINK Reference.}
  63.     function Rnd (min, max: Longint): Longint;
  64.         var
  65.             qdRdm: Longint;
  66.             range: LongInt;
  67. (* assume that min is less than max *)
  68.     begin
  69.         qdRdm := BitAnd(Longint(Random), $0000ffff);        {Avoid negative values while keeping the full range.}
  70.         range := max - min;
  71.         Rnd := (qdRdm * range) div 65536 + min;     (* now 0 <= t <= range *)
  72.     end; {Rnd}
  73.  
  74. (********************)
  75.  
  76.     procedure CleanUp;
  77.     begin
  78.         if OffscreenWorldP <> nil then
  79.             DisposePtr(Ptr(OffscreenWorldP));
  80.         if MyWindow <> nil then
  81.             DisposeWindow(WindowPtr(MyWindow));
  82.         FlushEvents(everyEvent, 0);
  83.     end; {CleanUp}
  84.  
  85. (****************************************)
  86.  
  87.     procedure Init;
  88.         var
  89.             WindowResX, WindowResY: LongInt;
  90.             i, j: Integer;
  91. { Palette and ColorTable stuff}
  92.             CampFirePal: PaletteHandle;
  93.             CampFireClut: CTabHandle;
  94. { Init the Macintosh environment}
  95.     begin
  96. {$IFC UNDEFINED THINK_PASCAL}
  97.         InitGraf(@qd.thePort);
  98.         InitFonts;
  99.         FlushEvents(everyEvent - osMask - diskMask, 0);
  100.         InitWindows;
  101.         InitMenus;
  102.         TEInit;
  103.         InitDialogs(nil);
  104.         InitCursor;
  105.         MaxApplZone;
  106.  
  107. { Randomize Random number Seed}
  108.         GetDateTime(qd.randSeed);
  109. {$ELSEC}
  110. { Randomize Random number Seed}
  111.         GetDateTime(randSeed);
  112. {$ENDC}
  113.  
  114.     { Open resource file}
  115.         resfileID := OpenResFile('Flame.res');
  116.         if resfileID = 0 then
  117.             ExitToShell;
  118.  
  119.     { Get the window palette from the resource file.}
  120.         CampFirePal := GetNewPalette(128);
  121.     { Create a color table for the offscreen world.}
  122.         CampFireClut := GetCTable(8);
  123.     { Give the color table a unique CTseed.}
  124.         CampFireClut^^.ctSeed := GetCTSeed;
  125.     { Copy the palette into the color table.}
  126.         Palette2CTab(CampFirePal, CampFireClut);
  127.  
  128.     { Set Up the Window}
  129. {$IFC UNDEFINED THINK_PASCAL}
  130.         WindowResX := qd.screenBits.bounds.right;
  131.         WindowResY := qd.screenBits.bounds.bottom;
  132. {$ELSEC}
  133.         WindowResX := screenBits.bounds.right;
  134.         WindowResY := screenBits.bounds.bottom;
  135. {$ENDC}
  136.         SetRect(WindowRect, (WindowResX - Resx) div 2, (WindowResY - Resy) div 2, (WindowResX - Resx) div 2 + Resx, (WindowResY - Resy) div 2 + Resy);
  137.         MyWindow := CWindowPtr(NewCWindow(nil, WindowRect, 'Flame!', TRUE, noGrowDocProc, nil, FALSE, 0));
  138.         SelectWindow(WindowPtr(MyWindow));
  139.         SetPort(WindowPtr(MyWindow));
  140.     { Get the Graphics World and Device associated with the window}
  141.         GetGWorld(saveWorld, saveDevice);
  142.     { Set a pointer to the windows PixMap}
  143.         windowPixMapH := GetGWorldPixMap(saveWorld);
  144.         HLockHi(Handle(windowPixMapH));
  145.         if LockPixels(windowPixMapH) then
  146.             ;
  147.         windowPixMapP := windowPixMapH^;
  148.     { Set the palette to the window}
  149.         SetPalette(WindowPtr(MyWindow), CampFirePal, TRUE);
  150.         ActivatePalette(WindowPtr(MyWindow));
  151.  
  152.     { Set Up Offscreen GWorld}
  153.         SetRect(OffscreenRect, 0, 0, Resx, Resy);
  154. {$IFC UNDEFINED THINK_PASCAL}
  155.         err := NewGWorld(OffscreenWorldP, 0, OffscreenRect, CampFireClut, nil, 0);
  156. {$ELSEC}
  157.         err := NewGWorld(OffscreenWorldP, 0, OffscreenRect, CampFireClut, nil, []);
  158. {$ENDC}
  159.         if err <> 0 then
  160.             ExitToShell;
  161.         SetGWorld(OffscreenWorldP, nil);
  162.     { Set a pointer to the Offscreen World's PixMap}
  163.         OffscreenPixMapH := GetGWorldPixMap(OffscreenWorldP);
  164.         HLockHi(Handle(OffscreenPixMapH));
  165.         if LockPixels(OffscreenPixMapH) then
  166.             ;
  167.         OffscreenPixMapP := OffscreenPixMapH^;
  168.     { Set a pionter to the first byte of the ofscreen PixMap}
  169.         base := ByteArrPtr(OffscreenPixMapH^^.baseAddr);
  170.         rb := BitAnd(OffscreenPixMapH^^.rowBytes, $3fff);
  171.  
  172.     { Set every pixle of the offscreen PixMap to colorID 3.}
  173.         for j := 0 to Resy - 1 do
  174.             for i := 0 to Resx - 1 do
  175.                 base^[rb * j + i] := 3;
  176.  
  177.         CloseResFile(resfileID);
  178.     end; {Init}
  179.  
  180.  
  181. (*******************************)
  182.  
  183.     procedure CampFireInit;
  184. { This function draws in the last two rows of the PixMap}
  185. { with some random colors to start the flame.}
  186. { The averaging then takes over and "pulls" these colors}
  187. { upwards creating the fire effect.}
  188.         var
  189.             blocksize, RndNum: LongInt;
  190.             left, right, halfresx: Real;
  191.             Maxcolor, Mincolor: LongInt;
  192.             tmpBASE2, tmpBASE3, tmpBASE4: Ptr;
  193.             BASE1, BASE2, BASE3, BASE4, BASE5: ByteArrPtr;
  194.             k: Integer;
  195.             i: Longint;
  196.             randomcolor: Integer;
  197.     begin
  198. { Initilize the pointers to the last two rows.}
  199.         BASE2 := @base^[rb * (Resy - 3)];
  200.         BASE3 := @base^[rb * (Resy - 2)];
  201.         BASE4 := @base^[rb * (Resy - 1)];
  202.     { Init the information required to choose the colors. }
  203.         halfresx := Resx / 2;
  204.         Maxcolor := 255;
  205.         Mincolor := 180;
  206.  
  207.     { Draw the last two rows}
  208.         RndNum := Rnd(5, 60);
  209.         i := 0;
  210.         while i < Resx do
  211.     { This IF statement gives the fire a "pointed" look.}
  212.             begin
  213.                 if i < halfresx then
  214.            { We are on the left half of the PixMap}
  215.                     begin
  216.                         left := (halfresx - (halfresx - i)) / halfresx + 0.5;
  217.                         if left > 1 then
  218.                             left := 1;
  219. {$PUSH}
  220. {$R-}
  221.                         randomcolor := Rnd(Trunc(left * Mincolor), Trunc(left * Maxcolor));
  222. {$POP}
  223.                     end
  224.                 else            { We are on the right half of the PixMap}
  225.                     begin
  226.                         right := (halfresx + (halfresx - i)) / halfresx + 0.5;
  227.                         if right > 1 then
  228.                             right := 1;
  229. {$PUSH}
  230. {$R-}
  231.                         randomcolor := Rnd(Trunc(right * MinColor), Trunc(right * Maxcolor));
  232. {$POP}
  233.                     end;
  234.  
  235.                 tmpBASE2 := Ptr(BASE2);
  236.                 tmpBASE3 := Ptr(BASE3);
  237.                 tmpBASE4 := Ptr(BASE4);
  238.         { Fill in a randomly sized block of color}
  239.                 blocksize := Rnd(1, MaxBlockSize);
  240.                 if ((blocksize + i) > Resx) then
  241.                     blocksize := Resx - i;
  242.                 for k := 0 to blocksize - 1 do
  243.                     begin
  244. {$PUSH}
  245. {$R-}
  246.                         tmpBASE2^ := randomcolor;
  247.                         tmpBASE3^ := randomcolor;
  248.                         tmpBASE4^ := randomcolor;
  249. {$POP}
  250.                         tmpBASE2 := Ptr(Longint(tmpBASE2) + 1);
  251.                         tmpBASE3 := Ptr(Longint(tmpBASE3) + 1);
  252.                         tmpBASE4 := Ptr(Longint(tmpBASE4) + 1);
  253.                     end;
  254.  
  255.         { Increment the PixMap pointers.}
  256.                 BASE2 := ByteArrPtr(Longint(BASE2) + RndNum);
  257.                 BASE3 := ByteArrPtr(Longint(BASE3) + RndNum);
  258.                 BASE4 := ByteArrPtr(Longint(BASE4) + RndNum);
  259.  
  260.                 i := i + RndNum;
  261.             end;
  262.     end; {CampFireInit}
  263.  
  264. (*********************************)
  265.  
  266.     procedure BuildFlame;
  267.     { This function averages each pixel in this manner}
  268.     { *T*}
  269.     { *P*  Where pixels marked "P" are averaged together}
  270.     { PPP  and the result is stored in pixel "T".}
  271.  
  272.     { Stagger the starting pixel.}
  273.         var
  274.             averagecolor: Integer;
  275.             BASE1, BASE2, BASE3, BASE4, BASE5: ByteArrPtr;
  276.     begin
  277.         start := start + 1;
  278.         if start = 10 then
  279.             start := 0;
  280.  
  281.     { Set all pointers to their first pixel}
  282.         BASE1 := @base^[rb * 0 + start];
  283.         BASE2 := @base^[rb * 1 + start];
  284.         BASE3 := @base^[rb * 2 + start];
  285.         BASE4 := @base^[rb * 2 - 1 + start];
  286.         BASE5 := @base^[rb * 2 + 1 + start];
  287.  
  288.         endbyte := @base^[rb * (Resy - 3) + Resx];
  289.         while Longint(BASE1) < Longint(endbyte) do
  290.         { Calculate the average color.}
  291.             begin
  292. {Note! I use byte-arrays to access the pixels, but this really needs some}
  293. {optimizing. As it is now, it isn't as fast as the C version. It still is}
  294. {fairly fast, but I think it takes some more to access data byte-wise in}
  295. {Pascal.}
  296. {As a comfort, a 16-bit version wouldn't need any of these workarounds.}
  297.                 averagecolor := BSR(BASE2^[0] + BASE3^[0] + BASE4^[0] + BASE5^[0], 2) - 5;
  298.         { Make sure the color's don't go below the lowest color}
  299.                 if averagecolor < 3 then
  300.                     averagecolor := 3;
  301.         { Set the color of the target pixel}
  302. {$PUSH}
  303. {$R-}
  304.                 BASE1^[0] := averagecolor;
  305. {$POP}
  306.         { Increment all pointers to the next pixels to be used.}
  307.         {BASE4 = BASE5;}
  308.                 BASE1 := ByteArrPtr(Longint(BASE1) + 10);
  309.                 BASE2 := ByteArrPtr(Longint(BASE2) + 10);
  310.                 BASE3 := ByteArrPtr(Longint(BASE3) + 10);
  311.                 BASE4 := ByteArrPtr(Longint(BASE4) + 10);
  312.                 BASE5 := ByteArrPtr(Longint(BASE5) + 10);
  313.             end;
  314.     end; {BuildFlame}
  315.  
  316. (********************************)
  317.  
  318.     procedure CampFire;
  319. { Draw the base of the Camp Fire}
  320.     begin
  321.         CampFireInit;
  322.  
  323.     { Build the flame of the Camp Fire}
  324.         BuildFlame;
  325.  
  326.     { Scroll the Camp Fire up a few pixels to help it out.}
  327.         BlockMove(@base^[rb * 3], @base^[0], rb * (Resy - 1) - rb * 3);
  328.  
  329.     {Set back the port/device! Otherwise the CopyBits might not work. Actually, it didn't work on my 68k Macs.}
  330.         SetGWorld(saveWorld, saveDevice);
  331.  
  332.     { Copy the image to the screen}
  333.         CopyBits(BitMapPtr(OffscreenPixMapP)^, BitMapPtr(windowPixMapP)^, OffscreenRect, OffscreenRect, srcCopy, nil);
  334.     end; {CampFire}
  335.  
  336.  
  337. (***************************)
  338. (***    Camp Fire        ***)
  339. (***************************)
  340. {Procedure main;}
  341. { Set image resolution}
  342. begin
  343.     Resx := 240;
  344.     Resy := 320;
  345.     MaxBlockSize := Resx div 20 + 5;
  346.  
  347.     { Init Application}
  348.     Init;
  349.  
  350.     { Init Frame Rate calculations}
  351.     Frames := 0;
  352.     StartTime := TickCount;
  353.  
  354.     { Begin Simulation //    }
  355.     while not Button do
  356.         begin
  357.             CampFire;
  358.             Frames := Frames + 1;
  359.         end;
  360.  
  361.     { Calculate Frame Rate, and display.    }
  362.     SetGWorld(saveWorld, saveDevice);
  363.     EndTime := TickCount;
  364.     TotalTime := (EndTime - StartTime) div 60;
  365.     FPS := Frames div TotalTime;
  366.     MoveTo(10, 50);
  367.     ForeColor(greenColor);
  368.     DrawString(StringOf(FPS));
  369.     Delay(90, finalTicks);
  370.  
  371.     { Dont forget to wash behind your ears.}
  372.     CleanUp;
  373. end.