Category : Forth Source Code
Archive   : FPCHERC.ZIP
Filename : HGTEXT.SEQ

 
Output of file : HGTEXT.SEQ contained in archive : FPCHERC.ZIP
\ HGTEXT.SEQ -- getting text into Hercules graphics mode
\ Written by Paul Snyder 1.31.90
\ 5520 Spinnaker DR #4
\ San Jose, Ca. 95123
\
\ P.SNYDER1 on Genie

comment:
The idea here is to vector F-PC I/O words so that most of the usual text
handling stuff built into forth will work & so not have to be re-invented.

WHAT IS STILL NEEDED:
1. Speed. This thing is SLOOOOOOOOOW.

comment;

needs hercvid.seq

\ -------------------------data structures -------------------------------
0 value curx.min \ max & min values for
0 value cury.min \ cursor x & y in pixels
8 constant csx \ character width in pixels
8 constant csy \ character size in pixels in y direction
720 csx / csx * csx -
value curx.max \ (max.x.pix/8)*8-8
348 csy / csy * csy -
value cury.max \ (max.y.pix/csy)*csy-csy
curx.max curx.min - value line.width

0 value gtcurx \ graphics text cursor x coord in pixels
0 value gtcury \ graphics text cursor y coord in pixels
0 value char.addr \ address of character in font table
false value wrap.flg \ default is wrap on

\ ........................loading the font.......................
create fontbuf 4100 allot \ the font table goes in here
handle fonthandle \ use this to load whatever font you want
: load.font ( --) \
fonthandle !hcb sequp
fonthandle hopen abort" unable to load font"
0.0 seek
fontbuf 4096 fonthandle hread . ." bytes read "
close
;
fontbuf value curr.font \ set pointer to base of curent font

load.font 8x8.fon

\ ------------------------ functions --------------------------------------
1 color ! \ just to make sure we can see our work

: cgs ( --) \ clear graphics screen & home cursor
gr curx.min =: gtcurx cury.min =: gtcury
;
: hgkill-line ( --)
line.width csx / 1+ spaces curx.min =: gtcurx
;
: scroll.up ( --)
cury.max csy + cury.min csy +
?do active.page @ curx.min i calc.bos
over curx.min i csy - calc.bos
line.width 8 / 1+ cmovel
loop curx.min =: gtcurx cury.max =: gtcury
hgkill-line
;
: hgdark ( --) \ blanks graphics text window
cury.max csy + cury.min
?do active.page @
curx.min i calc.bos
line.width 16 / 1+
0 EWFILL
loop
;
\ ---------cursor control words...work with arrow keys---------------
: backup.crsr ( --)
gtcurx curx.min > \ in middle of line?
if csx negate +!> gtcurx \ yes, back up x
else gtcury cury.min > \ at beg of line. Also at top of screen?
if curx.max =: gtcurx \ x to end of line
csy -1 * +!> gtcury \ & y to previous line
else wrap.flg \ at (0,0); wrap on?
if curx.max =: gtcurx \ yes, go to end of screen
cury.max =: gtcury
else curx.min =: gtcurx \ no, stay put
cury.min =: gtcury
then
then
then
;

