program test640x480;

uses crt,graph,dos{,vesa};

const vseg       = $A000;
      VIDEO     = $10;  { Video interrupt number                    }
      CRTC_ADDR	= $3d4; { Base port of the CRT Controller (color)   }
      SEQU_ADDR	= $3c4; { Base port of the Sequencer                }
      vgran     = 64;

type rgb          = record
                       red,
                       grn,
                       blu : byte
                     end;

      palettetype  = array[0..255] of rgb;

var curbank,pixels:word;
    palette : palettetype;
    reg:registers;

procedure vio(ax:word);
begin
 reg.ax:=ax;
 intr($10,reg);
end;

procedure setbank(bank:word);
begin
  if bank=curbank then exit;   {Only set bank if diff. from current value}
  curbank:=bank;
  reg.bx:=0;
  bank:=bank * longint(64) div vgran;
  reg.dx:=bank;
  vio($4f05);
  reg.bx:=1;
  reg.dx:=bank;
  vio($4f05);
end;

procedure InitXtended;
begin
  { Set VESA 640x480x256 mode }
  asm
    mov ax, $4F02
    mov bx, $101
    int VIDEO
  end;
end;

procedure settextmode;
begin
 asm
  mov ax,03h
  int 10h
 end;
end;

procedure XtendedPutPixel(x, y : word; color : longint); {zet putje op het scherm x,y,kleur}
var l:longint;
begin
   l:=y * longint(640)  + x;
   setbank(l shr 16);
   Mem[vseg :word(l)] := color;
end;

procedure writepalette(palette:palettetype;nr:byte);
var i : byte;

begin
  if nr > 255 then nr := 255;
  for i := 0 to nr do
  begin
    port[$3c8] := i;
    port[$3c9] := palette[i].red;
    port[$3c9] := palette[i].grn;
    port[$3c9] := palette[i].blu;
  end;
end;

procedure loadpcx640480(name:string;var palette:palettetype); {laad pcx file 640x400}
type dataar = array[1..20000] of byte;

var data   : ^dataar;
    f      : file;
    result : integer;
    page   : byte;
    tel    : longint;
    bufnr  : word;
    r,
    herh   : longint;


begin
   assign(f,name);
   reset(f,1);
   seek(f,filesize(f)-768);
   blockread(f,palette,768,result);
   for tel := 0 to 255 do
   begin
     palette[tel].red := palette[tel].red shr 2;
     palette[tel].grn := palette[tel].grn shr 2;
     palette[tel].blu := palette[tel].blu shr 2;
   end;
   writepalette(palette,255);
   r := 0;
   page := 0;
   setbank(page);
   seek(f,128);
   getmem(data,20000);
   bufnr := 1;
   blockread(f,data^,20000,result);
   repeat
     herh := 1;
     if (data^[bufnr] and $C0) = $C0 then
     begin
       herh := (data^[bufnr] and $3F);
       if bufnr < 20000 then inc(bufnr) else
       begin
         bufnr := 1;
         blockread(f,data^,20000,result);
       end;
     end;

     for tel:= 1 to herh do
     begin
      mem[$a000:r] := data^[bufnr];
       inc(r);
       if r =65536 then
       begin
         r := 0;
         inc(page);
         setbank(page);
       end;
     end;

     if bufnr < 20000 then inc(bufnr) else
     begin
       bufnr := 1;
       blockread(f,data^,20000,result);
     end;
   until page = 8;
   freemem(data,20000);
   close(f);
end;

procedure loadsmallpcx{640480}(name:string;var palette:palettetype); {laad pcx file 640x400}
type dataar = array[1..20000] of byte;

var data   : ^dataar;
    f      : file;
    result : integer;
    page   : byte;
    tel    : longint;
    bufnr  : word;
    r,
    herh   : longint;
    x,y:longint;

begin
   assign(f,name);
   reset(f,1);
   seek(f,filesize(f)-768);
   blockread(f,palette,768,result);
   for tel := 0 to 255 do
   begin
     palette[tel].red := palette[tel].red shr 2;
     palette[tel].grn := palette[tel].grn shr 2;
     palette[tel].blu := palette[tel].blu shr 2;
   end;
   writepalette(palette,255);
   r := 0;
   page := 0;
   setbank(page);
   seek(f,128);
   getmem(data,20000);
   bufnr := 1;
   blockread(f,data^,20000,result);
   repeat
     herh := 1;
     if (data^[bufnr] and $C0) = $C0 then
     begin
       herh := (data^[bufnr] and $3F);
       if bufnr < 20000 then inc(bufnr) else
       begin
         bufnr := 1;
         blockread(f,data^,20000,result);
       end;
     end;

     for tel:= 1 to herh do
     begin
       x:=r mod 640  shr 1{ 1280} + 100;
       y:=r div 640 shr 1 + 100;
       xtendedputpixel(x,y,data^[bufnr]);
{      mem[$a000:r] := data^[bufnr];}
       inc(r);
      { if r =65536 then
       begin
         r := 0;
         inc(page);
         setbank(page);
       end;}
     end;

     if bufnr < 20000 then inc(bufnr) else
     begin
       bufnr := 1;
       blockread(f,data^,20000,result);
     end;
   until {page = 8}r=306560;
   freemem(data,20000);
   close(f);
end;

procedure wrtext(x,y:word;txt:string);   {schrijf tekst op pos (X,Y)}
type
  pchar=array[char] of array[0..15] of byte;
var
  p:^pchar;
  c:char;
  i,j,z,b:integer;
  ad,bk:word;
  l,v,col:longint;
begin
  reg.bh:=6;
  vio($1130);
  col:=200; {was eerst 0}
  p:=ptr(reg.es,reg.bp);
  for z:=1 to length(txt) do
  begin
    c:=txt[z];
    for j:=0 to 15 do
    begin
      b:=p^[c][j];
      for i:=0 to 7 do
      begin
        if (b and 128)<>0 then v:=col else v:=0;
        xtendedputpixel(x+i,y+j,v);
        b:=b shl 1;
      end;
    end;
    inc(x,8); {afstand tussen de letters}
  end;
end;


begin
   initxtended; {grafische mode 640x480 256kleuren}
   loadpcx640480('a:\vinmenu.PCX',palette);
   delay(1200);
   loadsmallpcx('e:\400X300.PCX',palette); {size 400x300 256}
   delay(1200);
   repeat until keypressed;
   settextmode; {terug naar textmode}
end.