Category : Files from Magazines
Archive   : DDJ8607.ZIP
Filename : WINDOW4.JUL

file: WINDOW.BLK Block: 0
cl 11/10/85


window program
by
Craig A. Lindley
Manitou Springs
Colorado
November 1985


file: WINDOW.BLK Block: 1


\ window routines cl 11/10/85

\ window load screen


warning off


dark

.( Compiling window package and demo program )

cr


2 32 thru


warning on



file: WINDOW.BLK Block: 2



\ case statement cl 11/10/85

\ Dr. Charles Eakers Forth Dimensions Vol 2, Num 3

: ?comp state @ not abort" Compilation only" ;

: ?pairs <> abort" Bad CASE statement" ;



: case ?comp csp @ !csp 4 ; immediate

: of 4 ?pairs

compile over compile = compile ?branch

here 0 , compile drop 5 ; immediate

: endof 5 ?pairs compile branch here 0 ,

swap >resolve 4 ; immediate

: endcase 4 ?pairs compile drop

begin sp@ csp @ <>

while >resolve repeat

csp ! ; immediate




file: WINDOW.BLK Block: 3



\ window routines cl 11/10/85

\ write count # of chars with attrib at cursor position

code chra \ char/attrib count --

cx pop ax pop ah bl mov \ get count in cx, attrib in bl

bh bh xor 9 # ah mov \ char in al, func. code in ah

si push 16 int si pop \ do video interrupt

next

end-code

\ write 1 char with attrib at cursor - update cursor position

code chra+ \ char/attrib --

ax pop ah bl mov bh bh xor \ char in al, attrib in bl

1 # cx mov 9 # ah mov \ char in al, func. code in ah

si push 16 int \ count=1, write char/attrib

3 # ah mov 16 int dl inc 2 # ah mov 16 int

si pop next \ inc cursor position

end-code




file: WINDOW.BLK Block: 4



\ window routines cl 11/10/85

\ read char and attrib at cursor position

code rdchra \ -- char/attrib

0 # bh mov 8 # ah mov \ pg =0 func. code = 8

si push 16 int si pop \ do video interrupt

1push \ char/attrib to stk

end-code



\ put char with attrib at x,y

: putch \ x y char/attrib --

>r at r> 1 chra ;



\ get char with attrib at x,y

: getch \ x y -- char/attrib

at rdchra ;





file: WINDOW.BLK Block: 5



\ window routines cl 11/10/85



\ draw count # of chars/attrib starting at x,y

: draw_row \ x y char/attrib count --

>r >r at r> r> chra ;



\ scroll specified window up n lines

code scrlup \ xul yul xlr ylr cnt attrib --

bx pop bl bh mov di pop \ bh attrib si # of lines

dx pop dl dh mov ax pop al dl mov \ dx has lr x y

cx pop cl ch mov ax pop al cl mov \ cx has ul x y

di ax mov si push bp push \ save regs

6 # ah mov 16 int \ ax # of lines func. code ah

bp pop si pop next \ restore forth's regs

end-code



file: WINDOW.BLK Block: 6

\ window routines cl 11/10/85

\ memory management support

\ tell DOS to allociate memory bytes

code calloc \ # bytes -- seg T

bx pop 4 # cl mov bx cl shr \ -- maxp error code F

bx inc 72 # ah mov 33 int \ int 21h func. code 48h

u< if bx push ax push ax ax xor \ if C then error

else ax push -1 # ax mov then 1push

end-code

\ tell DOS to free memory segment

code free \ seg -- T

ax pop ax es mov \ -- error code F

73 # ah mov 33 int \ int 21h func. code 49h

u< if ax push ax ax xor \ if C then error

else -1 # ax mov then 1push

end-code


file: WINDOW.BLK Block: 7

\ window routines cl 11/10/85

\ memory management support

\ tell DOS to shrink or expand allociated memory segment



code setblock \ # bytes -- T

cs ax mov ax es mov \ -- maxp error code F

bx pop 4 # cl mov bx cl shr \ bx has # of paragraphs

bx inc 74 # ah mov 33 int \ int 21h func. code 4Ah

u< if bx push ax push ax ax xor \ if C then error

else -1 # ax mov

then 1push

end-code


file: WINDOW.BLK Block: 8

\ window routines cl 11/10/85

\ extended word fetch and store words

\ fetch word from extended memory

code e@ \ seg addr -- n

bx pop es pop \ seg in es addr in bx

es: 0 [bx] ax mov \ get the data on stk

1push

end-code


\ store word in extended memory

code e! \ n seg addr --

bx pop es pop ax pop

