Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FAHR32K.ZIP/FAHR32K.PAS

Pascal/Delphi Source File | 1993-04-09 | 5.2 KB | 215 lines

{ Orchid Fahrenheit 1280 32000 color test program
  by Danny Thorpe and David Wilhelm  11/9/91
  written in Turbo Pascal 6.0  - does not use BGI }

{$X+}
uses Crt;

const
  Frgd_Mix_Reg    = $bae8;
  Frgd_Color_Reg  = $a6e8;
  MultiFunc_Cntl  = $bee8;
  Cur_X           = $86e8;
  Cur_Y           = $82e8;
  Maj_Axis_Pcnt   = $96e8;
  DestX_Diastp    = $8ee8;
  DestY_Axstp     = $8ae8;
  Err_Term        = $92e8;
  Cmd_Reg         = $9ae8;

{ Thanks to Samx on the Orchid BBS for listing these bios mode numbers! }
  m640x480x256   = $201;
  m800x600x16    = $202;
  m800x600x256   = $203;
  m1024x768x16   = $204;
  m1024x768x256  = $205;
  m1280x960x16   = $206;
  m1280x1024x16  = $208;
  m640x480x32K   = $301;
  mText          = $3;

var VidMode: word;

procedure VideoOff; near; assembler;
asm
  mov  bl,36h
  mov  ax,1201h
  int  10h
end;

procedure VideoOn; near; assembler;
asm
  mov  bl,36h
  mov  ax,1200h
  int  10h
end;

procedure SetText;
begin
  Portw[$4ae8] := 0;
  Port[$3d4] := $40;
  Port[$3d5] := Port[$3d5] and not 1; { Set VGA }
  Port[$3d4] := $38;
  Port[$3d5] := $0; { lock 1 }
  Port[$3d4] := $39;
  Port[$3d5] := $0; { lock 2 }
  asm
    mov ax, $3
    int $10
  end;
  VidMode := $3;
end;



function SetGraph(Mode: Word): boolean;
begin
  SetGraph := True;  { assume true, prove false }
  VidMode := Mode;

  VideoOff;     { turn off video to avoid screen static }
  Port[$3d4] := $38;
  Port[$3d5] := $48; { Enhanced mode unlock 1 }
  Port[$3d4] := $39;
  Port[$3d5] := $a0; { Enhanced mode unlock 2 }
  Port[$3d4] := $40;
  Port[$3d5] := Port[$3d5] or 1; { Enable Enhanced commands & registers }

  Port[$3d4] := $36;
  if (Mode = m640x480x32k) and ((Port[$3d5] and 32) <> 0) then {1 meg check }
    begin
      VideoOn;
      SetText;   { to lock the enhanced mode registers }
      SetGraph := False;
      Exit;
    end;

  asm
   mov ax, $4f02
   mov bx, Mode
   int $10
  end;
  VideoOn;
end;

procedure Wait(W: Word);
begin
  while Portw[$9ae8] and (1 shl w) <> 0 do ;
end;

procedure Line(X1, Y1, X2, Y2: Integer; Color: Word);
var
  Min, Max: Integer;
  Reg: Word;
  X, Y: Word;
begin
  X := Abs(X2 - X1);
  Y := Abs(Y2 - Y1);
  if X > Y then
  begin
    Max := X;
    Min := Y;
  end
  else
  begin
    Max := Y;
    Min := X;
  end;
  Wait(3);
  Portw[Frgd_Mix_Reg] := $27;
  Portw[Frgd_Color_Reg] := lo(Color);
  Portw[MultiFunc_Cntl] := $A000;
  Wait(7);
  Portw[Cur_X] := X1;
  Portw[Cur_Y] := Y1;
  Portw[Maj_Axis_Pcnt] := Max;
  Portw[DestX_Diastp] := 2*(Min - Max);
  Portw[DestY_Axstp] := 2 * Min;
  Reg := $2013;
  if X1 < X2 then
  begin
    Portw[Err_Term] := 2 * Min - Max;
    Inc(Reg, 32);
  end
  else
    Portw[Err_Term] := 2 * Min - Max - 1;
  if Y1 < Y2 then Inc(Reg, 128);
  if Y > X then Inc(Reg, 64);
  Portw[Cmd_Reg] := Reg;
  if VidMode = m640x480x32k then  { draw line in second video plane }
  begin
    Wait(1);
    Portw[Frgd_Color_Reg] := hi(Color);
    Wait(7);
    Portw[Cur_X] := X1 + 1024;
    Portw[Cur_Y] := Y1;
    Portw[Maj_Axis_Pcnt] := Max;
    Portw[DestX_Diastp] := 2*(Min - Max);
    Portw[DestY_Axstp] := 2 * Min;
    if X1 < X2 then
      Portw[Err_Term] := 2 * Min - Max
    else
      Portw[Err_Term] := 2 * Min - Max - 1;
    Portw[Cmd_Reg] := Reg;
  end;
end;

function SetRGB(Red, Green, Blue: Word): Word;
begin
  SetRGB := (Red and 127) shl 10 + (Green and 127) shl 5 + (Blue and 127);
end;

const mag = 3;
      blocksize = 32 * mag;
      xblocks = 640 div blocksize;
      yblocks = 480 div blocksize;

var
  I, J, K, L, M, N: Integer;
  Color: Word;
  X, Y: Integer;
begin
   writeln('Orchid Fahrenheit 1280 32000 color test program');
   writeln('by Danny Thorpe and David Wilhelm 11/9/91');
   writeln('written in Turbo Pascal 6.0 - non-BGI');
   writeln;
   writeln('Three screens of color gradient squares will be displayed.');
   writeln('Each square is a 32x32 gradient of 2 colors, for a total of');
   writeln('1024 colors per square.  The third color is graded over the');
   writeln('30 squares that will fit on the 640x480 screen.');
   writeln('Add it up yourself - that''s over 30,000 colors on-screen!');
   writeln;
   writeln('Press any key to display the next screen.');
   readkey;

   if not SetGraph(m640x480x32k) then
   begin
     writeln('You don''t appear to have 1Mb of display memory, or your');
     writeln('video card is not an Orchid Fahrenheit 1280.');
   end
   else
   begin
     for N := 1 to 3 do
     begin
       for M := 0 to yblocks-1 do
         for L := 0 to xblocks-1 do
           for I := 0 to 31 do
             for J := 0 to 31 do
               for K := J * mag to J * mag + (mag -1) do
               begin
                 case N of
                   1: Color := SetRGB(L + M * xblocks,I,J);
                   2: Color := SetRGB(I,J,L + M * xblocks);
                   3: Color := SetRGB(I,L + M * xblocks,J);
                 end;
                 X := I * mag + (L * blocksize);
                 Y := K + (M * blocksize);
                 Line(X, Y, X + mag -1, Y, Color);
               end;
       ReadKey;
     end;
     SetText;
   end;
end.