program vesascroll;

uses Crt;

const
  Digits : array[0..$F] of Char = '0123456789ABCDEF';

  function HexW(W : Word) : string;
    {-Return hex string for word}
  begin
    HexW[0] := #4;
    HexW[1] := Digits[hi(W) shr 4];
    HexW[2] := Digits[hi(W) and $F];
    HexW[3] := Digits[lo(W) shr 4];
    HexW[4] := Digits[lo(W) and $F];
  end;

  function Trim(S : string) : string;
    {-Return a string with leading and trailing white space removed}
  var
    I : Word;
    SLen : Byte absolute S;
  begin
    while (SLen > 0) and (S[SLen] <= ' ') do
      Dec(SLen);

    I := 1;
    while (I <= SLen) and (S[I] <= ' ') do
      Inc(I);
    Dec(I);
    if I > 0 then
      Delete(S, 1, I);

    Trim := S;
  end;

  function LeftPadCh(S : string; Ch : Char; Len : Byte) : string;
    {-Return a string left-padded to length len with ch}
  var
    o : string;
    SLen : Byte absolute S;
  begin
    if Length(S) >= Len then
      LeftPadCh := S
    else if SLen < 255 then begin
      o[0] := Chr(Len);
      Move(S[1], o[Succ(Word(Len))-SLen], SLen);
      FillChar(o[1], Len-SLen, Ch);
      LeftPadCh := o;
    end;
  end;

  function LeftPad(S : string; Len : Byte) : string;
    {-Return a string left-padded to length len with blanks}
  begin
    LeftPad := LeftPadCh(S, ' ', Len);
  end;

  function PadCh(S : string; Ch : Char; Len : Byte) : string;
    {-Return a string right-padded to length len with ch}
  var
    o : string;
    SLen : Byte absolute S;
  begin
    if Length(S) >= Len then
      PadCh := S
    else begin
      o[0] := Chr(Len);
      Move(S[1], o[1], SLen);
      if SLen < 255 then
        FillChar(o[Succ(SLen)], Len-SLen, Ch);
      PadCh := o;
    end;
  end;

  function Pad(S : string; Len : Byte) : string;
    {-Return a string right-padded to length len with blanks}
  begin
    Pad := PadCh(S, ' ', Len);
  end;

  function Long2Str(L : LongInt) : string;
    {-Convert a long/word/integer/byte/shortint to a string}
  var
    S : string;
  begin
    Str(L, S);
    Long2Str := S;
  end;

type
  PWordArray = ^TWordArray;
  TWordArray = array [0..256] of Word;

  TVESARec = record
    Sig: array [0..3] of Char;
    uVersion: Byte;
    lVersion: Byte;
    Manufacturer: Pointer;
    Flag: LongInt;
    Modes: PWordArray;
    Padding: array [19..256] of Byte;
  end;

  TModeRec = record
    ModeFlag: Word;
    WindowFlags: array [0..1] of Byte;
    Gran: Word;
    WindowSize: Word;
    Window1Seg,Window2Seg: Word;
    VisiblePtr: Pointer;
    BytesPerLine: Word;
    {Optional: Byte;}
    XRes,YRes: Word;
    CharWidth,CharHeight: Byte;
    NumBitplanes: Byte;
    BitsPerPixel: Byte;
    MemBlocks: Byte;
    MemModel: Byte;
    MemBlockSize: Byte;
    padd: array [1..300] of Byte;
  end;

function IsVESAInstalled (var VESARec: TVESARec): Boolean; assembler;
asm
  mov   ax,4F00h
  les   di,VESARec
  int   10h
end;

function GetModeInfo (mode: Word; var ModeRec: TModeRec): Boolean; assembler;
asm
  mov   ax,4F01h
  mov   cx,[mode]
  les   di,ModeRec
  int   10h
end;

procedure DisplayString (x,y: Byte; s: String);
var
  i: Byte;
  c: Char;
begin
  for i := 1 to Length (s) do
  begin
    c := s [i];
    GotoXY (x,y);
    asm
      mov   ah,09h
      mov   al,[c]
      mov   bh,0
      mov   bl,01h
      mov   cx,1
      int   10h
    end;
    Inc (x);
  end;
end;

procedure SetDisplayStart (x,y: Word);
begin
  asm
    mov   ax,4F07h
    mov   bh,0
    mov   bl,0
    mov   cx,[x]
    mov   dx,[y]
    int   10h
  end;
end;

var
  i: Integer;
  VESARec: TVESARec;
  ModeRec: TModeRec;
  num: Word;
  ii: Byte;
  mode: String;
  x,y: Integer;