ax es: 0 [bx] mov \ store the data

next

end-code



file: WINDOW.BLK Block: 9

\ window routines cl 11/10/85

\ read current cursor location

code rdcur \ -- x y

si push 0 # bh mov 3 # ah mov \ int 10h func. code 3

16 int si pop ah ah xor

dl al mov ax push dh al mov

1push

end-code



file: WINDOW.BLK Block: 10

\ window routines cl 11/10/85

\ window control block (wcb) record layout

0 constant ulx 2 constant uly \ upper left corner

4 constant width 6 constant height \ width and height

8 constant curx 10 constant cury \ current cursor pos

12 constant oldx 14 constant oldy \ old cursor pos.

16 constant bufseg 18 constant oldwcbseg \ seg storage

20 constant attrib \ window attrib.

22 constant record_size \ size of record

15 constant boarder \ boarder attribute

hex

b800 constant v_seg \ video memory start

variable wcbseg \ current wcb seg

decimal \ storage




file: WINDOW.BLK Block: 11

\ window routines cl 11/10/85

\ extended memory fetch and store words

\ store word n at addr in current wcb

: wcbseg! \ n addr --

wcbseg @ swap e! ; \ store at addr in wcb seg


\ fetch word from addr in current wcb

: wcbseg@ \ addr -- n

wcbseg @ swap e@ ; \ fetch from addr in wcb seg


file: WINDOW.BLK Block: 12

\ window routines cl 11/10/85

\ window frame drawing routines

: top

ulx wcbseg@ uly wcbseg@ [ 201 boarder 256 * + ] literal putch

ulx wcbseg@ 1+ uly wcbseg@ [ 205 boarder 256 * + ] literal

width wcbseg@ draw_row

ulx wcbseg@ width wcbseg@ + 1+ uly wcbseg@

[ 187 boarder 256 * + ] literal putch ;

: bottom

ulx wcbseg@ uly wcbseg@ height wcbseg@ + 1+

[ 200 boarder 256 * + ] literal putch

ulx wcbseg@ 1+ uly wcbseg@ height wcbseg@ + 1+

[ 205 boarder 256 * + ] literal width wcbseg@ draw_row

ulx wcbseg@ width wcbseg@ + 1+ uly wcbseg@ height wcbseg@ + 1+

[ 188 boarder 256 * + ] literal putch ;



file: WINDOW.BLK Block: 13

\ window routines cl 11/10/85

\ window frame drawing routines

: sides

uly wcbseg@ height wcbseg@ + 1+ uly wcbseg@ 1+

do ulx wcbseg@ i [ 186 boarder 256 * + ] literal putch

ulx wcbseg@ width wcbseg@ + 1+ i

[ 186 boarder 256 * + ] literal putch

loop ;

file: WINDOW.BLK Block: 14

\ window routines cl 11/10/85

\ temporary data storage areas

\ used by scn->buf and buf->scn


label save_h nop nop \ storage for height parameter

label save_w nop nop \ storage for width parameter

label save_ptr nop nop \ storage for start pointer

label save_si nop nop \ storage for forths IP reg

label save_ds nop nop \ storage for current ds reg


file: WINDOW.BLK Block: 15

\ window routines cl 11/10/85

\ move data from screen to memory buffer

hex

code scn->buf \ x y width height seg --

cld es pop 0 # di mov save_h #) pop save_w #) pop ax pop

a0 # bl mov bl mul bx pop bx shl bx ax add ax save_ptr #) mov

si save_si #) mov ds ax mov ax save_ds #) mov v_seg # ax mov

ax ds mov cs: save_ptr #) si mov cs: save_h #) cx mov

here cx push cs: save_w #) cx mov rep movs

cs: save_ptr #) si mov a0 # si add si cs: save_ptr #) mov

cx pop

loop

cs: save_ds #) ax mov ax ds mov

save_si #) si mov

next

end-code


file: WINDOW.BLK Block: 16

\ window routines cl 11/10/85

\ move data from memory buffer to screen

code buf->scn \ seg x y width height --

cld save_h #) pop save_w #) pop ax pop a0 # bl mov

bl mul bx pop bx shl bx ax add ax save_ptr #) mov

si save_si #) mov ds ax mov ax save_ds #) mov ax pop ax ds mov

v_seg # ax mov ax es mov 0 # si mov cs: save_ptr #) di mov

cs: save_h #) cx mov

here cx push cs: save_w #) cx mov rep movs

cs: save_ptr #) di mov a0 # di add di cs: save_ptr #) mov

cx pop

loop

