| Home | Submit | Free Hosting | Link To Us | Contacts |
Pascal Vlib Pascal
 Download (.zip)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.
|
