[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
{$A-,B-,D+,E-,F-,G+,I-,L+,N-,O-,R-,S-,V-,X+} {TP 6.0 & 286 required!}
Unit x320x240;
{
Sean Palmer, 1993
released to the Public Domain
in tweaked modes, each latch/bit plane contains the entire 8-bit pixel.
the sequencer map mask determines which plane (pixel) to update, and, when
reading, the read map select reg determines which plane (pixel) to read.
almost exactly opposite from regular vga 16-color modes which is why I never
could get my routines to work For BOTH modes. 8)
# = source screen pixel
Normal 16-color Tweaked 256-color
Bit Mask Bit Mask
76543210 33333333
Map 76543210 Map 22222222
Mask 76543210 Mask 11111111
76543210 00000000
Functional equivalents
Bit Mask = Seq Map Mask
Seq Map Mask = Bit Mask
}
Interface
Var
color : Byte;
Const
xRes = 320;
yRes = 240; {displayed screen size}
xMax = xRes - 1;
yMax = yRes - 1;
xMid = xMax div 2;
yMid = yMax div 2;
vxRes = 512;
vyRes = $40000 div vxRes; {virtual screen size}
nColors = 256;
tsx : Byte = 8;
tsy : Byte = 8; {tile size}
Procedure plot(x, y : Integer);
Function scrn(x, y : Integer) : Byte;
Procedure hLin(x, x2, y : Integer);
Procedure vLin(x, y, y2 : Integer);
Procedure rect(x, y, x2, y2 : Integer);
Procedure pane(x, y, x2, y2 : Integer);
Procedure line(x, y, x2, y2 : Integer);
Procedure oval(xc, yc, a, b : Integer);
Procedure disk(xc, yc, a, b : Integer);
Procedure fill(x, y : Integer);
Procedure putTile(x, y : Integer; p : Pointer);
Procedure overTile(x, y : Integer; p : Pointer);
Procedure putChar(x, y : Integer; p : Word);
Procedure setColor(color, r, g, b : Byte);
{rgb vals are from 0-63}
Function getColor(color : Byte) : LongInt;
{returns $00rrggbb format}
Procedure setPalette(color : Byte; num : Word; Var rgb);
{rgb is list of 3-Byte rgb vals}
Procedure getPalette(color : Byte; num : Word; Var rgb);
Procedure clearGraph;
Procedure setWriteMode(f : Byte);
Procedure waitRetrace;
Procedure setWindow(x, y : Integer);
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Implementation
Const
vSeg = $A000; {video segment}
vxBytes = vxRes div 4; {Bytes per virtual scan line}
seqPort = $3C4; {Sequencer}
gcPort = $3CE; {Graphics Controller}
attrPort = $3C0; {attribute Controller}
tableReadIndex = $3C7;
tableWriteIndex = $3C8;
tableDataRegister = $3C9;
CrtcRegLen = 10;
CrtcRegTable : Array [1..CrtcRegLen] of Word =
($0D06, $3E07, $4109, $EA10, $AC11, $DF12, $0014, $E715, $0616, $E317);
Var
CrtcPort : Word; {Crt controller}
oldMode : Byte;
ExitSave : Pointer;
input1Port : Word; {Crtc Input Status Reg #1=CrtcPort+6}
fillVal : Byte;
Type
tRGB = Record
r, g, b : Byte;
end;
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Procedure clearGraph; Assembler;
Asm
mov ax, vSeg
mov es, ax
mov dx, seqPort
mov ax, $0F02
out dx, ax {enable whole map mask}
xor di, di
mov cx, $8000 {screen size in Words}
cld
mov al, color
mov ah, al
repz stosw {clear screen}
end;
Procedure setWriteMode(f : Byte); Assembler;
Asm {copy/and/or/xor modes}
mov ah, f
shl ah, 3
mov al, 3
mov dx, gcPort
out dx, ax {Function select reg}
end;
Procedure waitRetrace; Assembler;
Asm
mov dx, CrtcPort
add dx, 6 {find Crt status reg (input port #1)}
@L1:
in al, dx
test al, 8
jnz @L1; {wait For no v retrace}
@L2:
in al, dx
test al, 8
jz @L2 {wait For v retrace}
end;
{
Since a virtual screen can be larger than the actual screen, scrolling is
possible. This routine sets the upper left corner of the screen to the
specified pixel. Make sure 0 <= x <= vxRes - xRes, 0 <= y <= vyRes - yRes
}
Procedure setWindow(x, y : Integer); Assembler;
Asm
mov ax, vxBytes
mul y
mov bx, x
mov cl, bl
shr bx, 2
add bx, ax {bx=Ofs of upper left corner}
mov dx, input1Port
@L:
in al, dx
test al, 8
jnz @L {wait For no v retrace}
sub dx, 6 {CrtC port}
mov al, $D
mov ah, bl
cli {these values are sampled at start of retrace}
out dx, ax {lo Byte of display start addr}
dec al
mov ah, bh
out dx, ax {hi Byte}
sti
add dx, 6
@L2:
in al, dx
test al, 8
jz @L2 {wait For v retrace}
{this also resets Attrib flip/flop}
mov dx, attrPort
mov al, $33
out dx, al {Select Pixel Pan Register}
and cl, 3
mov al, cl
shl al, 1
out dx, al {Shift is For 256 Color Mode}
end;
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Procedure plot(x, y : Integer); Assembler;
Asm
mov ax, vSeg
mov es, ax
mov di, x
mov cx, di
shr di, 2
mov ax, vxBytes
mul y
add di, ax
mov ax, $0102
and cl, 3
shl ah, cl
mov dx, seqPort
out dx, ax {set bit mask}
mov al, color
stosb
end;
Function scrn(x, y : Integer) : Byte; Assembler;
Asm
mov ax, vSeg
mov es, ax
mov di, x
mov cx, di
shr di, 2
mov ax, vxBytes
mul y
add di, ax
and cl, 3
mov ah, cl
mov al, 4
mov dx, gcPort
out dx, ax {Read Map Select register}
mov al, es:[di] {get the whole plane}
end;
Procedure hLin(x, x2, y : Integer); Assembler;
Asm
mov ax, vSeg
mov es, ax
cld
mov ax, vxBytes
mul y
mov di, ax {base of scan line}
mov bx, x
mov cl, bl
shr bx, 2
mov dx, x2
mov ch, dl
shr dx, 2
and cx, $0303
sub dx, bx {width in Bytes}
add di, bx {offset into video buffer}
mov ax, $FF02
shl ah, cl
and ah, $0F {left edge mask}
mov cl, ch
mov bh, $F1
rol bh, cl
and bh, $0F {right edge mask}
mov cx, dx
or cx, cx
jnz @LEFT
and ah, bh {combine left & right bitmasks}
@LEFT:
mov dx, seqPort
out dx, ax
inc dx
mov al, color
stosb
jcxz @EXIT
dec cx
jcxz @RIGHT
mov al, $0F
out dx, al {skipped if cx=0,1}
mov al, color
repz stosb {fill middle Bytes}
@RIGHT:
mov al, bh
out dx, al {skipped if cx=0}
mov al, color
stosb
@EXIT:
end;
Procedure vLin(x, y, y2 : Integer); Assembler;
Asm
mov ax, vSeg
mov es, ax
cld
mov di, x
mov cx, di
shr di, 2
mov ax, vxBytes
mul y
add di, ax
mov ax, $102
and cl, 3
shl ah, cl
mov dx, seqPort
out dx, ax
mov cx, y2
sub cx, y
inc cx
mov al, color
@DOLINE:
mov bl, es:[di]
stosb
add di, vxBytes-1
loop @DOLINE
end;
Procedure rect(x, y, x2, y2 : Integer);
Var
i : Word;
begin
hlin(x, pred(x2), y);
hlin(succ(x), x2, y2);
vlin(x, succ(y), y2);
vlin(x2, y, pred(y2));
end;
Procedure pane(x, y, x2, y2 : Integer);
Var
i : Word;
begin
For i := y2 downto y do
hlin(x, x2, i);
end;
Procedure line(x, y, x2, y2:Integer);
Var
d, dx, dy,
ai, bi, xi, yi : Integer;
begin
if(x < x2) then
begin
xi := 1;
dx := x2 - x;
end
else
begin
xi := -1;
dx := x - x2;
end;
if (y < y2) then
begin
yi := 1;
dy := y2 - y;
end
else
begin
yi := -1;
dy := y - y2;
end;
plot(x, y);
if dx > dy then
begin
ai := (dy - dx) * 2;
bi := dy * 2;
d := bi - dx;
Repeat
if (d >= 0) then
begin
inc(y, yi);
inc(d, ai);
end
else
inc(d, bi);
inc(x, xi);
plot(x, y);
Until (x = x2);
end
else
begin
ai := (dx - dy) * 2;
bi := dx * 2;
d := bi - dy;
Repeat
if (d >= 0) then
begin
inc(x, xi);
inc(d, ai);
end
else
inc(d, bi);
inc(y, yi);
plot(x, y);
Until (y = y2);
end;
end;
Procedure oval(xc, yc, a, b : Integer);
Var
x, y : Integer;
aa, aa2,
bb, bb2,
d, dx, dy : LongInt;
begin
x := 0;
y := 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;
plot(xc, yc - y);
plot(xc, yc + y);
plot(xc - a, yc);
plot(xc + a, yc);
While (dx < dy) do
begin
if(d > 0) then
begin
dec(y);
dec(dy, aa2);
dec(d, dy);
end;
inc(x);
inc(dx, bb2);
inc(d, bb + dx);
plot(xc + x, yc + y);
plot(xc - x, yc + y);
plot(xc + x, yc - y);
plot(xc - x, yc - y);
end;
inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);
While (y > 0) do
begin
if (d < 0) then
begin
inc(x);
inc(dx, bb2);
inc(d, bb + dx);
end;
dec(y);
dec(dy, aa2);
inc(d, aa - dy);
plot(xc + x, yc + y);
plot(xc - x, yc + y);
plot(xc + x, yc - y);
plot(xc - x, yc - y);
end;
end;
Procedure disk(xc, yc, a, b:Integer);
Var
x, y : Integer;
aa, aa2,
bb, bb2,
d, dx, dy : LongInt;
begin
x := 0;
y := 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;
vLin(xc, yc - y, yc + y);
While (dx < dy) do
begin
if (d > 0) then
begin
dec(y);
dec(dy, aa2);
dec(d, dy);
end;
inc(x);
inc(dx, bb2);
inc(d, bb + dx);
vLin(xc - x, yc - y, yc + y);
vLin(xc + x, yc - y, yc + y);
end;
inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);
While (y >= 0) do
begin
if (d < 0) then
begin
inc(x);
inc(dx, bb2);
inc(d, bb + dx);
vLin(xc - x, yc - y, yc + y);
vLin(xc + x, yc - y, yc + y);
end;
dec(y);
dec(dy, aa2);
inc(d, aa - dy);
end;
end;
{This routine only called by fill}
Function lineFill(x, y, d, prevXL, prevXR : Integer) : Integer;
Var
xl, xr, i : Integer;
Label
_1, _2, _3;
begin
xl := x;
xr := x;
Repeat
dec(xl);
Until (scrn(xl, y) <> fillVal) or (xl < 0);
inc(xl);
Repeat
inc(xr);
Until (scrn(xr, y) <> fillVal) or (xr > xMax);
dec(xr);
hLin(xl, xr, y);
inc(y, d);
if Word(y) <= yMax then
For x := xl to xr do
if (scrn(x, y) = fillVal) then
begin
x := lineFill(x, y, d, xl, xr);
if Word(x) > xr then
Goto _1;
end;
_1 :
dec(y, d + d);
Asm
neg d;
end;
if Word(y) <= yMax then
begin
For x := xl to prevXL do
if (scrn(x, y) = fillVal) then
begin
i := lineFill(x, y, d, xl, xr);
if Word(x) > prevXL then
Goto _2;
end;
_2 :
for x := prevXR to xr do
if (scrn(x, y) = fillVal) then
begin
i := lineFill(x, y, d, xl, xr);
if Word(x) > xr then
Goto _3;
end;
_3 :
end;
lineFill := xr;
end;
Procedure fill(x, y : Integer);
begin
fillVal := scrn(x, y);
if fillVal <> color then
lineFill(x, y, 1, x, x);
end;
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Procedure putTile(x, y : Integer; p : Pointer); Assembler;
Asm
push ds
lds si, p
mov ax, vSeg
mov es, ax
mov di, x
mov cx, di
shr di, 2
mov ax, vxBytes
mul y
add di, ax
mov ax, $102
and cl, 3
shl ah, cl {make bit mask}
mov dx, seqPort
mov bh, tsy
@DOLINE:
mov cl, tsx
xor ch, ch
push ax
push di {save starting bit mask}
@LOOP:
{mov al, 2}
out dx, ax
shl ah, 1 {give it some time to respond}
mov bl, es:[di]
movsb
dec di
test ah, $10
jz @SAMEByte
mov ah, 1
inc di
@SAMEByte:
loop @LOOP
pop di
add di, vxBytes
pop ax {start of next line}
dec bh
jnz @DOLINE
pop ds
end;
Procedure overTile(x, y : Integer; p : Pointer); Assembler;
Asm
push ds
lds si, p
mov ax, vSeg
mov es, ax
mov di, x
mov cx, di
shr di, 2
mov ax, vxBytes
mul y
add di, ax
mov ax, $102
and cl, 3
shl ah, cl {make bit mask}
mov bh, tsy
mov dx, seqPort
@DOLINE:
mov ch, tsx
push ax
push di {save starting bit mask}
@LOOP:
mov al, 2
mov dx, seqPort
out dx, ax
shl ah, 1
xchg ah, cl
mov al, 4
mov dl, gcPort and $FF
out dx, ax
xchg ah, cl
inc cl
and cl, 3
lodsb
or al, al
jz @SKIP
mov bl, es:[di]
cmp bl, $C0
jae @SKIP
stosb
dec di
@SKIP:
test ah, $10
jz @SAMEByte
mov ah, 1
inc di
@SAMEByte:
dec ch
jnz @LOOP
pop di
add di, vxBytes
pop ax {start of next line}
dec bh
jnz @DOLINE
pop ds
end;
{won't handle Chars wider than 1 Byte}
Procedure putChar(x, y : Integer; p : Word); Assembler;
Asm
mov si, p {offset of Char in DS}
mov ax, vSeg
mov es, ax
mov di, x
mov cx, di
shr di, 2
mov ax, vxBytes
mul y
add di, ax
mov ax, $0102
and cl, 3
shl ah, cl {make bit mask}
mov dx, seqPort
mov cl, tsy
xor ch, ch
@DOLINE:
mov bl, [si]
inc si
push ax
push di {save starting bit mask}
@LOOP:
mov al, 2
out dx, ax
shl ah, 1
shl bl, 1
jnc @SKIP
mov al, color
mov es:[di], al
@SKIP:
test ah, $10
jz @SAMEByte
mov ah, 1
inc di
@SAMEByte:
or bl, bl
jnz @LOOP
pop di
add di, vxBytes
pop ax {start of next line}
loop @DOLINE
end;
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Procedure setColor(color, r, g, b : Byte); Assembler;
Asm {set DAC color}
mov dx, tableWriteIndex
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; {Write index now points to next color}
Function getColor(color : Byte) : LongInt; Assembler;
Asm {get DAC color}
mov dx, tableReadIndex
mov al, color
out dx, al
add dx, 2
cld
xor bh, bh
in al, dx
mov bl, al
in al, dx
mov ah, al
in al, dx
mov dx, bx
end; {read index now points to next color}
Procedure setPalette(color : Byte; num : Word; Var rgb); Assembler;
Asm
mov cx, num
jcxz @X
mov ax, cx
shl cx, 1
add cx, ax {mul by 3}
push ds
lds si, rgb
cld
mov dx, tableWriteIndex
mov al, color
out dx, al
inc dx
@L:
lodsb
out dx, al
loop @L
pop ds
@X:
end;
Procedure getPalette(color : Byte; num : Word; Var rgb); Assembler;
Asm
mov cx, num
jcxz @X
mov ax, cx
shl cx, 1
add cx, ax {mul by 3}
les di, rgb
cld
mov dx, tableReadIndex
mov al, color
out dx, al
add dx, 2
@L:
in al, dx
stosb
loop @L
@X:
end;
{XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}
Function vgaPresent : Boolean; Assembler;
Asm
mov ah, $F
int $10
mov oldMode, al { save old Gr mode}
mov ax, $1A00
int $10 { check For VGA}
cmp al, $1A
jne @ERR { no VGA Bios}
cmp bl, 7
jb @ERR { is VGA or better?}
cmp bl, $FF
jnz @OK
@ERR:
xor al, al
jmp @EXIT
@OK:
mov al, 1
@EXIT:
end;
Procedure Graphbegin;
Var
p : Array [0..255] of tRGB;
i, j,
k, l : Byte;
begin
Asm
mov ax, $0013
int $10
end; {set BIOS mode}
l := 0;
For i := 0 to 5 do
For j := 0 to 5 do
For k := 0 to 5 do
With p[l] do
begin
r := (i * 63) div 5;
g := (j * 63) div 5;
b := (k * 63) div 5;
inc(l);
end;
For i := 216 to 255 do
With p[i] do
begin
l := ((i - 216) * 63) div 39;
r := l;
g := l;
b := l;
end;
setpalette(0, 256, p);
color := 0;
Asm
mov dx, seqPort
mov ax, $0604
out dx, ax { disable chain 4}
mov ax, $0100
out dx, ax { synchronous reset asserted}
dec dx
dec dx
mov al, $E3
out dx, al { misc output port at $3C2}
{ use 25mHz dot clock, 480 lines}
inc dx
inc dx
mov ax, $0300
out dx, ax { restart sequencer}
mov dx, CrtcPort
mov al, $11
out dx, al { select cr11}
inc dx
in al, dx
and al, $7F
out dx, al
dec dx { remove Write protect from cr0-cr7}
mov si, offset CrtcRegTable
mov cx, CrtcRegLen
repz outsw { set Crtc data}
mov ax, vxBytes
shr ax, 1 { Words per scan line}
mov ah, al
mov al, $13
out dx, ax { set CrtC offset reg}
end;
clearGraph;
end;
Procedure Graphend; Far;
begin
ExitProc := exitSave;
Asm
mov al, oldMode
mov ah, 0
int $10
end;
end;
begin
CrtcPort := memw[$40 : $63];
input1Port := CrtcPort + 6;
if vgaPresent then
begin
ExitSave := exitProc;
ExitProc := @Graphend;
Graphbegin;
end
else
begin
Writeln(^G + 'VGA required.');
halt(1);
end;
end.
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]