( Utilities RHS 17:17 12/15/86 ) ( Last change: Screen 000 RHS 17:17 12/15/86 ) ***************************************** * F A R S I D E R E S E A R C H * * (C) 1985,1986 * ***************************************** Revision: 1.2 UR/FORTH version ( memory words 08:33 09/30/87 ) : MALLOC ( #paras --- segment | -1 ) getmem ; : FREE ( segment --- ) relmem DROP ; ( variables RHS 17:14 12/15/86 ) VARIABLE SCR-ADDR \ video ram addr VARIABLE ATTRIB 5 ALLOT \ video attributes 0 EQU WND.BUFF \ buffer for windows VARIABLE BUFF-END \ 'WINDOW-BUFF+BUFF-END = avail VARIABLE <#cols> 80 <#cols> ! ( window-buff-init rhs 09:49 09/19/86 ) : WINDOW-BUFF-INIT WND.BUFF 0= IF 1500 MALLOC DUP EQU WND.BUFF -1 = IF ." Not enough Memory for WINDOWS" 0 RETURN THEN 0 BUFF-END ! THEN ; : PCKEY KEY DUP 0= IF KEY SWAP THEN ; \ scr-init 11:39 12/14/87 : SCR-INIT ?MODE DUP 7 < IF DROP 1 THEN CASE 07 OF 112 ATTRIB 4 + C! 143 ATTRIB 3 + C! 15 ATTRIB 2 + C! 112 ATTRIB 1+ C! 7 ATTRIB C! ENDOF 01 OF 111 ATTRIB 4 + C! 148 ATTRIB 3 + C! 30 ATTRIB 2 + C! 120 ATTRIB 1+ C! 23 ATTRIB C! ENDOF ENDCASE ?VSEG SCR-ADDR ! \ video ram address WINDOW-BUFF-INIT ; \ attributes 1 22:10 12/02/87 \ These are set by SCR-INIT and are used for consistency on \ both monochrome and color systems. : NOR ATTRIB C@ ; \ normal : REV ATTRIB 1+ C@ ; \ reverse : HIL ATTRIB 2 + C@ ; \ high light : BLN ATTRIB 3 + C@ ; \ blink : LTB ATTRIB 4 + C@ ; \ light bar : +CUR ?MODE 7 = IF 10 11 ELSE 6 7 THEN SET-CURSOR ; : -CUR 14 0 SET-CURSOR ; ( Window Descriptions RHS 09:25 09/20/86 ) \ These windows uses a pseudo-stack for their allocation \ and therefore the window last opened has to be closed first. \ The window BUFFER starts and the address return SCR.BUFF and \ extends 24K after that. Each time a window is opened the \ system saves the screen under that window, allowing a \ layering effect to take place. It is the programmer's \ responibility to manage this window properly. \ The two words to do this are: \ PUSH-WINDOW - this saves the defined window on \ the window stack \ POP-WINDOW - restores the defined window from the \ window stack \ It should be noted that the row and col values can be \ changed when the window is NOT open, changing the position \ on the screen .. ( window 10:16 10/05/86 ) \ The layout in the window definitions is the four values \ on the stack plus current x, current y, the buffer address, \ and the buffer size . The number of lines is actually plus \ the zero line ( ie 24 # rows is 25 actual lines ) ( upper row, upper col, # rows, # cols -- ) : WINDOW CREATE OVER 1+ OVER 1+ * 2* , 0 , C, C, C, C, 1 C, 1 C, DOES> ; 0 0 24 79 WINDOW FULLW \ this defines the full screen ( window definitions RHS 16:00 09/21/86 ) \ These words define the elements in the WINDOW definition ( window -- addr of ) : WINDOW-BUFF 2+ ; \ offset into window storage : WINDOW-#ROW 5 + ; \ number of rows in window : WINDOW-#COL 4 + ; \ number of cols in window : WINDOW-ROW 7 + ; \ starting row : WINDOW-COL 6 + ; \ starting column : WINDOW-CURR 8 + ; \ current row position in window : WINDOW-CURC 9 + ; \ current col. position in window ( window -- size ) : WINDOW-SZ DUP WINDOW-#ROW C@ 1+ SWAP WINDOW-#COL C@ 1+ * 2* ; ( +wnd-xy & -wnd-xy 12:02 10/01/86 ) \ These routines allow the rw cl to be changed by the specified \ numbers ... ( cl rw wnd -- ) : +WND-XY SWAP OVER WINDOW-ROW C@ + OVER WINDOW-ROW C! SWAP OVER WINDOW-COL C@ + SWAP WINDOW-COL C! ; : -WND-XY SWAP OVER WINDOW-ROW C@ SWAP - OVER WINDOW-ROW C! SWAP OVER WINDOW-COL C@ SWAP - SWAP WINDOW-COL C! ; ( window -- cl rw ) : ?WND-XY >R ?XY R@ WINDOW-ROW C@ - R> SWAP >R WINDOW-COL C@ - R> ; ( offsets RHS 16:01 09/21/86 ) ( col row -- abs-off ) : SCREEN-OFF <#cols> @ * + 2 * ; \ rets. abs-off for x,y \ The returns the x,y offset relative to the window definition \ The returned Value is the systems absolute address in \ Video Memory ... ( col row window -- abs-off ) : WINDOW-OFF ROT OVER WINDOW-COL C@ + ROT ROT WINDOW-ROW C@ + SCREEN-OFF ; ( save-window RHS 09:23 09/20/86 ) \ This word saves the current characters and screen attribs \ to the next available chunk of the buffer ... ( window -- ) : PUSH-WINDOW DUP WINDOW-#ROW C@ 1+ 0 DO DUP WINDOW-ROW C@ I + OVER WINDOW-COL C@ SWAP SCREEN-OFF SCR-ADDR @ SWAP ROT WND.BUFF BUFF-END @ ROT DUP >R WINDOW-#COL C@ 1+ 2* DUP BUFF-END +! CMOVEL R> LOOP DROP ; ( pop-window 16:52 11/17/86 ) \ This word restores the size chunk of the specified window to \ the actual screen addr. ( window -- ) : POP-WINDOW DUP BUFF-END @ SWAP WINDOW-SZ - BUFF-END ! DUP WINDOW-#ROW C@ 1+ 0 DO WND.BUFF BUFF-END @ ROT SCR-ADDR @ SWAP DUP WINDOW-COL C@ OVER WINDOW-ROW C@ I + SCREEN-OFF SWAP DUP >R WINDOW-#COL C@ 1+ 2* DUP BUFF-END +! CMOVEL R> LOOP BUFF-END @ SWAP WINDOW-SZ - BUFF-END ! ; ( window functions 10:26 09/20/86 ) ( window -- dx cx bx ) : WND-PARMS DUP WINDOW-ROW C@ OVER WINDOW-#ROW C@ + 1- 8 SHIFT OVER DUP WINDOW-COL C@ SWAP WINDOW-#COL C@ + 1- + SWAP DUP WINDOW-ROW C@ 1+ 256 * SWAP WINDOW-COL C@ + 1+ NOR 8 SHIFT ; : WND-EXEC regAX ! regBX ! regCX ! regDX ! 16 INT86 ; \ Clears the inside of the defined WINDOW : WND-CLR WND-PARMS 1536 WND-EXEC ; ( window -- ) \ Clears the entire area of the defined WINDOW : BOX-CLR WND-PARMS ROT 257 + ROT 257 - ROT ( window -- ) 1536 WND-EXEC ; ( window functions - cont. 17:21 09/23/86 ) \ Scrolls the specified window up 1 line : WND-UP WND-PARMS 1537 WND-EXEC ; ( window -- ) \ Scrolls the specified window down 1 line : WND-DOWN WND-PARMS 1793 WND-EXEC ; ( window -- ) \ Sets the cursor position to the specified window position ( col row window -- ) : WND-GOTOXY 2 PICK OVER WINDOW-CURC C! \ put col in storage 2DUP WINDOW-CURR C! \ put row in storage DUP WINDOW-COL C@ SWAP WINDOW-ROW C@ >R ROT + SWAP R> + GOTOXY ; ( wnd-char! & wnd-str! RHS 16:01 09/21/86 ) ( attr byte offset -- ) : CHAR! ROT ROT SWAP 8 SHIFT + SCR-ADDR @ ROT !L ; ( cl rw window attr byte -- ) : WND-CHAR! >R >R WINDOW-OFF R> R> ROT CHAR! ; \ Displays a non-counted string at the specified location ( cl rw window attr len str-addr -- ) : WND-STR! 5 ROLL 5 ROLL 5 ROLL WINDOW-OFF ROT 0 DO 2 PICK 2 PICK I + C@ 2 PICK I 2 * + CHAR! LOOP DROP DROP DROP ; ( wnd-cstr! & cls RHS 09:25 09/20/86 ) \ Exactly the same as WND-STR! but uses a counted string ( cl rw window attr str-addr -- ) : WND-CSTR! DUP C@ SWAP 1+ WND-STR! ; \ Redefines CLS to use normal attribute ( -- ) : CLS 6223 0 NOR 8 SHIFT 1536 WND-EXEC 0 0 GOTOXY ; ( long display words 09:01 03/10/87 ) \ These perform like WND-CSTR! & WND-STR! yet require a segment \ and offset for displaying strings outside the forth segment ( cl rw window attr len seg off -- ) : WND-L.STR! 6 ROLL 6 ROLL 6 ROLL WINDOW-OFF 3 ROLL 0 ?DO 3 PICK \ get the attrib 3 PICK 3 PICK I + C@L \ get the character 2 PICK I 2* + CHAR! \ display it LOOP 2DROP 2DROP ; ( cl rw window attr seg off -- ) : WND-L.CSTR! 2DUP C@L ROT ROT 1+ WND-L.STR! ; ( wnd-emit 14:31 03/24/87 ) ( window -- t/f ) : ?WND-BOTTOM DUP WINDOW-CURR C@ SWAP WINDOW-#ROW C@ 1- = ; ( window -- t/f ) : ?WND-END DUP WINDOW-CURC C@ SWAP WINDOW-#COL C@ 1- = ; ( window -- t/f ) : ?WND-LRC DUP ?WND-BOTTOM SWAP ?WND-END AND ; ( wnd-emit cont. 14:31 03/24/87 ) ( window -- ) : WLF DUP ?WND-BOTTOM IF WND-UP ELSE DUP WINDOW-CURR C@ 1+ SWAP WINDOW-CURR C! THEN ; ( window -- ) : WCR 1 SWAP WINDOW-CURC C! OUT OFF ; ( window -- ) : WBS DUP WINDOW-CURC C@ 1 = IF DROP EXIT THEN DUP WINDOW-CURC C@ 1- OVER WINDOW-CURC C! >R R@ WINDOW-CURC C@ R@ WINDOW-CURR C@ R> NOR 32 WND-CHAR! ; ( wnd-emit cont. 14:31 03/24/87 ) ( char window -- ) : WND-EMIT SWAP OVER ROT ROT CASE 13 OF WCR ENDOF 10 OF WLF ENDOF 8 OF WBS ENDOF OVER ?WND-LRC IF OVER WND-UP THEN OVER ?WND-END IF OVER WCR OVER ?WND-BOTTOM NOT IF OVER WLF THEN THEN SWAP >R R@ WINDOW-CURC C@ SWAP R@ WINDOW-CURR C@ SWAP R@ SWAP NOR SWAP WND-CHAR! 1 OUT +! R@ WINDOW-CURC C@ 1+ R@ WINDOW-CURC C! R> ENDCASE >R R@ WINDOW-CURC C@ R@ WINDOW-CURR C@ R> WND-GOTOXY ; ( wnd-type 14:32 03/24/87 ) ( saddr cnt wnd -- ) : WND-TYPE SWAP 0 ?DO OVER I + C@ OVER WND-EMIT LOOP 2DROP ; ( window -- ) : WND-CR 13 OVER WND-EMIT 10 SWAP WND-EMIT OUT OFF ; ( window outlines 10:33 09/21/86 ) \ These words define the outline characters for boxes on \ the IBM PC ... Both single and doubles lines are defined CREATE DOUBLE 201 C, 187 C, 200 C, 188 C, 186 C, 205 C, CREATE SINGLE 218 C, 191 C, 192 C, 217 C, 179 C, 196 C, \ Defines the character in the array ( address of character array -- ) : ULC C@ ; : URC 1+ C@ ; : LLC 2+ C@ ; : LRC 3 + C@ ; : V-LNE 4 + C@ ; : H-LNE 5 + C@ ; ( box outliners 11:26 09/21/86 ) ( lines window -- ) : DRAW-V-LNE DUP WINDOW-#ROW C@ 0 DO OVER V-LNE 0 I ROT 3 PICK SWAP NOR SWAP WND-CHAR! 2DUP SWAP V-LNE SWAP WINDOW-#COL C@ I ROT 3 PICK SWAP NOR SWAP WND-CHAR! LOOP DROP DROP ; : DRAW-H-LNE DUP WINDOW-#COL C@ 1 DO 2DUP SWAP H-LNE SWAP I SWAP WINDOW-#ROW C@ ROT 3 PICK SWAP NOR SWAP WND-CHAR! I 0 2 PICK REV 32 WND-CHAR! LOOP DROP DROP ; ( window box 11:44 09/21/86 ) \ This word draws the defined box it is called like \ SINGLE WINDOW BOX ( char-outlines, window -- ) : BOX 2DUP SWAP LLC SWAP 0 SWAP WINDOW-#ROW C@ ROT 3 PICK SWAP NOR SWAP WND-CHAR! 2DUP SWAP LRC SWAP DUP WINDOW-#COL C@ SWAP WINDOW-#ROW C@ ROT 3 PICK SWAP NOR SWAP WND-CHAR! 2DUP DRAW-V-LNE DRAW-H-LNE ; ( window labels RHS 08:11 09/22/86 ) \ These words allow a label to be tagged with a sub label \ these words are called by WINDOW-BANNER : WINDOW-LABELS " edithelpviewlistmenutextstat " ; 0 CONSTANT EDITL 4 CONSTANT MENUL 1 CONSTANT HELPL 5 CONSTANT TEXTL 2 CONSTANT VIEWL 6 CONSTANT STATL 3 CONSTANT LISTL 7 CONSTANT NONE ( no for label -- address ) : WND-LABEL 4 * WINDOW-LABELS 1+ + ; ( window-banner 13:05 09/21/86 ) \ WINDOW-BANNER builds the reversed title line for the specified\ window. ( window title-addr label -- ) : WINDOW-BANNER WND-LABEL >R OVER DUP WINDOW-#COL C@ 6 - 0 ROT REV 4 R> WND-STR! >R 2 0 ROT REV R> WND-CSTR! ; \ Fills the specified window with the character ( char window -- ) : WND-FILL DUP WINDOW-#ROW C@ 1+ 0 DO DUP WINDOW-#COL C@ 1+ 0 DO I J 3 PICK 3 PICK SWAP NOR SWAP WND-CHAR! LOOP LOOP DROP DROP ; ( open-window 13:08 09/21/86 ) \ OPEN-WINDOW performs all the functions to put a labeled window\ on the screen: titleing, saving, outlining \ CLOSE-WINDOW is merely a POP-WINDOW but is used for \ consistency ( address of label, label, lines, window -- ) : OPEN-WINDOW 257 OVER WINDOW-CURR ! \ set cur. pos to 1,1 DUP PUSH-WINDOW \ save old stuff DUP BOX-CLR \ clear it out SWAP OVER BOX \ draw box ROT ROT WINDOW-BANNER \ put up header ; ( window -- ) : CLOSE-WINDOW POP-WINDOW ; ( isset RHS 00:30 01/01/87 ) \ ISSET returns a true/false is the value is within domain \ of the specified. ( n HIGH-LIM LOW-LIM -- ) : ISSET >R OVER >= IF R> >= IF -1 EXIT THEN ELSE R> DROP DROP THEN 0 ; ( char -- t/f ) : ISDIGIT 57 48 ISSET ; \ is byte a digit : ISUPPER 90 65 ISSET ; \ is upper case : ISLOWER 122 97 ISSET ; : ISALPHA DUP ISUPPER IF DROP -1 EXIT ELSE ISLOWER THEN ; : ISALNUM DUP ISALPHA IF DROP -1 EXIT ELSE ISDIGIT THEN ; : ERRTONE 512 8 BEEP ; \ system's error tone ( toupper & tolower 09:37 04/27/87 ) \ These words change a char from lower to upper case and vice \ versa ... if the char is now alpha then the char remains the \ same ... ( char -- upper case char ) : TOUPPER DUP ISLOWER IF 32 - THEN ; ( char -- lower case char ) : TOLOWER DUP ISUPPER IF 32 + THEN ; : MAKEUC ( addr count --- ) 0 ?DO DUP C@ TOUPPER OVER C! 1+ LOOP DROP ; ( choice words RHS 07:50 09/23/86 ) ( addr-choice num-choice disp-len str-len -- ) : CHOICE CREATE C, C, , , DOES> ; : CH-LEN@ C@ ; ( choice word -- len of str ) : CH-ADDR@ 4 + @ ; ( choice word -- addr text ) : CH-NUM@ 2+ @ ; ( choice word -- # choices ) : CH-DISP@ 1+ C@ ; ( choice word -- len disp ) ( choice num -- addr of choice ) : 'CHOICE OVER CH-LEN@ * SWAP CH-ADDR@ 1+ + ; ( .choice RHS 08:29 09/23/86 ) ( attr window choice-word num -- ) : .CHOICE ROT >R ROT >R \ store attr and window 2 SWAP 1+ ROT OVER 1- \ row and col R> R> SWAP >R ROT \ get window ROT R> ROT ROT \ cl,rw,window,attr OVER CH-DISP@ ROT ROT \ disp len 'CHOICE WND-STR! ; \ address and display ( choice - Cont. 12:19 09/24/86 ) ( window choice -- ) : CHOICE-FILL DUP CH-NUM@ 0 DO NOR 2 PICK 2 PICK I .CHOICE LOOP DROP DROP ; ( window choice -- window choice 1 ) : LAST-CHOICE NOR 2 PICK 2 PICK DUP CH-NUM@ 1- .CHOICE LTB 2 PICK 2 PICK 0 .CHOICE 1 ; ( window choice -- window choice ch-num@ ) : FIRST-CHOICE LTB 2 PICK 2 PICK DUP CH-NUM@ 1- .CHOICE NOR 2 PICK 2 PICK 0 .CHOICE DUP CH-NUM@ ; ( choice - Cont. RHS 10:25 04/12/86 ) \ These two words define the actions of the updown arrow \ keys ( window choice num -- window choice num-1 ) : UP-CHOICE NOR 3 PICK 3 PICK 3 PICK 1- .CHOICE 2- LTB 3 PICK 3 PICK 3 PICK .CHOICE 1+ ; ( window choice num -- window choice num+1 ) : DW-CHOICE NOR 3 PICK 3 PICK 3 PICK 1- .CHOICE LTB 3 PICK 3 PICK 3 PICK .CHOICE 1+ ; ( cap-scan RHS 10:37 09/23/86 ) \ This words define searchs the specified choice word for \ capital letter ( specifify choices ) ( window choice num char -- 0 for not found, + for found ) : CAP-SCAN DUP 90 65 ISSET IF 2 PICK DUP CH-LEN@ OVER CH-NUM@ * SWAP CH-ADDR@ 1+ SWAP ROT SCAN IF 2 PICK CH-ADDR@ - 2 PICK CH-LEN@ / 1+ ELSE DROP 0 THEN ELSE DROP 0 THEN ; ( choose-input 12:17 09/23/86 ) \ CHOOSE uses a vectored word for the main loop input this \ is built in for times when a function is defined on a key \ and should be accessed with one key stroke normal operation \ requires the returns to be those of PCKEY's VARIABLE 'CHOOSE-INP ( -- return value ) : CHOOSE-INPUT 'CHOOSE-INP PERFORM ; \ This changes the 'CHOOSE-INP value used ['] WORD !CHOOSE-INP ( vector of word -- ) : !CHOOSE-INP 'CHOOSE-INP ! ; ' PCKEY !CHOOSE-INP \ default for system ( choose RHS 10:51 09/23/86 ) ( window choice -- returned choice ) : CHOOSE 2DUP CHOICE-FILL LTB 2 PICK 2 PICK 0 .CHOICE 1 BEGIN CHOOSE-INPUT ?DUP DROP CASE 72 OF DUP 1 = IF DROP FIRST-CHOICE ELSE UP-CHOICE THEN ENDOF 80 OF DUP 2 PICK CH-NUM@ = IF DROP LAST-CHOICE ELSE DW-CHOICE THEN ENDOF 13 OF NOR 3 ROLL 3 ROLL 3 PICK 1- .CHOICE EXIT ENDOF 27 OF NOR 3 ROLL 3 ROLL 3 ROLL 1- .CHOICE 0 EXIT ENDOF CAP-SCAN DUP IF >R NOR 3 ROLL 3 ROLL 3 ROLL 1- .CHOICE R> EXIT THEN ENDCASE AGAIN ; ( choose-exec 07:38 06/11/86 ) ( words-lst window choice -- 1 for execute, 0 for escape ) : CHOOSE-EXEC 2DUP CHOICE-FILL LTB 2 PICK 2 PICK 0 .CHOICE 1 BEGIN CHOOSE-INPUT ?DUP DROP CASE 72 OF DUP 1 = IF DROP FIRST-CHOICE ELSE UP-CHOICE THEN ENDOF 80 OF DUP 2 PICK CH-NUM@ = IF DROP LAST-CHOICE ELSE DW-CHOICE THEN ENDOF 13 OF NOR 3 ROLL 3 ROLL 3 PICK 1- .CHOICE 1- 2* + @ EXECUTE 1 EXIT ENDOF 27 OF NOR 3 ROLL 3 ROLL 3 ROLL 1- .CHOICE DROP 0 EXIT ENDOF CAP-SCAN DUP IF >R NOR 3 ROLL 3 ROLL 3 ROLL 1- .CHOICE R> 1- 2* + @ EXECUTE 1 EXIT THEN ENDCASE AGAIN ; ( scroll choose 08:47 09/24/86 ) \ SCHOOSE is like CHOOSE however it is used with lists that \ can potenially be bigger then the window. It uses the same \ vectored input word and this allows the system to do data \ entry also with this routine. Further, SCHOOSE uses a vectored\ display word 'SDISP-WORD to allow for compilation lists. \ The vector defaults to S-DISP, and it is the programmer's \ responsibility to reset after changing it ( use SNORM ). ( scroll choose RHS 07:45 09/24/86 ) ( window line -- t/f ) : BL? SWAP WINDOW-#ROW C@ 1- = ; ( window line -- t/f ) : TL? NIP 1 = ; ( window line -- rw cl ) : SWND-POS NIP 2 SWAP ; \ Vector for display word VARIABLE 'SDISP-WORD ( attr window choices num lne -- ) : S-CH. 'SDISP-WORD @ EXECUTE ; ( scroll - cont. RHS 09:11 05/22/86 ) ( attr window choice num lne -- ) : S-DISP SWAP >R SWAP >R OVER >R SWND-POS ROT R> SWAP R> R> OVER CH-DISP@ ROT ROT 'CHOICE WND-STR! ; \ Set for system default ' S-DISP 'SDISP-WORD ! \ Resets display vector : SNORM ['] S-DISP 'SDISP-WORD ! ; \ Displays the last choice in the window ( window choice num line -- window choices num line ) : SLST-CH OVER 3 PICK CH-NUM@ = IF 100 5 BEEP EXIT THEN NOR 4 PICK 4 PICK 4 PICK 1- 4 PICK S-CH. 3 PICK WND-UP LTB 4 PICK 4 PICK 4 PICK 4 PICK S-CH. SWAP 1+ SWAP ; ( scroll - cont. RHS 09:08 09/03/86 ) ( window choices num line -- window choices num lne ) : SFST-CH OVER 1 = IF 100 5 BEEP EXIT THEN NOR 4 PICK 4 PICK 4 PICK 1- 4 PICK S-CH. 3 PICK WND-DOWN SWAP 2- SWAP LTB 4 PICK 4 PICK 4 PICK 4 PICK S-CH. SWAP 1+ SWAP ; ( window choices -- ) : SCH-FILL OVER WINDOW-#ROW C@ 1- OVER CH-NUM@ 2DUP >= IF NIP ELSE DROP THEN 0 DO NOR 2 PICK 2 PICK I I 1+ S-CH. LOOP DROP DROP ; ( scroll - cont. RHS 13:39 03/25/86 ) ( window choice num lne -- window choice num-1 lne-1 ) : SCH-UP NOR 4 PICK 4 PICK 4 PICK 1- 4 PICK S-CH. SWAP 2- SWAP 1- LTB 4 PICK 4 PICK 4 PICK 4 PICK S-CH. SWAP 1+ SWAP ; ( window choice num lne -- window choice num-1 lne-1 ) : SCH-DW OVER 3 PICK CH-NUM@ = IF 100 5 BEEP EXIT THEN NOR 4 PICK 4 PICK 4 PICK 1- 4 PICK S-CH. 1+ LTB 4 PICK 4 PICK 4 PICK 4 PICK S-CH. SWAP 1+ SWAP ; ( pg-up & pg-dw hs 09:28 07/09/86 ) ( window choice num lne -- window choice num lne ) : PG-UP OVER 1 = IF ERRTONE EXIT THEN 3 PICK WINDOW-#ROW C@ 2 - 0 DO OVER 1 = IF LEAVE THEN 3 PICK OVER TL? IF SFST-CH ELSE SCH-UP THEN LOOP ; ( window choice num lne -- window choice num lne ) : PG-DW 2 PICK CH-NUM@ 2 PICK = IF ERRTONE EXIT THEN 3 PICK WINDOW-#ROW C@ 2 - 0 DO 2 PICK CH-NUM@ 2 PICK = IF LEAVE THEN 3 PICK OVER BL? IF SLST-CH ELSE SCH-DW THEN LOOP ; ( schoose hs 09:29 07/09/86 ) ( win choices -- no of choose or 0 for escape ) : SCHOOSE 2DUP SCH-FILL LTB 2 PICK 2 PICK 0 1 S-CH. 1 1 BEGIN CHOOSE-INPUT ?DUP DROP CASE 72 OF DUP 4 PICK SWAP TL? IF SFST-CH ELSE SCH-UP THEN ENDOF 80 OF DUP 4 PICK SWAP BL? IF SLST-CH ELSE SCH-DW THEN ENDOF 73 OF PG-UP ENDOF 81 OF PG-DW ENDOF 13 OF NOR 4 ROLL 4 ROLL 4 PICK 1- 4 PICK S-CH. DROP EXIT ENDOF 27 OF NOR 4 ROLL 4 ROLL 4 ROLL 1- 4 ROLL S-CH. 0 EXIT ENDOF ENDCASE 0 UNTIL ; ( bits 14:57 10/30/87 ) ( bit number 0-15 -- mask ) : BITS 1 SWAP SHIFT ; ( byte bits -- byte ) : +BIT BITS OR ; \ turn bit on : -BIT BITS NOT AND ; \ turn bit off ( byte bits -- t/f ) : @BIT BITS AND 0= 0= ; \ fetch bit ( byte bits -- byte ) : ~BIT 2DUP @BIT IF -BIT ELSE +BIT THEN ; \ toggle bit ( ?exit 11:22 11/14/87 ) VARIABLE OK-KEYS CREATE NORM-KEYS 5 C, 13 C, 80 C, 72 C, 27 C, 68 C, NORM-KEYS OK-KEYS ! ( key -- t/f ) : ?EXIT ?DUP 0 = IF 7 +BIT THEN OK-KEYS @ C@ 0 ?DO DUP I OK-KEYS @ 1+ + C@ DUP 32 > IF 7 +BIT THEN = IF 7 -BIT -1 LEAVE THEN LOOP ; ( Variables 17:20 10/11/87 ) VARIABLE MAX-MS \ digits before decimal VARIABLE MAX-LS \ digits after decimal VARIABLE ?DECS \ in digits mode ? VARIABLE #DECS \ where are we VARIABLE #PAD 20 ALLOT \ pad for formatting 2VARIABLE WRK-NUM \ actual number \ <#num#> 15:05 03/16/88 : <#NUM#> ( d #decs --- addr count ) -ROT DUP >R DABS 2DUP <# #S #> NIP >R <# 32 HOLD ROT DUP >R ?DUP IF 0 ?DO # LOOP 46 HOLD THEN R> R> SWAP - 3 /MOD SWAP 0= + 0 MAX 0 ?DO # # # 44 HOLD LOOP #S R> SIGN #> ; \ fmt-num 1 14:52 03/16/88 ( -- addr num ) : FMT-NUM WRK-NUM 2@ ?DECS @ IF #DECS @ ELSE 0 THEN <#NUM#> ; ( cl rw wnd -- ) : DISP-NUM #PAD 17 BLANK MAX-MS @ MAX-LS @ + 1+ \ longest length MAX-MS @ 3 / + DUP \ last colum FMT-NUM ROT OVER 1- - #PAD + SWAP CMOVE REV SWAP #PAD WND-STR! ; ( !# 17:21 10/11/87 ) : 10D* 2DUP 2DUP D+ 2DUP D+ D+ 2DUP D+ ; ( number -- ) : !# #DECS @ MAX-LS @ = ?DECS @ AND IF DROP ERRTONE EXIT THEN ?DECS @ NOT IF WRK-NUM 2@ <# #S #> SWAP DROP #DECS @ - MAX-MS @ = IF DROP ERRTONE EXIT THEN THEN S>D ?DECS @ IF 1 #DECS +! THEN WRK-NUM 2@ 10D* D+ WRK-NUM 2! ; ( n-bcksp 17:21 10/11/87 ) : N-BCKSP ?DECS @ IF #DECS @ 0= IF ?DECS OFF EXIT ELSE -1 #DECS +! THEN THEN #PAD 17 BLANK WRK-NUM 2@ <# #S #> DUP >R #PAD 1+ SWAP CMOVE 32 #PAD 1+ R> + 1- C! 0. #PAD CONVERT DROP WRK-NUM 2! ; : DEC-ON MAX-LS @ IF ?DECS ON ELSE ERRTONE THEN ; ( process 17:21 10/11/87 ) ( rw cl wnd -- return_key ) : #PROCESS BEGIN PCKEY ?EXIT CASE -1 OF -1 ENDOF 08 OF N-BCKSP 2 PICK 2 PICK 2 PICK DISP-NUM 0 ENDOF 46 OF DEC-ON 2 PICK 2 PICK 2 PICK DISP-NUM 0 ENDOF 10 DIGIT> IF !# 2 PICK 2 PICK 2 PICK DISP-NUM 0 0 ELSE 0 0 THEN ENDCASE UNTIL ; ( @num 17:21 10/11/87 ) ( rw cl wnd d. ls ms -- ) : @NUM MAX-MS ! MAX-LS ! 2DUP WRK-NUM 2! ?DECS OFF #DECS OFF 0. D= NOT IF MAX-LS @ DUP ?DECS ! #DECS ! THEN 2 PICK 2 PICK 2 PICK DISP-NUM MAX-LS @ MAX-MS @ DUP >R + 3 PICK + R> 3 / + 2 PICK 2 PICK WND-GOTOXY #PROCESS >R WRK-NUM 2@ MAX-LS @ #DECS @ - 0 ?DO 10D* LOOP WRK-NUM 2! #PAD 17 BLANK HIL WRK-NUM 2@ 2DUP <# #S #> SWAP DROP >R <# MAX-LS @ IF MAX-LS @ 0 ?DO # LOOP 46 HOLD THEN R> MAX-LS @ - 3 /MOD SWAP 0= + 0 MAX 0 ?DO # # # 44 HOLD LOOP #S #> #PAD SWAP CMOVE MAX-LS @ MAX-MS @ + 3 + #PAD WND-STR! WRK-NUM 2@ R> ; \ pcexpect 10:06 04/04/88 : PCEXPECT ( addr len --- Ret_key ) SPAN OFF 13 -ROT 0 ?DO PCKEY ?EXIT CASE -1 OF BL EMIT NIP SWAP LEAVE ENDOF 08 OF I IF 8224 OVER I 1- + ! 8 EMIT BL EMIT 8 EMIT -1 DUP SPAN +! ELSE 7 EMIT 0 THEN ENDOF 205 OF DUP I + C@ EMIT 1 ENDOF 203 OF I IF -1 8 ELSE 0 7 THEN EMIT ENDOF DUP EMIT OVER I + C! 1 SPAN @ I <= IF 1 SPAN +! THEN 0 ENDCASE +LOOP DROP ; --> ( @string RHS 16:22 10/14/86 ) ( cl rw window addr len -- ret/code ) : @STRING 4 PICK 4 PICK 4 PICK 4 PICK 4 PICK REV ROT ROT SWAP WND-STR! REVERSE 4 PICK 4 PICK 4 PICK WND-GOTOXY 2DUP PCEXPECT >R REVERSE HIL ROT ROT SWAP WND-STR! R> ; ( ne-input RHS 17:46 05/05/86 ) : NE-INPUT SPAN OFF OVER SWAP DUP >R 0 DO PCKEY DUP 32 < IF DUP 8 = IF SPAN @ 0 = IF 7 EMIT R> 1- >R DROP ELSE 8 EMIT 32 EMIT 8 EMIT R> 2- >R -1 SPAN +! DROP 1- DUP 0 SWAP C! THEN ELSE ?DUP DROP LEAVE THEN ELSE 88 EMIT OVER C! 1 SPAN +! 1+ THEN LOOP R> SPAN C@ = IF 0 THEN ROT DROP SWAP DROP ; ( date stuff 10:08 09/24/86 ) : MTH-ARRAY " JanFebMarAprMayJunJulAugSepOctNovDec" ; ( addr of fmt-array date -- ) : FMT-DATE 256 /MOD 1- 3 * MTH-ARRAY 1+ + 3 PICK 3 CMOVE 0 <# 44 HOLD # # #> 3 PICK 4 + SWAP CMOVE 0 <# # # # # #> ROT 8 + SWAP CMOVE ; ( addr of fmt-pad -- ) : TODAY@ @DATE FMT-DATE ; ( cl rw window attr -- ) : SHOW-DATE PAD 12 32 FILL PAD TODAY@ 12 PAD WND-STR! ; ( comment RHS 00:24 01/01/87 ) \ This next section contains the code for FMT-INPUT ... \ FMT-INPUT ( ?valid-char RHS 13:46 10/06/86 ) ( fmt-str pos char -- t/f ) : ?VALID-CHAR ROT 1+ ROT + C@ CASE 97 OF ISALPHA EXIT ENDOF \ letter 109 OF ISALNUM EXIT ENDOF \ letter / digit 110 OF ISDIGIT EXIT ENDOF \ digit ENDCASE ; ( char -- t/f ) : ?FMT-CHAR CASE 97 OF -1 EXIT ENDOF 109 OF -1 EXIT ENDOF 110 OF -1 EXIT ENDOF ENDCASE 0 ; ( nxt-char RHS 13:36 10/06/86 ) ( 'fmt-str position -- 'fmt-str position+n ) : NXT-CHAR OVER C@ OVER 1+ = IF EXIT THEN 1+ OVER 1+ OVER + C@ BEGIN ?FMT-CHAR 0= WHILE OVER C@ OVER 1- = IF EXIT THEN 1+ OVER 1+ OVER + C@ \ get next char REPEAT ; ( bck-char RHS 13:35 10/06/86 ) ( 'fmt-str position -- 'fmt-str position-n ) : BCK-CHAR OVER DUP C@ 0 DO DUP 1+ I + C@ ?FMT-CHAR IF DROP I LEAVE THEN LOOP \ find first valid fmt char OVER = IF EXIT THEN \ same == at first position DUP 0= IF EXIT THEN 1- OVER 1+ OVER + C@ BEGIN ?FMT-CHAR 0= WHILE DUP 0= IF EXIT THEN \ at start ? 1- OVER 1+ OVER + C@ \ get back char REPEAT ; ( str-set hs 16:26 10/06/86 ) ( 'fstr 'dstr -- ) : STR-SET OVER C@ OVER C! OVER C@ 0 DO OVER 1+ I + C@ ?FMT-CHAR IF NOOP ELSE OVER 1+ I + C@ OVER 1+ I + C! THEN LOOP DROP DROP ; ( fmt-input 16:31 10/06/86 ) ( cl rw window 'fstr 'dstr -- ) : FMT-INPUT 2DUP STR-SET SWAP >R 2OVER 2OVER REV SWAP WND-CSTR! R> DUP 1+ C@ ?FMT-CHAR 0= IF 0 NXT-CHAR ELSE 0 THEN SWAP >R >R 3 PICK R@ + 3 PICK 3 PICK WND-GOTOXY R> R> SWAP BEGIN PCKEY ?EXIT CASE -1 OF >R SWAP 2DROP HIL SWAP WND-CSTR! R> EXIT ENDOF 8 OF 2 PICK 1+ OVER + 32 SWAP C! BCK-CHAR ENDOF 203 OF BCK-CHAR ENDOF 205 OF NXT-CHAR ENDOF 2 PICK 2 PICK 2 PICK ?VALID-CHAR IF 3 PICK 1+ 2 PICK + C! NXT-CHAR 1 ELSE ERRTONE THEN ENDCASE SWAP >R >R 2OVER 2OVER REV SWAP WND-CSTR! 3 PICK R@ + 3 PICK 3 PICK WND-GOTOXY R> R> SWAP AGAIN ; ( get-date RHS 10:02 10/13/86 ) \ This word fetches the date from the operator ( cl row window d=default -- d=date ) : GET-DATE SWAP 100 /MOD DROP SWAP 256 /MOD 100 * + 100 UM* ROT 0 D+ <# # # 47 HOLD # # 47 HOLD # # #> DUP TIB C! TIB 1+ SWAP CMOVE 2 PICK 2 PICK 2 PICK " nn/nn/nn" TIB FMT-INPUT >R HIL TIB WND-CSTR! 2 TIB C! TIB NUMBER? 2DROP 2 TIB 3 + C! TIB 3 + NUMBER? 2DROP 2 TIB 6 + C! TIB 6 + NUMBER? 2DROP 1900 + ROT ROT SWAP 256 * + R> ; ( lword 08:33 01/30/87 ) \ This word parses the input string for a specified character \ and returns the len of the string and the temp addr of the \ string ( char -- len saddr ) : LWORD SOURCE >IN @ /STRING ROT PARSE >IN +! \ no UNDEFINED ! HERE >R \ find free space DUP R@ ! \ put in count R@ 2+ \ dest. addr SWAP 2+ DUP >R \ store length for ret. CMOVE R> R> ; \ move from tib to here ( runtime & S" 08:38 01/30/87 ) \ This is the actual LONG STRING word. It functions exactly like\ " but allows the compilation of strings up to 65535 chars \ NOTE: LWORD is like WORD but it returns the STR Addr and the \ length .. This has a WORD as string count not a byte. ( RUNTIME long string word ) : llitq R@ DUP @ 2+ R> + ALIGN >R ; ( used like: S" THIS IS A SMALL STRING" ) : S" STATE @ IF COMPILE llitq ASCII " LWORD DROP ALLOT EVEN ELSE ASCII " LWORD THEN ; IMMEDIATE \ ?yes/no 09:25 02/26/88 ( cl rw window t/f --- ret_code t/f ) : ?YES/NO 3 PICK 3 PICK 3 PICK 3 PICK ABS 3 * " No Yes" 1+ + REV SWAP 3 SWAP WND-STR! 3 PICK 3 PICK 3 PICK WND-GOTOXY BEGIN PCKEY ?EXIT ?DUP -1 = IF DROP >R >R HIL 3 R@ ABS 3 * " No Yes" 1+ + WND-STR! R> R> SWAP EXIT THEN " YyNn" COUNT 2 PICK SCAN NIP 0<> IF NIP TOUPPER ASCII Y = >R HIL 3 R@ ABS 3 * " No Yes" 1+ + WND-STR! 13 R> EXIT ELSE DROP ERRTONE THEN AGAIN ; ( ?correct 14:02 04/28/87 ) \ This is a modified version of ?YES/NO that asks the full \ question, but this dissapears after input is received ( cl rw window -- t = yes, f = no ) : ?CORRECT 2 PICK 2 PICK 2 PICK HIL " Is this Correct ?" WND-CSTR! 2 PICK 18 + 2 PICK 2 PICK -1 ?YES/NO >R >R NOR " " WND-CSTR! R> R> ; ( \S 10:29 10/23/87 ) \ This word skips to the next screen : \S BLK @ IF >IN @ 1024 + -1024 AND ELSE #TIB @ THEN >IN ! ; ( screen input 09:24 12/03/87 ) ( #fields, CFA of help, CFA of input -- ) : INP-DEF CREATE , , C, DOES> ; ( input-screen, field to start -- t/f ) : @SCREEN BEGIN OVER @ OVER 2* + @ EXECUTE CASE 72 OF DUP 0= IF DROP DUP 4 + C@ THEN 1- ENDOF 80 OF 1+ OVER 4 + C@ OVER = IF DROP 0 THEN ENDOF 13 OF 1+ OVER 4 + C@ OVER = IF DROP 0 THEN ENDOF 59 OF OVER 2+ @ EXECUTE ENDOF 27 OF 2DROP 0 EXIT ENDOF 68 OF 2DROP -1 EXIT ENDOF ENDCASE AGAIN ; \ turnkey 11:10 04/15/88 : TURNKEY ( -- ) \ use: TURNKEY <name> <filename> ' vABORT ! \ poke cfa of <name> into ABORT vector ['] BYE vQUIT ! \ poke cfa of BYE into QUIT vector ( HP OFF ) \ no headers SAVE 0 RETURN ; \ save .EXE file and exit
