home *** CD-ROM | disk | FTP | other *** search
/ Software of the Month Club 1995 December / SOFM_Dec1995.bin / pc / os2 / vpascal / examples / flame / flame.pas
Pascal/Delphi Source File  |  1995-10-31  |  7KB  |  213 lines
  1. {█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
  2. {█                                                       █}
  3. {█      Virtual Pascal Examples. Version 1.0.            █}
  4. {█      Direct video memory access.                      █}
  5. {█      ─────────────────────────────────────────────────█}
  6. {█      OS/2 version by Vitaly Miryanov                  █}
  7. {█                                                       █}
  8. {▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}
  9.  
  10. { DOS version of this program has been posted to          }
  11. { COMP.LANG.PASCAL newsgroup. Here is slightly changed    }
  12. { original version with author comments.                  }
  13.  
  14. {$IFNDEF VIRTUALPASCAL}  { DOS version: Use Turbo Pascal 6.0+ to compile }
  15.  
  16. var c, x, y, z : Word;
  17. procedure setrgb( c, r, g, b : byte );
  18. begin
  19.   port[$3c8] := c;   { g'day, this is a probably the most simple version   }
  20.   port[$3c9] := r;   { of fire that you will ever see in pascal. i wrote   }
  21.   port[$3c9] := g;   { the code in pascal so it's slow and choppy, i have  }
  22.   port[$3c9] := b;   { another version in asm. and it's faster. anyways if }
  23. end;                 { you have any critics or question on this code, just }
  24.                      { e-mail me at ekd0840@bosoleil.ci.umoncton.ca. or    }
  25. begin                {              9323767@info.umoncton.ca               }
  26.   randomize;         {  note : I have code for all kinds of stuff (that I  }
  27.   asm   mov ax, 13h  {         wrote of course), if you want something     }
  28.         int 10h      {         e-mail me (i never get mail), maybe i have  }
  29.   end;               {         what you want.                              }
  30.   for x := 1 to 32 do{                               keith degrüce         }
  31.   begin              {                               moncton, n.-b. canada }
  32.     setrgb(x,   x*2-1, 0,     0    );
  33.     setrgb(x+32, 63,   x*2-1, 0    );
  34.     setrgb(x+64, 63,   63,    x*2-1);
  35.     setrgb(x+96, 63,   63,    63   );
  36.   end;
  37.   repeat
  38.    x := 0;
  39.    repeat
  40.      y := 60;
  41.      repeat
  42.        c := (mem[$a000:y * 320 + x]+
  43.              mem[$a000:y * 320 + x + 2]+
  44.              mem[$a000:y * 320 + x - 2]+
  45.              mem[$a000:(y+2) * 320 + x + 2]) div 4;
  46.        if c <> 0 then dec(c);
  47.        memw[$a000:(y-2) * 320 + x] := (c shl 8) + c;
  48.        memw[$a000:(y-1) * 320 + x] := (c shl 8) + c;
  49.        Inc(Y,2);
  50.      until y > 202;
  51.      Dec(y,2);
  52.      mem[$a000:y * 320 + x] := random(2) * 160;
  53.      Inc(X,2);
  54.     until x >= 320;
  55.   until port[$60] < $80;
  56.   asm  mov ax, 3
  57.        int 10h
  58.   end;
  59.  
  60. {$ELSE}                 { OS/2 version: use Virtual Pascal }
  61.  
  62. program Flame;
  63.  
  64. uses Os2Base, Use32;
  65.  
  66. {$IFDEF DYNAMIC_VERSION}
  67.   {$Dynamic System}
  68.   {$L VPRTL.LIB}
  69. {$ENDIF}
  70.  
  71. type
  72.   Ptr16Rec = record
  73.     Ofs,Sel: SmallWord;
  74.   end;
  75.  
  76. var
  77.   RGBValues: array [1..128] of record R,G,B: Byte; end;
  78.   OrgMode: VioModeInfo;
  79.   VioBufOfs: Longint;
  80.   C,X,Y,Z: Word;
  81.   Status: SmallWord;
  82.  
  83. { BIOS Video Mode #13 }
  84.  
  85. const
  86.   VioMode: VioModeInfo =
  87.    ( cb:     SizeOf(VioModeInfo);
  88.      fbType: vgmt_Other + vgmt_Graphics;
  89.      Color:  colors_256;
  90.      Col:    40;
  91.      Row:    25;
  92.      HRes:   320;
  93.      VRes:   200
  94.    );
  95.  
  96.   ColorRegs: VioColorReg =
  97.    ( cb:            SizeOf(VioColorReg);
  98.      rType:         3;  { Color registers }
  99.      FirstColorReg: 1;
  100.      NumColorRegs:  128;
  101.      ColorRegAddr:  @RGBValues
  102.    );
  103.  
  104.   VioBuf: VioPhysBuf =
  105.    ( pBuf: Ptr($A0000);
  106.      cb:   64*1024
  107.    );
  108.  
  109. const
  110.   AsFire: Boolean = False;
  111.   Locked: Boolean = False;
  112.  
  113. { Returns True when key is pressed.              }
  114. { Keystroke is removed from the keyboard buffer. }
  115.  
  116. function KeyPressed: Boolean;
  117. var
  118.   Key: KbdKeyInfo;
  119. begin
  120.   KbdCharIn(Key, io_NoWait, 0);
  121.   KeyPressed := (Key.fbStatus and kbdtrf_Final_Char_In) <> 0;
  122. end;
  123.  
  124. { Restores screen to the original state }
  125.  
  126. procedure RestoreScreen;
  127. begin
  128.   VioSetMode(OrgMode, 0);
  129.   if Locked then VioScrUnLock(0);
  130. end;
  131.  
  132. { Displays error message and halts program execution }
  133.  
  134. procedure HaltError(const ErrMsg: String);
  135. begin
  136.   RestoreScreen;
  137.   WriteLn('**Error**  ', ErrMsg);
  138.   Halt(1);
  139. end;
  140.  
  141. { Prepares R,G and B values for color register # No }
  142.  
  143. procedure SetRGB(No,AR,AG,AB: Byte);
  144. begin
  145.   with RGBValues[No] do
  146.   begin
  147.     R := AR;
  148.     G := AG;
  149.     B := AB;
  150.   end;
  151. end;
  152.  
  153. begin
  154.   { Use /f command line option to see the flame in the triangular form }
  155.   if (ParamCount = 1) and (Pos(ParamStr(1),'-f -F /f /F') <> 0) then
  156.     AsFire := True;
  157.   Randomize;
  158.   for X := 1 to 32 do
  159.   begin
  160.     SetRGB(X     , X*2-1, 0    , 0    );
  161.     SetRGB(X + 32, 63   , X*2-1, 0    );
  162.     SetRGB(X + 64, 63   , 63   , X*2-1);
  163.     SetRGB(X + 96, 63   , 63   , 63   );
  164.   end;
  165.   { Save original video mode }
  166.   OrgMode.cb := SizeOf(VioModeInfo);
  167.   VioGetMode(OrgMode, 0);
  168.   { Set VGA 320x200x256 video mode }
  169.   if VioSetMode(VioMode, 0) <> 0 then HaltError('VGA display required.');
  170.   { Convert flat pointer to 16:16 form that is used by Vio }
  171.   FlatToSel(ColorRegs.ColorRegAddr);
  172.   { Modify color registers with values prepared above }
  173.   if VioSetState(ColorRegs, 0) <> 0 then HaltError('Cannot modify color registers.');
  174.   { Lock the screen }
  175.   if (VioScrLock(lockIO_NoWait, Status, 0) <> 0) or
  176.     (Status <> lock_Success) then HaltError('Cannot lock the screen.');
  177.   Locked := True;
  178.   { Get selector for physical video buffer }
  179.   if VioGetPhysBuf(VioBuf, 0) <> 0 then HaltError('Cannot access video screen selector.');
  180.   { Make flat pointer that points to the physical video buffer}
  181.   Ptr16Rec(VioBufOfs).Ofs := 0;
  182.   Ptr16Rec(VioBufOfs).Sel := VioBuf.Sel;
  183.   SelToFlat(Pointer(VioBufOfs));
  184.   { Clear the screen. Unlike function 0 of the BIOS INT 10h }
  185.   { VioSetMode doesn't clear the screen.                    }
  186.   FillChar(Pointer(VioBufOfs)^,64*1024,0);
  187.   { Main drawing algorithm (no comments) }
  188.   repeat
  189.     X := 0;
  190.     repeat
  191.       Y := 60;
  192.       repeat
  193.         C := (Mem[VioBufOfs + Y * 320 + X]     +
  194.               Mem[VioBufOfs + Y * 320 + X + 2] +
  195.               Mem[VioBufOfs + Y * 320 + X - 2] +
  196.               Mem[VioBufOfs + (Y+2) * 320 + X + 2]) div 4;
  197.         if C <> 0 then Dec(C);
  198.         MemW[VioBufOfs + (Y-2) * 320 + X] := (C shl 8) + C;
  199.         MemW[VioBufOfs + (Y-1) * 320 + X] := (C shl 8) + C;
  200.         Inc(Y,2);
  201.       until Y > 200;
  202.       Dec(Y,2);
  203.       if not AsFire then Z := 120
  204.         else if X < 160 then Z := X else Z := 320 - X;
  205.       Mem[VioBufOfs + Y * 320 + X] := Random(2) * (Z + 40);
  206.       Inc(X,2);
  207.     until X >= 320;
  208.   until KeyPressed;
  209.   { Restore the screen }
  210.   RestoreScreen;
  211. {$ENDIF}
  212. end.
  213.