Software of the Month Club 1995 December/SOFM_Dec1995.bin/pc/os2/vpascal/examples/flame/flame.pas

Pascal/Delphi Source File | 1995-10-31 | 6.5 KB | 213 lines

{█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
{█                                                       █}
{█      Virtual Pascal Examples. Version 1.0.            █}
{█      Direct video memory access.                      █}
{█      ─────────────────────────────────────────────────█}
{█      OS/2 version by Vitaly Miryanov                  █}
{█                                                       █}
{▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}

{ DOS version of this program has been posted to          }
{ COMP.LANG.PASCAL newsgroup. Here is slightly changed    }
{ original version with author comments.                  }

{$IFNDEF VIRTUALPASCAL}  { DOS version: Use Turbo Pascal 6.0+ to compile }

var c, x, y, z : Word;
procedure setrgb( c, r, g, b : byte );
begin
  port[$3c8] := c;   { g'day, this is a probably the most simple version   }
  port[$3c9] := r;   { of fire that you will ever see in pascal. i wrote   }
  port[$3c9] := g;   { the code in pascal so it's slow and choppy, i have  }
  port[$3c9] := b;   { another version in asm. and it's faster. anyways if }
end;                 { you have any critics or question on this code, just }
                     { e-mail me at [e-mail]. or    }
begin                {              [e-mail]               }
  randomize;         {  note : I have code for all kinds of stuff (that I  }
  asm   mov ax, 13h  {         wrote of course), if you want something     }
        int 10h      {         e-mail me (i never get mail), maybe i have  }
  end;               {         what you want.                              }
  for x := 1 to 32 do{                               keith degrüce         }
  begin              {                               moncton, n.-b. canada }
    setrgb(x,   x*2-1, 0,     0    );
    setrgb(x+32, 63,   x*2-1, 0    );
    setrgb(x+64, 63,   63,    x*2-1);
    setrgb(x+96, 63,   63,    63   );
  end;
  repeat
   x := 0;
   repeat
     y := 60;
     repeat
       c := (mem[$a000:y * 320 + x]+
             mem[$a000:y * 320 + x + 2]+
             mem[$a000:y * 320 + x - 2]+
             mem[$a000:(y+2) * 320 + x + 2]) div 4;
       if c <> 0 then dec(c);
       memw[$a000:(y-2) * 320 + x] := (c shl 8) + c;
       memw[$a000:(y-1) * 320 + x] := (c shl 8) + c;
       Inc(Y,2);
     until y > 202;
     Dec(y,2);
     mem[$a000:y * 320 + x] := random(2) * 160;
     Inc(X,2);
    until x >= 320;
  until port[$60] < $80;
  asm  mov ax, 3
       int 10h
  end;

{$ELSE}                 { OS/2 version: use Virtual Pascal }

program Flame;

uses Os2Base, Use32;

{$IFDEF DYNAMIC_VERSION}
  {$Dynamic System}
  {$L VPRTL.LIB}
{$ENDIF}

type
  Ptr16Rec = record
    Ofs,Sel: SmallWord;
  end;

var
  RGBValues: array [1..128] of record R,G,B: Byte; end;
  OrgMode: VioModeInfo;
  VioBufOfs: Longint;
  C,X,Y,Z: Word;
  Status: SmallWord;

{ BIOS Video Mode #13 }

const
  VioMode: VioModeInfo =
   ( cb:     SizeOf(VioModeInfo);
     fbType: vgmt_Other + vgmt_Graphics;
     Color:  colors_256;
     Col:    40;
     Row:    25;
     HRes:   320;
     VRes:   200
   );

  ColorRegs: VioColorReg =
   ( cb:            SizeOf(VioColorReg);
     rType:         3;  { Color registers }
     FirstColorReg: 1;
     NumColorRegs:  128;
     ColorRegAddr:  @RGBValues
   );

  VioBuf: VioPhysBuf =
   ( pBuf: Ptr($A0000);
     cb:   64*1024
   );

const
  AsFire: Boolean = False;
  Locked: Boolean = False;

{ Returns True when key is pressed.              }
{ Keystroke is removed from the keyboard buffer. }

function KeyPressed: Boolean;
var
  Key: KbdKeyInfo;
begin
  KbdCharIn(Key, io_NoWait, 0);
  KeyPressed := (Key.fbStatus and kbdtrf_Final_Char_In) <> 0;
end;

{ Restores screen to the original state }

procedure RestoreScreen;
begin
  VioSetMode(OrgMode, 0);
  if Locked then VioScrUnLock(0);
end;

{ Displays error message and halts program execution }

procedure HaltError(const ErrMsg: String);
begin
  RestoreScreen;
  WriteLn('**Error**  ', ErrMsg);
  Halt(1);
end;

{ Prepares R,G and B values for color register # No }

procedure SetRGB(No,AR,AG,AB: Byte);
begin
  with RGBValues[No] do
  begin
    R := AR;
    G := AG;
    B := AB;
  end;
end;

begin
  { Use /f command line option to see the flame in the triangular form }
  if (ParamCount = 1) and (Pos(ParamStr(1),'-f -F /f /F') <> 0) then
    AsFire := True;
  Randomize;
  for X := 1 to 32 do
  begin
    SetRGB(X     , X*2-1, 0    , 0    );
    SetRGB(X + 32, 63   , X*2-1, 0    );
    SetRGB(X + 64, 63   , 63   , X*2-1);
    SetRGB(X + 96, 63   , 63   , 63   );
  end;
  { Save original video mode }
  OrgMode.cb := SizeOf(VioModeInfo);
  VioGetMode(OrgMode, 0);
  { Set VGA 320x200x256 video mode }
  if VioSetMode(VioMode, 0) <> 0 then HaltError('VGA display required.');
  { Convert flat pointer to 16:16 form that is used by Vio }
  FlatToSel(ColorRegs.ColorRegAddr);
  { Modify color registers with values prepared above }
  if VioSetState(ColorRegs, 0) <> 0 then HaltError('Cannot modify color registers.');
  { Lock the screen }
  if (VioScrLock(lockIO_NoWait, Status, 0) <> 0) or
    (Status <> lock_Success) then HaltError('Cannot lock the screen.');
  Locked := True;
  { Get selector for physical video buffer }
  if VioGetPhysBuf(VioBuf, 0) <> 0 then HaltError('Cannot access video screen selector.');
  { Make flat pointer that points to the physical video buffer}
  Ptr16Rec(VioBufOfs).Ofs := 0;
  Ptr16Rec(VioBufOfs).Sel := VioBuf.Sel;
  SelToFlat(Pointer(VioBufOfs));
  { Clear the screen. Unlike function 0 of the BIOS INT 10h }
  { VioSetMode doesn't clear the screen.                    }
  FillChar(Pointer(VioBufOfs)^,64*1024,0);
  { Main drawing algorithm (no comments) }
  repeat
    X := 0;
    repeat
      Y := 60;
      repeat
        C := (Mem[VioBufOfs + Y * 320 + X]     +
              Mem[VioBufOfs + Y * 320 + X + 2] +
              Mem[VioBufOfs + Y * 320 + X - 2] +
              Mem[VioBufOfs + (Y+2) * 320 + X + 2]) div 4;
        if C <> 0 then Dec(C);
        MemW[VioBufOfs + (Y-2) * 320 + X] := (C shl 8) + C;
        MemW[VioBufOfs + (Y-1) * 320 + X] := (C shl 8) + C;
        Inc(Y,2);
      until Y > 200;
      Dec(Y,2);
      if not AsFire then Z := 120
        else if X < 160 then Z := X else Z := 320 - X;
      Mem[VioBufOfs + Y * 320 + X] := Random(2) * (Z + 40);
      Inc(X,2);
    until X >= 320;
  until KeyPressed;
  { Restore the screen }
  RestoreScreen;
{$ENDIF}
end.