[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
version 2.02
copile/use this in far model
wait for the new 3.00 version - 70k large
{$G+}
type VirtualArray = array[1..64000] of byte;
VPointer = ^VirtualArray;
coor = record
x,y:word;
end;
coordtyp = array [1..2,1..12] of integer;
fp = longint;
var coord : array [1..20] of coor;
{ ******************************* DOS ************************************ }
function DosMax : longint;assembler;{vrati velikost volne dol. pam. v bytech}
asm {OK}
mov bx,0ffffh
mov ah,48h
int 21h
mov ax,bx
mov bx,16
mul bx
end;
function GMem(size:longint) : pointer;assembler;
asm {OK}
@@1:
mov ax,word ptr [size]
mov dx,word ptr [size+2]
mov cx,16
div cx
inc ax
mov bx,ax
mov ah,48h
int 21h
jnc @@2
xor ax,ax
@@2:
mov dx,ax
xor ax,ax
end;
procedure FMem(p:pointer);assembler;
asm {OK}
mov es,word ptr [p+2]
mov ah,49h
int 21h
end;
function ReAlloc(p:pointer; newsize:longint) : pointer;assembler;
asm {OK}
mov ax,word ptr [p+2]
mov es,ax
mov ax,word ptr [newsize]
mov dx,word ptr [newsize+2]
mov cx,16
div cx
inc ax
mov bx,ax
mov ah,4ah
int 21h
jnc @@end
xor dx,dx
xor ax,ax
@@end:
end;
{ ******************************* CRT ************************************ }
{ MOUSE }
procedure MouseInit(no:word);assembler;
asm
mov ax,no
int 33h
end;
procedure GetMouse(var x,y,b:word);assembler;
asm {OK}
mov ax,3
int 33h
les di,dword ptr [bp+0eh]
mov word ptr es:[di],bx
les di,dword ptr [bp+0ah]
mov word ptr es:[di],cx
les di,dword ptr [bp+6]
mov word ptr es:[di],dx
end;
procedure SetMWin(x,y,x2,y2:word);assembler;
asm {OK}
mov ax,7
mov cx,[x]
mov dx,[x2]
int 33h
inc ax
mov cx,[y]
mov dx,[y2]
int 33h
end; {OK}
procedure NewCur(hotspotx,hotspoty:word;var newcursor);assembler;
asm
mov ax,word ptr newcursor+2
mov es,ax
mov dx,word ptr newcursor
mov ax,9h
mov bx,hotspotx
mov cx,hotspoty
int 33h
end;
{ KEYBOARD }
procedure KeybOn;assembler;
asm {OK}
in al,21h
and al,11111101b
out 21h,al
end;
procedure KeybOff;assembler;
asm {OK}
in al,21h
or al,00000010b
out 21h,al
end;
function KeyPressed:boolean;
begin
asm
mov ah,1
int 16h
jnz @true
mov [@result],false
jmp @end
@true:
mov [@result],true
@end:
end;
end;
function ReadKey:char;assembler;
asm {OK}
mov ah,0h
int 16h
end;
{ PC SPEAKER }
procedure NoSound;assembler;
asm {OK}
in al,61h
and al,0fch
out 61h,al
end;
procedure Sound(hz:word);assembler;
asm {OK}
mov bx,hz
mov ax,34ddh
mov dx,0012h
cmp dx,bx
jnc @2
div bx
mov bx,ax
in al,61h
test al,3
jnz @1
or al,3
out 61h,al
mov al,0b6h
out 43h,al
@1:
mov al,bl
out 42h,al
mov al,bh
out 42h,al
@2:
end;
{ MISCELANEOUS }
procedure XDelay(ms:word);assembler;
asm {OK}
mov ax,1000
mul ms
mov cx,dx
mov dx,ax
mov ah,86h
int 15h
end;
{ ******************************** GRAPH ********************************** }
{ BASIC }
procedure SetVga(mode:word);assembler;
asm {OK}
mov ax,[mode]
int 10h
end;
procedure Cls(target:word);assembler;
asm {OK}
mov ax,[bp+offset target]
mov es,ax
xor di,di
db 66h; xor ax,ax
mov cx,16000
db 0f3h,66h,0abh
end;
procedure CCls(color:byte;target:word);assembler;
asm {OK}
mov ax,[target]
mov es,ax
xor di,di
mov cx,16000
mov al,[color]
mov ah,al {hi i low maji hodnotu barvy}
mov bx,ax
db 66h; shl ax,16 {ax*65535 -> hi word eax}
mov ax, bx {dolni word eax - v kazdym bytu eax je hodnota barvy}
db 0f3h,66h,0abh {rep movsd}
end;
procedure PPix(x,y: Integer;color:byte;target:word); assembler;
asm {OK}
mov ax,target
mov es,ax
mov ax,y
mov di,ax
shl ax,6
shl di,8
add di,ax
add di,x
mov al,color
mov es:[di],al
end;
function GPix(x,y:integer;target:word):byte;assembler;
asm {OK}
mov ax,target
mov es,ax
mov ax,y
mov di,ax
shl ax,6
shl di,8
add di,ax
add di,x
mov al,es:[di]
mov [bp-1],al
end;
{ 2D GRAPHIC }
procedure HLn(x1,x2,y:word;col:byte;target:word);assembler;
asm {OK}
mov ax,target
mov es,ax
mov ax,y
mov di,ax
shl ax,8
shl di,6
add di,ax
add di,x1 {pocatecni x1}
mov al,col
mov ah,al
mov cx,x2
sub cx,x1 {cx:=x2-x1}
inc cx
shr cx,1 {cx:=cx/2}
jnc @1 {sklace na @1 a misto stosb jede 2* rychlejsi stosw}
mov es:[di],ah
inc di
@1:
rep stosw {mov es:[di],ah cx/2*2 krat}
end;
procedure HLn32(x1,x2,y:word;col:byte;target:word);assembler;
asm {OK}
mov ax,target
mov es,ax
mov ax,y
mov di,ax
shl ax,8
shl di,6
add di,ax
add di,x1 {pocatecni x1}
mov al,col
mov ah,al
mov bx,ax
db $66; shl ax,16
mov ax,bx
mov cx,x2
sub cx,x1 {cx:=x2-x1}
inc cx
mov bx,cx
and bx,3
shr cx,2
db 66h; rep stosw
@2:
mov es:[di],al
add di,1
dec cx
jns @2
end;
procedure VLn(x1,y1,y2:word;c:byte;target:word);assembler;
asm {OK}
mov ax,x1
mov bx,y1
mov dx,y2
@1:
mov di,bx
mov cx,di
shl cx,8
shl di,6
add di,cx
add di,ax
mov cx,[target]
mov es,cx
mov cx,dx
sub cx,bx
inc cx
mov al,c
@2:
stosb
add di,319
loop @2
end;
procedure XLine(x,y,x2,y2:integer;color:byte;target:word);
var ax,bx,ay,by,f,aa,bb:integer;
begin
if x<x2 then begin ax:=1;bx:=x2-x; end
else begin ax:=-1;bx:=x-x2; end;
if y<y2 then begin ay:=1;by:=y2-y; end
else begin ay:=-1;by:=y-y2; end;
if bx>by then begin
aa:=(by-bx)*2;
bb:=by*2;
f:=bb-bx;
repeat
if(f>=0)then begin inc(y,ay);inc(f,aa);end
else inc(f,bb);inc(x,ax);
PPix(x,y,color,target);
until(x=x2);
end
else begin
aa:=(bx-by)*2;
bb:=bx*2;
f:=bb-by;
repeat
if(f>=0)then begin inc(x,ax);inc(f,aa);end
else inc(f,bb);inc(y,ay);
PPix(x,y,color,target);
until(y=y2);
end;
end;
procedure XCircle(x,y:integer;radius,ankle:word;color:byte;
presnost:word;posun:integer;target:word); {posun- 1/8 presnosti}
var g,h,e,f,c,d,a:real;
i,rotX,rotY:integer;
b:word;
begin
a:=presnost/ankle;
b:=round(presnost*(ankle/360));
c:=a*radius;
d:=(2*Pi)/presnost;
e:=5/6;
for i:=posun to posun+b do begin
f:=d*i;
g:=c*sin(f);
h:=c*cos(f);
rotX:=round((g-h)/a);
rotY:=round(((g+h)/a)*e);
ppix((rotX+x),(rotY+y),color,target);
end;
end;
procedure Ellipse(x,y,a,b:integer;c:byte;target:word);
var xa,ya:integer;
aa,aa2,bb,bb2,d,dx,dy:longint;
begin
xa:=0;ya:=b;
aa:=longint(a)*a;aa2:=2*aa;
bb:=longint(b)*b;bb2:=2*bb;
d:=bb-aa*b+aa div 4;
dx:=0;dy:=aa2*b;
ppix(x,y-ya,c,target);
ppix(x,y+ya,c,target);
ppix(x-a,y,c,target);
ppix(x+a,y,c,target);
while(dx<dy)do begin
if(d>0)then begin dec(ya);
dec(dy,aa2);
dec(d,dy);
end;
inc(xa);
inc(dx,bb2);
inc(d,bb+dx);
ppix(x+xa,y+ya,c,target);
ppix(x-xa,y+ya,c,target);
ppix(x+xa,y-ya,c,target);
ppix(x-xa,y-ya,c,target);
end;
inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);
while(ya>0)do begin
if(d<0)then begin
inc(xa);
inc(dx,bb2);
inc(d,bb+dx);
end;
dec(ya);
dec(dy,aa2);
inc(d,aa-dy);
ppix(x+xa,y+ya,c,target);
ppix(x-xa,y+ya,c,target);
ppix(x+xa,y-ya,c,target);
ppix(x-xa,y-ya,c,target);
end;
end;
procedure FillEllipse(x,y,a,b:integer;c:byte;target:word);
var xa,ya:integer;
aa,aa2,bb,bb2,d,dx,dy:longint;
begin
xa:=0;ya:=b;
aa:=longint(a)*a;
aa2:=2*aa;
bb:=longint(b)*b;
bb2:=2*bb;
d:=bb-aa*b+aa div 4;
dx:=0;dy:=aa2*b;
vLn(x,y-ya,y+ya,c,target);
while(dx<dy)do begin
if(d>0)then begin dec(ya);
dec(dy,aa2);
dec(d,dy);
end;
inc(xa);
inc(dx,bb2);
inc(d,bb+dx);
vLn(x-xa,y-ya,y+ya,c,target);
vLn(x+xa,y-ya,y+ya,c,target);
end;
inc(d,(3*(aa-bb)div 2-(dx+dy))div 2);
while(ya>=0)do begin
if(d<0)then begin
inc(xa);
inc(dx,bb2);
inc(d,bb+dx);
vLn(x-xa,y-ya,y+ya,c,target);
vLn(x+xa,y-ya,y+ya,c,target);
end;
dec(ya);
dec(dy,aa2);
inc(d,aa-dy);
end;
end;
procedure Triangle(x1,y1,x2,y2,x3,y3:integer;color:byte;target:word);
var
x,minY,maxY,ax,bx,yy,p1,q1,p2,q2,p3,q3:integer;
begin
minY:=y1; maxY:=y1;
if y2<minY then minY:=y2;
if y2>maxY then maxY:=y2;
if y3<minY then minY:=y3;
if y3>maxY then maxY:=y3;
p1:=x1-x3; q1:=y1-y3;
p2:=x2-x1; q2:=y2-y1;
p3:=x3-x2; q3:=y3-y2;
for yy:=minY to maxY do
begin
ax:=320;
bx:=-1;
if (y3>=yy) or (y1>=yy) then
if (y3<=yy) or (y1<=yy) then
if not(y3=y1) then begin
x:=(yy-y3)*p1 div q1+x3;
if x<ax then ax:=x;
if x>bx then bx:=x;
end;
if (y1>=yy) or (y2>=yy) then
if (y1<=yy) or (y2<=yy) then
if not(y1=y2) then begin
x:=(yy-y1)*p2 div q2+x1;
if x<ax then ax:=x;
if x>bx then bx:=x;
end;
if (y2>=yy) or (y3>=yy) then
if (y2<=yy) or (y3<=yy) then
if not(y2=y3) then begin
x:=(yy-y2)*p3 div q3+x2;
if x<ax then ax:=x;
if x>bx then bx:=x;
end;
if ax<=bx then hln(ax,bx,yy,color,target);
end;
end;
procedure XTriangle(x1,y1,x2,y2,x3,y3:integer;color:byte;target:word);assembler;
var tmp1,tmp2,neg1,neg2,ax1,ax2,ay1,ay2:integer;
asm {OK}
cli {y-trideni}
mov cx,2 {cx=2}
@sort:
mov ax,[y2]
cmp ax,[y3]
jbe @ok1 { if y2 <= y3 then @ok1 }
xor ax,[y3]
xor [y3],ax
xor ax,[y3]
mov [y2],ax
mov ax,[x2] {ted neco jako xchg y2,y3}
xor ax,[x3]
xor [x3],ax
xor ax,[x3]
mov [x2],ax {stejne pro x}
@ok1:
mov ax,[y1]
cmp ax,[y2]
jbe @ok2 {kdyz je y1 vetsi,jak y2 pak na @3}
xor ax,[y2]
xor [y2],ax
xor ax,[y2]
mov [y1],ax {jinak xchg y1,y2}
mov ax,[x1]
xor ax,[x2]
xor [x2],ax
xor ax,[x2]
mov [x1],ax {xchg x1,x2}
@ok2:
mov ax,[y1]
cmp ax,[y3]
jbe @ok3 {y1<=y3 pak ok}
xor ax,[y3]
xor [y3],ax
xor ax,[y3]
mov [y1],ax {xchg y1,y3}
mov ax,[x1]
xor ax,[x3]
xor [x3],ax
xor ax,[x3] {xchg x1,x3}
mov [x1],ax
@ok3:
loop @sort
mov dx,[y1] {vypocet offsetu}
shl dx,6
mov bx,dx
shl dx,2
add dx,bx
add dx,[x1]
mov si,dx {si,dx:=320*y1+x1}
mov ax,[y3] {vypocet ay-nu}
sub ax,[y1]
inc ax
mov [ay1],ax {*ay1=y3-y1}
mov [tmp1],ax {*tmp1=y3-y1}
mov ax,[y2]
sub ax,[y1]
inc ax
mov [ay2],ax {*ay2=y2-y1}
mov [tmp2],ax {*tmp2=y2-y1}
{vypocet ax-u}
mov [neg1],1 {*if1=1}
mov ax,[x3]
sub ax,[x1] {ax,sirka}
jnc @noneg1 {kdyz>=0 pak skip, jinak}
neg ax {a dostanu abs(x3-x1)}
neg [neg1] {*neg1=65535}
@noneg1:
inc ax {inc sirka}
mov [ax1],ax {*ax1=x3-x1}
mov [neg2],1 {*neg2=1}
mov ax,[x2]
sub ax,[x1]
jnc @noneg2 {x2-x1 jnc skok}
neg ax {neg-abs}
neg [neg2] {*neg2=65535}
@noneg2:
inc ax
mov [ax2],ax {*ax2=x2-x1}
mov ax,[target]
mov es,ax
mov al,[color]
mov ah,al {ax,color}
mov cx,[ay2] {od y1 do y2}
@draw1:
push cx
mov di,dx {hln}
mov cx,si
cmp cx,di
ja @noswap1
xchg cx,di
@noswap1:
sub cx,di
inc cx
shr cx,1
jnc @1
stosb
@1:
rep stosw
{zmena tmpu a ay}
mov bx,[tmp1] {bx=y3-y1}
sub bx,[ax1] {bx:=(y3-y1)-(x3-x1)}
cmp bx,0
jg @no1 {=0 then skok, else..}
@yes1:
add bx,[ay1] {bx:=2*(y3-y1)-(x3-x1)}
add dx,[neg1] {add dx,1 nebo 65535}
cmp bx,0
jle @yes1 {loop}
@no1:
add dx,320 {offset+320}
mov [tmp1],bx
mov bx,[tmp2] {y2-y1}
sub bx,[ax2] {-(x2-x1)}
cmp bx,0
jg @no2
@yes2:
add bx,[ay2]
add si,[neg2]
cmp bx,0
jle @yes2 {dokud bx>=0}
@no2:
add si,320 {add ofs2,320}
mov [tmp2],bx
pop cx
loop @draw1
{2. cast polyho}
push dx
mov dx,[y3]
sub dx,[y2]
inc dx
mov [ay2],dx
mov [tmp2],dx
mov [neg2],1
mov dx,[x3]
sub dx,[x2]
jnc @x2pos
neg dx
neg [neg2]
@x2pos:
inc dx
mov [ax2],dx
pop dx
mov cx,[ay2]
@draw2:
push cx
mov di,dx
mov cx,si
cmp cx,di
ja @noswap2
xchg cx,di
@noswap2:
sub cx,di
inc cx
shr cx,1
jnc @2
stosb
@2:
rep stosw
mov bx,[tmp1]
sub bx,[ax1]
cmp bx,0
jg @no3
@yes3:
add bx,[ay1]
add dx,[neg1]
cmp bx,0
jle @yes3
@no3:
add dx,320
mov [tmp1],bx
mov bx,[tmp2]
sub bx,[ax2]
cmp bx,0
jg @no4
@yes4:
add bx,[ay2]
add si,[neg2]
cmp bx,0
jle @yes4
@no4:
add si,320
mov [tmp2],bx
pop cx
loop @draw2
@exit:
sti
end;
procedure Poly4(x1,y1,x2,y2,x3,y3,x4,y4:integer;color:byte;target:word);
var
x,minY,maxY,ax,bx,yy,p1,q1,p2,q2,p3,q3,p4,q4:integer;
begin
minY:=y1; maxY:=y1;
if y2<minY then minY:=y2;
if y2>maxY then maxY:=y2;
if y3<minY then minY:=y3;
if y3>maxY then maxY:=y3;
if y4<minY then minY:=y4;
if y4>maxY then maxY:=y4;
{y2-4 se porovnaji k y1, ziska se nejmensi a nejvetsi y}
if minY<0 then minY:=0;
if maxY>199 then maxY:=199;
if minY>199 then exit;
if maxY<0 then exit;
{nebude se prekreslovat zpatky}
p1:=x1-x4; q1:=y1-y4;
p2:=x2-x1; q2:=y2-y1;
p3:=x3-x2; q3:=y3-y2;
p4:=x4-x3; q4:=y4-y3;
{vzdalenosti mezi vsemy x a mezi vsemy y}
{pro vysku polyho dela..}
for yy:=minY to maxY do
begin
ax:=320;
bx:=-1;
if (y4>=yy) or (y1>=yy) then
if (y4<=yy) or (y1<=yy) then {jestlize je yy mezi y1 a y4 pak.. }
if not(y4=y1) then begin
x:=(yy-y4)*p1 div q1+x4;
if x<ax then ax:=x;
if x>bx then bx:=x;
end;
if (y1>=yy) or (y2>=yy) then
if (y1<=yy) or (y2<=yy) then {jestlize je yy mezi y1 a y2 pak..}
if not(y1=y2) then begin
x:=(yy-y1)*p2 div q2+x1;
if x<ax then ax:=x;
if x>bx then bx:=x;
end;
if (y2>=yy) or (y3>=yy) then
if (y2<=yy) or (y3<=yy) then {jestlize je yy mezi y2 a y3 pak..}
if not(y2=y3) then begin
x:=(yy-y2)*p3 div q3+x2;
if x<ax then ax:=x;
if x>bx then bx:=x;
end;
if (y3>=yy) or (y4>=yy) then
if (y3<=yy) or (y4<=yy) then {jestlize je yy mezi y3 a y4 pak..}
if not(y3=y4) then begin
x:=(yy-y3)*p4 div q4+x3;
if x<ax then ax:=x;
if x>bx then bx:=x;
end;
if ax<0 then ax:=0;
if bx>319 then bx:=319;
if ax<=bx then hln(ax,bx,yy,color,target); {horesli horiz. caru}
end;
end;
procedure PolyInit(var init:coordtyp;PocetBodu:byte);
var i:byte;
begin
for i:=1 to PocetBodu do
begin
coord[i].x:=init[1,i];
coord[i].y:=init[2,i];
end;
end;
procedure XPoly(rohu:byte;color:byte;target:word);
type int=record
p,q:integer;
end;
var yy,x,ax,bx,i,minY,maxY:integer;
internal:array[1..20] of int;
begin
minY:=coord[1].y;
maxY:=coord[1].y;
for i:=2 to rohu do begin
if coord[i].y<minY then minY:=coord[i].y;
if coord[i].y>maxY then maxY:=coord[i].y;
end;
if minY<0 then minY:=0;
if maxY>199 then maxY:=199;
if minY>199 then exit;
if maxY<0 then exit;
internal[1].p:=coord[1].x-coord[rohu].x;
internal[1].q:=coord[1].y-coord[rohu].y;
for i:=0 to rohu-2 do
begin
internal[i+2].p:=coord[i+2].x-coord[i+1].x;
internal[i+2].q:=coord[i+2].y-coord[i+1].y;
end;
for yy:=minY to MaxY do
begin
ax:=320;
bx:=-1;
if (coord[rohu].y>=yy) or (coord[1].y>=yy) then
if (coord[rohu].y<=yy) or (coord[1].y<=yy) then
if not(coord[rohu].y=coord[1].y) then begin
x:=(yy-coord[rohu].y)*internal[1].p div internal[1].q+coord[rohu].x;
if x<ax then ax:=x;
if x>bx then bx:=x;
end;
if ax<0 then ax:=0;
if bx>319 then bx:=319;
if ax<=bx then hln(ax,bx,yy,color,target);
for i:=0 to rohu-2 do begin
if (coord[i+1].y>=yy) or (coord[i+2].y>=yy) then
if (coord[i+1].y<=yy) or (coord[i+2].y<=yy) then
if not(coord[i+1].y=coord[i+2].y) then begin
x:=(yy-coord[i+1].y)*internal[i+2].p div internal[i+2].q+coord[i+1].x;
if x<ax then ax:=x;
if x>bx then bx:=x;
if ax<0 then ax:=0;
if bx>319 then bx:=319;
if ax<=bx then hln(ax,bx,yy,color,target);
end;
end;
end;
end;
{ PALETTE }
procedure SetRGB(color,r,g,b:Byte);assembler;
asm {OK}
mov dx,3c8h
mov al,[Color]
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 GetRGB(Color:byte;var r,g,b:byte);assembler;
asm {OK}
mov dx,3c7h
mov al,[color]
out dx,al
inc dx
inc dx
in al,dx
les di,dword ptr [bp+14]
mov byte ptr es:[di],al
in al,dx
les di,dword ptr [bp+10]
mov byte ptr es:[di],al
in al,dx
les di,dword ptr [bp+6]
mov byte ptr es:[di],al
end;
procedure RotPal(r,g,b:byte;skipR,skipG,skipB:boolean;loops,ms:integer);
type
tcount = record
r,g,b:real;
end;
var
i,c,rr,gg,bb:byte;
red,blue,green:real;
current,count:array [0..255] of tcount;
begin
for c:=0 to 255 do begin
getrgb(c,rr,gg,bb);
if skipr=false then count[c].r:=(r-rr)/loops;
if skipg=false then count[c].g:=(g-gg)/loops;
if skipb=false then count[c].b:=(b-bb)/loops;
current[c].r:=rr;
current[c].g:=gg;
current[c].b:=bb;
end;
for i:=1 to loops do begin
for c:=0 to 255 do begin
if skipr=false then current[c].r:=count[c].r+current[c].r;
if skipg=false then current[c].g:=count[c].g+current[c].g;
if skipb=false then current[c].b:=count[c].b+current[c].b;
setrgb(c,round(current[c].r),round(current[c].g),round(current[c].b));
end;
xdelay(ms);
end;
end;
procedure FadeIn(r,g,b:byte;loops,ms:integer);
type
tcount = record
r,g,b:real;
end;
var
i,c,rr,gg,bb:byte;
red,blue,green:real;
current,count:array [0..255] of tcount;
begin
for c:=0 to 255 do begin
getrgb(c,rr,gg,bb);
count[c].r:=(r-rr)/loops;
count[c].g:=(g-gg)/loops;
count[c].b:=(b-bb)/loops;
current[c].r:=rr;
current[c].g:=gg;
current[c].b:=bb;
end;
for i:=1 to loops do begin
for c:=0 to 255 do begin
current[c].r:=count[c].r+current[c].r;
current[c].g:=count[c].g+current[c].g;
current[c].b:=count[c].b+current[c].b;
setrgb(c,round(current[c].r),round(current[c].g),round(current[c].b));
end;
xdelay(ms);
end;
end;
{ VIRTUAL SCREENS }
function VSetup(VScreen:VPointer):word;
begin {OK}
new(Vscreen);
VSetup:=seg(vscreen^);
end;
procedure VDispose(Va:word);
var vscreen:pointer absolute va;
begin {OK}
dispose(Vscreen);
end;
procedure Flip(source,target:word);assembler;
asm {OK}
push ds {kdyz se neulozi, pak je hodnota pointru nil a je to v prdeli}
mov ax,target
mov es,ax {target:=es:[di]}
mov ax,Source
mov ds,ax {sourcre:=ds:[si]}
xor si,si
xor di,di
mov cx,16000
db $f3,66h,$a5 {rep movsd}
pop ds
end;
procedure FImage(x1,y1,x2,y2,sx,sy:integer;source,target:word);assembler;
asm
push ds
mov ax,target
mov es,ax {target:=es:[di]}
mov ax,Source
mov ds,ax {sourcre:=ds:[si]}
mov si,y1
mov ax,si
shl si,6
shl ax,8
add si,ax
add si,x1 {source}
mov di,sy
mov ax,di
shl di,6
shl ax,8
add di,ax
add di,sx {dest}
mov cx,y2
sub cx,y1
inc cx {h}
mov dx,x2
sub dx,x1
inc dx {w}
mov ax,dx
and ax,3
@loop:
mov bx,cx
mov cx,dx
shr cx,2
db 66h; rep movsw
mov cx,ax
rep movsb
add si,320
add di,320
sub si,dx
sub di,dx
mov cx,bx
loop @loop
pop ds
end;
{ IMGAES & BITMAPS }
procedure Bitmap(x,y,w,h:word;var bitmap);assembler;
asm
push ds
mov ax,word ptr bitmap+2
mov ds,ax
mov ax,$0a000
mov es,ax
mov si,word ptr bitmap
mov ax,[y]
mov di,ax
shl ax,8
shl di,6
add di,ax
add di,[x]
mov cx,[h]
@loop:
mov bx,cx
mov cx,[w]
shr cx,1
jnc @1
movsb
@1:
rep movsw
add di,320
sub di,[w]
mov cx,bx
loop @loop
pop ds
end;
procedure RLEBitmap(x,y,w,h:word;var bitmap);assembler;
asm
push ds
mov ax,word ptr bitmap+2
mov ds,ax
mov ax,$0a000
mov es,ax
xor si,si
xor di,di
mov si,word ptr bitmap
mov ax,[y]
mov di,ax
shl ax,8
shl di,6
add di,ax
add di,[x]
mov cx,[h]
@loop:
mov bx,cx
mov cx,[w]
@1:
mov al,ds:[si]
cmp al,0
je @2
mov es:[di],al
@2:
inc di
inc si
loop @1
add di,320
sub di,[w]
mov cx,bx
loop @loop
pop ds
end;
procedure ScBitmap(x,y,w,h,tox,toy:word;var bitmap);
var tmp1,rx,repx,restx,ry,repy,resty:word;
{tmp1=add di,320 sub di,tox}
begin
repx:=tox div w;
restx:=tox mod w;
rx:=restx;
repy:=toy div h;
resty:=toy mod h;
ry:=resty;
asm
mov ax,320
sub ax,tox
mov tmp1,ax
push ds
mov ax,word ptr bitmap+2
mov ds,ax
mov ax,0a000h
mov es,ax
mov si,word ptr bitmap
mov ax,[y]
mov di,ax
shl ax,8
shl di,6
add di,ax
add di,[x]
mov cx,[h]
@loop:
mov dx,cx
mov bx,repy
@line:
mov cx,[w]
@pixel:
mov ax,repx
@rep:
movsb
dec si
dec ax
jnz @rep
mov ax,restx
cmp ax,0
je @no_rest
movsb
dec restx
dec si
@no_rest:
inc si
dec cx
jnz @pixel
add di,tmp1
mov ax,rx
mov restx,ax
sub si,[w]
dec bx
jnz @line
mov bx,resty
cmp bx,0
je @no_ry
mov cx,[w]
@pixel2:
mov ax,repx
@rep2:
movsb
dec si
dec ax
jnz @rep2
mov ax,restx
cmp ax,0
je @no_rest2
movsb
dec restx
dec si
@no_rest2:
inc si
dec cx
jnz @pixel2
add di,tmp1
mov ax,rx
mov restx,ax
sub si,[w]
dec bx
mov resty,bx
@no_ry:
add si,[w]
mov cx,dx
dec cx
jnz @loop
end;
end;
procedure GImage(x,y,x2,y2:word;p:pointer);assembler;
asm {OK}
push ds
mov es,word ptr p+2
mov di,word ptr p
mov ax,0a000h
mov ds,ax
mov dx,[bp+offset x2]
sub dx,[bp+offset x]
inc dx
mov ax,dx
and ax,3
mov es:[di],dx {sirka dx}
mov cx,[bp+offset y2]
sub cx,[bp+offset y]
inc cx
mov es:[di+2],cx {vyska cx}
add di,4
mov si,[bp+offset y]
mov bx,si
shl si,8
shl bx,6
add si,bx
add si,[bp+offset x]
@loop:
mov bx,cx
mov cx,dx
shr cx,2
db 66h; rep movsw
mov cx,ax
rep movsb
add si,320
sub si,dx
mov cx,bx
loop @loop
pop ds
end;
procedure PImage(x,y:word;p:pointer);assembler;
asm
push ds
mov ds,word ptr p+2
mov si,word ptr p
mov ax,0a000h
mov es,ax
mov cx,word ptr ds:[si+2] {vyska}
mov ax,word ptr ds:[si]
mov dx,ax {sirka}
and ax,3 {sub dx,(dx shr,2 ; dx shl,2)}
add si,4
mov di,[bp+offset y]
mov bx,di
shl di,8
shl bx,6
add di,bx
add di,[bp+offset x]
@loop:
mov bx,cx
mov cx,dx
shr cx,2
db 66h; rep movsw
mov cx,ax
rep movsb
add di,320
sub di,dx
mov cx,bx
loop @loop
pop ds
end;
procedure Save2File(x,y,x2,y2:integer;filename:string);
var
f:file;
p:pointer;
size:word;
begin
assign(f,filename);
size:=abs(x2-x)*abs(y2-y)+10;
rewrite(f,size);
GetMem(p,size);
GImage(x,y,x2,y2,p);
BlockWrite(f,p^, 1);
freemem(p,size);
close(f);
end;
procedure LoadFFile(x,y,sx,sy,sx2,sy2:integer;filename:string);
var
f:file;
p:pointer;
size:word;
begin
assign(f,filename);
size:=abs(sx2-sx)*abs(sy2-sy)+10;
reset(f,size);
GetMem(p,size);
BlockRead(f,p^, 1);
PImage(x,y,p);
FreeMem(p,size);
close(f);
end;
{ SCROLLING }
procedure ScrollDown(x1,y1,x2,y2:integer);assembler;
asm {OK}
push ds
mov ax,$a000
mov es,ax
mov ds,ax
mov si,[y1]
mov cx,[y2]
mov ax,cx
mov bx,cx
shl ax,8
shl bx,6
add ax,bx
sub cx,si
inc cx
mov bx,[x1]
mov dx,[x2]
add ax,bx
sub dx,bx
inc dx
cld
@1:
mov bx,cx
mov di,ax
mov si,ax
sub si,320
mov cx,dx
shr cx,2
db $f3,$66,$a5 {rep movsd}
mov cx,dx
and cx,3
rep movsb
@2:
mov cx,bx
sub ax,320
loop @1
pop ds
end;
procedure ScrollLeft(X1,Y1,X2,Y2:integer);assembler;
asm {OK}
push ds
mov ax,$a000
mov es,ax
mov ds,ax
mov si,[y1]
mov ax,si
shl ax,6
shl si,8
add si,ax
mov cx,[y2]
sub cx,si
inc cx
mov dx,[x1]
add ax,dx
mov bx,[x2]
sub bx,dx
inc bx
cld
@1:
mov dx,cx
mov di,ax
dec di
mov si,ax
mov cx,bx
shr cx,2
db $f3,$66,$a5 {rep movsd}
mov cx,bx
and cx,3
rep movsb
@2:
mov cx,dx
add ax,320
loop @1
pop ds
end;
procedure ScrollRight(x1,y1,x2,y2:integer);assembler;
asm {OK}
push ds
mov ax,$a000
mov es,ax
mov ds,ax
mov si,[y1]
mov ax,si
shl ax,6
shl si,8
add si,ax
mov cx,[y2]
sub cx,si
inc cx
mov dx,[x1]
mov bx,[x2]
add ax,bx
sub bx,dx
inc bx
std
@1:
mov dx,cx
mov di,ax
mov si,ax
dec si
mov cx,bx
shr cx,2
db $f3,$66,$a5 {rep movsd}
mov cx,bx
and cx,3
rep movsb
@2:
mov cx,dx
add ax,320
loop @1
cld
pop ds
end;
procedure ScrollUp(x1,y1,x2,y2:integer);assembler;
asm {OK}
push ds
mov ax,$a000
mov es,ax
mov ds,ax
mov si,[y1]
mov cx,[y2]
sub cx,si
inc cx
mov ax,si
shl si,8
shl ax,6
add ax,si
mov dx,[x1]
add ax,dx
mov bx,[x2]
sub bx,dx
inc bx
cld
@1:
mov dx,cx
mov di,ax
sub di,320
mov si,ax
mov cx,bx
shr cx,2
db $f3,$66,$a5 {rep movsd}
mov cx,bx
and cx,3
rep movsb
@2:
mov cx,dx
add ax,320
loop @1
pop ds
end;
{ MISCELANEOUS }
procedure WaitRet; assembler;
asm {OK}
mov dx,3dah
@1:
in al,dx
test al,08h
jnz @1
@2:
in al,dx
test al,08h
jz @2
end;
{ VESA }
var VI : record
MAtrib : word;
WinA : byte;
WinB : byte;
WGran : word;
WSize : word;
WsegA : word;
WsegB : word;
SetBank : procedure;
ScanLn : word;
ScreenW : word;
ScreenH : word;
CharW : byte;
CharH : byte;
Planes : byte;
BitsPixel : byte;
Banks : byte;
MemModel : byte;
BnkSize : byte;
ImgPages : byte;
Res1 : byte;
RMSize : byte;
RFPos : byte;
GMSize : byte;
GFPos : byte;
BMSize : byte;
BFPos : byte;
MSize : byte;
MPos : byte;
DCinfo : byte;
Res2 : byte;
trash : array [$2a..255] of byte;
end;
cbank : byte;
procedure GetMode(mode:word);assembler;
asm {OK}
mov ax,ds { protoze je to vlastne promenna }
mov es,ax
mov ax,4f01h
mov cx,mode
mov di,offset VI
int 10h
end;
function SetVesa(mode:word):boolean;assembler;
asm {OK}
mov ax,4f02h
mov bx,mode
int 10h
sub ax,004fh
mov [bp-1],al
end;
function GetVesa:word;assembler;
asm {OK}
mov ax,4f03h
int 10h
cmp ax,004fh
je @ok
mov ax,-1
jmp @end
@ok:
mov ax,bx
@end:
end;
procedure GScanLn(var BytesPerScanline,PixsPerScanline,NumOfScanlines:word);assembler;
asm {OK}
mov ax,4f06h
mov bl,01h
int 10h
les di,dword ptr [bp+0eh]
mov word ptr es:[di],bx
les di,dword ptr [bp+0ah]
mov word ptr es:[di],cx
les di,dword ptr [bp+6]
mov word ptr es:[di],dx
end;
procedure SScanLn(width:word);assembler;
asm {OK}
mov ax,4f06h
mov bl,00h
mov cx,word ptr width
int 10h
end;
procedure GDStart(var x,y:integer);assembler; { Get Display Start }
asm {OK}
mov ax,4f07h
mov bx,0001h
int 10h
les di,dword ptr [bp+0ah]
mov word ptr es:[di],cx
les di,dword ptr [bp+6]
mov word ptr es:[di],dx
end;
procedure SDStart(x,y:integer);assembler; { Set Display Start }
asm {OK}
mov ax,4f07h
sub bx,bx
mov cx,word ptr x
mov dx,word ptr y
int 10h
end;
procedure PPix8(x,y:word;c:byte);assembler;
{ vypocet efektivni adresy:
1024x768x256:
db 66h;mov di,y
db 66h;shl di,10
db 66h;add di,x ; y:=y*1024+x
db 66h;mov dx,di ; puvodni mul uklada to co se nevleze do r16,r/m16
db 66h;shr dx,16 ; do dx:ax, s dx se ale dal pracuje a nepouziva se
edx proto nakonci ten shrdx,16}
asm {OK}
mov ax,$0a000
mov es,ax
mov di,x
mov ax,y
mul vi.screenw
add di,ax
adc dx,0
cmp dl,cbank
je @skip
mov cbank,dl
mov ax,4f05h
xor bx,bx
adc dx,0
int 10h
@skip:
mov al,byte ptr c
mov es:[di],al
end;
{ ********************************* MATH ********************************** }
{ 8087x }
procedure Init8087;assembler;
asm
finit
end;
function fmul(s1,s2:single):single;
var s:single;
begin
asm
fld s1
fmul s2
fstp s
end;
fmul:=s;
end;
function fdiv(s1,s2:single):single;
var s:single;
begin
asm
fld s1
fdiv s2
fstp s
end;
fdiv:=s;
end;
function fadd(s1,s2:single):single;
var s:single;
begin
asm
fld s1
fadd s2
fstp s
end;
fadd:=s;
end;
function fsub(s1,s2:single):single;
var s:single;
begin
asm
fld s1
fsub s2
fstp s
end;
fsub:=s;
end;
function fabs(s1:single):single;
var s:single;
begin
asm
fld s1
fabs
fstp s
end;
fabs:=s;
end;
function fneg(s1:single):single;
var s:single;
begin
asm
fld s1
fchs
fstp s
end;
fneg:=s;
end;
function fsqrt(s1:single):single;
var s:single;
begin
asm
fld s1
fsqrt
fstp s
end;
fsqrt:=s;
end;
function fround(s1:single):single;
var s:single;
begin
asm
fld s1
frndint
fstp s
end;
fround:=s;
end;
procedure fnop;assembler;
asm
fnop
end;
function esc:byte;assembler;
asm
in al,60h
mov [bp-1],al
end;
{ ----------------------------- CUT HERE ---------------------------------- }
var va1,c,color:word;
x,y,Gd,Gm:integer;
vs1:vpointer;
p:pointer;
const Cur: array [0..1,0..15] of word=
(($FFCF, { 1111111111001111 } { PenCursor}
$FF87, { 1111111110000111 }
$FF03, { 1111111100000011 }
$FE01, { 1111111000000001 }
$FC03, { 1111110000000011 }
$F807, { 1111100000000111 }
$F00F, { 1111000000001111 }
$E01F, { 1110000000011111 }
$C03F, { 1100000000111111 }
$807F, { 1000000001111111 }
$00FF, { 0000000011111111 }
$01FF, { 0000000111111111 }
$03FF, { 0000001111111111 }
$07FF, { 0000011111111111 }
$0FFF, { 0000111111111111 }
$9FFF), { 1001111111111111 }
($0000, { 0000000000000000 }
$0030, { 0000000000110000 }
$0078, { 0000000001111000 }
$009C, { 0000000010011100 }
$01E8, { 0000000111101000 }
$03F0, { 0000001111110000 }
$07E0, { 0000011111100000 }
$0FC0, { 0000111111000000 }
$1F80, { 0001111110000000 }
$2700, { 0010011100000000 }
$7A00, { 0111101000000000 }
$5C00, { 0101110000000000 }
$4800, { 0100100000000000 }
$5000, { 0101000000000000 }
$6000, { 0110000000000000 }
$0000)); { 0000000000000000 }
const Cur2: array [0..1,0..15] of word=
(($0000, { 0000000000000000 }
$0000, { 0000000000110000 }
$0000, { 0000000001111000 }
$0000, { 0000000010011100 }
$0000, { 0000000111101000 }
$0000, { 0000001111110000 }
$0000, { 0000011111100000 }
$0000, { 0000111111000000 }
$0000, { 0001111110000000 }
$0000, { 0010011100000000 }
$0000, { 0111101000000000 }
$0000, { 0101110000000000 }
$0000, { 0100100000000000 }
$0000, { 0101000000000000 }
$0000, { 0110000000000000 }
$0000)
,($FFfF, { 1111111111001111 } { PenCursor}
$FFff, { 1111111110000111 }
$FFff, { 1111111100000011 }
$Ffff, { 1111111000000001 }
$Ffff, { 1111110000000011 }
$Ffff, { 1111100000000111 }
$FffF, { 1111000000001111 }
$fffF, { 1110000000011111 }
$fffF, { 1100000000111111 }
$ffff, { 1000000001111111 }
$ffFF, { 0000000011111111 }
$fffF, { 0000000111111111 }
$fFfF, { 0000001111111111 }
$fFFf, { 0000011111111111 }
$FfFF, { 0000111111111111 }
$FFfF)); { 1001111111111111 }
{ 0000000000000000 }
const map:array[1..7,1..17] of byte=(
(05,15,05,15,05,15,05,15,05,15,05,15,05,15,05,15,05),
(15,05,15,05,15,05,15,05,15,05,15,05,15,05,15,05,15),
(05,15,05,15,05,15,05,15,05,15,05,15,05,15,05,15,05),
(15,05,15,05,15,05,15,05,15,05,15,05,15,05,15,05,15),
(05,15,05,15,05,15,05,15,05,15,05,15,05,15,05,15,05),
(15,05,15,05,15,05,15,05,15,05,15,05,15,05,15,05,15),
(05,15,05,15,05,15,05,15,05,15,05,15,05,15,05,15,05));
const map2:array[1..7,1..17] of byte=(
(02,15,02,15,02,15,02,15,02,15,02,15,02,15,02,15,02),
(15,02,15,02,15,02,15,02,15,02,15,02,15,02,15,02,15),
(02,15,02,15,02,15,02,15,02,15,02,15,02,15,02,15,02),
(15,02,15,02,15,02,15,02,15,02,15,02,15,02,15,02,15),
(02,15,02,15,02,15,02,15,02,15,02,15,02,15,02,15,02),
(15,02,15,02,15,02,15,02,15,02,15,02,15,02,15,02,15),
(02,15,02,15,02,15,02,15,02,15,02,15,02,15,02,15,02));
const bar1 : coordtyp =((0,100,100,0,0,0,0,0,0,0,0,0),{x}
(0,0,100,100,0,0,0,0,0,0,0,0));{y}
begin
setvesa($101);
getmode($101);
ppix8(100,100,156);
ppix8(200,200,14);
readln;
setvga($13);
rlebitmap(100,100,17,7,map);
readln;
scbitmap(20,20,17,7,100,100,map2);
readln;
mouseinit(0);
mouseinit(1);
readln;
newcur(1,1,cur);
readln;
newcur(1,2,cur2);
readln;
xtriangle(50,50,100,100,100,0,14,$0a000);
xcircle(170,100,85,300,9,400,20,$0a000);
ppix(100,100,2,$0a000);
c:=gpix(100,100,$0a000);
ppix(101,100,c,$0a000);
repeat
SetRGB(16,x,y,63);
xcircle(170,100,85,300,16,400,20,$0a000);
x:=succ(x);
if x=63 then begin y:=y+9; x:=0;end;
xdelay(5);
until y=63;
p:=gmem(150);
{if realloc(p,10000)=nil then writeln('ee');}
{realloc(p,10050);}
p:=gmem(10050);
gimage(0,0,100,100,p);
ccls(14,$0a000);
pimage(30,30,p);
waitret;
readln;
cls($0a000);
Xline(0,0,300,199,1,$0a000);
{Poly(100,100,15,05,45,45,94,43,2,$0a000);}
readln;
va1:=vsetup(vs1);
flip($0a000,va1);
cls($0a000);
xline(0,100,319,100,2,$0a000);
randomize;
x:=0;
repeat
inc(x);
ppix(random(320),random(100),random(15),$0a000);
until x=200;
readln;
flip(va1,$0a000);
Vdispose(va1);
readln;
cls($0a000);
x:=330;
repeat
inc(x);
until x=3000;
x:=0;
repeat
ppix(random(320),random(200),random(15),$0a000);
inc(x);
until x=3000;{
polyinit(bar1,4);
xpoly(4,2,$0a000);
coord[1].x:=0;
coord[1].y:=0;
coord[2].x:=20;
coord[2].y:=5;
coord[3].x:=30;
coord[3].y:=30;
coord[4].x:=50;
coord[4].y:=40;
coord[5].x:=28;
coord[5].y:=100;
coord[6].x:=10;
coord[6].y:=60;
Xpoly(6,1,$0a000);
va1:=vsetup(vs1);
fimage(0,0,100,100,0,0,$0a000,va1);
readln;
fimage(0,0,100,100,219,100,va1,$0a000);
vdispose(va1);
readln; }
rotpal(63,0,0,false,false,false,63,18);
end.
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]