: adv.crsr ( --)
gtcurx curx.max < \ in middle of line?
if csx +!> gtcurx \ yes, advance x
else gtcury cury.max < \ at end of line. Not at end of screen?
if curx.min =: gtcurx \ x to beginning of line
csy +!> gtcury \ & y to next line
else wrap.flg \ at end of screen; Wrap on?
if curx.min =: gtcurx \ yes, go to beginning of screen
cury.min =: gtcury
else curx.max =: gtcurx \ no, stay put
cury.max =: gtcury
then
then
then
;
: crsr.up ( --)
gtcury cury.min > \ not at top?
if csy negate +!> gtcury \ then decrement y
else wrap.flg \ at top. Wrap on?
if cury.max =: gtcury \ yes, go to bottom line
else cury.min =: gtcury \ no, stay put
then
then
;
: crsr.dn ( --)
gtcury cury.max < \ not at bottom?
if csy +!> gtcury \ then increment y
else wrap.flg \ at bottom; Wrap on?
if cury.min =: gtcury \ yes go to top line
else cury.max =: gtcury \ no, stay put
scroll.up
then
then
;
: gat ( x y--) \ a graphics version of AT
=: gtcury =: gtcurx
;
: calc.char.addr ( c--) \ calculate the addr in font table where char begins
csy * curr.font + =: char.addr
;
: hercules-at ( col row--)
2dup IBM-AT csy * swap csx * swap gat
;
: paint-it ( c--) \ paints hercules graphic text char at ([x/8],y)
calc.char.addr csy 0 \ determine offset into font table
do i char.addr + c@ \ data to store on screen
gtcurx gtcury i + calc.bos \ calc byte offset into screen memory
active.page @ !scrn.byte \ store on graphics page
loop
;
: hgblinker ( --) \ background task for blinking cursor
2 tenths 2 paint-it 2 tenths bl paint-it
;
: hgkey ( --c)
begin (key?) not while hgblinker repeat (key)
;
: gemit ( c--) \ sort of a smart emit for use in GMODE (ref hercvid.seq)
case
10 of ( linefeed) crsr.dn endof
13 of ( return) curx.min =: gtcurx endof
200 of ( up-arrow cursor key) crsr.up endof
203 of ( back-arrow cursor key. no delete) backup.crsr endof
205 of ( fwd-arrow cursor key) adv.crsr endof
208 of ( down-arrow cursor key) crsr.dn endof
paint-it adv.crsr \ it must have been a printable character
endcase
;
: hgconsole ( c--) dup gemit (console) ;
: hgdel-in ( n c--0|n-1) \ This is a kludge, but it works.
>r dup \ It is a perversion of (del-in)
if 1- #out @ backup.crsr bs (emit)
backup.crsr bl (emit) #out ! bs
else bell
then backup.crsr (emit) backup.crsr
#out dup @ 2- 0 max swap ! r>
bl paint-it
;
: hgcr-in ( m a n c--m a m c)
crsr.dn curx.min =: gtcurx cr-in
;
: hgback-up ( n c--0 c)
over 0 ?do backup.crsr bl paint-it loop
back-up
;
: hgkeytable
exec:
^char ^char ^char res-in ^char ^char ^char ^char
hgdel-in ^char ^char ^char ^char hgcr-in ^char ^char
p-in ^char ^char ^char ^char hgback-up ^char ^char
hgback-up ^char ^char esc-in ^char ^char ^char ^char
;
: hgtype ( adr count--)
2dup video-type bounds
?do i c@ gemit loop
;
: hgTYPEL ( seg adr count--)
0
?do 2dup i + c@l gemit loop
2drop
;
: ge ( --) \ vector to hercules graphics mode
['] hgkeytable is keytable
['] hgconsole is console
['] hgtype is type
['] hgTYPEL is TYPEL
['] (expect) is expect
['] hgkey is key
['] hercules-at is AT
statv off
false =: ?dosio
;
hidden also
: te ( --) \ vector back to normal
['] norm-keytable is keytable
['] (console) is console
['] video-type is type
['] (TYPEL) is TYPEL
['] xexpect is expect
['] (key) is key
['] IBM-AT is AT
statv on
;
forth also
: gwind ( x1 y1 x2 y2--) \ set graphing window in pixels
=: hgy.max =: hgx.max =: hgy.min =: hgx.min
;
: twind ( x1 y1 x2 y2--) \ set graphic text window in text rows & columns
hgy.min csy / max hgy.max csy / min csy * =: cury.max
hgx.min csx / max hgx.max csx / min csx * =: curx.max
hgy.min csy / max hgy.max csy / min csy * =: cury.min
hgx.min csx / max hgx.max csx / min csx * =: curx.min
curx.max curx.min - =: line.width
;
: hghome ( --) curx.min cury.min gat ;
\
\ --------stuff to test this file with ----------------------------------
comment:
Run the demo file HGDEMO.SEQ It makes a text window of 6 lines below
the graphics window. It then graphs the sine function with labelled axes.
The user is left with the F-PC prompt in the text window at the bottom of
the screen allowing interaction with Forth from the graphics screen.
Remember that gr displays graphics screen & clears it
gmode switches display to graphics without clearing
txt returns to text display
ge sets up EMIT et al so that text is output to
both text & graphics screens.
te sets up EMIT et al so that text is output to
text screen only (in fast mode).
twind ( x1 y1 x2 y2--) sets the size of the text window
on the graphics page.
comment;




  3 Responses to “Category : Forth Source Code
Archive   : FPCHERC.ZIP
Filename : HGTEXT.SEQ

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/