Program vytvorí prechod medzi dvoma farbami

{ 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.