Forum Programmazione

[gorilla_bas]

Code: Select all

uses crt;
CONST AVGA = $A000;

Type Virtual = Array [1..64000] of byte;
     VirtPtr = ^Virtual;
     light2d   =  array[0..128*128] of byte;
     light = ^light2d;

VAR Virscr : VirtPtr;
    Vaddr  : word;
    buffer:virtual;
    lmap:light;

Procedure Cls (Where:word;Col : Byte);
BEGIN
     asm
        push    es
        mov     cx, 32000;
        mov     es,[where]
        xor     di,di
        mov     al,[col]
        mov     ah,al
        rep     stosw
        pop     es
     End;
END;

Procedure SetUpVirtual;
BEGIN
  GetMem (VirScr,64000);
  getmem (lmap,128*128);
  vaddr := seg (virscr^);
END;


Procedure ShutDown;
BEGIN
  FreeMem (VirScr,64000);
  FreeMem (lmap,128*128);
END;


procedure flip(source,dest:Word);
begin
  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;
end;

procedure punto(x,y:integer;col:byte;where:word);assembler;
asm
        mov ax,where
        mov es,ax
        mov cx,y
        shl y,8
        shl cx,6
        add cx,x
        add cx,y
        mov di,cx
        mov al,col
        stosb
end;

Procedure SetEnvMap;
var nx,ny,nz:real;
    x,y,tmp:integer;
begin
     for y:=0 to 127 do
     for x:=0 to 127 do
     begin
          nx:=(x-64)/64;
          ny:=(y-64)/64;
          nz:=1-sqrt(sqr(nx)+sqr(ny));
          if nz<0 then nz:=0;
          lmap^[x+(y shl 7)]:=round(nz*255);
     end;
end;

Procedure loadbump;
var f: file of Virtual;
begin
     assign(f,'ranbm.raw');
     reset(f);
     read(f,buffer);
     close(f);
end;

type tpal=array[0..768] of byte;
procedure Pal(VAR p:tpal); ASSEMBLER;

   ASM
      MOV DX,3C8h
      XOR AX,AX
      OUT DX,AL
      INC DX
      MOV CX,768
      PUSH DS
      LDS SI,p
   @@l:
       OUTSB
       LOOP @@l
      POP DS
   END;

Function Pow(base:real;esponente:integer):real;
var i:integer;
    p:real;
begin
     p:=base;
     for i:=1 to esponente do p:=p*base;
     pow:=p;
end;


Procedure PhongPal(rosso,verde,blu,luce,riflesso,ambiente:real);
var tmp,i:real;
    d:integer;
    col:tpal;
begin
     for d:=0 to 255 do
     begin
          i:=cos((255-d)/512*3.14159);
          tmp:=rosso*ambiente/63+rosso*i+pow(i,round(riflesso))*luce;
          if tmp>63 then tmp:=63;
          col[d*3]:=round(tmp);
          tmp:=verde*ambiente/63+verde*i+pow(i,round(riflesso))*luce;
          if tmp>63 then tmp:=63;
          col[d*3+1]:=round(tmp);
          tmp:=blu*ambiente/63+blu*i+pow(i,round(riflesso))*luce;
          if tmp>63 then tmp:=63;
          col[d*3+2]:=round(tmp);
     end;
    pal(col);
end;

Procedure bmap(lx,ly:integer);
var nx,ny,x,y:integer;
    offset:word;
begin
     lx:=lx+64;
     ly:=ly+64;
     offset:=64000;
     for y:=200 downto 2 do
     for x:=320 downto 1 do
     begin
          nx:=buffer[offset+1]-buffer[offset-1];
          ny:=buffer[offset+320]-buffer[offset-320] ;
          nx:=nx+(lx-x);
          ny:=ny+(ly-y);
          if (nx>127)or(nx<0) then nx:=127;
          if (ny>127)or(ny<0) then ny:=127;
          mem[Vaddr:offset]:=buffer[offset]shr 1 +(lmap^[nx+(ny shl 7)])shr 1;
          dec(offset);
     end;
end;

procedure SetVga;assembler;
asm
     MOV     AX,13h
     INT     10h
end;

procedure testo;assembler;
ASM
   MOV     AX,3
   INT     10h
END;
var rad:real;
begin
     writeln('ATTENDERE PREGO...');
     setupvirtual;
     setenvmap;
     loadbump;
     setvga;
     phongpal(0,0,63,255,5,0);
     rad:=0;
     cls(vaddr,0);
     cls(avga,0);
     repeat
           bmap(160+round(cos(rad*3)*90),100+round(cos(rad*5)*80));
           rad:=rad+0.03;
           if rad>2*3.14159 then rad:=0;
           phongpal(round(rad*30),round(rad*10),round((6.3-rad)*10),255,10,0);
           flip (vaddr,avga);
     until keypressed;
     shutdown;
     testo;
end.


Code: Select all

unit vga_buf;
interface

CONST AVGA = $A000;

type Palette = Array[0..256*3] of byte;
     Virtual = Array [1..64000] of byte;
     VirtPtr = ^Virtual;

var vaddr:word;
    VirScr:virtptr;

Procedure SetUpVirtual;
Procedure ShutDown;
procedure punto(x,y:integer;col:byte;where:word);
procedure SetVga;
procedure testo;
procedure Pall(VAR p:palette);
Procedure Cls (Where:word;Col : Byte);
procedure flip(source,dest:Word);
Function  get(x,y:integer;where:word):byte;

implementation

Procedure SetUpVirtual;
BEGIN
  GetMem (VirScr,64000);
  vaddr := seg (virscr^);
END;


Procedure ShutDown;
BEGIN
  FreeMem (VirScr,64000);
END;

procedure punto(x,y:integer;col:byte;where:word);assembler;
asm
        mov ax,where
        mov es,ax
        mov cx,y
        shl y,8
        shl cx,6
        add cx,x
        add cx,y
        mov di,cx
        mov al,col
        stosb
end;


procedure SetVga;assembler;
asm
     MOV     AX,13h
     INT     10h
end;

procedure testo;assembler;
ASM
   MOV     AX,3
   INT     10h
END;
procedure Pall(VAR p:palette); ASSEMBLER;

   ASM
      MOV DX,3C8h
      XOR AX,AX
      OUT DX,AL
      INC DX
      MOV CX,768
      PUSH DS
      LDS SI,p
   @@l:
       OUTSB
       LOOP @@l
      POP DS
   END;
Procedure Cls (Where:word;Col : Byte);
BEGIN
     asm
        push    es
        mov     cx, 32000;
        mov     es,[where]
        xor     di,di
        mov     al,[col]
        mov     ah,al
        rep     stosw
        pop     es
     End;
END;

procedure flip(source,dest:Word);
begin
  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;
end;
Function get(x,y:integer;where:word):byte;
begin
asm
  mov ax,y
  mov bx,ax
  shl ax,8
  shl bx,6
  add bx,ax
  add bx,x
  mov ax,where
  mov es,ax
  mov al,es:[bx]
  mov @result,al
end;
end;
end.