unit vlib;
interface
uses crt;
const scr:pointer=ptr($a000,0);
type pal=array[0..767] of byte;
var pal_akt,pal_des:pal;
    tlo:pointer;
    zmienna:word;

procedure Init;
procedure Clinit;
procedure GetBk;
procedure FreeBk;
procedure WaitVbl;
procedure Plot(xe,ye:integer;c:byte);
function GetPlot(xe,ye:integer):byte;
procedure GetPal(var p:pal);
procedure SetPal(p:pal);
procedure SetColor(nr,Rpal,Gpal,Bpal:byte);
procedure GetColor(nr:byte;var Rpal,Gpal,Bpal:byte);
procedure Fader;
procedure Spread(nr1,r1,g1,b1,nr2,r2,g2,b2:byte);
procedure Cls(color:byte);
procedure Bar(x1,y1,x2,y2:word;color:byte);
procedure Box(x1,y1,x2,y2:word;color:byte);
procedure Line(x1,y1,x2,y2:word;color:byte);
procedure LineH(x1,x2,y:word;c:byte);
procedure LineV(x,y1,y2:word;c:byte);
procedure Circle(xc,yc,rc:word;cc:byte);
procedure Circle_Fill(xc,yc,rc:word;cc:byte);
procedure Beep(Hz,t:word);
procedure Kasza(zakr:byte);
function Click:boolean;
function GetKey:char;

implementation

procedure Init;
begin
  asm
    mov ax,13h
    int 10h
  end;
  DirectVideo:=false;
  port[$3ce]:=6;
  port[$3cf]:=1;
end;

procedure Clinit;
begin
  asm
    mov ax,3h
    int 10h
  end;
end;

procedure GetBk;
begin
  GetMem(tlo,64000);
  move(mem[$0A000:0000],mem[seg(tlo^):ofs(tlo^)],64000);
end;

procedure FreeBk;
begin
  FreeMem(tlo,64000);
end;

procedure WaitVbl;
begin
    repeat until (port[$3DA] and 8)=8;
    repeat until (port[$3DA] and 8)=0;
end;

procedure plot(xe,ye:integer;c:byte);assembler;
asm
  mov ax,$A000
  mov es,ax
  mov dx,ye
  mov di,xe
  shl dx,6
  add di,dx
  shl dx,2
  add di,dx
  mov al,c
  mov es:[di],al
end;

function getplot(xe,ye:integer):byte;
begin
  asm
    mov ax,$A000
    mov es,ax
    mov dx,ye
    mov di,xe
    shl dx,6
    add di,dx
    shl dx,2
    add di,dx
    mov al,es:[di]
    mov @Result,al
  end;
end;

procedure GetPal(var p:pal); assembler;
asm
  mov dx,3c8h
  xor al,al
  out dx,al
  inc dx
  mov cx,768
  les di,p
  rep insb
end;


procedure SetPal(p:pal); assembler;
asm
  push ds
  push ds
  mov ax,ds
  mov es,ax
  mov di,offset pal_akt
  lds si,p
  mov cx,768/4
  db 66h; rep movsw
  pop ds
  mov dx,3c8h
  xor al,al
  out dx,al
  mov si,offset pal_akt
  mov cx,768
  mov dx,$3c9
  rep outsb
  pop ds
end;

procedure SetColor(nr,Rpal,Gpal,Bpal:byte);
begin
  pal_akt[(nr shl 2)-nr+0]:=Rpal;
  pal_akt[(nr shl 2)-nr+1]:=Gpal;
  pal_akt[(nr shl 2)-nr+2]:=Bpal;
  port[$3c8]:=nr;
  port[$3c9]:=Rpal;
  port[$3c9]:=Gpal;
  port[$3c9]:=Bpal;
end;

procedure GetColor(nr:byte;var Rpal,Gpal,Bpal:byte);
begin
  port[$3c7]:=nr;
  Rpal:=port[$3c9];
  Gpal:=port[$3c9];
  Bpal:=port[$3c9];
end;

procedure Fader;
var l1,l2:word;
    pal_fad:pal;
begin
  move(pal_akt,pal_fad,768);
  for l1:=1 to 64 do begin
    for l2:=0 to 767 do begin
      pal_akt[l2]:=round((pal_des[l2]-pal_fad[l2])*l1 shr 6)+pal_fad[l2];
    end;
    WaitVbl;
    asm
      push ds
      mov dx,3c8h
      xor al,al
      out dx,al
      mov si,offset pal_akt
      mov cx,768
      mov dx,$3c9
      rep outsb
      pop ds
    end;
  end;
end;

procedure Spread(nr1,r1,g1,b1,nr2,r2,g2,b2:byte);
var lc:integer;
    Rp,Gp,Bp:byte;
    macroM:real;
