type PalInfoType=array[0..15] of byte;
MousePtr=^MouseRec;
MouseRec=record
x,y,
oldx,oldy:integer;
cursor:pointer;
end;
page2type=array[0..64000] of byte;
var Blend:PalInfoType;
curx,cury:integer;
minfo:mouseptr;
msback:pointer;
page2:^page2type;
{----------------------------------------------------------------------}
procedure Pal(col,r,g,b:byte);
{Change the red, green, and blue intensities of a given color COL}
assembler;
asm
mov
al,[col]
mov
dx,03C8h
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(col:byte; var r,g,b:byte);
{Gets the red, green, and blue attributes of color COL}
var rr,gg,bb:byte;
begin
asm
mov
dx,03C7h
mov
al,col
out
dx,al
add
dx,2
in
al,dx
mov
[rr],al
in
al,dx
mov
[gg],al
in
al,dx
mov
[bb],al
end;
r:=rr; g:=gg; b:=bb;
end;
{-----------------------------------------------------------------------}
procedure PutPixel(x,y:integer; col:byte);
{This puts down a pixel at (X,Y) in color COL}
assembler;
asm
push
0a000h {ES = $A000}
pop
es
mov
ax,[y] {AX = Y}
mov
bx,ax {BX =
Y (faster than MOV bx,[y])}
shl
ax,6
{AX = AX * 64 (Y*64)}
shl
bx,8
{BX = BX * 128 (Y*256)}
add
ax,bx {AX =
AX + BX (Y*64 + Y*256 = Y*320}
add
ax,[x] {AX = AX +
X (Y*320 + X)}
mov
di,ax {DI (offset)
= AX}
mov
al,[col] {AL = color}
stosb
{ES:DI = Col (mem[$a000:y*320+x]:=col;)}
end;
{----------------------------------------------------------------------}
procedure SetColor(col,pos:byte);
{This is a unique way to draw a colored line. A process that
Jeremey
uses (he is a genius!). Anyway, there is an array of max
16 colors (0..15).
You can store color values in as many slots in the array Blend
as you want.
Then, when you draw a line, it draws the line in the colors that
you specify}
assembler;
asm
push
bx {Save AX & BX}
push
ax
mov
si,offset Blend {Set SI to Blend offset}
xor
bx,bx
{BX = 0}
mov
al,[col] {AL
= Col(or)}
mov
bl,[pos] {BL
(BX) = Pos(ition)}
cmp
bl,15
{If Pos > 15, then get outta here!}
ja
@Quit
mov
[si+bx],al {Blend[BX]:=Col}
@Quit:
pop
ax
pop
bx {Restore AX & BX}
end;
{----------------------------------------------------------------------}
procedure SaveScreen(filename:string);
{Saves the entire screen!}
var f:file; dummy:word;
p:pointer;
begin
assign(f,filename);
rewrite(f,1);
p:=ptr($a000,0);
{P = pointer to beginning of video mem}
blockwrite(f,p^,64000,dummy);
close(f);
end;
{----------------------------------------------------------------------}
procedure LoadScreen(filename:string);
{Loads an entire screen-saved image}
var f:file; dummy:word;
p:pointer;
begin
assign(f,filename);
{$I-}
reset(f,1);
{$I+}
if IOResult<>0 then exit;
p:=ptr($a000,0);
blockread(f,p^,64000,dummy);
close(f);
end;
{----------------------------------------------------------------------}
procedure SaveImage(bitmap:pointer; filename:string; where:word);
{This will save an image stored in a bitmap to the hard drive under
the file
name you pass. Each file can contain a max of 65535 different
images in it.
Where is the variable which tells the record location for the current
image
you are saving... For example, if you could do:
saveimage(bitmap,'test.pic',1);
then
loadimage(bitmap,'test.pic',1);
putimage(10,10,bitmap,NormalPut);
}
var buf,dummy,tempcount,
x,y,l1:word;
f:file;
begin
buf:=0; tempcount:=0;
if where=0 then exit;
{If file location = 0, we've errored! :( }
assign(f,filename);
if where=1 then
rewrite(f,1)
{If first record, rewrite file}
else begin
{$I-}
reset(f,1);
{$I+}
if IOResult<>0 then
exit;
if where=$ffff then
seek(f,filesize(f)) else {If file location}
repeat
{65353, then go to}
seek(f,filepos(f)+buf);
{end of file}
blockread(f,x,2,dummy);
blockread(f,y,2,dummy);
buf:=(x+1)*(y+1);
{Finds the linear length of each}
inc(tempcount);
{previous bitmap}
until tempcount=where;
end;
x:=memw[seg(bitmap^):ofs(bitmap^)];
y:=memw[seg(bitmap^):ofs(bitmap^)+2];
blockwrite(f,x,2,dummy);
blockwrite(f,y,2,dummy);
l1:=(y+1)*(x+1);
{Calculates linear length of current bitmap}
blockwrite(f,bitmap^,l1+2,dummy);
close(f);
end;
{----------------------------------------------------------------------}
procedure LoadImage(var bitmap:pointer; filename:string; where:word);
var xdiff,ydiff,l1,dummy,
tempcount,buf:word;
f:file;
begin
buf:=0; tempcount:=0;
assign(f,filename);
{$I-}
reset(f,1);
{$I+}
if IOResult<>0 then begin
close(f);
exit;
end;
repeat
seek(f,filepos(f)+buf);
blockread(f,xdiff,2,dummy);
blockread(f,ydiff,2,dummy);
buf:=(xdiff+1)*(ydiff+1);
inc(tempcount);
until tempcount=where;
getmem(bitmap,(xdiff+1)*(ydiff+1));
memw[seg(bitmap^):ofs(bitmap^)]:=xdiff;
memw[seg(bitmap^):ofs(bitmap^)+2]:=ydiff;
l1:=(ydiff+1)*(xdiff+1);
blockread(f,bitmap^,l1,dummy);
close(f);
end;
{----------------------------------------------------------------------}
procedure wait; {Clears the keyboard buffer, and waits
for a keypress}
var r:char;
begin
MEM[$0040:$001A]:=MEM[$0040:$001C]; {Clears keyboard
buffer}
r:=readkey;
end;
{----------------------------------------------------------------------}
procedure GetImageASM(x1,y1,x2,y2:integer; bitmap:pointer);
var xorig:integer;
begin
getmem(bitmap,(x2-x1+1)*(y2-y1+1)+4);
asm
push
ds
les di,[bitmap]
mov
ax,[x1]
mov
[xorig],ax
mov
ax,[x2]
mov
cx,ax
sub
ax,[x1]
inc
ax
stosw
mov
ax,[y2]
mov
dx,ax
sub
ax,[y1]
inc
ax
stosw
mov
ax,0A000h
mov
ds,ax
@RepeatX:
mov
ax,[y1]
mov
bx,ax
shl
ax,6
shl
bx,8
add
ax,bx
mov
si,ax
add
si,[x1]
inc
[x1]
cmp
cx,[x1]
jne
@RepeatX
inc
[y1]
cmp
dx,[y1]
mov
ax,[xorig]
mov
[x1],ax
jne
@RepeatX
pop
ds
end;
end;
{----------------------------------------------------------------------}
procedure ClearPalette;
{Initializes the Blend Array}
assembler;
asm
mov si,offset Blend
{Prepare to clear out blend palette array}
xor bx,bx
xor ax,ax
{AX = BX = 0}
mov cx,16
{Slots in array}
@ClearArray:
mov
[si+bx],al
inc
bx
{BX = BX + 1}
loop @ClearArray
end;
{----------------------------------------------------------------------}
procedure GetImage(x1,y1,x2,y2:integer; var bitmap:pointer; needmem:boolean);
{This simply stores the box designated by (x1,y1)-(x2,y2) into
the pointer
NeedMem is a boolean. If true, then this procedure
gets the necessary
memory for the pointer. Else, it relies on the
programmer getting the mem
in his procs. (if NeedMem is false)}
var l1,l2,factor:word;
begin
factor:=3;
if needmem then
getmem(bitmap,(x2-x1+1)*(y2-y1+1)+4);
memw[seg(bitmap^):ofs(bitmap^)]:=(x2-x1);
memw[seg(bitmap^):ofs(bitmap^)+2]:=(y2-y1);
for l1:=y1 to y2 do
for l2:=x1 to
x2 do begin
inc(factor);
mem[seg(bitmap^):ofs(bitmap^)+factor]:=mem[$A000:(l1*320)+l2];
end;
end;
{----------------------------------------------------------------------}
procedure PutImage(x,y:integer; bitmap:pointer; mode:byte);
var l1,l2,factor,xdiff,ydiff:word;
{This simply puts the image stored in a pointer back onto the screen.
It can
XorPut it, AndPut it, NOrmal Put it, NoDistort (doesn't distort
background,
or ORPut it...}
begin
factor:=3;
xdiff:=memw[seg(bitmap^):ofs(bitmap^)];
ydiff:=memw[seg(bitmap^):ofs(bitmap^)+2];
for l1:=y to (y+ydiff) do
for l2:=x to (x+xdiff)
do begin
inc(factor);
case mode of
NormalPut:mem[$a000:(320*l1)+l2]:=
mem[seg(bitmap^):ofs(bitmap^)+factor];
AndPut:mem[$a000:(320*l1)+l2]:=mem[$A000:(320*l1)+l2] and
mem[seg(bitmap^):ofs(bitmap^)+factor];
XORPut:mem[$a000:(320*l1)+l2]:=mem[$A000:(320*l1)+l2] xor
mem[seg(bitmap^):ofs(bitmap^)+factor];
ORPut:mem[$a000:(320*l1)+l2]:=mem[$A000:(320*l1)+l2] or
mem[seg(bitmap^):ofs(bitmap^)+factor];
NoDistort:if mem[seg(bitmap^):ofs(bitmap^)+factor]<>0 then
mem[$a000:(320*l1)+l2]:=
mem[seg(bitmap^):ofs(bitmap^)+factor];
end;
end;
end;
{----------------------------------------------------------------------}
procedure initgraph(mode:byte);
{Initializes the graphics card. If mode = 1 --> 320x200x256...
If mode = 0 --> Text mode (80x25)}
assembler;
asm
push ax
{Save AX & BX}
pop bx
xor ax,ax
{AX=0}
mov bh,[mode]
{AH=Mode}
cmp bh,0
{Does Mode=0}
ja @ModeX
{If Mode<>0 then set ModeX}
mov ax,3
{AX = 3 (Set text mode)}
int 10h
{Initialize graphics (call interrupt 10h)}
jmp @AllDone
{Let's get the hell outta here}
@ModeX:
{Initialize 320x200x256}
mov ax,13h
{AX=13h (320x200x256 (Mode-X))}
int 10h
mov si,offset Blend
{Prepare to clear out blend palette array}
xor bx,bx
xor ax,ax
{AX = BX = 0}
mov cx,16
{Slots in array}
@ClearArray:
mov
[si+bx],al
inc
bx
{BX = BX + 1}
loop @ClearArray
@AllDone:
pop bx
pop ax
{Restore AX & BX}
end;
{----------------------------------------------------------------}
procedure line(xa,y1,xb,y2:integer; pos:byte);
{Draws a line from (xa,y1) to (xb,y2) in color COL...
This procedure was created
by some smart graphics guy who worked at
IBM. ANyway, what this
does, instead of using real tricky math (no
pun intended) by using the
quadratic, this procedure closes in
horizontally on the center
of the line. If this is our line, and the
period represents the center,
then we just execute a loop which
plots points at XA,Y1 and
XB,Y2.
(xa,y1)
\
\
\
.
\
\
\
(xb,y2)
We then increase XA by one
and decrease XB by one. We then have a
rather simple equation that
determines if our y value will change. If
the equation is positive,
that means, "Hey, change the Y value by one."
If it is negative, do nothing.
So, if it is positive, we increment Y1
by one and decrement Y2 by
one. We repeat this until XA=XB. Simple &
Fast.... :) (About
5 times faster than using real math!)}
var var1,dummy,var2,deltax,deltay,d:integer;
ncol:byte;
xahi,y1hi,done:boolean;
{************************************************************}
procedure HLine(x1,x2,y:integer;
col:byte);
{Draws a horizontal line}
var ncol:byte;
dummy:integer;
begin
if x1>x2 then begin dummy:=x1; x1:=x2; x2:=dummy; end;
{Checks to see if x vars need to be switched}
repeat
ncol:=blend[random(pos+1)];
putpixel(x1,y,ncol);
putpixel(x2,y,ncol);
inc(x1); dec(x2); {Closes in horizontally}
until x1>x2;
end;
{************************************************************+}
procedure VLine(x,y1,y2:integer;
col:byte);
{Draws a verticle line}
var ncol:byte;
dummy:integer;
begin
if y1>y2 then begin dummy:=y1; y1:=y2; y2:=dummy; end;
{Checks to see if y vars need to be switched}
repeat
ncol:=blend[random(pos+1)];
putpixel(x,y1,ncol); putpixel(x,y2,ncol);
inc(y1); dec(y2); {Closes in vertically}
until y1>y2;
end;
{************************************************************+}
begin
xahi:=false; y1hi:=false;
done:=false;
ncol:=blend[random(pos+1)];
if (y1=y2) and (xa=xb) then begin
putpixel(xa,y1,ncol);
exit;
end;
if xa>xb then xahi:=true; {Notifies
proc. if xa > xb or y1>y2}
if y1>y2 then y1hi:=true;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@ HOR/VOR CHECK @@@@@@@@@@@@@@@@@@@@@@@@@@@@}
if y1=y2 then begin
{Checks to see if it should draw a horizontal}
HLine(xa,xb,y1,pos);
{line or not...}
exit;
end;
if xa=xb then begin
VLine(xa,y1,y2,pos);
{Checks to see if it should draw a verticle}
exit;
{line or not...}
end;
{@@@@@@@@@@@@@@@@@@@@@@@@@@@ HOR/VOR CHECK @@@@@@@@@@@@@@@@@@@@@@@@@@@}
deltay:=abs(y2-y1); deltax:=abs(xa-xb);{\
}
d:=(deltay shl 1) - deltax;
{ \ }
var1:=deltay shl 1;
{ Set in stone variables}
var2:=(deltay - deltax) shl 1;
{ / }
repeat
ncol:=blend[random(pos+1)];
putpixel(xa, y1, ncol); { Draw a
pixel at upper-left tracer }
putpixel(xb, y2, ncol); { Draw a
pixel at the lower-right tracer }
if d<0 then
{If d = - then no y change}
d:=d+var1
{Add VAR1 to d}
else begin
d:=d+var2;
{Add VAR2 to d}
if not(y1hi) then
begin
inc(y1); dec(y2);
{Since d = +, bring down YA (y1) and shove YB up}
end else begin
dec(y1); inc(y2);
end;
end;
if not(xahi) then begin
inc(xa);
dec(xb); {Close in horizontally}
if
xa>xb then done:=true;
end else begin
dec(xa);
inc(xb);
if
xb>xa then done:=true; {See if completed drawing line}
end;
until xa>xb
end;
{----------------------------------------------------------------------}
procedure Cls(col:byte);
{Clears the screen in color COL}
assembler;
asm
mov cx,64000
push 0A000h
pop es
xor di,di
mov al,[col]
rep stosb
end;
{---------------------------------------------------------------------}
procedure FadeASM(delay:word);
{This fades out the colors evenly. The speed of the fade
is determined by
the delay value passed}
assembler;
var redl,greenl,bluel:byte;
asm
mov
[redl],63
mov
[greenl],63 {Set Level Vars to MAX}
mov
[bluel],63
{-----------------------------------------------}
{This block decrements the shade by one, 64 times:}
@MainLoop:
mov
dx,100
@delaylooptop:
mov cx,[delay]
@delayloop:
{The delay loop}
loop @delayloop
dec dx
cmp dx,0
ja @delaylooptop
xor ax,ax {Sets AH & AL to 0}
@DecrementShade:
{----------------------------------------------}
{Makes PORT Calls and stores Red,Green,& Blue
Registers Destroyed:
DX BH
AL CL
BL AH }
mov dx,03C7h
{Write to Port $3c7}
mov al,ah
{set AL = to AH (AL = COlor Value)}
out dx,al
{Send color to port $3c7}
add dx,2
{Write to Port $3c9}
in al,dx
{Get port value}
mov bl,al
{BL = red}
in al,dx
{Get port value}
mov bh,al
{BH = green}
in al,dx
{Get port value}
mov cl,al
{CL = blue}
mov al,ah
{Reset AL to color value (AH)}
{------------------------------------------}
{Checks to see if levels need to be decremented
Registers Destroyed =
BL BH
CL }
cmp bl,[redl]
{Does Red = RedL(evel)?}
jna @skipred
dec bl
@skipred:
cmp bh,[greenl]
{If the color's value is}
jna @skipgreen
{greater than greenl, then
decrement by one}
dec bh
@skipgreen:
cmp cl,[bluel]
jna @skipblue
dec cl
@skipblue:
{--------------------------------------}
{Sends to Port to confirm palette changes}
mov
dx,03C8h
out
dx,al
inc
dx
mov
al,bl {Move RED into AL}
out
dx,al {Send to port}
mov
al,bh {Move GREEN into AL}
out
dx,al
mov
al,cl {Move Blue (CL) into AL}
out
dx,al
{---------------------------------------------}
inc ah {Increment COLOR NUMBER}
cmp ah,255
jne @DecrementShade {Are we at
color 255 yet? If not
goto decrementshade}
dec [redl]
dec [greenl] {Decrement necessary
color values}
dec [bluel]
cmp [redl],0 {Have we looped
trough MainLoop 64 times?}
je @QuitLoop {If so, Quit}
jmp @MainLoop {ELSE goto
MainLoop}
@QuitLoop:
end;
{----------------------------------------------------------------------}
procedure Clear(x1,y1,x2,y2:integer; pos:byte);
{This draws a filled rectangle from (x1,y1) to (x2,y2)}
var loop,l2:word;
begin
for loop:=y1 to y2 do
for l2:=x1 to
x2 do
PutPixel(l2,loop,blend[random(pos+1)]);
end;
{----------------------------------------------------------------------}
procedure rect(x1,y1,x2,y2:integer; pos:byte);
{Draws a hollow rectangle from (x1,y1) to (x2,y2)}
begin
line(x1,y1,x2,y1,pos);
line(x2,y1,x2,y2,pos);
line(x2,y2,x1,y2,pos);
line(x1,y1,x1,y2,pos);
end;
{----------------------------------------------------------------------}
--=====================_837406168==_--
Get your own Free Homepage