home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
forth
/
compiler
/
fpc
/
source
/
herc.seq
< prev
next >
Wrap
Text File
|
1990-03-15
|
6KB
|
223 lines
\\ HERC.SEQ Hercules point plotting routines by Wempe
Hercules graphics support, originally by Wempe, subsequently
modified by Oliver Shank, Mike Mayo, and Tom Zimmer.
This is a simple two color system, color zero being black, and color
one being white. If you set a color above 127, a point will be drawn
XOR'd with the current pixel.
{
FORTH DECIMAL anew herc-words
0 VALUE VDOTS \ verticle dots in screen
0 VALUE HDOTS \ horizontal dots in screen
0 VALUE #COLORS \ # of colors in current graphics mode
0 VALUE VID.SEG \ video buffer segment address
0 VALUE VID.SIZE \ video buffer size
VARIABLE COLOR \ color of the DOT
VARIABLE HERC-SEG \ segment for Hercules video buffer
create GTBL
$35 c, $2D c, $2E c, $07 c, $5B c, $02 c,
$57 c, $57 c, $02 c, $03 c, $00 c, $00 c,
create TTBL
$61 c, $50 c, $52 c, $0F c, $19 c, $06 c,
$19 c, $19 c, $02 c, $0D c, $0B c, $0C c,
create BIT-MASKS
$7F c, $BF c, $DF c, $EF c, $F7 c, $FB c, $FD c, $FE c,
: SET-HMODE ( tbl -- )
12 0 do i $3B4 pc! dup c@ $3B5 pc! 1+ loop
drop ;
: GDARK ( -- ) \ graphics dark
VID.SEG 0 VID.SIZE 0 LFILL ;
: GLIGHT ( -- ) \ graphics light, opposite of dark.
VID.SEG 0 VID.SIZE $00FF LFILL ;
: HPAGED ( p -- ) \ select displaying lower or upper page of video buffer
0= if $0A else $8A then
$3B8 pc! ;
: HPAGEW ( p -- ) \ select writing to lower or upper page of video buffer
0= if $B000 else $B800 then
DUP =: VID.SEG HERC-SEG ! ;
: HERCULES ( -- )
3 $3BF P! \ set herc for FULL mode
$02 $3B8 PC! \ set mode register for graphics, with video disabled
gtbl set-hmode
$8000 =: VID.SIZE \ Hercules video buffer size
0 HPAGED \ display the first graphics page
0 HPAGEW \ enable writing to the first graphics page
720 =: HDOTS
348 =: VDOTS
2 =: #COLORS
GDARK 1 color ! ; \ clear the screen
: HTEXT ( -- )
$20 $3B8 PC! \ set mode register for text, with video disabled
ttbl set-hmode
$28 $3B8 PC! \ re-enable video
DARK ;
LABEL XY_ADDR ( x y -- a1:DX )
\ y in DX
\ x in CX
\ returns bit mask in AL and address in DI
MOV AX, DX
SHR AX, # 1
SHR AX, # 1 \ row/4 in AX
PUSH DX \ y for later
MOV BX, # 90
MUL BX
MOV DI, AX \ DI is now row/4 * 90
MOV AX, CX
SHR AX, # 1
SHR AX, # 1
SHR AX, # 1 \ col/8 in AX
ADD DI, AX \ DI is now the byte address
POP DX
TEST DX, # 1
U> IF ADD DI, # $2000 \ deal with row mod 4
THEN
TEST DX, # 2
U> IF ADD DI, # $4000
THEN
AND CX, # 7
MOV BX, # BIT-MASKS
MOV AX, CX
XLAT \ get bit mask
RET END-CODE
CODE HPLOT ( x y -- ) \ turn on pixel at x,y
POP DX \ y
POP CX \ x
CALL XY_ADDR
MOV CX, COLOR \ is COLOR zero
PUSH DS
MOV DS, HERC-SEG
CX<>0 IF NOT AL
CMP CX, # 128
< IF OR 0 [DI], AL \ set the bit
ELSE XOR 0 [DI], AL \ xor the bit
THEN
ELSE AND 0 [DI], AL \ clear the bit
THEN
POP DS
NEXT END-CODE
CODE HPOINT ( x y -- n1 ) \ Get status of pixel at x,y
POP DX \ y
POP CX \ x
CALL XY_ADDR
PUSH DS
MOV DS, HERC-SEG
MOV BL, 0 [DI]
NOT AL
AND AL, BL \ mask the bit
POP DS
0= IF SUB AX, AX
ELSE MOV AX, # 1
THEN
1PUSH END-CODE
\ Text for Hurcules Graphics Mode
$0F000 value charseg
$0FA6E value chartbl
0 value charadr
0 value hercX
0 value hercY
: h-at ( x y -- ) \ AT for Hercules
=: hercY =: hercX ;
: herc-at ( x y -- ) \ AT for Hercules
8 * =: hercY 8 * =: hercX ;
: herc-at? ( -- x y ) \ AT? for Hercules
hercX 8 * hercY 8 * ;
: herc-emit ( c -- )
8 * chartbl + =: charadr
hercX 8 /
hercY 4 /mod 90 * swap $2000 * +
+ ( video-byte-addr )
\ POINTOFFSET = INT[ROW/4] * 90 + REM[ROW/4]*$2000 + INT[COL/8]
\ PIXEL(1 BIT)ADDR = REM[COL/8] {WITHIN BYTE}
\ Next bit, step along byte and to next byte.
\ Next row, add $2000, and add 90 when wrapping.
8 0 do charseg charadr c@l incr> charadr
over herc-seg @ swap c!l
$2000 + dup $7FFF u> if 90 + then $7FFF and
loop
drop
hercX 8 + 720 /mod if 8 +!> hercY then =: hercX ;
: herc-typeL ( s a l -- )
bounds ?do dup i c@L emit loop drop ;
: herc-type ( a l -- )
bounds ?do i c@ emit loop ;
: herc-cr ( -- )
hercY 8 + 319 min =: hercY off> hercX ;
: HERCULES$ ( -- )
HERCULES \ switch to Hercules graphics mode
['] herc-typeL is typeL
['] herc-type is type
['] herc-emit is emit
['] herc-at is at
['] herc-at? is at?
['] herc-cr is cr ;
: HTEXT$ ( -- )
HTEXT \ switch to text mode
['] QtypeL is typeL
['] (type) is type
['] (emit) is emit
['] ibm-at is at
['] ibm-at? is at?
['] crlf is cr
DARK ;
}