begin
  if nr2<nr1 then
  begin
    rp:=r1;
    gp:=g1;
    bp:=b1;
    r1:=r2;
    g1:=g2;
    b1:=b2;
    r2:=rp;
    g2:=gp;
    b2:=bp;
    lc:=nr1;
    nr1:=nr2;
    nr2:=lc;
  end;
  for lc:=nr1 to nr2 do begin
    macroM:=(lc-nr1)/(nr2-nr1);
    Rp:=round(r1+(r2-r1)*macroM);
    Gp:=round(g1+(g2-g1)*macroM);
    Bp:=round(b1+(b2-b1)*macroM);
    pal_akt[(lc shl 2)-lc+0]:=Rp;
    pal_akt[(lc shl 2)-lc+1]:=Gp;
    pal_akt[(lc shl 2)-lc+2]:=Bp;
  end;
  asm
    push ds
    mov dx,3c8h
    xor al,al
    out dx,al
    mov si,offset pal_akt
    mov cx,768
    mov dx,$3c9
    rep outsb
    pop ds
  end;
end;

procedure Cls(color:byte);assembler;
asm
  mov ax,0a000h
  mov es,ax
  xor di,di
  db 66h
  xor ax,ax
  mov al,color
  mov ah,al
  mov bx,ax
  db 66h
  shl ax,16
  mov ax,bx
  mov cx,16000
  db 66h
  rep stosW
end;

procedure Bar(x1,y1,x2,y2:word;color:byte);assembler;
asm
    mov ax,$A000
    mov es,ax
    mov dx,y1
    mov di,x1
    xchg dh,dl
    add di,dx
    shr dx,2
    add di,dx
    mov cx,y2
    sub cx,y1
    inc cx
    mov ah,color
    mov al,ah

@Y: mov bx,cx
    mov cx,x2
    sub cx,x1
    inc cx
    rep stosB
    add di,319
    sub di,x2
    add di,x1

    mov cx,bx
    Loop @Y
end;

procedure Box(x1,y1,x2,y2:word;color:byte);
begin
  LineH(x1,x2,y1,color);
  LineH(x1,x2,y2,color);
  LineV(x1,y1,y2,color);
  LineV(x2,y1,y2,color);
end;

procedure Line(x1,y1,x2,y2:word;color:byte);
var
  wsk1,wsk2,podpr:word;
begin
asm

        push si
        push di
        push es
        mov ax,$a000
        mov es,ax
        mov si,320
        mov cx,x2
        sub cx,x1
        jz  @@VL
        jns @@pdr1
        neg cx
        mov bx,x2
        xchg bx,x1
        mov x2,bx
        mov bx,y2
        xchg bx,y1
        mov y2,bx
@@pdr1:
        mov bx,y2
        sub bx,y1
        jz @@HL
        jns @@pdr3
        neg bx
        neg si
@@pdr3:
        push si
        mov podpr,offset @@LL1
        cmp bx,cx
        jle @@pdr4
        mov podpr,offset @@HL1
        xchg bx,cx
@@pdr4:
        shl bx,1
        mov wsk1,bx
        sub bx,cx
        mov si,bx
        sub bx,cx
        mov wsk2,bx
        push cx
        mov ax,y1
        mov bx,x1

       xchg ah,al
       add bx,ax
       shr ax,1
       shr ax,1
       add bx,ax

        mov di,bx
        pop cx
        inc cx
        pop bx
        jmp podpr
@@VL:
        mov ax,y1
        mov bx,y2
        mov cx,bx
        sub cx,ax
        jge @@pdr31
        neg cx
        mov ax,bx
@@pdr31:
        inc cx
        mov bx,x1
        push cx
       xchg ah,al
       add bx,ax
       shr ax,1
       shr ax,1
       add bx,ax

        pop cx
        mov di,bx
        dec si
        mov al,color
@@pdr32:
        stosb
        add di,si
        loop @@pdr32
        jmp @@Exit
@@HL:
        push cx
        mov ax,y1
        mov bx,x1

       xchg ah,al
       add bx,ax
       shr ax,1
       shr ax,1
       add bx,ax

        mov di,bx
        pop cx
        inc cx
        mov al,color
        rep stosb
        jmp @@Exit
@@LL1:
        mov al,color
@@pdr11:
        stosb
        or si,si
        jns @@pdr12
        add si,wsk1
        loop @@pdr11
        jmp @@Exit
@@pdr12:
        add si,wsk2
        add di,bx
        loop @@pdr11
        jmp @@Exit
@@HL1:
        mov al,color
@@pdr21:
        stosb
        add di,bx
@@pdr22:
        or si,si
        jns @@pdr23
        add si,wsk1
        dec di
        loop @@pdr21
        jmp @@Exit
@@pdr23:
        add si,wsk2
        loop @@pdr21
@@Exit:
        pop es
        pop di
        pop si

 end;
end;

procedure LineH(x1,x2,y:word;c:byte);assembler;
asm
  mov ax,x1
  cmp ax,x2
  jb @ok
  xchg ax,x2
  mov x1,ax
@ok:

  mov ax,0A000h
  mov es,ax
  mov dx,y
  mov di,x1
  xchg dh,dl
  add di,dx
  shr dx,2
  add di,dx
  mov cx,x2
  sub cx,x1
  inc cx
  mov al,c
  rep Stosb
