( Screen # 1 )                                                  : LABEL  0 VARIABLE -2 ALLOT ;                                  : LISTS  OVER + SWAP DO I LIST LOOP ;                           : LOADS  OVER + SWAP DO I LOAD LOOP ;                           : 'S     SP@ 2 - ;                                              : DEPTH  S0 @ 'S - 2/ 2 - ;                                     : LOAD-$   15 4 LOADS ;                                         : NOT 0= ;                                                      : UMOVE   >R OVER OVER U< R> SWAP                                         IF  <CMOVE  ELSE CMOVE ENDIF ;                        : MTB  EMPTY-BUFFERS  ;                                         : DCX  DECIMAL ;   : 0# 0= 0= ;   : <> = NOT ;                  14 LOAD  ( LOAD SEL )                                           50 LOAD  ( LOAD VEDIT )                                         25 LOAD  ( LOAD ASSM  )                                         31 LOAD  ( LOAD QUAN  )                DCX -->                  ( DUMP routine )                                                                                                                HEX                                                                                                                             : .ADDR       100  /MOD  .HEX  .HEX  ." :  " ;                                                                                  : .DUMP       DUP .ADDR DUP 10 + SWAP DO                                      I C@ .HEX SPACE LOOP ;                                                                                            : DUMP        OVER + SWAP DO CR I .DUMP 10 +LOOP ;                                                                              DECIMAL                                                                                                                        -->                                                                                                                                                                                              ( INDEX, TRIAD, LINE, E, COPY, CLEAR )     HEX                                                                                  : INDEX        CR 1+ SWAP DO                                                      CR I 3 .R SPACE 0 I .LINE                                    LOOP CR ;                                        : TRIAD        CR 3 / 3 * 3 OVER + SWAP                                        DO CR I LIST LOOP CR                                            CR CR ;                                          : LINE         DUP FFF0 AND 17 ?ERROR SCR @ (LINE) DROP ;       : E            LINE C/L BLANKS UPDATE ;                         : CLEAR        SCR ! 10 0 DO FORTH I E LOOP ;                   : COPY         B/SCR * OFFSET @ + SWAP B/SCR * B/SCR OVER                      + SWAP DO DUP  FORTH I BLOCK 2 - ! 1+                           UPDATE LOOP DROP FLUSH ;                                                                                                                                         DECIMAL -->     ( CASE:, TABLE, ARRAY, CARRAY,  )                                                                                               : CASE:        <BUILDS SMUDGE ] DOES> SWAP 2* + @ EXECUTE ;                                                                     : ARRAY        <BUILDS 2* ALLOT DOES> SWAP 2* + ;                                                                               : CARRAY       <BUILDS ALLOT DOES> SWAP + ;                                                                                     : TABLE        <BUILDS 0 DO , LOOP DOES> SWAP 2* + @ ;                                                                         DECIMAL                                                                                                                         24 LOAD    ( LOAD IN ASSEMBLER )                                DECIMAL                                                         29 LOAD                                                                                                 DECIMAL ;S               ( Proteus Fisk Forth                Forth Video Editor )                                                                        HEX                                                                                                                             VOCABULARY VEDIT  IMMEDIATE    VEDIT  DEFINITIONS                                                                               0 VARIABLE VPTR      0 VARIABLE INSRT                                                                                           : CSHOW    VPTR @ DUP C@ 80 OR SWAP C! ;                        : CBLANK   VPTR @ DUP C@ 7F AND SWAP C! ;                                                                                       : TAB      CBLANK VPTR @ 8 + CFF8 AND   ( 8 place tab stop )               0C00 OR VPTR ! CSHOW ;                                                                                                                                           DECIMAL   -->                                                                       ( Proteus Disk Forth                      Video Editor )        HEX                                                             ( The following are cursor positioning routines )                                                                               : ALLCUR   VPTR @ CBLANK + 0C00 OR CFFF AND                                VPTR ! CSHOW ;                                                                                                       : UCUR     -40  ALLCUR ;    ( Move the cursor up )              : DCUR      40  ALLCUR ;    ( Move the cursor down )            : LCUR      -1  ALLCUR ;    ( left )                            : RCUR       1  ALLCUR ;    ( right )                                                                                           : RUB      20 VPTR @ C! LCUR UPDATE ;                                                                                           : INTGL    INSRT @ 0= INSRT ! ;                                                                            DECIMAL    -->       ( Proteus Disk Forth                      Video Editor )                                                                         HEX                                                                                                                            : NLIN    CBLANK VPTR @ FFC0 AND VPTR ! DCUR ;                                                                                  : BMOVE   VPTR @ + VPTR @ ROT + DUP 3F AND 40 - ABS                       CBLANK UMOVE VPTR @ OR 20 SWAP C!                               CSHOW UPDATE ;                                                                                                        : BINS    VPTR @ 3F AND 3F = IF 20 VPTR @ C! CSHOW                        ELSE  0 1 0 BMOVE ENDIF ;                                                                                             : BDEL    3F  0 1 BMOVE ;                                                                                                       : PCHAR    INSRT @ IF BINS ENDIF VPTR @ C! RCUR UPDATE ;  -->   ( Proteus Disk Forth                      Video Editor )                                                                        HEX                                                                                                                             : LINS    VPTR @ FFC0 AND DUP DUP 0FFF OR                                 SWAP - 40 -  1+ SWAP DUP 40 + ROT CBLANK UMOVE                  VPTR @ FFC0 AND 40 20 FILL CSHOW UPDATE ;                                                                             : LDEL    VPTR @ FFC0 AND DUP DUP 0FFF OR                                 SWAP - 40 -  1+ SWAP DUP 40 +                                   SWAP ROT CBLANK UMOVE                                           VPTR @ 0FFF OR 3F - 40 20 FILL CSHOW UPDATE ;                                                                         DECIMAL  -->                                                                                                                                                                                    ( Proteus Disk Forth                      Video Editor )        HEX                                                            : CONTROL    DUP 17 = IF DROP UCUR 0 0 ENDIF                                 DUP 1A = IF DROP DCUR 0 0 ENDIF                                 DUP  1 = IF DROP LCUR 0 0 ENDIF                                 DUP 13 = IF DROP RCUR 0 0 ENDIF                                 DUP  2 = IF DROP LINS 0 0 ENDIF                                 DUP 10 = IF DROP LDEL 0 0 ENDIF                                 DUP  8 = IF DROP BDEL 0 0 ENDIF   DUP 7F = IF DROP RUB 0 0 THEN DUP 1B = IF 0 ENDIF   ( Escape )  DUP 9 = IF DROP  TAB 0 0 THEN DUP 12 = IF 0 ENDIF   ( Next screen )                           DUP 03 = IF 0 ENDIF   ( Prev screen )                           DUP 0D = IF DROP NLIN 0 0 ENDIF                                 DUP 14 = IF DROP INTGL 0 0 ENDIF                                DUP 0= IF DROP ELSE PCHAR 0 ENDIF ;                 DECIMAL                                                -->      ( Proteus Disk Forth                      Video Editor )        FORTH DEFINITIONS                                               HEX                                                             CC00 CONSTANT VDM                                               : V  VEDIT  DECIMAL SCR !                                                BEGIN  WIPE                                                         SCR @ B/SCR * DUP BLOCK PAD 200 CMOVE 1+ BLOCK                  PAD 200 + 200 CMOVE PAD VDM 400 CMOVE                           VDM VPTR ! CSHOW                                                BEGIN                                                               KEY CONTROL -DUP                                            UNTIL                                                           CBLANK VDM SCR @ B/SCR * BLOCK 200 CMOVE UPDATE                 VDM 200 + SCR @ B/SCR * 1+ BLOCK 200 CMOVE UPDATE                                                                                                                          -->     ( Proteus Disk Forth                      Video Editor )                                                                                     DUP 1B =                                                        IF                                                                  DROP 1                                                      ELSE                                                                12 = IF -1 ELSE 1 ENDIF                                         SCR @ + 1 MAX 17F MIN SCR ! 0                               ENDIF                                                       UNTIL                                                           CLS                                                             CR  ." Last edit on screen # " SCR @ . CR CR ;                                                                         : L      SCR @ DUP 17F > IF DROP 1 ENDIF V ;                                                                                                                              DECIMAL  ;S          ( QUAN structures   screen 12 )                                                                                                 : TO    -FIND 0= 0 ?ERROR DROP                                          STATE @ IF , ELSE EXECUTE ENDIF ;     IMMEDIATE                                                                         : AT    -FIND 0= 0 ?ERROR DROP                                          4 + [COMPILE] LITERAL ;   IMMEDIATE                     ;S                                                              LABEL (2@6)  HEX                                                  21 C, 05 C, 00 C, 19 C, 5E C, 23 C, 56 C, D5 C, C3 C, NEXT ,                                                                  LABEL (2!4)                                                       13 C, 13 C, 13 C, E1 C, EB C, 73 C, 23 C, 72 C, C3 C, NEXT ,                                                                  : QUAN  LABEL -2 ALLOT (2@6) , (2!4) , [ ' VARIABLE 4 + ]               LITERAL , 2 ALLOT ;                     DCX ;S          ( LABEL , ASSEMBLER , HPUSH , DPUSH , etc.  )                                                                                   : LABEL  0 VARIABLE -2 ALLOT ;                                                                                                  VOCABULARY ASSEMBLER                                                                                                            ' LIT 7 + @ CONSTANT HPUSH                                      HPUSH 1- CONSTANT DPUSH                                         HPUSH 1+ CONSTANT NEXT                                                                                                          ;S                                                                                                                                                                                                                                                                                                                                                                                              ( 14 )                                                                                                                          : (SEL)                                                           0 R <ROT R DUP C@ 127 AND 4 * 1+ DUP R> + >R                    OVER + SWAP 1+ DO OVER I @ =                                    IF 1 OR I 2+ @ <ROT LEAVE ENDIF                                 4 +LOOP SWAP DROP                                               IF EXECUTE C@ 128 AND 0= 0= 2* R> + >R                          ELSE DROP ENDIF ;                                                                                                             : SEL ' (SEL) CFA , HERE 0 C, [COMPILE] [ ; IMMEDIATE           : -> , [COMPILE] ' CFA , 1 OVER +! ; IMMEDIATE                  : NOSEL DUP C@ 128 OR OVER C! [COMPILE] ] ; IMMEDIATE           : SELEND DROP [COMPILE] ] ; IMMEDIATE                                                                                           ;S                                                               ( Forth String Stack Extention          )          HEX                                                                          FORTH DEFINITIONS                                                                                                               200 CONSTANT *$*       *$* ALLOT                                HERE CONSTANT $0       $0  VARIABLE $P                                                                                          : $P!    $0 $P ! ;                                              : $P@    $P @ ;                                                 : $DROP  $P@ DUP @ + 2+ $P ! ;                                  : $@     DUP >R $P@ SWAP - SWAP OVER R CMOVE                             2 - R> OVER ! $P ! ;                                   : $!     DUP 2+ SWAP @ ROT SWAP CMOVE $DROP ;                   : $.     $P@ DUP 2+ SWAP @ TYPE $DROP ;                         : $DUP   $P@ DUP 2+ SWAP @ $@ ;                                                                         DECIMAL ;S              ( Forth String Stack Extension  )            HEX                                                                                : (")    R DUP 2+ SWAP @        ( Moves string to $STACK )               DUP 2+ R> + >R $@ ;                                                                                                    : "      22 STATE @                                                      IF                                                                 COMPILE  (")  0 C, WORD HERE C@                                 -1 ALLOT DUP , ALLOT                                         ELSE                                                               0 C, WORD HERE C@ -1 ALLOT HERE !                               HERE DUP 2+ SWAP @ $@                                        ENDIF ;   IMMEDIATE                                                                                                                                                   DECIMAL  ;S                                                                      ( Forth String Stack Extension )               HEX                                                                              0E +ORIGIN @ CONSTANT BS                                        7F CONSTANT PBS                                                                                                                 : $INPUT   PAD DUP                                                         BEGIN KEY DUP BS =                                                 IF ( backspace ) >R 2DUP = R> SWAP                                 IF DROP 0 ELSE DROP PBS EMIT 1 - 0 ENDIF                     ELSE DUP 0D =                                                      IF DROP 20 EMIT 1                                               ELSE DUP EMIT OVER C! 1+ 0                                      ENDIF                                                        ENDIF                                                        UNTIL OVER - $@ ;                                                                                   DECIMAL ;S       ( Forth String Stack Extension )               HEX                                                                              : $VARIABLE    <BUILDS DUP , DUP HERE                                          SWAP BLANKS ALLOT DOES> ;                                                                                        : $VARFILL     OVER @ ROT 2+ SWAP ROT FILL ;                                                                                    : $VAR@        DUP 2+ SWAP @ $@ ;                                                                                               : $VAR!        DUP 20 $VARFILL                                                 DUP 2+ SWAP @ $P@ @ MIN                                         $P@ 2+ <ROT CMOVE $DROP ;                                                                                                                                                                                                      DECIMAL ;S                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       ( Definition of -TEXT )                                         : -TEXT                   ( Address  Count  Address ---  f )      SWAP -DUP                                                       IF                                                                OVER + SWAP                                                     DO                                                                DUP C@ FORTH I C@ -                                             IF                                                                0= LEAVE                                                      ELSE                                                              1+                                                            ENDIF                                                         LOOP                                                          ELSE                                                              DROP 0=                                                       ENDIF ;                                       ;S                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              ( SCREEN TRANSFER )                                             0 VARIABLE FN#                                                  : "FNAME" ." SCREENS/1 " ;                                                                                                      : TRANSFER                                                        [ ' "FNAME" 3 + ] LITERAL -1 OPEN                               IF                                                                FN# ! DROP 40 1                                                 DO                                                                I BLOCK 1024 FN# @ WRITE                                      LOOP                                                          ENDIF ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       ( 8080 Assembler by John Cassady                               )HEX VOCABULARY ASSEMBLER IMMEDIATE                              : 8* 2* 2* 2* ;                                                 ( ' ASSEMBLER 8 + ' ;CODE 8 + ! )                               : CODE ?EXEC CREATE [COMPILE] ASSEMBLER !CSP ;                  : C;  CURRENT @ CONTEXT ! ?EXEC ?CSP SMUDGE  ;                  ASSEMBLER DEFINITIONS                                           4 CONSTANT H    5 CONSTANT L    7 CONSTANT A    6 CONSTANT PSW  2 CONSTANT D    3 CONSTANT E    0 CONSTANT B    1 CONSTANT C    6 CONSTANT M    6 CONSTANT SP                                   ' ;S 0B + @ CONSTANT NEXT                                       : 1MI <BUILDS C, DOES> C@ C, ;                                  : 2MI <BUILDS C, DOES> C@ + C, ;                                : 3MI <BUILDS C, DOES> C@ SWAP 8* + C, ;                        : 4MI <BUILDS C, DOES> C@ C, C, ;                               : 5MI <BUILDS C, DOES> C@ C, , ;                        -->     ( 8080 Assembler by John Cassady                               )                                                                NEXT 1- CONSTANT HPUSH      HPUSH 1- CONSTANT DPUSH             00 1MI NOP,     76 1MI HLT,     F3 1MI DI,      FB 1MI EI,      07 1MI RLC,     0F 1MI RRC,     17 1MI RAL,     1F 1MI RAR,     E9 1MI PCHL,    F9 1MI SPHL,    E3 1MI XTHL,    EB 1MI XCHG,    27 1MI DAA,     2F 1MI CMA,     37 1MI STC,     3F 1MI CMC,     80 2MI ADD,     88 2MI ADC,     90 2MI SUB,     98 2MI SBB,     A0 2MI ANA,     A8 2MI XRA,     B0 2MI ORA,     B8 2MI CMP,     09 3MI DAD,     C1 3MI POP,     C5 3MI PUSH,    02 3MI STAX,    0A 3MI LDAX,    04 3MI INR,     05 3MI DCR,     03 3MI INX,     0B 3MI DCX,     C7 3MI RST,     D3 4MI OUT,     DB 4MI IN,      C6 4MI ADI,     CE 4MI ACI,     D6 4MI SUI,     DE 4MI SBI,     E6 4MI ANI,     EE 4MI XRI,     F6 4MI ORI,     FE 4MI CPI,     22 5MI SHLD,    2A 5MI LHLD,    32 5MI STA,     3A 5MI LDA,     CD 5MI CALL,    C3 5MI JMP,     C9 1MI RET,                 --> ( 8080 Assembler by John Cassady                               )                                                                C2 CONSTANT ZE  D2 CONSTANT CS  E2 CONSTANT PE  F2 CONSTANT MI  CA CONSTANT NZ  DA CONSTANT CC  EA CONSTANT PO  FA CONSTANT PL  : NOT 8 XOR ;                                                   : MOV,  8*  40 + + C, ;                                         : MVI,  8* 6 + C, C, ;                                          : LXI,  8* 1+ C, , ;                                                                                                            : IF,    C, HERE 0 , ;       : BEGIN,  HERE ;    : WHILE, IF, ; : ENDIF, HERE SWAP !  ;      : THEN, ENDIF, ;                   : ELSE,  C3 IF, SWAP ENDIF, ;                                   : UNTIL, C, , ;         : END, UNTIL, ;                         : REPEAT, SWAP C3 C, , ENDIF, ;   : AGAIN,  C3 C, , ;                                                                           FORTH DEFINITIONS  FORTH                               DCX  --> ( DECOMPER )                                                    HEX                                                             : CFALIT                                                          STATE @  [COMPILE] [ [COMPILE] ' CFA SWAP                       IF [COMPILE] ] ENDIF [COMPILE] LITERAL ; IMMEDIATE                                                                            0 VARIABLE .WORD                                                                                                                : PWORD 2+ NFA ID. ;                                            : 1BYTE PWORD .WORD @ C@ . 1 .WORD +! ;                         : 1WORD PWORD .WORD @ @ . 2 .WORD +! ;                          : NP DUP CFALIT ;S = OVER CFALIT (;CODE) = OR                        IF PWORD CR CR ." ok" CR QUIT ENDIF ?TERMINAL                   IF DROP ." ok" CR QUIT ENDIF ;                             : BRNCH PWORD ." to " .WORD @ .WORD @ @ + U. 2 .WORD +! ;       : NXT1 .WORD @ U. 2 SPACES .WORD @ @ 2 .WORD +! ;       -->     ( DECOMPER )                                                    : STG PWORD 22 EMIT .WORD @ DUP COUNT TYPE 22 EMIT                    C@ .WORD @ + 1+ .WORD ! ;                                                                                                 : CKIT DUP CFALIT 0BRANCH = OVER CFALIT BRANCH = OR                    OVER CFALIT (LOOP) = OR OVER CFALIT (+LOOP) = OR                IF BRNCH ELSE DUP CFALIT LIT = IF 1WORD                         ELSE DUP CFALIT COMPILE = IF PWORD CR NXT1 PWORD                ELSE DUP 4 - @ A922 = IF STG ELSE PWORD ENDIF                   ENDIF ENDIF ENDIF ;                                      : ?DOCOL DUP 2- @ [ ' : 12 + ] LITERAL -                                 IF ." Primitive" CR CR ." ok" CR QUIT ENDIF ;          : DECOMP [COMPILE] ' DUP NFA CR CR DUP ID. C@ 40 AND IF                 ." (IMMEDIATE)" ENDIF CR CR ?DOCOL .WORD !                      BEGIN NXT1 NP CKIT CR AGAIN ;                           DECIMAL                                                         HEX   ( A WIPE SCREEN COMMAND )                                 CODE WIPE                                                         A XRA,   FE  OUT,                                               BL D LXI, CC00 H LXI,                                           BEGIN,                                                             E M MOV,  H INX,  H A MOV,  D0 CPI,                          ZE UNTIL,                                                       NEXT JMP,                                                     C;                                                              DCX                                                                                                                                                                                                                                                                                                                                                                                                                                                             ( Machine dependent QUAN code for the 8080 processor )                                                                          LABEL (2@6)  ASSEMBLER                                                5 H LXI,    D DAD,    M E MOV,    H INX,                        M D MOV,    D PUSH,   NEXT JMP,                                                                                           LABEL (2!4)  ASSEMBLER                                                D INX,     D INX,    D INX,     H POP,    XCHG,                 E M MOV,   H INX,    D M MOV,   NEXT JMP,                                                                                 LABEL (2!2)                                                           (2!4) 2+ JMP,                                                                                                             LABEL (2V4) ASSEMBLER                                                 D INX,     D INX,    D INX,     XCHG,     M E MOV,              H INX,     M D MOV,  XCHG,      ' EXECUTE 2+ @ JMP,   --> ( QUAN and VECT structures                                     )                                                                : TO                                                              -FIND 0= 0 ?ERROR DROP                                          STATE @ IF , ELSE EXECUTE ENDIF ;  IMMEDIATE                                                                                  : AT                                                              -FIND 0= 0 ?ERROR DROP                                          4 + [COMPILE] LITERAL ;  IMMEDIATE                                                                                            : QUAN                                                            LABEL -2 ALLOT (2@6) , (2!4) ,                                  [ ' VARIABLE 4 + ] LITERAL , 2 ALLOT ;                                                                                        : VECT                                                            LABEL -2 ALLOT (2V4) , (2!2) , [ ' NOOP CFA ] LITERAL , ;  -->( PICK )                                                        CODE PICK                                                            D  POP,   0 H LXI,   SP DAD,                                    BEGIN,                                                             E DCR,                                                       NZ WHILE,                                                          SP INX,   SP INX,                                            REPEAT,                                                         D POP,   SPHL,   D PUSH,                                        NEXT JMP,                                                  C;                                                              : 2DROP DROP DROP ;                                             CODE J                                                              ' I 1+ @ LHLD,   H INX,  H INX, H INX, H INX,  ' I 3+ JMP,  C;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              ( MUTLI-CF:    SUBROUTINE               )                                                                                       DECIMAL                                                         FORTH DEFINITIONS                                               0 VARIABLE BONGO                                                ' BONGO CFA @                                                   FORGET BONGO                                                    CONSTANT DOVAR                                                                                                                  : SUBROUTINE  ( CCC, -- )                                         [COMPILE] CODE -2 ALLOT DOVAR , ;                                                                                             -->                                                                                                                                                                                                                                                             ( MULTI-CF:  MCFID                      )                                                                                       HEX                                                             0FFFF CONSTANT MCFID                                            DECIMAL                                                                                                                         40 LOAD                                                                                                                         -->                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ( MULTI-CF: ?MODE                       )                                                                                       : ?MODE     ( CF -- )                                             STATE @                                                         IF , ELSE EXECUTE THEN ;                                                                                                      : HEADER   ( CCC, -- )                                            0 VARIABLE -4 ALLOT ;                                                                                                         : ?EXISTS    ( -- CF0 )                                           -FIND 0= 0 ?ERROR                                               DROP CFA ;                                                                                                                    -->                                                                                                                                                                                             ( MULTI-CF:  ASSIGN                     )                                                                                       CODE <ASSIGN>                                                     -2 ALLOT ' LIT CFA @ ,                                        C;                                                                                                                              : ASSIGN                                                          ?EXISTS                                                         STATE @                                                         IF COMPILE <ASSIGN> ,                                           THEN ;   IMMEDIATE                                                                                                            -->                                                                                                                                                                                                                                                             ( MULTI-CF:  TO IS ADR  CF-INDEX        )                                                                                       : CF-INDEX              ( CCC, N -- )                             <BUILDS                                                           2* C, IMMEDIATE                                               DOES>                                                             C@ ?EXISTS +                                                    DUP @ 2- @ MCFID = NOT                                          11 ?ERROR                                                       ?MODE ;                                                                                                                     1 CF-INDEX TO                                                   1 CF-INDEX IS                                                   2 CF-INDEX ADR                                                  DECIMAL                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         ( MULTI-CF:   <CF>  DOES:  CODE:        )                                                                                       SUBROUTINE <CF>                                                   H POP,   D INX,   D PUSH,                                       H DCX,   XCHG,    ' : CFA @ JMP,                              C;                                                                                                                              : DOES:                                                           <BUILDS                                                           MCFID ,  205 C, <CF> ,    ( CALL <CF> )                         SMUDGE  !CSP  ]                                               DOES>  2+ , ;                                                                                                                 : CODE:                                                           [COMPILE] CODE 0 , MCFID ,                                      DOES> 2+ , ;                                                  ( valDOS )                                                      : FNCON                                                           0 TO DISKERR  2E TO FNSEP                                       COUNT GETUNIT                                                   IF  8 TO FNCNT FNFLD B BLANKS FNFLD                               BEGIN                                                             3 PICK C@ DUP FNSEP =                                           IF 2DROP FNFLD C@ BL = IF 2DROP BADNME DOSERR ENDIF                FNFLD 7 + DUP 1+ 3 BLANKS 3 TO FNCNT 0FF TO FNSEP            ELSE DUP 2A = IF OVER FNFLD B + OVER - 3F FILL DROP               ELSE DUP 30 < OVER 5A > OR                                         OVER 39 > 3 PICK 41 < AND OR OVER 3F ( "?" ) <> AND             IF 2DROP 2DROP BADNME DOSERR ENDIF OVER C!                   ENDIF  FNCNT 1- DUP TO FNCNT 0<                                 IF DROP 2DROP BADNME DOSERR ENDIF                             ENDIF                                              -->    ( valDOS )                                                                                                                            1+ ROT 1+ ROT 1- ROT                                            OVER 0 =                                                      UNTIL                                                           2DROP DROP                                                    ENDIF                                                           FNFLD C@ DUP 2F ( "/" ) > SWAP 3A ( ":"  ) < AND  ( "1..9")     IF BADNME DOSERR ENDIF                                          DISKERR 0= ;                                                  DCX                                                             : DIRLOC PAD ;                                                  : DIRTBL DIRLOC 512 + ;                                                                                                         -->                                                                                                                             ( CHKDIR )      DECIMAL                                         : CHKDIR                                                          0 TO #ENTRIES 0 TO #FREE                                       ( 368 360 ) 22 20                                                DO DIRLOC I UNIT ( 720) 384 * + 1 R/W I TO DIRBLK                 DIRLOC ( 128) 256  + DIRLOC                                     DO 1 TO ?SAME I C@ 127 AND 0= 0=                                  IF 11 0                                                            DO                                                                J I + 5 + C@ FNFLD I + C@                                       DUP [ HEX ] 3F [ DCX ] = IF DROP DUP ENDIF                      <> IF 0 TO ?SAME ENDIF                                        LOOP                                                            ?SAME IF #ENTRIES DIRTBL + 1 AT #ENTRIES +!                      I DIRLOC - 16 / J 20 - 16 * + SWAP C! ENDIF                 ELSE                                              -->     ( GET A FILE NAME )                                                     1 AT #FREE +!                                                 ENDIF                                                         16 +LOOP                                                      LOOP #ENTRIES ;                                               : FN?                                                             CR ." Enter filename: "                                         PAD 1+ 20 EXPECT PAD 1+                                         BEGIN  DUP C@ 0= 0= WHILE 1+ REPEAT                             PAD 1+ - PAD C!                                                 PAD FNCON                                                       CR IF ." Good " ELSE ." Bad " ENDIF ." filename."               ;                                                                                                                             : ASK                                                             0 DO FN? CR FNFLD 11 TYPE 3 SPACES UNIT . CR .S CR LOOP CR ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   ( Proteus Fisk Forth                Forth Video Editor )                                                                        HEX                                                                                                                             VOCABULARY VEDIT  IMMEDIATE    VEDIT  DEFINITIONS                                                                               0 VARIABLE VPTR      0 VARIABLE INSRT                                                                                           : CSHOW    VPTR @ DUP C@ 80 OR SWAP C! ;                        : CBLANK   VPTR @ DUP C@ 7F AND SWAP C! ;                                                                                       : TAB      CBLANK VPTR @ 8 + CFF8 AND   ( 8 place tab stop )               0C00 OR VPTR ! CSHOW ;                                                                                                                                           DECIMAL                                                                    -->      ( Proteus Disk Forth                      Video Editor )        HEX                                                             ( The following are cursor positioning routines )                                                                               : ALLCUR   VPTR @ CBLANK + 0C00 OR CFFF AND                                VPTR ! CSHOW ;                                                                                                       : UCUR     -40  ALLCUR ;    ( Move the cursor up )              : DCUR      40  ALLCUR ;    ( Move the cursor down )            : LCUR      -1  ALLCUR ;    ( left )                            : RCUR       1  ALLCUR ;    ( right )                           : INTGL    INSRT @ NOT INSRT ! ;                                : NLIN     CBLANK VPTR @ FFC0 AND VPTR ! DCUR ;                                                                                                                                                                                            DECIMAL    -->       ( Proteus Disk Forth                      Video Editor )                                                                         HEX                                                                                                                            : BMOVE   VPTR @ + VPTR @ ROT + DUP 3F AND 40 - ABS                       CBLANK UMOVE VPTR @ OR 20 SWAP C!                               CSHOW UPDATE ;                                                                                                        : BINS    VPTR @ 3F AND 3F = IF 20 VPTR @ C! CSHOW                        ELSE  0 1 0 BMOVE ENDIF ;                                                                                             : BDEL    3F  0 1 BMOVE ;                                                                                                       : RUB     LCUR 20 VPTR @ C! INSRT @ IF BDEL ENDIF CSHOW ;                                                                       : PCHAR   INSRT @ IF BINS ENDIF VPTR @ C! RCUR UPDATE ;  -->    ( Proteus Disk Forth                      Video Editor )                                                                        HEX                                                                                                                             : LINS    VPTR @ FFC0 AND DUP DUP 0FFF OR                                 SWAP - 40 -  1+ SWAP DUP 40 + ROT CBLANK UMOVE                  VPTR @ FFC0 AND 40 20 FILL CSHOW UPDATE ;                                                                             : LDEL    VPTR @ FFC0 AND DUP DUP 0FFF OR                                 SWAP - 40 -  1+ SWAP DUP 40 +                                   SWAP ROT CBLANK UMOVE                                           VPTR @ 0FFF OR 3F - 40 20 FILL CSHOW UPDATE ;                                                                                                                                                                                                        DECIMAL                                                 -->      ( Proteus Disk Forth                      Video Editor )        HEX                                                            : CONTROL    DUP 17 = IF DROP UCUR 0 0 ENDIF                                 DUP 1A = IF DROP DCUR 0 0 ENDIF                                 DUP  1 = IF DROP LCUR 0 0 ENDIF                                 DUP 13 = IF DROP RCUR 0 0 ENDIF                                 DUP  2 = IF DROP LINS 0 0 ENDIF                                 DUP 10 = IF DROP LDEL 0 0 ENDIF                                 DUP  8 = IF DROP BDEL 0 0 ENDIF   DUP 7F = IF DROP RUB 0 0 THEN DUP 1B = IF 0 ENDIF   ( Escape )  DUP 9 = IF DROP  TAB 0 0 THEN DUP 12 = IF 0 ENDIF   ( Next screen )                           DUP 03 = IF 0 ENDIF   ( Prev screen )                           DUP 0D = IF DROP NLIN 0 0 ENDIF                                 DUP 14 = IF DROP INTGL 0 0 ENDIF                                DUP 0= IF DROP ELSE PCHAR 0 ENDIF ;                 DECIMAL                                                 -->     ( Proteus Disk Forth                      Video Editor )        FORTH DEFINITIONS                                               HEX                                                             CC00 CONSTANT VDM                                               : V  VEDIT  DECIMAL SCR !                                                BEGIN 0 INSRT !                                                     SCR @ B/SCR * DUP BLOCK PAD 200 CMOVE 1+ BLOCK                  PAD 200 + 200 CMOVE PAD VDM 400 CLS CMOVE                       VDM VPTR ! CSHOW                                                BEGIN                                                             BEGIN INKEY DUP NOT IF INSRT @ IF CBLANK                         5 0 DO LOOP  CSHOW ENDIF ENDIF -DUP UNTIL                      CONTROL -DUP                                                  UNTIL                                                           CBLANK VDM SCR @ B/SCR * BLOCK 200 CMOVE UPDATE              VDM 200 + SCR @ B/SCR * 1+ BLOCK 200 CMOVE UPDATE --> ( Proteus Disk Forth                      Video Editor )                                                                                     DUP 1B =                                                        IF                                                                  DROP 1                                                      ELSE                                                                12 = IF -1 ELSE 1 ENDIF                                         SCR @ + 1 MAX 17F MIN SCR ! 0                               ENDIF                                                       UNTIL                                                           CLS                                                             CR  ." Last edit on screen # " SCR @ . CR CR ;                                                                         : L      SCR @ DUP 17F > IF DROP 1 ENDIF V ;                                                                                                                              DECIMAL  ;S