begin
  if IsVESAInstalled (VESARec) then
  begin
    repeat
      ClrScr;
      i := 0;
      while VESARec.Modes^ [i] <> $FFFF do
      begin
        Write (Pad (HexW (VESARec.Modes^ [i]),8));
        GetModeInfo (VESARec.Modes^ [i], ModeRec);
        with ModeRec do
          Writeln (LeftPad (Long2Str (XRes)+'x'+Long2Str (YRes),9),' ',BitsPerPixel:2,' ',MemModel:2,' ',Gran);
        Inc (i);
      end;

      Writeln;
      Write ('Enter video mode: ');
      Readln (mode);
      mode := Trim (mode);
      if mode <> '' then
      begin
        num := 0;
        ii := 0;
        for i := Length (mode) downto 1 do
        begin
          num := num + ((Ord (mode [i]) - Ord ('0')) shl ii);
          Inc (ii,4);
        end;
        if GetModeInfo (num, ModeRec) then
        begin
          ClrScr;
          with ModeRec do
          begin
            Writeln ('Information for mode ',HexW (num),'h - ',XRes,'x',YRes,' ',BitsPerPixel,'bit color');
            Writeln;
            Write ('Can this mode be used with the attached monitor?    ');
            if ModeFlag and 1 = 1 then Writeln ('Yes') else Writeln ('No');
            Write ('Are the BIOS text functions supported in this mode? ');
            if ModeFlag and 4 = 4 then Writeln ('Yes') else Writeln ('No');
            Write ('Monochrome or colour?                               ');
            if ModeFlag and 8 = 8 then Writeln ('Colour') else Writeln ('Monochrome');
            Write ('Mode type                                           ');
            if ModeFlag and 16 = 16 then Writeln ('Graphic') else Writeln ('Text');
            Writeln;
            Writeln ('Access window information:');
            for i := 0 to 1 do
            begin
              Write ('  ',i,' ');
              if WindowFlags [i] and 1 = 1 then Write ('Available') else Write ('Not Available');
              Write (',');
              if WindowFlags [i] and 2 = 2 then Write ('Read Access') else Write ('No Read Access');
              Write (',');
              if WindowFlags [i] and 4 = 4 then Write ('Write Access') else Write ('No Write Access');
              Writeln;
            end;
            Writeln;
            Writeln ('Granularity                                         ',Gran,'k');
            Writeln ('Size of the two access windows                      ',WindowSize,'k');
            Writeln ('Segment address of first access window              ',HexW (Window1Seg),'h');
            Writeln ('Segment address of second access window             ',HexW (Window2Seg),'h');
            Writeln ('Number of bytes required for each pixel line        ',BytesPerLine);
            Writeln ('Width of character matrix in pixels                 ',CharWidth);
            Writeln ('Height of character matrix in pixels                ',CharHeight);
            Writeln ('Number of bitplanes                                 ',NumBitPlanes);
            Writeln ('Number of bits per screen pixel                     ',BitsPerPixel);
            Writeln ('Number of memory blocks                             ',MemBlocks);
            Writeln ('Memory model                                        ',MemModel);
            Writeln ('Size of memory blocks                               ',MemBlockSize);
          end;
        end
        else Writeln ('Invalid mode');
        Writeln;
        Write ('Press any key...');
        Readln;
      end;
    until Trim (mode) = '';

    asm
      { set mode to 101h - 640x480x256 on my PC }
      mov ax,4F02h
      mov bx,101h
      int 10h

      { Address vid RAM and write first 64k (first bank) }
      mov ax,0A000h           { vid RAM is at A000:0000 so set segment address }
      mov es,ax
      xor di,di               { set offset - DI=0000 (xor di,di = mov di,0}
      cld                     { clear direction flag }
      mov cx,0FFFFh           { FFFF bytes - 65536 }
      mov al,7                { color - 7 }
      rep stosb               { store color in FFFF successive bytes starting }
                              { at ES:DI - A000:0000 }

      { Switch bank }
      mov ax,4F05h
      mov bh,0
      mov bl,0  { Access window }
      mov dx,1  { Bank 1 }
      int 10h

      { Address vid RAM and write second 64k }
      mov ax,0A000h
      mov es,ax
      xor di,di
      cld
      mov cx,0FFFFh
      mov al,2
      rep stosb

      { Switch bank }
      mov ax,4F05h
      mov bh,0
      mov bl,0  { Access window }
      mov dx,2  { Bank 2 }
      int 10h

      { Address vid RAM and write second 64k }
      mov ax,0A000h
      mov es,ax
      xor di,di
      cld
      mov cx,0FFFFh
      mov al,3
      rep stosb

      { Switch bank }
      mov ax,4F05h
      mov bh,0
      mov bl,0  { Access window }
      mov dx,3  { Bank 3 }
      int 10h

      { Address vid RAM and write second 64k }
      mov ax,0A000h
      mov es,ax
      xor di,di
      cld
      mov cx,0FFFFh-6144
      mov al,4
      rep stosb
    end;

    i := 1;
    repeat
      while i <= 400 do
      begin
        SetDisplayStart (0,i);
        Inc (i,3);
      end;
      while i >= 0 do
      begin
        SetDisplayStart (0,i);
        Dec (i,3);
      end;
      i := 0;
    until KeyPressed;

    Readln;
    asm
      mov   ax,0003h
      int   10h
    end;
  end
  else Writeln ('VESA is not installed.');
end.