cs: save_ds #) ax mov ax ds mov save_si #) si mov

next

end-code

decimal



file: WINDOW.BLK Block: 17

\ window routines cl 11/10/85

\ lowest level window routine

\ moves screen data to memory buffer

\ and then draws the actual window frame

: ((window)) \ move data scn->buf

ulx wcbseg@ uly wcbseg@ \ x y coordinates

width wcbseg@ 2+ height wcbseg@ 2+ \ width height

bufseg wcbseg@ scn->buf \ get buf seg addr

top sides bottom ;



file: WINDOW.BLK Block: 18

\ window routines cl 11/10/85

\ clear window routine

: clr_window \ --

ulx wcbseg@ 1+ \ upper left corner x

uly wcbseg@ 1+ \ upper right corner y

ulx wcbseg@ width wcbseg@ + \ lower left corner x

uly wcbseg@ height wcbseg@ + \ lower right corner y

0 attrib wcbseg@ scrlup \ scroll entire window

0 curx wcbseg! \ home window cursor

0 cury wcbseg! ;




file: WINDOW.BLK Block: 19

\ window routines cl 11/10/85

: (window) \ x y width height attrib -- f

record_size calloc \ try to allociate space for wcb

if wcbseg @ >r wcbseg ! r> \ if successful store seg var

oldwcbseg wcbseg! attrib wcbseg! \ save attrib in wcb

2dup 2+ swap 2+ * 2* calloc \ alloc space for screen buf

if bufseg wcbseg! \ save buffer seg

height wcbseg! width wcbseg! \ save parameters in

uly wcbseg! ulx wcbseg! \ new wcb

rdcur oldy wcbseg! oldx wcbseg! \ get old cursor pos.

((window)) clr_window true \ move data draw frame

else ." buffer alloc. failure" cr \ if no memory

wcbseg @ free drop drop 0 \ free wcb memory

then

else ." wcb alloc. failure" drop drop 0

then ; \ return flag



file: WINDOW.BLK Block: 20

\ window routines cl 11/10/85

\ window parameter checking

: wfit cr

abort" Window won't fit on crt" ;

: open_window \ x y width height attrib -- f

depth 5 >=

if >r 4dup rot + 2+ 24 <=

if + 2+ 79 <=

if r> (window)

else cr ." ULX and/or WIDTH incorrect" wfit

then

else cr ." ULY and/or HEIGHT incorrect" wfit

then

else cr ." Incorrect # of parameters specified" quit

then ;



file: WINDOW.BLK Block: 21

\ window routines cl 11/10/85

\ close the current window (defined by wcbseg data)

\ free wcb and buffer memory then unlink window

: close_window \ --

wcbseg @ 0 <> \ if window exists

if bufseg wcbseg@ \ get buffer seg addr

ulx wcbseg@ uly wcbseg@ \ get x,y corner

width wcbseg@ 2+ height wcbseg@ 2+

buf->scn \ mov data back to screen

oldx wcbseg@ oldy wcbseg@ at

bufseg wcbseg@ free drop \ free buffer seg memory

wcbseg @ free drop \ free wcb seg memory

oldwcbseg wcbseg@ wcbseg ! \ unlink this window

else \ if no current window

cr ." No open windows !" cr

then ;




file: WINDOW.BLK Block: 22

\ window routines cl 11/10/85

\ position cursor in window

\ if parameters out of range do the best we can and still

\ stay in the window

: wat \ x y --

swap dup abs width wcbseg@ \ req. x in window ?

1- > \ if not then

if drop width wcbseg@ 1- then \ set x to max in window

curx wcbseg! \ save new cursor x position

dup abs height wcbseg@ \ req y in window ?

1- > \ if not then

if drop height wcbseg@ 1- then \ set y to max in window

cury wcbseg! \ save new cursor y position

curx wcbseg@ ulx wcbseg@ + 1+ \ actual cursor position

cury wcbseg@ uly wcbseg@ + 1+ \ calculation

at ;



file: WINDOW.BLK Block: 23

\ window routines cl 11/10/85

\ read window cursor position

: rdwcur \ -- x y

curx wcbseg@ cury wcbseg@ ;

\ read char/attrib of character at cursor in window

: rdwcha \ x y -- char/attrib

wat rdchra ;

\ scroll window up for blank line at bottom

: scroll_window \ --

ulx wcbseg@ 1+ uly wcbseg@ 1+ \ upper left corner to scroll

ulx wcbseg@ width wcbseg@ + \ lower right x coordinate

uly wcbseg@ height wcbseg@ + \ lower right y coordinate

