Simulácia horiaceho ohňa

Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
Category: KMP (Club of young programmers)
fire.pngAuthor: Aleš Kucik
web: www.webpark.cz/prog-pascal

Program: Fire.pasGraphx.pas
need: F1.palF2.pal

Demonštrační program pro efekt ohne
Tento program by měl sloužit jenom jako ukázka. Tvorivosti se meze nekladou. Mužete měnit paletu, pixely ze kterých se počíta pruměrná hodnota, zhášecí konstantu atd. Pokud nevíte jak vytvořit svou paletu kouknete sem makepal.pas. Uvidíte několik efektu, pracujícich na stejnem princípu.
{ GRAPHX.PAS                               Copyright (c) Ales Kucik }
{ Unit pro praci s grafickym rezimem v Pascalu.                     }
{                                                                   }
{ Datum:29.11.2002                             http://www.trsek.com }
 
unit GraphX;
{$G+}
interface
 
const
  VGA=$a000;
 
type
    tVirtual = array [1..64000] of byte;
 
    tpal=array [0..255,0..2] of byte;
 
    bod3D=record
            x,y,z:integer;
    end;
 
    bod2D=record
            x,y:integer;
    end;
 
 
procedure SetVGA;
procedure SetText;
procedure Cls (col:byte; where:word);
procedure PutPixel (x,y :integer; col:byte; where:word);
procedure Flip (source,dest:word);
procedure SetPal(col,r,g,b:byte);
procedure GetPal(col:byte;var r,g,b:byte);
procedure getVGApal(var pal:tpal);
procedure setVGApal(pal: tpal);
function  BIOSFont:pointer;
procedure XYText(const font: pointer;const x,y:word;
                 const col:byte;const s:string; where:word);
procedure XYTextB(font:pointer; x,y:word;
                  color:byte; s:string; where:word);
procedure WaitRetrace;
procedure LineH(x,y,d:integer; col:byte; where:word);
procedure LineV(x,y,d:integer; col:byte; where:word);
procedure Line(a,b,c,d:integer; col:byte; where:word);
 
procedure Pixel3D(var a,b:integer; x,y,z:integer);
 
 
implementation
 
procedure SetVGA; assembler;
asm
    mov  ax,0013h
    int  10h
end;
 
procedure SetText; assembler;
asm
    mov  ax,0003h
    int  10h
end;
 
procedure Cls; assembler;
asm
    push    es
    mov     cx, 32000;
    mov     es,[where];
    xor     di,di
    mov     al,[col]
    mov     ah,al
    rep     stosw
    pop     es
end;
 
procedure PutPixel; assembler;
asm
    mov     ax,[where]
    mov     es,ax
    mov     bx,[x]
    mov     dx,[y]
    mov     di,bx
    mov     bx,dx
    shl     bx,8
    shl     dx,6
    add     dx,bx
    add     di,dx
    mov     al,[col]
    stosb
end;
 
procedure Flip; assembler;
asm
    push    ds
    mov     ax, [Dest]
    mov     es, ax
    mov     ax, [Source]
    mov     ds, ax
    xor     si, si
    xor     di, di
    mov     cx, 32000
    rep     movsw
    pop     ds
end;
 
procedure SetPal; assembler;
asm
    mov     dx,3c8h
    mov     al,[col]
    out     dx,al
    inc     dx
    mov     al,[r]
    out     dx,al
    mov     al,[g]
    out     dx,al
    mov     al,[b]
    out     dx,al
end;
 
procedure GetPal;
begin
  port[$3c7]:= col;
  r:= port[$3c9];
  g:= port[$3c9];
  b:= port[$3c9];
end;
 
procedure getVGApal;
var
  loop:byte;
begin
  for loop:=0 to 255 do
    getpal(loop,pal[loop,0],pal[loop,1],pal[loop,2]);
end;
 
procedure setVGApal;
var
  loop:byte;
begin
  for loop:=0 to 255 do
    setpal(loop,pal[loop,0],pal[loop,1],pal[loop,2]);
end;
 
 
 
function BIOSFont;
var
  font:pointer;
begin
  asm
    push bp
    mov  ax, 1130h
    mov  bx, 0100h
    int  10h
    mov  ax, bp
    pop  bp
    mov  word ptr[font],   ax
    mov  word ptr[font+2], es
  end;
  BIOSFont:=font;
end;
 
procedure XYText; assembler;
var
 FirstChar,
 CharHeight   :Byte;
 CharNr,
 ScreenPTR    :Word;
 
asm
 push ds
 
 mov ax,where     { Setup ES:[BX] = X,Y to plot at }
 mov es,ax
 mov bx,x
 mov ax,y
 xchg ah,al
 add bx,ax
 shr ax,2
 add bx,ax
 lds di,font
 mov dl,[di]       { height of font goes into dh }
 mov CharHeight,dl
 inc di
 mov dl,[di]
 mov FirstChar,dl
 mov CharNr,0     { Ugh! Character counter, not a very }
                  { good method, but I'm all out of registers :-( }
 
@nextchar:
 inc CharNr       { also skips lengthbyte! }
 push ds          { This I don't like, pushing and popping. }
 lds si,[S]       { But unfortunately I can't seem to find }
 add si,CharNr    { any spare registers? Intel, can you help? }
 lodsb            { load asciivalue into al }
 pop ds
 cmp al,0         { check for null-termination }
 je @exit         { exit if end of string }
 
 mov ScreenPTR,BX { save bx }
 mov dh,CharHeight
 xor ah,ah
 mov cl,firstchar { firstchar }
 sub al,cl        { al = currentchar - firstchar }
 mov si,ax        { di = scrap register }
 mul dh           { ax * fontheight }
 add ax,si        { ax + characters to skip }
 
 lds di,font      { This can be omptimized I think (preserve DI) }
 add di,3         { skip header }
 add di,ax        { Point into structure }
 mov cl,[di]      { get character width }
 
@nextline:
 mov ch,cl        { ch is the height counter. cl is the original. }
 inc di           { .. now points to bitmap }
 mov dl,[di]      { get bitmap byte }
 
@nextpixel:
 rol dl,1         { rotate bitmap and prepare for next pixel }
 mov al,dl        { mov bitmap into al for manipulation }
 and al,1         { mask out the correct bit }
 jz @masked       { jump if transperent }
 mov al,col
 mov byte ptr es:[bx],al { Set the pixel on the screen }
@masked:
 inc bx           { increment X-offset }
 dec ch           { are we done? last byte in character? }
 jnz @nextpixel   { nope, out with another pixel }
 add bx,320       { Go to next line on the screen }
 sub bx,cx        { X-alignment fixup }
 dec dh           { are we done with the character? }
 jnz @nextline
 mov bx,ScreenPTR { restore screen offset and prepare for next character }
 add bx,cx
 inc bx           { A little gap between the letters, thank you... }
 jmp @nextchar
 
@exit:
 pop ds
end;
 
procedure XYTextB; assembler;
var
  firstChar:  byte;
  charNr,
  screenPTR:  word;
 
 
asm
  push  ds
 
  mov   ax, where      {vypocet pocatecni pozice}
  mov   es, ax         {es obsahuje segment obrazovky/pameti}
  mov   bx, x
  mov   ax, y
  xchg  ah, al
  add   bx, ax
  shr   ax, 2
  add   bx, ax         {pozice je ulozena v bx}
  lds   di, font
  mov   charNr, 0
  mov   cl, color      {v cl je cislo barvy}
 
 
  @nextchar:
   inc  charNr
   push ds
   lds  si, [s]
   add  si, charNr
   lodsb
   pop  ds
   cmp  al, 0
   je   @exit
 
   mov  screenPTR, bx   {ulozime si bx}
   mov  dh, 8
   xor  ah, ah
   mul  dh
   mov  si, di
   add  si, ax
 
 
  @nextline:
   lodsb
   mov  ch, 8
   mov  dl, al
 
 
  @nextpixel:
   rol  dl, 1
   mov  al, dl
   and  al, 1
   jz   @masked
   mov byte ptr es:[bx], cl
 
  @masked:
   inc  bx
   dec  ch
   jnz  @nextpixel
   add  bx, 320
   sub  bx, 8
   dec  dh
   jnz  @nextline
   mov  bx, screenPTR
   add  bx, 8
   inc  bx
   jmp  @nextChar
 
  @exit:
   pop ds
end;
 
procedure WaitRetrace; assembler;
label
  l1,l2;
 
asm
  mov dx,3DAh
 
l1:
  in   al,dx
  and  al,08h
  jnz  l1
l2:
  in   al,dx
  and  al,08h
  jz   l2
end;
 
procedure LineH;
var loop:word;
begin
  for loop:=x to d+x do
    putpixel(loop,y,col,where);
end;
 
procedure LineV;
var loop:word;
begin
  for loop:=y to y+d do
    putpixel(x,loop,col,where);
end;
 
procedure Line;
 
  function sgn(a:real):integer;
  begin
    if a>0 then sgn:=1
    else
      if a<0 then sgn:=-1
      else sgn:=0;
  end;
 
var
  i,s,d1x,d1y,d2x,d2y,u,v,m,n:integer;
 
begin
  u:= c-a;
  v:= d-b;
  d1x:= sgn(u);
  d1y:= sgn(v);
  m:= abs(u);
  n:= abs(v);
  if not(m>n) then
    begin
      d2x:= 0;
      d2y:= d1y;
      i:=m;
      m:=n;
      n:=i;
    end
  else
    begin
      d2x:= d1x;
      d2y:= 0;
    end;
  s:= m shr 1;
  for i:=0 to m do
    begin
      putpixel(a,b,col,where);
      s:= s+n;
      if not(s<m) then
        begin
          s:= s-m;
          a:= a+d1x;
          b:= b+d1y;
        end
      else
        begin
          a:= a+d2x;
          b:= b+d2y;
        end;
    end;
end;
 
procedure Pixel3D;
var q:longint;
begin
  q:= z+300;
  a:= ((x shl 8) div q)+160;
  b:= ((y shl 8) div q)+100;
end;
 
end.