This file is my version of the DDJ 6/86 article on FORTH and windows. My version of FORTH and concepts of how the operation should occur is naturally different than the original authors. \ beginning of windows NEED MOUSE NEED FOR.ME NEED CASE CAPS OFF VISA WINDOWS.BLK VOCABULARY WINDOW ONLY FORTH ALSO WINDOW DEFINITIONS ALSO 2 19 THRU CAPS ON ONLY FORTH ALSO \ SIMPLIFIED L@ FOR WINDOWS 3 /16/88VARIABLE DSEG DSEG OFF : DSEG@ DSEG @ DUP IF L@ THEN ; : DSEG! DSEG @ ?DUP IF L! ELSE DROP THEN ; DEFER SCRN>BUF DEFER BUF>SCRN DEFER MODIFY? ' NOOP IS MODIFY? $B800 CONSTANT V.SEG \ write count of chars with attribute CODE CHRA ( chra/attrib count -- ) BX CX MOV AX POP AH BL MOV \ count in cx, attrib in bl DSCR# #) BH MOV \ GET WHICH SCREEN# 9 # AH MOV \ char in al, func code in ah SI PUSH $10 INT SI POP BX POP NEXT END-CODE CODE CHRA+ ( chra/attrib -- ) \ co chra + move cursor BX AX MOV AH BL MOV \ char in al, attrib in bl DSCR# #) BH MOV \ GET WHICH SCREEN# 1 # CX MOV 9 # AH MOV SI PUSH $10 INT 3 # AH MOV $10 INT DL INC 2 # AH MOV $10 INT SI POP BX POP NEXT END-CODE \ read cursor 6 /21/88CODE RDCUR ( -- x y ) BX PUSH SI PUSH BH BH XOR 3 # AH MOV $10 INT SI POP BH BH XOR DL BL MOV BX PUSH DH BL MOV NEXT END-CODE 0 CONSTANT ULX 2 CONSTANT ULY 4 CONSTANT WIDTH 6 CONSTANT HEIGHT 8 CONSTANT CURX 10 CONSTANT CURY 12 CONSTANT OLDX 14 CONSTANT OLDY 16 CONSTANT BUFSEG 18 CONSTANT OLDWCBSEG 20 CONSTANT ATTRIB 22 CONSTANT EATTRIB 24 CONSTANT SCROLL? 26 CONSTANT OLDTYPE 28 CONSTANT OLDDARK 30 CONSTANT OLDAT 32 CONSTANT #SCROLL 34 CONSTANT WINDOW# 36 CONSTANT VIDEO.MODE 38 CONSTANT MULTI.OLD 40 CONSTANT MENU.OLD 42 CONSTANT RECORD.SIZE : BORDER EATTRIB DSEG@ ; CREATE START.DSEG RECORD.SIZE 2- 16 + ALLOT \ read char and attrib at cursor CODE RDCHRA ( -- char/attrib ) BX PUSH BH BH XOR 8 # AH MOV \ pg=0 fcn code = 8 SI PUSH $10 INT SI POP AX BX MOV NEXT END-CODE FORTH DEFINITIONS : INSIDE? ( x0 y0 xn yn x? y? -- f ) ROT 4 ROLL SWAP BETWEEN >R -ROT BETWEEN R> AND ; : MY.WINDOW ( -- x0 y0 xn yn ) 0 0 [ WINDOW ] WIDTH DSEG@ 1- HEIGHT DSEG@ 1- ; WINDOW DEFINITIONS : PUTCH ( x y char/attrib -- ) -ROT 2DUP 0 25 WITHIN SWAP 0 80 WITHIN AND IF IBM-AT 1 CHRA ELSE 3DROP THEN ; : GETCH ( x y -- char/attrib ) IBM-AT RDCHRA ; : DRAW.ROW ( x y char/attrib count -- ) 2SWAP 2DUP 0 25 WITHIN SWAP 0 80 WITHIN AND IF IBM-AT CHRA ELSE 4DROP THEN ; \ window frame drawing : TOP ULX DSEG@ 1- ULY DSEG@ 1- 201 BORDER + PUTCH ULX DSEG@ ULY DSEG@ 1- 205 BORDER + WIDTH DSEG@ DRAW.ROW ULX DSEG@ WIDTH DSEG@ + ULY DSEG@ 1- 187 BORDER + PUTCH ; : BOTTOM ULX DSEG@ 1- ULY DSEG@ HEIGHT DSEG@ + 200 BORDER + PUTCH ULX DSEG@ ULY DSEG@ HEIGHT DSEG@ + 205 BORDER + WIDTH DSEG@ DRAW.ROW ULX DSEG@ WIDTH DSEG@ + ULY DSEG@ HEIGHT DSEG@ + 188 BORDER + PUTCH ; \ sides of border 6 /21/88: SIDES ULY DSEG@ HEIGHT DSEG@ + ULY DSEG@ DO ULX DSEG@ 1- I 186 BORDER + PUTCH ULX DSEG@ WIDTH DSEG@ + I 186 BORDER + PUTCH LOOP ; VARIABLE SAVE.H VARIABLE SAVE.W VARIABLE SAVE.PTR VARIABLE SAVE.SI VARIABLE SAVE.DS FORTH DEFINITIONS DEFER MENU WINDOW DEFINITIONS \ Print on top and bottom border : >BRACES ( char -- char' ) ASCII { OVER = IF DROP 181 ELSE ASCII } OVER = IF DROP 198 THEN THEN ; : TYPE>EDGE ( addr count -- ) 0 [ WINDOW ] ?DO COUNT >BRACES BORDER OR CHRA+ CURX DSEG@ WIDTH DSEG@ 2- = ?LEAVE LOOP DROP ; : >TOP ( loc addr count -- ) >R >R WIDTH DSEG@ 3 - MIN ULX DSEG@ + ULY DSEG@ 1- IBM-AT R> R> TYPE>EDGE ; : >BOTTOM ( loc addr count -- ) >R >R WIDTH DSEG@ 3 - MIN ULX DSEG@ + ULY DSEG@ HEIGHT DSEG@ + IBM-AT R> R> TYPE>EDGE ; \ move data from screen to memory buffer 3 /28/88CODE (SCRN>BUF) ( x y width height seg -- ) CLD BX ES MOV 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 >BODY #) 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 BX POP NEXT END-CODE ' (SCRN>BUF) IS SCRN>BUF : SET-EDGES ( -- x y width height ) ULX DSEG@ 1- 0 MAX ULY DSEG@ 1- 0 MAX WIDTH DSEG@ 2+ 80 MIN HEIGHT DSEG@ 2+ 25 MIN ; \ move data from memory buffer to screen 3 /28/88CODE (BUF>SCRN) ( seg x y width height -- ) CLD BX SAVE.H #) MOV 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 >BODY #) CX MOV AX POP AX DS MOV CX 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 BX POP NEXT END-CODE ' (BUF>SCRN) IS BUF>SCRN : GRAPHICS? ( -- f ) \ f is true for graphics modes VIDEO-MODE? DUP 4 < SWAP 7 = OR NOT ; : EGA? ( -- f ) VIDEO-MODE? 16 = ; \ ((window)) 7 /5 /88: ((WINDOW)) \ move data scrn>buf SET-EDGES BUFSEG DSEG@ SCRN>BUF ; : CLR.WINDOW HIDE.CURSOR ULX DSEG@ ( 1+ ) ULY DSEG@ ( 1+ ) ULX DSEG@ 1- WIDTH DSEG@ + ULY DSEG@ 1- HEIGHT DSEG@ + 0 GRAPHICS? IF 0 ELSE ATTRIB DSEG@ THEN SCRLUP SHOW.CURSOR ; : SAVE-CONFIG ['] TYPE >IS @ OLDTYPE DSEG! ['] AT >IS @ OLDAT DSEG! ['] DARK >IS @ OLDDARK DSEG! ['] MENU >IS @ MENU.OLD DSEG! ['] PAUSE 1+ @ MULTI.OLD DSEG! ; : RESET-CONFIG MENU.OLD DSEG@ IS MENU OLDTYPE DSEG@ IS TYPE OLDAT DSEG@ IS AT OLDDARK DSEG@ IS DARK MULTI.OLD DSEG@ IF MULTI THEN ; : OLDSEG@ ( addr -- n ) OLDWCBSEG DSEG@ L@ ; \ (window) 3 /21/88: (WINDOW) ( x y width height sattrib eattrib -- f ) RECORD.SIZE 16 / 1+ allocate.memory IF ." ALLOCATION FAILURE# " . DROP ELSE DSEG @ >R DSEG ! R> \ store seg var OLDWCBSEG DSEG! EATTRIB DSEG! \ save attribs in wcb ATTRIB DSEG! SAVE-CONFIG 2DUP 2+ SWAP 2+ * 8 / MODIFY? 1+ allocate.memory IF ." BUFFER ALLO. FAILURE" CR DSEG @ deallocate 2DROP 0 ELSE BUFSEG DSEG! DUP #SCROLL DSEG! HEIGHT DSEG! WIDTH DSEG! ULY DSEG! ULX DSEG! RDCUR OLDY DSEG! OLDX DSEG! WINDOW# OLDSEG@ 1+ WINDOW# DSEG! ((WINDOW)) TRUE THEN THEN ; \ parameter checking 7 /5 /88: WFIT CR ABORT" Window won't fit on crt" ; : OPEN.WINDOW ( x y width height sattrib eattrib -- f ) 6 ?ENOUGH >R >R 4DUP ROT + ( 2+ ) 25 <= IF + ( 2+ ) 80 <= IF R> R> (WINDOW) ELSE CR ." ULX and/or WIDTH incorrect" WFIT THEN ELSE CR ." ULY and/or HEIGHT incorrect" WFIT THEN ; \ CLOSE OPEN WINDOW DEFER SET.VIDEO : CLOSE.WINDOW 'CURSOR? @ >R HIDE.CURSOR DSEG @ 0= NOT IF BUFSEG DSEG@ ?DUP IF DUP SET-EDGES BUF>SCRN deallocate ABORT" can't free memory!" THEN DSEG @ deallocate ABORT" can't free memory!" OLDX DSEG@ OLDY DSEG@ IBM-AT RESET-CONFIG OLDWCBSEG DSEG@ DSEG ! ELSE CR ." No open windows!" CR THEN R> ?CURSOR ; \ wat 5 /6 /89: W-AT ( x y -- ) SWAP DUP ABS WIDTH DSEG@ 1- > IF DROP WIDTH DSEG@ 1- THEN CURX DSEG! DUP ABS HEIGHT DSEG@ 1- > IF DROP HEIGHT DSEG@ 1- THEN CURY DSEG! CURX DSEG@ ULX DSEG@ + CURY DSEG@ ULY DSEG@ + IBM-AT ; FORTH DEFINITIONS : SCROLL TRUE SCROLL? DSEG! ; : NOSCROLL FALSE SCROLL? DSEG! ; : AT? ( -- x y ) CURX DSEG@ CURY DSEG@ ; WINDOW DEFINITIONS : RDWCHA ( x y -- char/attrib ) W-AT RDCHRA ; : SCROLL.WINDOW ULX DSEG@ ULY DSEG@ #SCROLL DSEG@ - HEIGHT DSEG@ + ULX DSEG@ 1- WIDTH DSEG@ + ULY DSEG@ 1- HEIGHT DSEG@ + 1 GRAPHICS? IF 0 ELSE ATTRIB DSEG@ THEN SCRLUP ; \ misc cr/lf 3 /16/88: CROUT AT? NIP 0 SWAP W-AT ; \ cr in window : LFOUT AT? 1+ DUP HEIGHT DSEG@ 1- > SCROLL? DSEG@ AND IF 1- SCROLL.WINDOW THEN W-AT ; : BSOUT AT? OVER 0= NOT IF SWAP 1- SWAP W-AT THEN ; : WEMIT PAUSE DUP 17 < IF CASE 7 OF BELL SP@ 1 DOS-TYPE DROP ENDOF 8 OF BSOUT ENDOF 10 OF LFOUT ENDOF 13 OF CROUT ENDOF ENDCASE ELSE ATTRIB DSEG@ + AT? ROT CHRA+ DROP DUP WIDTH DSEG@ 1- = IF DROP SCROLL? DSEG@ IF LFOUT THEN CROUT ELSE 1+ CURX DSEG! THEN THEN ; \ more cr/lf etc 3 /16/88: W-TYPE PRINTING @ IF PR-TYPE ELSE 'CURSOR? @ >R HIDE.CURSOR DUP #OUT +! 0 ?DO COUNT WEMIT LOOP DROP R> ?CURSOR THEN ; : (OW) ( col row width height sattrib eattrib -- ) 'CURSOR? @ >R HIDE.CURSOR OPEN.WINDOW 0= ABORT" Can't open" TOP SIDES BOTTOM CLR.WINDOW SCROLL R> ?CURSOR ; : WINDOW.EMIT ['] W-TYPE IS TYPE ['] CLR.WINDOW IS DARK ['] W-AT IS AT ; CODE (>VMODE) ( n -- ) BX AX MOV 16 INT BX POP NEXT END-CODE \ simple testing 3 /17/88\ backgrnd \/ multiply by 16 and add to foreground for color \ 0 CONSTANT BLACK 1 CONSTANT BLUE 2 CONSTANT GREEN \ 3 CONSTANT CYAN 4 CONSTANT RED 5 CONSTANT MAGENTA \ 6 CONSTANT BROWN 7 CONSTANT WHITE foreground \/ \ 8 CONSTANT GRAY 9 CONSTANT LIGHT.BLUE \ 10 CONSTANT LIGHT.GREEN 11 CONSTANT LIGHT.CYAN \ 12 CONSTANT LIGHT.RED 13 CONSTANT LIGHT.MAGENTA \ 14 CONSTANT YELLOW 15 CONSTANT BRIGHT.WHITE ONLY FORTH ALSO DEFINITIONS WINDOW ALSO : ?MONO ( attr -- attr' ) VIDEO-MODE? 7 = IF $0800 AND $0700 OR THEN ; : OW ( col row width height sattrib eattrib -- ) ?MONO SWAP ?MONO SWAP (OW) WINDOW.EMIT 0 0 AT VIDEO-MODE? VIDEO.MODE DSEG! ; \ SCREEN RESTORING 3 /16/88: >VMODE DUP VIDEO.MODE DSEG! (>VMODE) ; : (DONE) VIDEO-MODE? VIDEO.MODE OLDSEG@ <> OLDWCBSEG DSEG@ AND IF HIDE.CURSOR SINGLE VIDEO.MODE OLDSEG@ >VMODE CLOSE.WINDOW TEXT/CURSOR ELSE CLOSE.WINDOW THEN ; : CLOSE WINDOW# DSEG@ 1 > IF (DONE) THEN ; : >WINDOW# ( n -- ) WINDOW# DSEG@ 2DUP < IF SWAP DO CLOSE LOOP ELSE 2DROP THEN ; : WWAIT BEGIN PAUSE KEY? DUP IF KEY DROP THEN ANY? OR UNTIL BEGIN ANY? 0= UNTIL CLOSE ; : FULL.SCREEN 0 0 80 25 ATTRIB DSEG@ 0 OPEN.WINDOW DROP SINGLE ; \ read char and attrib at cursor CODE RDCHRA ( -- char/attrib ) BX PUSH BH BH XOR 8 # AH MOV \ pg=0 fcn code = 8 SI PUSH $10 INT SI POP AX BX MOV NEXT END-CODE FORTH DEFINITIONS : INSIDE? ( x0 y0 xn yn x? y? -- f ) ROT 4 ROLL SWAP BETWEEN >R -ROT BETWEEN R> AND ; : AT? ( -- x y ) IBM-AT? WINDOW DEFINITIONS : PUTCH ( x y char/attrib -- ) -ROT IBM-AT 1 CHRA ; : GETCH ( x y -- char/attrib ) IBM-AT RDCHRA ; : DRAW.ROW ( x y char/attrib count -- ) 2SWAP IBM-AT CHRA ; \ beginning of windows requirements: MOUSE FOR.ME CASE name the file load the file \ SIMPLIFIED L@ FOR WINDOWS 3 /16/88DSEG temp variable for window default segment DSEG@ L@ from window segment DSEG! L! to window segment \ write count of chars with attribute CHRA ( chra/attrib count -- ) write chars with an attribute do not move cursor CHRA+ ( chra/attrib -- ) write chars with an attribute move cursor \ read char and attrib at cursor RDCHRA ( -- char/attrib ) get a char and attribute at cursor PUTCH ( x y char/attrib -- ) write a char at a loc GETCH ( x y -- char/attrib ) get a char at a loc DRAW.ROW ( x y char/attrib count -- ) write a char multiple times at a loc SCRLUP ( xul yul xlr ylr cnt attrib -- ) scroll the screen up \ read cursor RDCUR ( -- x y ) get current cursor loc define a number of offsets in the default window seg: 0 CONSTANT ULX 2 CONSTANT ULY 4 CONSTANT WIDTH 6 CONSTANT HEIGHT 8 CONSTANT CURX 10 CONSTANT CURY 12 CONSTANT OLDX 14 CONSTANT OLDY 16 CONSTANT BUFSEG 18 CONSTANT OLDWCBSEG 20 CONSTANT ATTRIB 22 CONSTANT EATTRIB 24 CONSTANT SCROLL? 26 CONSTANT OLDTYPE 28 CONSTANT OLDDARK 30 CONSTANT OLDAT 32 CONSTANT #SCROLL 34 CONSTANT WINDOW# 36 CONSTANT VIDEO.MODE 38 CONSTANT MULTI.OLD 40 CONSTANT RECORD.SIZE BORDER ( -- attr ) get the current default border V.SEG constant address of video display \ window frame drawing TOP draw the top of a window BOTTOM draw the bottom of a window \ sides of border SIDES draw both sides of a window define some temp storage: VARIABLE SAVE.H VARIABLE SAVE.W VARIABLE SAVE.PTR VARIABLE SAVE.SI VARIABLE SAVE.DS \ Print on top and bottom border TYPE>EDGE ( addr count -- ) print a message on the border >TOP ( loc addr count -- ) print message on top border >BOTTOM ( loc addr count -- ) print message on bottom border \ move data from screen to memory buffer 3 /28/88CODE SCRN>BUF ( x y width height seg -- ) move data from screen to memory buffer \ move data from memory buffer to screen 3 /28/88CODE BUF>SCRN ( seg x y width height -- ) move data from memory to screen \ ((window)) 3 /21/88((WINDOW)) move data scrn>buf CLR.WINDOW clear current window only SAVE-CONFIG save params to be reloaded when window is closed RESET-CONFIG restore saved params OLDSEG@ ( addr -- n ) return old default segment \ (window) 3 /21/88(WINDOW) ( x y width height sattrib eattrib -- f ) allocate memory and save a window \ parameter checking WFIT error report OPEN.WINDOW ( x y width height sattrib eattrib -- f ) check window size and open \ CLOSE OPEN WINDOW SET.VIDEO video mode to set CLOSE.WINDOW close a window, restoring needed params \ wat 3 /11/88W-AT ( x y -- ) window goto x y RDWCUR ( -- x y ) get window x y locs RDWCHA ( x y -- char/attrib ) get char at window loc SCROLL.WINDOW scroll window one line SCROLL allow window to scroll when bottom is reached NOSCROLL don't allow scrolling of window \ misc cr/lf 3 /16/88CROUT cr in window LFOUT window line feed BSOUT window backspace WEMIT window emit \ more cr/lf etc 3 /16/88W-TYPE window type (OW) ( col row width height sattrib eattrib -- ) open window WINDOW.EMIT set window defaults \ simple testing 3 /17/88\ backgrnd \/ multiply by 16 and add to foreground for color \ 0 CONSTANT BLACK 1 CONSTANT BLUE 2 CONSTANT GREEN \ 3 CONSTANT CYAN 4 CONSTANT RED 5 CONSTANT MAGENTA \ 6 CONSTANT BROWN 7 CONSTANT WHITE foreground \/ \ 8 CONSTANT GRAY 9 CONSTANT LIGHT.BLUE \ 10 CONSTANT LIGHT.GREEN 11 CONSTANT LIGHT.CYAN \ 12 CONSTANT LIGHT.RED 13 CONSTANT LIGHT.MAGENTA \ 14 CONSTANT YELLOW 15 CONSTANT BRIGHT.WHITE ?MONO ( attr -- attr' ) modify attribute for mono screen OW ( col row width height sattrib eattrib -- ) user open window \ SCREEN RESTORING 3 /16/88(>VMODE) ( n -- ) set video mode primitive >VMODE set mode and let window package know about it (DONE) primitive window close routine DONE close a window >WINDOW# ( n -- ) go to a nested window # typicaly used to go to base window WWAIT wait until mouse button is released
