You are the supreme counselor of the ruler of ancient Egypt Ramesse II

{ univgraf.pas                          Copyright (c) Petr Masopust  }
{ Unit pre hru pyramida.pas                                          }
{ Inicializacia grafickejj karty v potrebnom rezime.                 }
{                                                                    }
{ Datum:03.09.2018                              http://www.trsek.com }
UNIT univgraf;
 
Interface
 CONST getmaxx=319; getmaxy=199;getmaxcolors=256;
 
   Black=0;
   Blue=1;
   Green=2;
   Cyan=3;
   Red=4;
   Magenta=5;
   Brown=6;
   LightGray=7;
   DarkGray=8;
   LightBlue=9;
   LightGreen=10;
   LightCyan=11;
   LightRed=12;
   LightMagenta=13;
   Yellow=14;
   White=15;
   Blink=128;
 
 
 
 PROCEDURE InitGraph; inline($b8/$13/0/$cd/$10);
 PROCEDURE doneGraph;
 
{Takhle kratke procedury je lepsi psat jako makro. Usetri se
nekolik bajtu a nekolik taktu. Dneska uz me to netrapi, ale vzpominam si,
jak jsem zamlada blaznil kvuli jednomu taktu. Makra se pisou
cela uz v interface, takze:} inline($b8/3/0/$cd/$10{mov ax,3;int 10h});
 PROCEDURE ClearScreen;
 procedure pozadi(c:byte);
 procedure poly(x1,y1,x2,y2,x3,y3,x4,y4:word;c:byte);
 FUNCTION  GetPixel(x,y:word):byte;
 PROCEDURE PutPixel(x,y:word;barva:byte);
 procedure perspektiva(zobrplocha,xp,yp,zp:integer;var x,y:word);
 procedure gwrite(s: string;cp,cz,x,y: byte);
 procedure swapint(var x,y: integer);
 procedure line(x1,y1,x2,y2:integer;c:byte);
 procedure ctverec(x,y,x1,y1:word;c:byte);
 
Implementation
 
procedure swapint(var x,y: integer);
var dummy: integer;
begin
  dummy:=x;
  x:=y;
  y:=dummy;
end;
 
procedure line(x1,y1,x2,y2:integer;c:byte);
var p,dx,dy,ainc,binc,xinc,yinc,x,y: integer;
begin
  if(abs(x2-x1) < abs(y1-y2)) then begin
    if (y1 >y2) then begin
      swapint(y1,y2);
      swapint(x1,x2);
    end;
    if (x2 > x1) then xinc:=1
                 else xinc:=-1;
    dy:=y2-y1;
    dx:=abs(x2-x1);
    p:=2*dx-dy;
    ainc:=2*(dx-dy);
    binc:=2*dx;
    x:=x1;y:=y1;
    putpixel(x,y,c);
    for y:=y1+1 to y2 do begin
      if (p>=0) then begin
        inc(x,xinc);
        inc(p,ainc);
      end
      else inc(p,binc);
       putpixel(x,y,c);
    end;
  end
   else begin
    if (x1>x2) then begin
      swapint(x1,x2);
      swapint(y1,y2);
    end;
    if (y2>y1) then yinc:=1
    else yinc:=-1;
    dx:=x2-x1;
    dy:=abs(y2-y1);
    p:=2*dy-dx;
    ainc:=2*(dy-dx);
    binc:=2*dy;
    x:=x1;y:=y1;
    putpixel(x,y,c);
    for x:=x1+1 to x2 do begin
      if (p>=0) then begin
        inc(y,yinc);
        inc(p,ainc);
      end
      else inc(p,binc);
      putpixel(x,y,c);
    end;
  end;
end;
 
procedure ctverec(x,y,x1,y1:word;c:byte);
begin
  line(x,y,x1,y,c);
  line(x1,y,x1,y1,c);
  line(x1,y1,x,y1,c);
  line(x,y1,x,y,c);
end;
 
procedure gwrite(s: string;cp,cz,x,y: byte);
var j,c : byte;
begin
  for j:=1 to length(s) do begin
    c:=ord(s[j]);
    asm
      mov ah,2
      mov bh,0
      mov dh,y
      mov dl,x
      int 10h
      mov ah,9
      mov al,c
      mov bh,cp
      mov bl,cz
      mov cx,1
      int 10h
    end;
    inc(x);
  end;
end;
 
procedure perspektiva(zobrplocha,xp,yp,zp:integer;var x,y:word);
var pomer: integer;
begin
  dec(xp,160);dec(yp,100);
  x:=xp*zobrplocha div zp;
  y:=yp*zobrplocha div zp;
  inc(x,160);inc(y,100);
end;
{
PROCEDURE InitGraph;assembler;
asm
  mov ax,13h
  int 10h
end;
 
PROCEDURE ClrScr;assembler;
 asm mov es,SegA000
     xor di,di
     mov cx,16000
     db 66h;xor ax,ax
     db 66h;rep stosw
 end;
}
procedure clearscreen;
begin
  pozadi(black);
end;
 
procedure pozadi(c:byte);
var i:word;
begin
  for i:=0 to 64000 do mem[sega000:i]:=c;
end;
 
FUNCTION  GetPixel(x,y:word):byte;assembler;
 asm mov es,SegA000
     mov ax,320
     mul y
     add ax,x
     xchg ax,bx
     mov al,[es:bx]
 end;
 
procedure poly(x1,y1,x2,y2,x3,y3,x4,y4:word;c:byte);
begin
  line(x1,y1,x2,y2,c);
  line(x2,y2,x3,y3,c);
  line(x3,y3,x4,y4,c);
  line(x4,y4,x1,y1,c);
end;
 
 
PROCEDURE PutPixel(x,y:word;barva:byte);assembler;
asm mov es,SegA000
    mov ax,320
    mul y
    add ax,x
    xchg ax,bx
    mov al,barva
    mov [es:bx],al
end;
 
END.