end;

procedure LineV(x,y1,y2:word;c:byte);assembler;
asm
  mov ax,0A000h
  mov es,ax
  mov dx,y1
  mov di,x
  xchg dh,dl
  add di,dx
  shr dx,2
  add di,dx
  mov cx,y2
  sub cx,y1
  inc cx
  mov al,c
@p:
  StosB
  add di,319
  loop @p

end;

procedure Circle(xc,yc,rc:word;cc:byte);
begin
  if rc=0 then begin plot(xc,yc,cc); exit; end;
  asm
    push ds
    mov cx,0
    mov ax,rc
    mov dx,1
    sub dx,rc
@do:
    push dx
    push $a000
    pop es
    mov dx,yc
    mov di,xc
    xchg dh,dl
    add di,dx
    shr dx,2
    add di,dx

    {push yc+y}
    push di
    mov dx,ax
    shl dx,6
    add di,dx
    shl dx,2
    add di,dx

    mov dl,cc
    mov bx,cx
    mov es:[di+bx],dl
    not bx
    inc bx
    mov es:[di+bx],dl
    pop di
    {push yc-y}
    push di
    mov dx,ax
    not dx
    inc dx
    shl dx,6
    add di,dx
    shl dx,2
    add di,dx

    mov dl,cc
    mov bx,cx
    mov es:[di+bx],dl
    not bx
    inc bx
    mov es:[di+bx],dl
    pop di
    {push yc+x}
    push di
    mov dx,cx
    shl dx,6
    add di,dx
    shl dx,2
    add di,dx

    mov dl,cc
    mov bx,ax
    mov es:[di+bx],dl
    not bx
    inc bx
    mov es:[di+bx],dl
    pop di
    {push yc-x}
    push di
    mov dx,cx
    not dx
    inc dx
    shl dx,6
    add di,dx
    shl dx,2
    add di,dx

    mov dl,cc
    mov bx,ax
    mov es:[di+bx],dl
    not bx
    inc bx
    mov es:[di+bx],dl
    pop di
    pop dx

    inc cx
    cmp dx,0
    jl @subd
    dec ax
    mov bx,cx
    sub bx,ax
    shl bx,1
    add dx,bx
    inc dx
    jmp @cont
@subd:
    mov bx,cx
    shl bx,1
    add dx,bx
    inc dx
@cont:
    cmp cx,ax
    jna @do
    pop ds
  end;
end;

procedure Circle_Fill(xc,yc,rc:word;cc:byte);
begin
  if rc=0 then begin plot(xc,yc,cc); exit; end;
  asm
    push ds
    mov cx,0
    mov ax,rc
    mov dx,1
    sub dx,rc
@do:
    push dx
    les di,scr
    mov dx,yc
    mov di,xc
    xchg dh,dl
    add di,dx
    shr dx,2
    add di,dx

    {push yc+y}
    push di
    mov dx,ax
    shl dx,6
    add di,dx
    shl dx,2
    add di,dx
    sub di,cx

    push ax
    push cx
    shl cx,1
    inc cx
    mov al,cc
    rep stosB
    pop cx
    pop ax
    pop di
    {push yc-y}
    push di
    mov dx,ax
    not dx
    inc dx
    shl dx,6
    add di,dx
    shl dx,2
    add di,dx
    sub di,cx

    push ax
    push cx
    shl cx,1
    inc cx
    mov al,cc
    rep stosB
    pop cx
    pop ax
    pop di
    {push yc+x}
    push di
    mov dx,cx
    shl dx,6
    add di,dx
    shl dx,2
    add di,dx
    sub di,ax

    push ax
    push cx
    mov cx,ax
    shl cx,1
    inc cx
    mov al,cc
    rep stosB
    pop cx
    pop ax
    pop di
    {push yc-x}
    push di
    mov dx,cx
    not dx
    inc dx
    shl dx,6
    add di,dx
    shl dx,2
    add di,dx
    sub di,ax

    push ax
    push cx
    mov cx,ax
    shl cx,1
    inc cx
    mov al,cc
    rep stosB
    pop cx
    pop ax
    pop di

    pop dx

    inc cx
    cmp dx,0
    jl @subd
    dec ax
    mov bx,cx
    sub bx,ax
    shl bx,1
    add dx,bx
    inc dx
    jmp @cont
@subd:
    mov bx,cx
    shl bx,1
    add dx,bx
    inc dx
@cont:
    cmp cx,ax
    jna @do
    pop ds
  end;
end;

procedure Beep(Hz,t:word);
begin
  Sound(Hz);
  delay(t);
  nosound;
end;

procedure Kasza(zakr:byte);
var kx,ky:word;
begin
  for ky:=0 to 199 do for kx:=0 to 319 do Plot(kx,ky,random(zakr));
end;

function Click:boolean;
begin
  Click:=keypressed;
end;

function GetKey:char;
begin
  GetKey:=Readkey;

end;

begin
end.





Published in: Pascal
Download

Related snippets