@L|}6CD l0C)HCC WhL/h `CmCDiD`  R@W( L(1   Y I`  d  Ld M * @  $ % CC$$)%1 Udߥ$9%: !0 S$% DD˙`  }J)Lr  741 @ 4000 - DP ! ( SUGGESTED PLACEMENT OF TAREA ) 1 VARIABLE TPFLAG VARIABLE OLDDP ==>( Xsients: TRANSIENT PERMANENT ) : TRANSIENT ( -- ) TPFLAG @ NOT : PERMANENT ( -- ) TPFLAG @ IF HERE TP ! OLDDP @ DP ! 0 TPFLAG ! ENDIF ; --> BEGIN @ DUP TAREA U< UNTIL DUP ROT ! DUP 0= UNTIL DROP VOC-LINK @ BEGIN DUP 4 - UNTIL DROP @ DUP 0= UNTIL DROP [COMPILE] FORTH DEFINITIONS ." Done" CR ; PERMANENT BASE ! ( Utils: CARRAY ARRAY )BASE @ HEX : CARRAY ( cccc, n -- ) CREATE SMUDGE ( cccc: n -- a ) 95 C, 01 C, 4C C, ' + ( CFA @ ) , C; : ARRAY ( cccc, n -- ) CREATE SMUDGE ( cccc: n -- a ) 2* ALLOT ;CODE 16 C, 00 C, 36 C, 01 C, 4C C, ' CARRAY 08 + , C; ==>( Utils: CTABLE TABLE ) : CTABLE ( cccc, -- ) CREATE SMUDGE ( cccc: n -- a ) ;CODE 4C C, ' CARRAY 08 + , C; : TABLE ( cccc, -- ) CREATE SMUDGE ( cccc: n -- a ) ;CODE 4C C, ' ARRAY 0A + , C; -->( Utils: 2CARRAY 2ARRAY ) : 2CARRAY ( cccc, n n -- ) DUP >R @ * + 2* R> + 2+ ; ==>( Utils: XC! X! ) : XC! ( n0...nm cnt addr -- ) OVER 1- + >R 0 DO J I - C! LOOP R> DROP ; : X! ( n0...nm cnt addr -- ) OVER 1- 2* + >R 0 DO J I 2* - ! LOOP R> DROP ; ( Caution: Remember limitation ( on stack size of 30 values ( because of OS conflict. ) -->( Utils: CVECTOR VECTOR ) : CVECTOR ( cccc, cnt -- ) CREATE SMUDGE ( cccc: n -- a ): VECTOR ( cccc, cnt -- ) CREATE SMUDGE ( cccc: n -- a ) HERE OVER 2* ALLOT X! ;CODE 4C C, ' ARRAY 0A + , C; BASE ! ( Utils: HIDCHR NOKEY CURSOR)BASE @ DCX '( CASE )( 28 KLOAD ) : NOKEY ( -- ) 255 764 C! ; ) : CURSOR ( f -- ) 0= 752 C! 28 EMIT 29 EMIT ; ==>( Utils: INKEY$ )DCX : (INKEY$) ( c -- ) 702 C! NOKEY ; : INKEY$ ( -- c ) 764 C@ COND 252 = << 128 (INKEY$) 0 >> 191 > << 0 >> 188 = << 0 >> 124 = << 64 (INKEY$) 0 >> 60 = << 0 (INKEY$) 0 >> 39 = << 0 >> NOCOND KEY CONDEND ; -->( Utils: -Y/N ) : -Y/N ( -- f ) BEGIN KEY 0 CONDEND UNTIL ; ==>( Utils: Y/N -RETURN RETURN ) : Y/N ( -- f ) ." " -Y/N DUP IF 89 ELSE 78 ENDIF EMIT SPACE ; : -RETURN ( -- ) BEGIN KEY 155 = UNTIL ; : RETURN ( -- ) ." " -RETURN ; BASE ! ( Screen code conversion words ) BASE @ HEX NEXT , B1 C, C6 C, 48 C, 29 C, 7F C, C9 C, 60 C, B0 C, 0D C, C9 C, 20 C, B0 C, 06 C, 18 C, 69 C, 40 C, 4C C, HERE 2 ALLOT 38 C, E9 C, 20 C, HERE SWAP ! 91 C, C4 C, 68 C, 29 C, ==>( Screen code conversion words ) 80 C, 11 C, C4 C, 91 C, C4 C, C8 C, D0 C, D3 C, E6 C, C7 C, E6 C, C5 C, 4C C, , C; CODE BSCD> ( a a n -- ) A9 C, 03 C, 20 C, SETUP , HERE C4 C, C2 C, D0 C, 07 C, C6 C, C3 C, 10 C, 03 C, 4C C, NEXT , B1 C, C6 C, 48 C, 29 C, 7F C, C9 C, 60 C, B0 C, 0D C, C9 C, 40 C, B0 C, 06 C, 18 C, 69 C, 20 C, 4C C, HERE 2 ALLOT 38 C, E9 C, 40 C, HERE -->( Screen code conversion words ) SWAP ! 91 C, C4 C, 68 C, 29 C, 80 C, 11 C, C4 C, 91 C, C4 C, : >SCD SP@ DUP 1 >BSCD ; : SCD> SP@ DUP 1 BSCD> ; BASE ! ( Case Statements: CASE )BASE @ DCX '( PERMANENT PERMANENT )( ) : (CASE) : NOCASE 6 ?PAIRS 7 ; IMMEDIATE ==>( Case statements: CASE ) : CASEND DUP 6 = IF DROP COMPILE NOOP ELSE 7 ?PAIRS '( PERMANENT PERMANENT )( ) -->( Case statements: SEL ) '( PERMANENT PERMANENT )( ) : (SEL) : SEL ?COMP ?LOADING COMPILE (SEL) HERE 0 C, COMPILE NOOP [COMPILE] [ 8 ; IMMEDIATE ==> OVER 1+ ! 8 ; IMMEDIATE : -> SWAP 8 ?PAIRS , DUP C@ 1+ 8 ?PAIRS DROP [COMPILE] ] ; IMMEDIATE '( PERMANENT PERMANENT )( ) -->( Case statements: COND )'( TRANSIENT TRANSIENT )( ) : COND 0 COMPILE DUP ; IMMEDIATE : >> [COMPILE] ELSE COMPILE DUP ROT ; IMMEDIATE : NOCOND COMPILE 2DROP ; IMMEDIATE '( PERMANENT PERMANENT )( ) ==>( Case statements: COND ) '( TRANSIENT TRANSIENT )( ) : CONDEND 0 DO [COMPILE] ENDIF LOOP ; IMMEDIATE '( PERMANENT PERMANENT )( ) -->( Case statements: CASE: ) : CASE: ( ValFORTH Video editor V1.1 ) VOCABULARY EDITOR IMMEDIATE EDITOR DEFINITIONS 0 VARIABLE LSTCHR ( last key )0 VARIABLE ?BUFSM ( buf same? )0 VARIABLE ?PADSM ( PAD same? )0 VARIABLE ?ESC ( coded char?)0 VARIABLE TBLK ( top block ) ==>( ValFORTH Video editor V1.1 ) 0 VARIABLE LNFLG ( oops flag )4 ARRAY UPSTAT ( update map ) 15 CONSTANT 15 32 CONSTANT 32 128 CONSTANT 128 5 32 * CONSTANT BLEN : LMOVE 32 CMOVE ; : BOL 88 @ YLOC @ 1+ 32 * + ; : SBL 88 @ 544 + ; : PBL PAD 544 + ; : PBLL PBL BLEN + 32 - ; : !SCR 88 @ 32 + PAD 512 BSCD> ; --> : CSHOW ( -- ) CURLOC DUP ( GET SCR ADDR ) C@ 128 OR ( INVERSE CHAR ) SWAP C! ; ( STORE ON SCR ) : CBLANK ( -- ) CURLOC DUP ( GET SCR ADDR ) IF DROP 0 ENDIF YLOC ! CSHOW ; --> 1 - DUP 0< ( AT L-SIDE?) IF DROP 31 ENDIF ( FIX IF SO ) XLOC ! CSHOW ; : RTCUR ( -- ) CBLANK XLOC @ 1+ DUP 31 > ( AT R-SIDE?) IF DROP 0 ENDIF ( FIX IF SO ) 1 LNFLG ! CURLOC ( CLEAR ) 32 XLOC @ - ( TO END ) ERASE CSHOW ( OF LINE) EDMRK ; --> 0 YLOC ! CSHOW ; : BYTINS CBLANK ( -- ) XLOC @ 31 < ( SPREAD LN ) ENDIF 0 CURLOC C! ( CLEAR OLD ) CSHOW EDMRK ; ( CHARACTER ) ==>( ValFORTH Video editor V1.1 ) : BYTDEL ( -- ) CBLANK ( CLOSE LINE) XLOC @ 31 < IF CURLOC DUP ( FROM ADDR ) 1+ SWAP ( TO ADDR ) 31 XLOC @ - ( # CHARS ) CMOVE ( MOVE IT ) ENDIF 0 CURLOC ( BLANK OUT ) 31 XLOC @ - + C! ( CHAR AT ) CSHOW EDMRK ; ( END OF LN ) --> 4 YLOC @ 4 / DO 1 I UPSTAT ! LOOP YLOC @ 15 < IF BOL 32 ERASE CSHOW EDMRK ; ==>( ValFORTH Video editor V1.1 ) : LNDEL ( -- ) CBLANK 3 LNFLG ! !SCR BOL 15 YLOC @ - 32 * + 32 ERASE CSHOW EDMRK ; -->( ValFORTH Video editor V1.1 ) : BFSHW ( -- ) PBLL 128 - ( F , T ) BLEN + LMOVE PBL DUP 32 + SWAP BLEN 32 - CMOVE PBLL 32 + PBLL LMOVE BFSHW ; ==>( ValFORTH Video editor V1.1 ) : ( ValFORTH Video editor V1.1 ) : BFCPY ( -- ) CBLANK BFROT ( BRING LN ) : >BFNXT BFCPY NXTLN ; ( -- ) : >BFLN BFCPY LNDEL ; ( -- ) : BFLN> ( -- ) LNINS PBLL ( TAKE LINE) BOL LMOVE ( UP FROM ) CSHOW ( ValFORTH Video editor V1.1 ) : BFRPL ( -- ) CBLANK !SCR 4 LNFLG ! ( TAKE LINE ) PBLL BOL LMOVE ( UP TO SCR ) IF DROP 31 ENDIF XLOC ! CSHOW ; -->( ValFORTH Video editor V1.1 ) : RUB ( -- ) XLOC @ 0= NOT ( ON L-EDGE? ) ENDIF INSRT @ IF BYTDEL ENDIF ; ==>( ValFORTH Video editor V1.1 ) : ARROW ( -- ) CBLANK 88 @ 541 + DUP @ COND 3341 = << 30 7453 >> 7453 = << 00 0000 >> NOCOND 30 3341 CONDEND 3 PICK ! SWAP 2+ C! 1 3 UPSTAT ! CSHOW ; -->( ValFORTH Video editor V1.1 ) : OOPS ( -- ) LNFLG @ 0 LNFLG ! ENDIF ; ==>( ValFORTH Video editor V1.1 ) : SPLIT ( -- ) YLOC @ 15 <> IF CBLANK LNINS BOL DUP 32 + SWAP XLOC @ CMOVE BOL 32 + XLOC @ ERASE CSHOW ENDIF ; -->( ValFORTH Video editor V1.1 ) : SCRSV ( -- ) 88 @ 32 + PAD 512 BSCD> ENDIF LOOP 0 INSRT ! 0 XLOC ! 0 YLOC ! ; ==>( ValFORTH Video editor V1.1 ) : SCRGT ( -- ) 4 0 DO TBLK @ I + BLOCK PAD 128 I * + -->( ValFORTH Video editor V1.1 ) : NWSCR ( -1/0/1 -- ) CBLANK DUP ENDIF 88 @ 17 + C! 0 84 C! 11 85 ! 1 752 C! . 2 SPACES CSHOW ; ==>( ValFORTH Video editor V1.1 ) : PRVSCR -1 NWSCR ; ( -- ) : NXTSCR 1 NWSCR ; ( -- ) : SPLCHR 1 ?ESC ! ; ( -- ) : EXIT ( -- ) HMCUR 19 LSTCHR ! ; : EDTABT ( -- ) 0 UPSTAT 8 ERASE EXIT ; -->( ValFORTH Video editor V1.1 ) : PTCHR ( -- ) INSRT @ EDMRK RTCUR XLOC @ 0= IF DNCUR ENDIF 0 ?ESC ! CSHOW ; : CONTROL ( n -- ) SEL 19 -> EXIT 17 -> EDTABT 28 -> UPCUR 29 -> DNCUR ==>( ValFORTH Video editor V1.1 ) 30 -> LFCUR 31 -> RTCUR 126 -> RUB 127 -> TAB 9 -> INTGL 155 -> NXTLN 255 -> BYTINS 254 -> BYTDEL 157 -> LNINS 156 -> LNDEL 18 -> BFROT 2 -> BFCLR 11 -> >BFNXT 20 -> >BFLN 6 -> BFLN> 16 -> PRVSCR 14 -> NXTSCR 27 -> SPLCHR 8 -> CLREOL 1 -> ARROW 21 -> BFRPL 15 -> OOPS 10 -> SPLIT NOSEL PTCHR SE( ValFORTH Video editor V1.1 ) : (V) ( TBLK -- ) DECIMAL 112 560 @ 23 + C! ." Screen #" 11 SPACES ." #Bufs: " BLEN 32 / . HIDCHR 0 UPSTAT 8 ERASE 0 NWSCR IF ?ESC @ IF DROP PTCHR 0 LSTCHR ! ELSE CONTROL ENDIF ENDIF ENDIF LSTCHR @ 19 = UNTIL -->( ValFORTH Video editor V1.1 ) CBLANK SCRSV 0 767 C! 2 560 @ 6 + C! EDITOR TBLK @ ELSE SCR @ B/SCR * ENDIF EDITOR (V) ; -->( ValFORTH Video editor V1.1 ) : CLEAR ( s -- ) B/SCR * B/SCR O+S : COPY ( s1 s2 -- ) B/SCR * OFFSET @ + SWAP B/SCR * B/SCR O+S DO DUP FORTH I BLOCK 2- ! 1+ UPDATE LOOP DROP ( FLUSH ) ; ==>( ValFORTH Video editor V1.1 ) : CLEARS ( s # -- ) OVER >R O+S 2DUP CR ." Clear from SCR " . CR ." thru SCR " 1 - . Y/N IF DO FORTH I CLEAR LOOP ELSE 2DROP ENDIF R> SCR ! FLUSH ; --> DUP 65532 AND SWAP OVER - 128 * ROT + 32 /MOD YLOC C! : #BUFS ( # -- ) 5 MAX 320 MIN 32 * EDITOR ' BLEN ! 0 ?PADSM ! ; ==>( ValFORTH Video editor V1.1 ) : (LOC) ( sys ) BLK @ , IN @ C, ; --> 2- @ DUP 1439 U< SWAP 0# AND IF SWAP DROP DUP C@ SWAP 2- @ WHERE 2DROP ENDIF ; BASE ! ( Hi-resolution text printing ) BASE @ DCX 0 VARIABLE GCPTR 2 VARIABLE GCLFT 39 VARIABLE GCRGT 0 VARIABLE GMOD 0 VARIABLE GCCOL 0 VARIABLE GCROW 120 VARIABLE VMI# ==>( Hi-res: GCR ) : GCR ( -- ) 1 GCROW @ + DUP 20 703 C@ MAX < IF GCROW ! ELSE DROP 88 @ 320 O+S 703 C@ 4 = IF 6400 ELSE 7680 ENDIF 2DUP + 320 - >R CMOVE R> 320 ERASE ENDIF GCROW @ 320 * GCLFT @ DUP GCCOL ! + GCPTR ! ; -->( Hi-res: [GCEMIT] ) : (GCEMIT) ( c -- ) >SCD 8 * GCBAS @ + I C! 1+ 40 /LOOP DROP 1 GCPTR +! 1 GCCOL @ + DUP GCRGT @ > IF DROP GCR ELSE GCCOL ! ENDIF ; ==>( Hi-res: GCBKS OSTRIKE GCINIT) : GCBKS ( -- ) GCCOL @ GCLFT @ > IF -1 GCCOL +! ( backspace ) -1 GCPTR +! ENDIF ; : OSTRIKE ( f -- ) GMOD ! ; ( overstrike) : GCINIT ( -- ) 0 GCROW ! GCLFT @ DUP GCCOL ! GCPTR ! ; -->( Hi-res: GCPOS SUPER SUB ) : GCPOS ( col row -- ) 2DUP 320 * + GCPTR ! : SUB ( -- ) VMI# @ GCPTR +! ; ==>( Hi-res: GCEMIT GCTYPE ) : GCEMIT ( chr -- ) DUP COND 28 = << DROP SUPER >> 29 = << DROP SUB >> 30 = << DROP GCBKS >> NOCOND (GCEMIT) CONDEND ; : GCTYPE ( adr count -- ) 0 MAX -DUP IF O+S DO I C@ GCEMIT LOOP ELSE DROP ENDIF ; --> GCTYPE ; : GC" ( -- ) 34 STATE @ IF COMPILE (GC") WORD HERE C@ 1+ ALLOT DO GCSPACE LOOP ENDIF ; : GCD.R ( d n -- ) >R SWAP OVER DABS <# #S SIGN #> R> OVER - GCSPACES GCTYPE ; --> : GC. ( n -- ) 0 GC.R GCSPACE ; : GCLEN ( adr cnt -- #chrs ) 0 D@ ; 0. DCONSTANT 0. 1. DCONSTANT 1. : D= ( d d -- f ) D- D0= ; : D0< ( d -- f ) SWAP DROP 0< ; : D< ( d d -- f ) D- D0< ; : D> ( d d -- f ) 2SWAP D< ; -->( Double: DMIN DMAX ) : DMIN ( d d -- d ) 2OVER 2OVER D> : DMAX ( d d -- d ) 2OVER 2OVER D< IF 2SWAP ENDIF 2DROP ; ==>( Double: D>R DR> D, M+ ) : D>R ( d -- ) R> R >R >R ; : DR> ( -- d ) R> R> R> SWAP ROT >R ; : D, ( d -- ) , , ; : M+ ( d n -- d ) S->D D+ ; --> IF 2DROP D0< NOT ELSE D- D0< BASE ! ( Utils: Initialization ) BASE @ DCX ==>( Utils: ) -->( Utils: XR/W ) : XR/W ( #secs a blk# f -- ) 4 PICK 0 2DROP 2DROP ; ==>( Utils: SMOVE ) : SMOVE ( org des cnt -- ) FLUSH MTB 741 @ PAD DUP 1 AND - - 2DUP SWAP B/SCR * B/BUF * U< IF CR ." Too many: " B/BUF B/SCR * / U. ." max." DROP 2DROP ELSE DROP >R DCX MTB CR ." SMOVE from " OVER DUP 3 .R ." thru " R + 1- 3 .R CR 8 SPACES ." to " DUP DUP 3 .R ." thru " R + 1- 3 .R -->( Utils: SMOVE ) SPACE Y/N IF CR ." Insert dest." RETURN R> B/SCR * PAD DUP 1 AND - ROT B/SCR * OFFSET @ + 0 XR/W ELSE R> DROP 2DROP CR ." Smove aborted..." CR ENDIF ENDIF ; ==>( Utils: LOADS THRU ) : LOADS ( n cnt -- ) O+S DO I LOAD ?EXIT LOOP ;