1 attrib wcbseg@ scrlup ; \ up 1 line




file: WINDOW.BLK Block: 24

\ window routines cl 11/10/85

\ do carrage return in the current window

: crout rdwcur nip 0 swap wat ; \ carrage ret in window

\ do a line feed in the current window

: lfout rdwcur 1+ dup

height wcbseg@ 1- > \ cursor out of window

if 1- scroll_window then \ if so scroll the window up

wat ; \ place the cursor in window


\ do a back space in the current window

: bsout rdwcur over 0<> \ backspace cursor in window

if swap 1- swap wat then ;


\ ring the bell

: bell 7 (emit) ; \ sound the horn




file: WINDOW.BLK Block: 25

\ window routines cl 11/10/85

: wemit dup 32 < \ char --

if case \ if control char process it

7 of bell endof \ if bell then

8 of bsout endof \ if backspace then

10 of lfout endof \ if linefeed then

13 of crout endof \ if carrage ret then

endcase

else \ else its a display char

attrib wcbseg@ 256 * + \ char now char/attrib

rdwcur rot chra+ \ output char adv. cursor

drop dup width wcbseg@ 1- = \ if at end of window line

if drop lfout crout \ do lfcr to next line

else 1+ curx wcbseg! \ store new x coordinate

then

then ;



file: WINDOW.BLK Block: 26

\ window routines cl 11/10/85

: wcr 13 wemit 10 wemit ; \ window carrage return



: wtype 0 \ window equiv. of type

?do count wemit loop drop ;

\ use memory manager to give forth a full 64k segment

: initialize \ --

cr ." Memory management " \ output 1/2 msg

-1 setblock \ request FFFF bytes

if \ if successful

." initialized" \ output message and

0 wcbseg ! \ initialize link variable

else

." error" quit \ abort program

then cr ;




file: WINDOW.BLK Block: 27

\ window demo cl 11/10/85

\ window equivalents of standard Forth words

: wlist block 16 0

do dup i c/l * + c/l \ window equiv. of list

-trailing wtype wcr

loop drop ;

: wtriad 3 / 3 * 3 bounds \ window equiv. of triad

do i wlist \ list screen in window

wcr wcr \ add a couple of cr's

loop ;



file: WINDOW.BLK Block: 28

\ window demo cl 11/10/85

\ window canned messages

: msg1

" This could be your application program! " wtype ;

: msg2 " Ain't this window package something! " wtype ;

: msg3 " ** Window 4 ** " wtype ;


: msg1out 0 0 wat \ output msg1 20 times

20 0 do msg1 loop ;


: msg2out 0 0 wat \ output msg2 10 times

10 0 do msg2 loop ;


: msg3out 0 0 wat \ output msg3 80 times

80 0 do msg3 loop ;




file: WINDOW.BLK Block: 29

\ window demo cl 11/10/85

\ video attribute constants

7 constant normal 15 constant high_int

112 constant reverse 128 constant blink


: fill_crt 0 0 \ fill crt with rev video A's

[ ascii A reverse 256 * + ] \ calculate char/attrib code

literal 2048 draw_row ;


: wait 10000 0 do noop loop ; \ timing loop




file: WINDOW.BLK Block: 30

\ window demo cl 11/10/85

\ define the four windows used in the demo program


: window1 \ define window #1

0 0 20 10 reverse open_window ;


: window2 \ define window #2

2 1 70 8 normal open_window ;


: window3 \ define window #3

7 6 69 10 reverse open_window ;


: window4 \ define window #4

10 9 59 4 high_int open_window ;




file: WINDOW.BLK Block: 31

\ window demo cl 11/10/85

: demo

fill_crt window1

if 0 0 wat msg2 wait wcr wait 7 emit wcr

wait " It sure is" wtype wait 8 wemit 8 wemit

wait 10 5 wat wait window2

if msg1out wait window3

if 0 10 wat 24 wtriad wait window4

if msg3out wait close_window wait close_window

wait clr_window msg2out wait close_window

0 wlist wait wait wait wait close_window

then

then

then

then

wait ;




file: WINDOW.BLK Block: 32

\ window demo cl 11/10/85

only forth also dos also \ search dos and forth

: test empty-buffers \ dummy program name

initialize \ initialize memory manager

" window.blk" fcb1 (!fcb) \ parse filename to fcb

fcb1 !files open-file \ open the file to list

2 0

do \ run the demo 2 times

demo wait wait wait dark wait

loop

." What did you think of that Huh?" cr bye ;


only forth also \ power up search order

' test is boot \ make demo run automatically

save-system window.com \ create .COM demo


\End Listing