Jump to content
TheBF

Camel99 Forth Information goes here

Recommended Posts

Two Barbers WHILEs, No Waiting  

 

I made mention of what you can do with these new ISO loops so here is an example.

 

I have been working on the VIBE block editor by Samuel Falvo and it's working well now in 80 column mode.

I was reading the commands in the VI editor and one that is missing in VIBE is $ key which puts the cursor at the end of the text on the editing line.

I had read the these double WHILE constructs are handy for string functions and now I can see why.  

One WHILE is handling the absolute end of the loop. It is resolved by the THEN word which maybe should be renamed to ENDWHILE. (?)

The 2nd WHILE is for the processing action of finding the space character. 

I did this for my own edification because I think -TRAILING would work faster for this job. :) 

 

( WH sets "where" the cursor is in memory in VIBE, SOL and EOL are just the addresses of the start and end of line in memory)

 

: EOTEXT
        SOL EOL ( addr1 addr2) \ start & end of edit line
        BEGIN
          2DUP <> WHILE      \ while we are not at SOL
          DUP [email protected] BL = WHILE  \ while the char at EOL is blank
          1-                 \ decrement the EOL address
        REPEAT               \ BOTH loops jumps to BEGIN on true logic
        THEN                 \ 1st WHILE jumps to here on false logic
        - ABS 1+ X ! WH ;    \ compute new X coord and set where cursor goes

 

Share this post


Link to post
Share on other sites
4 hours ago, TheBF said:

 

: EOTEXT
        SOL EOL ( addr1 addr2) \ start & end of edit line
        BEGIN
          2DUP <> WHILE      \ while we are not at SOL
          DUP [email protected] BL = WHILE  \ while the char at EOL is blank
          1-                 \ decrement the EOL address
        REPEAT               \ BOTH loops jumps to BEGIN on true logic
        THEN                 \ 1st WHILE jumps to here on false logic
        - ABS 1+ X ! WH ;    \ compute new X coord and set where cursor goes

 

 

I am probably missing something here, but this appears to be overlapping loops, which I would think a bad idea. If there must be a second resolver for WHILE , I would think it should be resolved within any other loop construct. I would expect the first WHILE to be resolved by REPEAT and that THEN or ENDWHILE (placed before REPEAT ) would properly resolve the second WHILE .

 

...lee

Share this post


Link to post
Share on other sites

I believe they are overlapping and I can accept that in a purely structured paradigm it is a bad idea.

However all ALC programmers know that sometimes jumping is more efficient that structured programming albeit more confusing and prone to error.

But then force fitting pure structure onto something that just needs a damned jump can loop be ugly too.

 

So this structure, like using EXIT THEN,  is letting Forth jump around a bit but in a "structured" manner. 

But I admit my first look at this made me say "That ain't right".

 

Consider:

With these simplified loops structures WHILE is really just IF .  ( I guess the SWAP is getting the HERE from BEGIN in the correct order. ? )

 

: WHILE   POSTPONE IF SWAP ;                  IMMEDIATE

And REPEAT is AGAIN followed by THEN to resolve the IF ( ie: WHILE)

: REPEAT  POSTPONE AGAIN POSTPONE THEN ;      IMMEDIATE

So after the REPEAT we need that extra THEN to resolve the first WHILE.

 

It almost makes sense to me.  :)   

 

I am amazed by the people who come up with this stuff however.  I would never have considered this.

 

Today I was studying a faster smaller way to do a CASE statement that came from the mind of the late Neil Baud (aka Wil Baden)

When I get a working version on my system I will publish here.

Share this post


Link to post
Share on other sites

I still don’t like it. There must be a better way than to expose that kind of cleanup in high-level code. But, that is just my problem, I suppose.

 

...lee

Share this post


Link to post
Share on other sites

Yes perhaps you could make a word called REPEATS.

It would compile AGAIN and then a two THEN words

 

Un-tested!!!

 

: REPEATS    POSTPONE AGAIN POSTPONE THEN  POSTPONE THEN ;      IMMEDIATE

That would handle 2 while conditions.

 

But I am looking at something right now call THENS

: THENS
  BEGIN  ?DUP WHILE  POSTPONE THEN  REPEAT ; IMMEDIATE

This mops up like ENDCASE in the Eaker case statement.

 

So in theory we could do 

: REPEATS  POSTPONE AGAIN  POSTPONE THENS ;      IMMEDIATE

 

 

Would that remove any discomfort for you?  :) 

  • Like 1

Share this post


Link to post
Share on other sites
25 minutes ago, TheBF said:

Would that remove any discomfort for you?  :) 

 

Probably. 😊 I guess it would work something like

: EOTEXT
        SOL EOL ( addr1 addr2) \ start & end of edit line
        BEGIN
          2DUP <> 
        WHILE                \ while we are not at SOL
          DUP [email protected] BL = 
        WHILE                \ while the char at EOL is blank
          1-                 \ decrement the EOL address
        REPEATS              \ BOTH loops jump to BEGIN on true logic and exit on false logic
        - ABS 1+ X ! WH ;    \ compute new X coord and set where cursor goes

 

...lee

  • Like 1

Share this post


Link to post
Share on other sites

Updated FoxShell

 

As I put my new kernel through its paces I used the new SAVESYS utility to compile a version of my DV80 disk utilities.

It's not Force Command by any stretch but handy for me with a large number of text files in the system. At this time they only work with DV80 files.

I am still thinking about the best way deal with other file types to make a simple syntax for the end user.

 

There is an APND command that lets you append files to a second file.

You can copy files. It is record by record so not a speed demon.

In Classic99 it is very handy to to COPY DSK1.MYFILE CLIP   and copy a TI-99 file to the windows clipboard.

 

The zip file includes a 40 column and an 80column version. 80 columns was only tested on Classic99.

 

Latest Source for those interested is here:

 

Spoiler
\ FOXSHELL.FTH   CAMEL99 shell for disk file management
\ Oct 2020:  built with SAVESYS to create stand alone program

NEEDS DUMP       FROM DSK1.TOOLS
NEEDS OPEN-FILE  FROM DSK1.ANSFILES
NEEDS VALUE      FROM DSK1.VALUES
NEEDS CASE       FROM DSK1.CASE
NEEDS BUFFER:    FROM DSK1.BUFFER
NEEDS MALLOC     FROM DSK1.MALLOC
NEEDS COMPARE    FROM DSK1.COMPARE
NEEDS U.R        FROM DSK1.UDOTR   \ right justified printing


CR .( Compiling FOXSHELL )

VARIABLE WARNINGS   WARNINGS ON
VARIABLE #BYTES

\ busy spinner to show activity
VARIABLE SPIN#
CREATE SCHARS   CHAR | C, CHAR / C, CHAR - C, CHAR \ C,
: GETXY    ( -- col row) VROW [email protected] ;
: SPINCHAR ( -- char ) SPIN# @ 1+ 3 AND DUP SPIN# ! SCHARS + [email protected]  ;
: SPINNER  ( -- )      SPINCHAR GETXY >VPOS VC! ;

\ simplified file language
\ Usage example:  S" DSK2.MYFILE" R/W OPEN AS: #1
HEX .( .)
0 VALUE #1   0 VALUE #2   0 VALUE #3

: AS:  ( n -- <value> )  POSTPONE TO ;  IMMEDIATE

: OPEN  ( addr len -- hndl ) OPEN-FILE ?FILERR ;
: CLOSE ( hndl -- )         CLOSE-FILE ?FILERR ;
: READH ( hndl -- )         READ-LINE ?FILERR 2DROP ;

DECIMAL
\ CR if near end of screen
: ?CR     ( n -- ) LINES @ 3 MOD 0= IF CR THEN ;
.( .)
HEX
\ string helpers
 : ARG$     ( -- addr len ) BL PARSE-WORD ?FILE ;
 : $.       ( $addr -- ) COUNT TYPE ;
 : $.LEFT   ( $ width -- ) OVER [email protected] - >R $.  R> SPACES ;
 : NEXT$    ( addr len -- addr' len') + COUNT ;
\  : +PLACE  ( addr n $ -- ) 2DUP 2>R  COUNT +  SWAP CMOVE 2R> C+! ;
.( .)
HEX
: CLOSE-ALL ( --)  4 1 DO  I ]FID @ IF  I CLOSE-FILE DROP THEN   LOOP ;

\ ?break closes all open files.
: ?BREAK ( ? -- ) IF  CLOSE-ALL   TRUE ABORT" *BREAK*"   THEN ;

\ Modify key to allow it to break and close files
: FKEY    ( -- char)
           VPOS [email protected] >R
           BEGIN                  \ start the loop
              CURS @              \ fetch 2 char cursor (space & _ )
              [email protected] 1FFF <         \ compare hardware timer to 1FFF
              IF DROP [email protected] THEN VPUT   \ swap cursor for screen char, write
              ?TERMINAL ?BREAK    \ test for Break key
              KEY?                \ check the keyboard
              ?DUP                \ DUP IF <> 0
            UNTIL                 \ loop until a key pressed
            R>  VPUT ;            \ put the space char on screen

\ screen control
: SPACE?   ( -- ?) KEY? BL = ;
: SPACEBAR ( -- ) SPACE? IF    FKEY DROP    THEN ;

.( .)
: OPEN-CATFILE ( adr len -- hndl) RELATIVE 100 FIXED R/O BIN OPEN ;

\ 3 DIGIT BCD to int convertor. Limited to 999
HEX
: F>INT   ( addr len -- addr len n)
          OVER [email protected]  ( -- mantissa)
          CASE
            0 OF  0                    ENDOF
           40 OF  OVER 1+ [email protected]           ENDOF
           41 OF  OVER 1+ [email protected] 64 * >R
                  OVER 2+ [email protected]  R> +     ENDOF
           ( default)  -1  \ bad # indicator
           ENDCASE ;

DECIMAL
: DIR.TYPE  ( addr -- )
          F>INT
          CASE
             1 OF ." Txt/Fix"  ENDOF
             2 OF ." Txt/Var"  ENDOF
             3 OF ." Bin/Fix"  ENDOF
             4 OF ." Bin/Var"  ENDOF
             5 OF ." Program"  ENDOF
             ." ????"
          ENDCASE ;
.( .)
: HEAD.REC ( addr -- )
          DECIMAL
          DUP  7 $.LEFT SPACE COUNT ( addr len)
          NEXT$
          ."  Size " NEXT$ F>INT 5 U.R   ."  Used " NEXT$ F>INT 5 U.R
          2DROP ;

: DIR.REC ( addr -- )
          DUP  11 $.LEFT SPACE COUNT ( addr len)
          NEXT$ DIR.TYPE
          NEXT$ F>INT 7 U.R
          NEXT$ F>INT 7 U.R
          2DROP ;

: FILE.REPORT  CR LINES @ . ." lines, " #BYTES @ . ." bytes" ;

\ ========================================
\ *
\ * User commands: CAT DIR MORE DEL COPY
\ *

: CAT  ( <DSK?.> )   \  needs the '.' ONLY shows file name
          BASE @ >R DECIMAL
          ARG$ OPEN-CATFILE >R  \ store file handle

          PAD 80 [email protected] READH
          CR PAD HEAD.REC
          CR 13 SPACES  ." -type-  -sect- -b/rec-"

          LINES OFF
          BEGIN
             PAD DUP 80 [email protected] READH
           ( PAD)  [email protected]   \ do while length > 0
          WHILE
             CR PAD DIR.REC
             1 LINES +!
             SPACEBAR
             ?TERMINAL ?BREAK
          REPEAT
          R> CLOSE
          CR LINES @ . ." files" CR
          R> BASE ! ;
.( .)
HEX
: DIR  ( <DSK?.> )
          ARG$
          OPEN-CATFILE >R  \ push handle
          PAD 50 [email protected] READH
          CR PAD HEAD.REC
          CR

          LINES OFF
          BEGIN
            PAD DUP 80 [email protected] READH
          ( PAD) [email protected]   \ do while length <> 0
          WHILE
             PAD 0D $.LEFT ?CR
             1 LINES +!
             SPACEBAR
            ?TERMINAL ?BREAK
          REPEAT
          R> CLOSE
          DECIMAL
          CR LINES @ . ." files" CR
          HEX ;

.( .)
: MORE  ( <filename>)
          LINES OFF  #BYTES OFF
          ARG$ DV80 R/O OPEN >R
          BEGIN
             PAD DUP 50 [email protected] READ-LINE ?FILERR ( adr len flag)
          WHILE
             DUP #BYTES +!
             CR TYPE
             LINES 1+!
             SPACEBAR
             ?TERMINAL ?BREAK
          REPEAT
          R> CLOSE
          2DROP
          FILE.REPORT
;

HEX
: TOUPPER ( char -- upperchar ) 5F AND ;

: SURE?  ( -- ?)
         WARNINGS @
         IF
           CR ." Are you sure? (Y/N)"
           KEY TOUPPER [CHAR] Y =
         THEN ;

: .CANCEL  CR ." Cancelled" CR ;

: DEL   ( <filename>)
         ARG$ 2DUP R/W OPEN-FILE ?FILERR
         CR ." Delete " TYPE
         SURE?
         IF  7 FILEOP ?FILERR
              CLOSE-FILE 2DROP
              CR ." Done"
         ELSE
            DROP  .CANCEL
         THEN ;

: MOVE-FILE ( buff-size -- buff-size)
        #BYTES OFF
        DUP MALLOC >R
        LINES OFF
        SPACE
        BEGIN
          [email protected]  50  #1 READ-LINE ?FILERR ( -- #bytes eof?)
        WHILE
          DUP #BYTES +!
          [email protected] SWAP #2 WRITE-LINE ?FILERR
          LINES 1+!
          SPINNER
        REPEAT
        R> DROP                 \ DROP buffer address from rstack
        MFREE
;
.( .)
DECIMAL

: COPY  ( <file1> <file2> )
        ARG$ ARG$
        SURE?
        IF
          DV80 W/O OPEN AS: #2
          DV80 R/O OPEN AS: #1
          52 MOVE-FILE
          #2 CLOSE
          #1 CLOSE
          BASE @ >R
          DECIMAL
          CR ." Copy complete. "
          FILE.REPORT
          R> BASE !
        ELSE
           2DROP 2DROP  .CANCEL
        THEN
;

: W/O+  ( -- fam ) APPEND FAM @  ;  \ TI-99 file access mode: write/append

HEX
: APND  ( <file1> <file2> )
        ARG$  ARG$
        DV80 W/O+ OPEN AS: #2
        DV80 R/O  OPEN AS: #1
        52 MOVE-FILE
        #2 CLOSE
        #1 CLOSE
        BASE @ >R
        DECIMAL
        CR ." Append complete"
        FILE.REPORT
        R> BASE ! ;

: CLS   PAGE ;

: HELP  CR
        CR ." Commands"
        CR ." --------------------"
        CR ." HELP Show this list"
        CR ." DIR  <DSK?.> show file names"
        CR ." CAT  <DSK?.> show files and types"
        CR ." MORE <path>  show contents of DV80 file"
        CR ." DEL  <path>  delete file at path"
        CR ." COPY <path1> <space> <path2> "
        CR ."      Copy file at path1 to path2"
        CR ." APND <path1> <space> <path2"
        CR ."      Append file1 to file2"
        CR ." WAITFOR <path> Paste to Classic99"
        CR ." CLS  Clear screen"
        CR ." BYE  Return to Home screen"
        CR ." WARNINGS OFF   Disables 'Are you sure?'"
        CR ." ------------------"
        CR ." SPACE bar will stop scrolling"
        CR ." FNCT 4 halts operations"
;


\ re-write accept to use new KEY. ( could patch it but this is clearer)
: FACCEPT     ( c-addr +n -- +n')
             OVER + OVER
             BEGIN
               FKEY DUP 0D <>
             WHILE
                DUP EMIT
                DUP 8 =
                IF   DROP 1-  3 PICK  UMAX  \ changed to use: 3 PICK   B.F.
                ELSE OVER C!  1+ OVER UMIN
                THEN
             REPEAT
             DROP NIP SWAP - ;
.( .)
: RCV  ( caddr len --  )
      DV80 W/O OPEN AS: #1
      BEGIN
        PAD DUP 50 FACCEPT ( addr len) #1 WRITE-LINE ?FILERR
      AGAIN ;

\ USED WITH Classic99. Pastes text into DV80 FILE
: WAITFOR  ( <PATH> )
        ARG$
        CR ." Waiting for file " 2DUP TYPE
        CR ." Press FCTN 4 to halt & SAVE"
        CR RCV ;

: SHELL
       WARM
       PAGE ." Fox Shell V1.0,    Brian Fox 2020"
       DECIMAL
       HELP
       WARNINGS ON
       ABORT ;

CR .( Save as EA5 binary files)
INCLUDE DSK1.SAVESYS
 ' SHELL  SAVESYS DSK2.FOXSHELL

 

 

 

FOXSHELL_SCREEN.png

FSHELL.zip

  • Like 4

Share this post


Link to post
Share on other sites
1 hour ago, TheBF said:

Updated FoxShell

 

As I put my new kernel through its paces I used the new SAVESYS utility to compile a version of my DV80 disk utilities.

It's not Force Command by any stretch but handy for me with a large number of text files in the system. At this time they only work with DV80 files.

I am still thinking about the best way deal with other file types to make a simple syntax for the end user.

 

Very nice, indeed! You are giving me ideas for fbForth 2.0 I don’t need. I have other fish to fry.  Well done!

 

...lee

  • Like 1
  • Thanks 1

Share this post


Link to post
Share on other sites

Going through my Demo files and testing things on V2.66 I did some improvements to AUTOMOTION. 

The motion vectors now correct the X vector (-1) when Y vector is a negative value. I had that on my list for while.

 

Changed motion table access to a machine code word. Same size as Forth but much faster.

 

In my coincidence test nowI first do  COINCALL before testing coincidence. This allows faster polling.

: COINC ( spr#1 spr#2 tol -- ?)
        COINCALL
        IF
          >R
          POSITION ROT POSITION ( -- x1 y1 x2  y2 )
          ROT - ABS [email protected] <
         -ROT - ABS R> <
          AND
          EXIT          \ get out
        THEN            \ if coincall=true then do this
        2DROP DROP      \ drop parameters
        FALSE           \ return false flag
 ;

 

 

Wrote this demo a while back and it seems to work. It reads the motion table and the sprite location table directly  to "trap" the sprites on the screen.

Spoiler
\ Sprite COINC under Automotion    Nov 2020 BFox

\ NEEDS DUMP       FROM DSK1.TOOLS
NEEDS SPRITE     FROM DSK1.DIRSPRIT
NEEDS AUTOMOTION FROM DSK1.AUTOMOTION
NEEDS HZ         FROM DSK1.SOUND

MARKER /DEMO

DECIMAL
: NEGATE.VC! ( Vaddr -- ) DUP [email protected] NEGATE  SWAP VC! ;

: BOUNCE.X  ( spr# -- ) ]SMT 1+  NEGATE.VC! ;
: BOUNCE.Y  ( spr# -- ) ]SMT     NEGATE.VC! ;

DECIMAL
: TINK    GEN1 1600 HZ -6 DB  40 MS  MUTE ;
: THUMP   GEN2  150 HZ  0 DB ;

: TRAP ( spr# -- )
      DUP SP.X [email protected] 240 1 WITHIN
      IF   DUP BOUNCE.X TINK  THEN

      DUP SP.Y [email protected] 180 1 WITHIN
      IF  DUP BOUNCE.Y  TINK  THEN
      DROP ;

: RAINBOW  ( spr# -- )
     THUMP
     16 3
     DO
        I OVER SP.COLOR
        25 MS
        1 TRAP 2 TRAP   \ keep the other guys trapped
        GEN2 I DB       \ FADE the sound down
     LOOP
     DROP MUTE ;

: SP.STOP  ( spr# ) 0 0 ROT MOTION ;

: COLLISION ( spr1 spr2 -- )
      2DUP 8 COINC
      IF
  ( spr2)  DUP BOUNCE.X BOUNCE.Y
  ( spr1)  DUP SP.STOP        \ stop the sprite 1
           DUP BOUNCE.X DUP BOUNCE.Y
           DUP RAINBOW        \ show his displeasure :)
           15 15 ROT MOTION   \ start up again
      ELSE
          2DROP
      THEN ;

DECIMAL
: TITLES
     7 SCREEN
     PAGE
     CR ."          CAMEL99 Forth"
     CR ."    Automotion Coincidence Test"
     CR
     4 21 AT-XY ." '#' and '@' will collide" ;

: RUN ( motionx motiony -- )
      TITLES
   ( char   colr  x   y  sp#        vx vy spr#     )
   [CHAR] @  16   90 100  0 SPRITE  14 15  0 MOTION
   [CHAR] #   3  200 100  1 SPRITE  20 22  1 MOTION
   [CHAR] Q   8  200 100  2 SPRITE  10 11  2 MOTION
   1 MAGNIFY
   AUTOMOTION
   BEGIN
      0 TRAP   0 1 COLLISION  \ poll for trap and coincidence
      1 TRAP   0 1 COLLISION
      2 TRAP   0 1 COLLISION
     ?TERMINAL
   UNTIL
   STOPMOTION  ;

CR .( Type RUN to start demo)

 

 

  • Like 1

Share this post


Link to post
Share on other sites

Updating the MORSE Code Demo program using WORDLISTs.

 

The way this demo worked was to redefine letters and punctuation so that they would transmit as Morse Code.

This meant that the Forth words that were single characters and part of the Morse system were now unavailable.

The solution always was to use a different namespace for the Morse code characters but I didn't have that until now.

I also took the liberty of adding upper case conversion to TRANSMIT so that it doesn't barf on a lower case string.

 

 

 

Spoiler
\ MORSE CODE GENERATOR for Rosetta Code   Brian Fox, Feb 2016
\ Ported to Camel99 Forth May 2020
\ Updated with wordlist and lower case ability   Nov 2020

NEEDS VALUE FROM DSK1.VALUES
NEEDS SOUND FROM DSK1.SOUND
NEEDS TOOLS FROM DSK1.TOOLS
NEEDS WORDLIST FROM DSK1.WORDLISTS

ONLY FORTH DEFINITIONS

MARKER /MORSE

HEX
: LOWER?  ( c -- c ?) DUP [CHAR] a [CHAR] z 1+  WITHIN ;
: TOUPPER ( c -- c') LOWER? IF  5F AND  THEN ;
: $UPPER  ( addr len -- ) BOUNDS ?DO  I [email protected] TOUPPER  I C!   LOOP ;

DECIMAL
  750 VALUE FREQ    \ 750 Hz will be the tone freq.
  100 VALUE ADIT    \ duration of one "dit" for ~10 words per minute

: WPM  ( n -- ) 1000 SWAP /  25 MAX  TO ADIT ;

\ Compute all durations based on ADIT
: DIT_DUR      ADIT MS ;
: DAH_DUR      ADIT 3 * MS ;
: WORDGAP      ADIT 5 * MS ;
: OFF_DUR      ADIT 2/ MS ;
: LETTERGAP    DAH_DUR ;   \ space between letters is commonly a DAH.

: TONE ( -- ) FREQ HZ 0 DB  ;

: MORSE-EMIT  ( char -- )
        DUP  BL =                      \ check for space character
        IF
             DROP WORDGAP              \ ignore char and delay
        ELSE
             PAD C!                    \ write char to buffer
             PAD 1 EVALUATE            \ evaluate 1 character string
             LETTERGAP
        THEN ;


: TRANSMIT ( ADDR LEN -- )
           2DUP $UPPER                 \ convert string, leave a copy
           CR                          \ newline,
           BOUNDS                      \ convert loop indices to address ranges
           DO
              I [email protected] DUP EMIT            \ dup and send char to console
              MORSE-EMIT               \ send the morse code
           LOOP ;

\ **** new namespace stops conflict with FORTH words and numbers ***
VOCABULARY MORSE  ALSO MORSE DEFINITIONS

\ dit and dah define all the rest
: .   ( -- ) TONE  DIT_DUR  MUTE  OFF_DUR ;
: -   ( -- ) TONE  DAH_DUR  MUTE  OFF_DUR ;

\ define morse letters as Forth words. They transmit when executed
: A  . -  ;     : B  - . . . ;   : C  - . - . ;    : D  - . . ;
: E  . ;        : F  . . - . ;   : G  - - . ;      : H  . . . . ;
: I  . . ;      : J  . - - - ;   : K  - . - ;      : L  . - . . ;
: M  - - ;      : N  - . ;       : O  - - - ;      : P  . - - . ;
: Q  - - . - ;  : R  . - . ;     : S  . . . ;      : T  - ;
: U  . . - ;    : V  . . . - ;   : W  . - - ;      : X  - . . - ;
: Y  - . - - ;  : Z  - - . . ;

: 0  - - - - - ;     : 1  . - - - - ;
: 2  . . - - - ;     : 3  . . . - - ;
: 4  . . . . - ;     : 5  . . . . . ;
: 6  - . . . . ;     : 7  - - . . . ;
: 8  - - - . . ;     : 9  - - - - . ;

: '  - . . - . ;     
: \  . - - - . ;
: !  . - . - . ;

: ?  . . - - . . ;
: ,  - - . . - - ;
: /  . . . - . - ;  ( SK means end of transmission in int'l Morse code)
: .  . - . - . - ;

FORTH DEFINITIONS
( ~ 10 words per minute )
: TEST
   PAGE  ." Morse Code Transmitter Demo"
   CR
   CR S" Let's try a lower case string." 2DUP TYPE
   1000 MS
   CR MORSE TRANSMIT
   CR
   CR ." Now something more appropriate:"  500 MS
   CR S" CQ CQ CQ DE VE3CFW / K " MORSE TRANSMIT
;

 

 

  • Like 1

Share this post


Link to post
Share on other sites

ISR Sound List Player Re-visited

 

As I a slowly go through the system libraries looking for unfinished bits and bobs I found my ISR sound list player. I have experimented with playing sound under the cooperative multi-tasker and it works but you have to "tune" the other programs carefully to get hard timing for the music player.  The previous work meant that I had everything I needed to create named sound lists in VDP RAM but I recalled that I had never got my ISRPLAY word to actually play sounds.

Page 312 of the E/A manual gave me all the detail I needed, so I thought, but my code didn't work.

 

For some reason way back then I had not looked into the purpose of what I have seen called the AMSQ byte (>83C2)

 

From: http://www.unige.ch/medecine/nouspikel/ti99/ints.htm#VDP ISR

Four bits in byte >83C2 are used to enable/disable the first 3 functions:

  • If the first bit (weight >80) is set, the ISR jumps directly to point 4.
  • If the second bit (>40) is set, the ISR won't handle sprites.
  • If the third bit (>20) is set, the ISR won't process the sound list.
  • If the fourth bit (>10) is set, the ISR won't test the <quit> key

I had learned about these control bits when I got AUTOMOTION running but had not circled back on the sound list player.

Armed with knowledge it was simple to make the player work.  Since I wanted this in Forth I need two machine code words to control interrupts.

CODE 0LIMI ( -- )  0300 , 0000 , NEXT, ENDCODE
CODE 2LIMI ( -- )  0300 , 0002 , NEXT, ENDCODE

\ ........................................
\  ISR sound list player
HEX
: ISRPLAY ( vaddr -- )
            0LIMI                     \ interrupts off
            83CC !                    \ Vaddr -> sound table
            AMSQ [email protected]  5 AND AMSQ C!    \ enable sound interrupts
            01 83CE C!                \ trigger sound processing
            83FD [email protected]  01 OR 83FD C!    \ set VDP flag
            2LIMI ;                   \ interrupts on

To make a sound list I used the VDPMEM library which lets you manage VDP memory the same way the Forth dictionary is managed.

To that I added a VBYTE directive so that it is easy to transport Assembly language sound lists over to Forth.

VBYTE compiles directly to VDP RAM so there is no need to take-up CPU ram space in your program if you compile from source code and then run it.

 

Here is the CHIME example from page  322 of the E/A manual using the VBYTE directive:

( Not too much text editing required) :) 

Edit: accidently removed the CHIME code

 

Spoiler
\ chime demo sound from TI E/A Manual page 322
\ play from VDP memory with VDPBGSND

HEX
VCREATE CHIME
       VBYTE 05,9F,8F,DF,FF,E3,1
       VBYTE 09,8E,01,A4,02,C5,01,90,B6,D3,6
       VBYTE 03,91,B7,D4,5
       VBYTE 03,92,B8,D5,4
       VBYTE 05,A7,04,93,B0,D6,5
       VBYTE 03,94,B1,D7,6
       VBYTE 03,95,B2,D8,7
       VBYTE 05,CA,02,96,B3,D0,6
       VBYTE 03,97,B4,D1,5
       VBYTE 03,98,B5,D2,4
       VBYTE 05,85,03,90,B6,D3,5
       VBYTE 03,97,B4,D1,5
       VBYTE 03,95,B2,D8,7
       VBYTE 05,CA,02,96,B3,D0,6
       VBYTE 03,97,B4,D1,5
       VBYTE 03,98,B5,D2,4
       VBYTE 05,85,03,90,B6,D3,5
       VBYTE 03,91,B7,D4,6
       VBYTE 03,92,B8,D5,7
       VBYTE 05,A4,02,93,B0,D6,6
       VBYTE 03,94,B1,D7,5
       VBYTE 03,95,B2,D8,4
       VBYTE 05,C5,01,96,B3,D0,5
       VBYTE 03,97,B4,D1,6
       VBYTE 03,98,B5,D2,7
       VBYTE 03,9F,BF,DF,0
/VEND

 

 

For reference here is VDPMEM

Spoiler
\ vdp memory manager lexicon    BJF

\ VDP Memory Usage in Camel99 Forth when this file is loaded
\ |  VDP screen   |
\ + --------------|
\ |   RESERVED    |    sprites, patterns color tables
\ |               |
\ +---------------+  HEX 1000, VDP HEAP start
\ |    VHERE      |  VDP heap moves upwards
\ |      .        |
\ |      .        |
\ |      .        |
\ |      .        |
\ |               |
\ |               |
\ |               |        ^^^^^^^
\ |   ^^^^^^^     |  move downwards
\ |  PAB stack    |  PABs start here
\ +---------------+ <-- VDPTOP returns this address
\ | 99 O/S space  |
\ |---------------|

\ INCLUDE DSK1.TOOLS  \ debugging only

\ VARIABLE VP    ( moved to kernel for V2.55 )

HEX 1000 VP !   \ "VDP pointer" start of free VDP RAM
: VHERE   ( -- addr) VP @ ;   \ FETCH the value in VDP pointer
: VALLOT  ( n -- )   VP +! ;  \ add n to the value in VDP pointer
: VC,     ( n -- )   VHERE VC!  1 VALLOT ;
: V,      ( n -- )   VHERE V!   2 VALLOT ;
: VCOUNT  ( vdp$adr -- vdpadr len ) DUP 1+ SWAP [email protected] ;
: VCREATE ( <text> -- ) VHERE CONSTANT  ; \ address when <text> invoked

 

 

The complete sound player lib file

Spoiler
\ ISR Sound player for Camel99 Forth   Jan 10, 2019 BJF
\ Changed to use VDPMEM library Nov 10, 2020 BJF

NEEDS VHERE  FROM DSK1.VDPMEM

 83C2 CONSTANT AMSQ      \ interrupt DISABLE bits
\ AMSQ bit meaning:
\ 80 all interrupts disabled
\ 40 motion disabled
\ 20 Sound disabled
\ 10 quit key disabled

\ VDP BYTE directive: compile bytes into VDP RAM
: VBYTE ( -- )  \ read input stream of bytes and compile to VDP mem.
         BEGIN
           [CHAR] , PARSE-WORD  DUP  ( -- adr len len )
         WHILE
            EVALUATE  DUP FF00 AND ABORT" Not a byte"
            VC,
         REPEAT
         2DROP ;

: /VEND   ( -- ) 0 VC,  ;     \ compile a zero BYTE into VDP RAM

CODE 0LIMI ( -- )  0300 , 0000 , NEXT, ENDCODE
CODE 2LIMI ( -- )  0300 , 0002 , NEXT, ENDCODE

\ ........................................
\  ISR sound list player
HEX
: ISRPLAY ( vaddr -- )
            0LIMI                     \ interrupts off
            83CC !                    \ Vaddr -> sound table
            AMSQ [email protected]  5 AND AMSQ C!    \ enable sound interrupts
            01 83CE C!                \ trigger sound processing
            83FD [email protected]  01 OR 83FD C!    \ set VDP flag
            2LIMI ;                   \ interrupts on

\ example list
1000 VP !    \ reset VDP memory heap

VCREATE PACMAN
       VBYTE 6,86,0D,97,AC,1A,B7,8
       VBYTE 2,8F,08,2
       VBYTE 2,AB,23,5
       VBYTE 2,86,0D,4
       VBYTE 1,BF,3
       VBYTE 2,8E,0B,8
       VBYTE 2,8A,0A,2
       VBYTE 3,AC,1A,B7,8
       VBYTE 2,9F,BF              \ mute generators 1 & 2
/VEND

 

 

  • Like 2

Share this post


Link to post
Share on other sites
1 hour ago, TheBF said:

[CHAR] , PARSE-WORD

 

How does PARSE-WORD know to stop at the end of a VBYTE comma-delimited string without a terminal comma? I ask this with a passing interest in how I might implement such a thing in fbForth, where I would actually need a pair of commas to get a token with a null length were there any spaces after the string as there would surely be in LOADing a block with such code.

 

...lee

Share this post


Link to post
Share on other sites

It seems to take what ever is left at the end up to the "enter" key.

The CODE is rather hard to follow but here it is.

I recently took PARSE from GForth because it was simpler that Brad's version.

 

Of course PARSE et al.  is part of the push to stack strings versus counted strings however they have not deprecated FIND and so WORD is still required. :)

It's not easy to shepherd a language standard especially one that doesn't actually have syntax. :-))))

 

Spoiler
: SOURCE   ( -- addr len) 'SOURCE [email protected] ;    \ Common factor, saves space

: PARSE    ( char -- c-addr u )  \ gForth
            >R
            SOURCE  >IN @ OVER MIN /STRING
            OVER SWAP R>  SCAN >R
            OVER - DUP
            R> IF 1+ THEN  >IN +! ;

: PARSE-WORD  ( char -- c-addr n)  \ Camel/BFox common factor for WORD
            DUP SOURCE >IN @ /STRING
            ROT SKIP
            DROP SOURCE  -ROT -  MIN  0 MAX >IN !
            PARSE ;

: WORD     ( char -- c-addr)
            PARSE-WORD
            HERE 2DUP C!      \ store length byte count
            1+ SWAP CMOVE     \ write the string to HERE
            HERE BL OVER COUNT + C! ; \ append BLank character

 

 

For reference here is /STRING SKIP and SCAN 

 

Spoiler
CODE: /STRING ( c-addr1 u1 n -- c-addr2 u2 ) 
              TOS   *SP  SUB,     
              TOS 2 (SP) ADD,   
              TOS POP,      
              NEXT,       
              END-CODE

 

 

Spoiler
CODE: SKIP  ( c-addr u char -- c-addr' u')    \ skip matching chars
              TOS SWPB,                       
              2 (SP) W MOV,                   \ get address->w, leave space on stack
             *SP+ R1 MOV,                     \ POP count into R1, char is already in TOS
              NE IF,                          \ if r1=0 get out
                  BEGIN,
                    TOS *W+ CMPB,             \ does character match?  auto-incr. address
                    @@2 JNE,                  \ NO MATCH jump out
                    R1 DEC,                   \ decr loop counter
                  EQ UNTIL,                   \ loop until R1=0
@@2:              W DEC,                      \ correct result address after auto-inc.
              ENDIF,
              W *SP  MOV,                     \ store updated address on stack
              R1 TOS MOV,                     \ updated count to TOS
              NEXT,
              END-CODE

 CODE: SCAN   ( adr len char -- adr' len' )   \ find matching char
              TOS SWPB,                      
              2 (SP) W MOV,                   \ get address->w
             *SP+ R1 MOV,                     \ POP count into R1, char is already in TOS
              NE IF,                          \ R1<>0 ?
                  BEGIN,
                    TOS *W CMPB,              \ does character match?
                    @@2 JEQ,                  \ YES, we are done, JUMP OUT
                     W INC,                   \ next character
                     R1 DEC,                  \ dec. loop counter
                  EQ UNTIL,                   \ hit end of string, jmp out
              ENDIF,
@@2:          W *SP  MOV,                     \ store updated address on stack
              R1 TOS MOV,                     \ updated count to TOS
              NEXT,
             END-CODE

 

 

Share this post


Link to post
Share on other sites
41 minutes ago, TheBF said:

It seems to take what ever is left at the end up to the "enter" key.

 

I figured as much. With fbForth, a null (which is waiting in the TIB where <enter> was hit, as well as at the end of any block buffer) will stop parsing, but, again, everything between the last delimiter and those nulls will be part of the last token. That will probably work as long as there is nothing but spaces after the last good datum. However, putting two VBYTE constructs on the same line will probably not end well because EVALUATE will properly put the last byte of the first VBYTE on the stack, but will surely interpret the second VBYTE before the first one can finish.

 

...lee

Share this post


Link to post
Share on other sites
5 minutes ago, Lee Stewart said:

 

I figured as much. With fbForth, a null (which is waiting in the TIB where <enter> was hit, as well as at the end of any block buffer) will stop parsing, but, again, everything between the last delimiter and those nulls will be part of the last token. That will probably work as long as there is nothing but spaces after the last good datum. However, putting two VBYTE constructs on the same line will probably not end well because EVALUATE will properly put the last byte of the first VBYTE on the stack, but will surely interpret the second VBYTE before the first one can finish.

 

...lee

Yes on the same line would end badly.

I think it would be ok if you added the final comma. Not at my machine right now but I will test that.

Share this post


Link to post
Share on other sites
5 hours ago, Lee Stewart said:

 

I figured as much. With fbForth, a null (which is waiting in the TIB where <enter> was hit, as well as at the end of any block buffer) will stop parsing, but, again, everything between the last delimiter and those nulls will be part of the last token. That will probably work as long as there is nothing but spaces after the last good datum. However, putting two VBYTE constructs on the same line will probably not end well because EVALUATE will properly put the last byte of the first VBYTE on the stack, but will surely interpret the second VBYTE before the first one can finish.

 

...lee

 

Lee your fastidiousness made me re-think this. Here is an alternative that will error out if there is anything on the line but numbers and commas -OR- if the number is not a byte

This will of course  preclude comments as well, which EVALUATE handles as a matter of course, but oh well.

 

What do you think?

EDIT: To make it less error prone I add BL SKIP to remove leading blanks before the numbers

: VBYTE ( -- )  \ read input stream of bytes and compile to VDP mem.
         BEGIN
           [CHAR] , PARSE-WORD BL SKIP DUP  ( -- adr len len )
         WHILE
            NUMBER?  ( -- n ?)     \ text->n  ?=0 if good
            OVER FF00 AND          \ test if we have a byte
            OR ABORT" VBYTE error" \ Error out on either
            VC,
         REPEAT
         2DROP ;

 

 

  • Like 1

Share this post


Link to post
Share on other sites

80 COL VIBE Editor by Sam Falvo.

 

I finally have this interesting editor working reliably on TI-99.  It is only 80 columns at the moment because I wanted to work on the editing functions and not the screen display.

It works very much like VI but on Forth block files. VI is pretty strange if you have never encountered it, but it has a following.

 

One of the interesting things in this code, that I have never done, is just drop an item off the return stack to escape from a part of the program. :) 

See the definition for ?CONFIRM. 

 

Spoiler
\ VIBE Release 2.2
\ Copyright (c) 2001-2003 Samuel A. Falvo II
\ All Rights Reserved
\ * Use with written permission for Camel99 Forth *
\
\ Highly portable block editor -- works under nearly every ANS Forth
\ I can think of, and with only a single screenful of words, will
\ work under Pygmy and FS/Forth too.
\
\ USAGE: vibe ( n -- ) Edits block 'n'.  Sets SCR variable to 'n'.
\        ed ( -- ) From Pygmy.  Re-edits last edited block.
\
\
\ 2.1 -- Fixed stack overflow bugs; forgot to DROP in the non-default
\        key handlers.
\

\ 2.2 Ported to CAMEL99 Forth B. Fox 2019
\     Removed some character constants to save space.
\     Changed TYPE for VTYPE.
\     Removed shadow block function
\     Added some block navigation commands

\ 2.3 Fixed keyboard bugs for TI-99/4A
\     VI command takes a filename parameter like real VI
\     simplfied wipe screen logic and saved bytes
\     Add $ command: goto end of line
\     Add PC delete KEY for Classic99

NEEDS DUMP   FROM DSK1.TOOLS
NEEDS 80COLS FROM DSK1.80COL
NEEDS RKEY   FROM DSK1.RKEY
NEEDS BLOCK  FROM DSK1.BLOCKS
NEEDS -TRAILING FROM DSK1.TRAILING

MARKER /VIBE

HERE
( Editor Constants )
CHAR i  CONSTANT 'i   \ Insert mode
CHAR c  CONSTANT 'c   \ Command mode
\ camel99 values
DECIMAL
 64 CONSTANT WIDTH
 80 CONSTANT MAXBLKS

( Editor State )
 VARIABLE SCR       \ Current block
 VARIABLE X         \ Cursor X position 0..63
 VARIABLE Y         \ Cursor Y position 0..15
 VARIABLE MODE      \ current mode: INSERT or command ( 'i OR 'c

\ CMDNAME the command string, is built, found and executed
CREATE CMDNAME    5 C,  CHAR $ C, CHAR $ C,  0 C, 0 C, 0 C,

( Editor Display )
 DECIMAL
: BLANKS      BL FILL ; \ BF add
: MODE.       63 0 AT-XY MODE @ EMIT ;
: VTYPE       ( addr len -- ) TUCK  VPOS SWAP VWRITE   VCOL +! ;
: SCR.        0 0 AT-XY S" Block: " VTYPE  SCR @ . ( S"      " VTYPE ) ;
: HEADER      SCR. MODE. ;
: 8-S         S" --------" VTYPE ;
: WIDTH-S     8-S 8-S 8-S 8-S 8-S 8-S 8-S 8-S ;
: BORDER      SPACE WIDTH-S CR ;
: ROW         ( addr -- addr') DUP 63 VTYPE  64 + ;   \ FAST
\ : ROW         ( addr -- addr') DUP 63 TYPE 63 + ;  \ SLOW
: LINE       ." |" ROW CR ;
: 4LINES      LINE LINE LINE LINE ;
: 16LINES     SCR @ BLOCK  4LINES 4LINES 4LINES 4LINES DROP ;
: CARD        0 1 AT-XY BORDER 16LINES BORDER ;
: CURSOR      X @ 1+  Y @ 2+ AT-XY ;
: SCREEN      HEADER CARD CURSOR ;

( Editor State Control )
: INSERT      'i MODE ! ;
: REPLACE     [CHAR] r MODE ! ;
: CMD         'c MODE ! ;

: BOUNDED      ( addr n -- ) 0 MAX MAXBLKS MIN SWAP ! ;
: PREVBLOCK    SCR DUP @ 1- BOUNDED ;
: NEXTBLOCK    SCR DUP @ 1+ BOUNDED ;
\ : TOGGLESHADOW 1 SCR @ XOR SCR ! ;

( Editor Cursor Control )
: FLUSHLEFT     0 X ! ;
: BOUNDX        X @  0 MAX 63 MIN X ! ;
: BOUNDY        Y @  0 MAX 15 MIN Y ! ;
: BOUNDXY       BOUNDX BOUNDY ;
: LEFT          X 1-! BOUNDXY ;
: RIGHT         X 1+! BOUNDXY ;
: UP            Y 1-! BOUNDXY ;
: DOWN          Y 1+! BOUNDXY ;
\ : beep          7 EMIT ;
: NEXTLINE      Y @ 15 < IF FLUSHLEFT DOWN THEN ;
: NEXT          X @ 63 = IF NEXTLINE EXIT  THEN RIGHT ;

( Editor Insert/Replace Text )
: WIDTH*        6 LSHIFT ;  \  x64
: WHERE         SCR @ BLOCK SWAP WIDTH* + SWAP + ;
: WH            X @ Y @ WHERE ;
: SOL           0  Y @ WHERE ;
: EOL           63 Y @ WHERE ;
: PLACE         WH C! UPDATE NEXT ;
: -EOL?         X @ 63 < ;
: OPENR         WH DUP 1+ 63 X @ - MOVE ;
: OPENRIGHT     -EOL? IF OPENR THEN ;
: INSERTING?    MODE @ 'i = ;
: CHR           INSERTING? IF OPENRIGHT THEN PLACE ;
: EOTEXT        SOL 63 -TRAILING NIP X ! ;
: NEXTWORD
     WH EOL OVER - DUP -ROT  ( len adr len)
     BL SKIP  \ skip spaces
     BL SCAN  \ find next space
     NIP - 1+ X ! BOUNDX WH ;

( Editor Keyboard Handler CMDWORD encoding)
\ CMD name key: $ $ _ _ _
\                    | | |
\ 'c'=command mode --+ | |
\ 'i"=ins/repl mode    | |
\                      | |
\ Key code (hex#) -----+-+
\
\ Called with ( k -- ) where k is the ASCII key code.

( Editor COMMANDS: Quit, cursor, block, et. al. )
( Modified for Ti-99 keyboard )
: $$c51       DROP 0 19 AT-XY R> R> DROP >R ; \ : -- quit main loop
: $$c30       DROP FLUSHLEFT ;         \ 0  goto start of line
: $$c24       DROP EOTEXT ;            \ $  goto end of line
: $$c69       DROP INSERT ;            \ i
: $$c49       DROP FLUSHLEFT INSERT ;  \ I
: $$c52       DROP REPLACE ;           \ R
: $$i0F       DROP CMD ;               \ (escape) GOTO command mode
: $$c68       DROP LEFT ;              \ h
: $$c6A       DROP DOWN ;              \ j
: $$c6B       DROP UP ;                \ k
: $$c6C       DROP RIGHT ;             \ l
: $$c5B       DROP PREVBLOCK ;         \ [
\ : $$c5C       DROP TOGGLESHADOW ;     \ \
: $$c5D       DROP NEXTBLOCK ;         \ ]
: $$c77       DROP NEXTWORD  ;         \ w

( Editor Backspace/Delete )
: PADDING     BL EOL C! UPDATE ;
: DEL         WH DUP 1+ SWAP 63 X @ - MOVE ;
: DELETE      -EOL? IF DEL THEN PADDING ;
: BS          LEFT DELETE ;
: BACKSPACE   X @ 0 > IF BS THEN ;

( Editor Carriage Return )
: NEXTLN      EOL 1+ ;
: #CHRS       SCR @ BLOCK 1024 + NEXTLN - WIDTH - ;
: COPYDOWN    Y @ 14 < IF NEXTLN DUP WIDTH + #CHRS MOVE THEN ;
: BLANKDOWN   NEXTLN WIDTH BLANKS UPDATE ;
: SPLITDOWN   WH NEXTLN 2DUP SWAP - MOVE ;
: BLANKREST   WH NEXTLN OVER -  BLANKS ;
: OPENDOWN    COPYDOWN BLANKDOWN ;
: SPLITLINE   OPENDOWN SPLITDOWN BLANKREST ;
: RETRN       INSERTING? IF SPLITLINE THEN FLUSHLEFT NEXTLINE ;
: RETURN      Y @ 15 < IF RETRN THEN ;

( Editor Wipe Block ) \ simplified by BFox
HEX
: >UPPER  ( c -- c')  5F AND ;
DECIMAL
: PROMPT      0 19 AT-XY ;
: MSG         PROMPT ." Are you sure? (Y/N) " ;
: CLRMSG      PROMPT  WIDTH SPACES ;
: NO?         MSG KEY >UPPER CLRMSG [CHAR] Y <> ;
: ?CONFIRM    NO? IF R> DROP THEN ;
: WIPE        ?CONFIRM SCR @ BLOCK  1024 BLANKS UPDATE 0 X ! 0 Y ! ;

( Editor Commands: backspace, delete, et. al. )
: $$i04       DROP DELETE ;                 \ ^D
: $$i03       DROP DELETE ;                 \ PC delete key
: $$i08       DROP BACKSPACE ;              \ Backspace
\ : $$i7F       DROP BACKSPACE ;             \ DEL -- for Unix
: $$i0D       DROP RETURN ;                 \ Enter
: $$c5A       DROP WIPE ;                   \ Z
: $$c6F       DROP OPENDOWN DOWN $$c49 ;    \ o
: $$c4F       DROP OPENDOWN ;               \ O
: $$i15       DROP X OFF  Y OFF ;           \ "HOME" key INSERT mode
: $$c15       $$i15 ;

HEX
  0F CONSTANT $0F
  F0 CONSTANT $F0

: KEYBOARD    RKEY 7F AND ;  \ for TI-99 we need to mask upper bit
DECIMAL
: CMD?        MODE @ 'c = ;
: INS?        MODE @ 'i =   MODE @ [CHAR] r =  OR ;
: MODE!       INS? 'i AND CMD? 'c AND OR  CMDNAME 3 + C! ;
: >HEX        DUP 9 > IF 7 + THEN [CHAR] 0 + ;
: H!          DUP $F0 AND  4 RSHIFT >HEX  CMDNAME 4 + C! ;
: L!          $0F AND >HEX CMDNAME 5 + C! ;
: NAME!       MODE! H! L! ;
: NOMAPPING   DROP ['] HONK CMD? AND   ['] CHR INS? AND  OR ;
\ : .CMDNAME    68 0 AT-XY CMDNAME COUNT TYPE ; \ debugging
: HANDLERWORD
  NAME! CMDNAME ( .CMDNAME)
  FIND 0= IF NOMAPPING THEN ;
: HANDLER  DUP HANDLERWORD EXECUTE ;
: EDITOR  'c MODE !
           BEGIN  KEYBOARD HANDLER SCREEN ?BREAK  AGAIN ;

: VIBE    ( n -- ) DECIMAL SCR ! PAGE SCREEN EDITOR   ;

\ VI command additions
: VI  ( <path>)
      BL PARSE-WORD DUP 0>
      IF  OPEN-BLOCKS SCR OFF  THEN SCR @ VIBE ;

: LIST    ( n -- ) SCR ! PAGE SCREEN 50 18 AT-XY ;
: ?BREAK  ?TERMINAL ABORT" *BREAK*" ;
: INDEX   ( from to -- )
  1+ SWAP ?DO  CR I 4 .R 2 SPACES I BLOCK 64 TYPE ?BREAK  LOOP ;

\ VI like command interpreter is handled by Forth interpreter
: :X    ." Saving... " FLUSH ;
: :WQ   :X  ." Removing VIBE" /VIBE CR ;

SCR OFF
80COLS
HERE SWAP - DECIMAL . .( bytes)

 

 

  • Like 1

Share this post


Link to post
Share on other sites
8 hours ago, TheBF said:

One of the interesting things in this code, that I have never done, is just drop an item off the return stack to escape from a part of the program. :) 

See the definition for ?CONFIRM. 

 

There are one or two other words in fbForth 2.0 that use that device, but the following definition of “<null>” is from figForth and is how INTERPRET (an infinite loop) is exited at the end of the TIB or a disk block:

\   The name of this word is actually a true null, i.e., ASCII 0
: <null>   ( --- )   \ <null> = 0
   BLK @ IF
      ?EXEC
   THEN
   R> DROP
;  IMMEDIATE

 

...lee

  • Like 2

Share this post


Link to post
Share on other sites

A Different (Better?) Case Statement

 

I am going over ED99 code which has a big (inefficient) Eaker case statement in it for the key handler.

HEX
: KEYHANDLER ( char -- ) \ TI-99 BASIC key codes used
      CASE
         01 OF  +TAB              ENDOF  \ TAB
         02 OF  PGDN              ENDOF  \ FCTN 6
         03 OF  DEL-CHAR          ENDOF  \ PC Delete / FCTN 1
         04 OF  TOGGLE            ENDOF  \ PC Insert / FCTN 2
         06 OF  NEW-LINE          ENDOF  \ FCTN 8
         07 OF  DEL-LINE          ENDOF  \ FCTN 3
         08 OF  LEFT              ENDOF  \ FCTN S
         09 OF  RIGHT             ENDOF  \ FCTN D
         0A OF  CURSDWN           ENDOF  \ FCTN X
         0B OF  CURSUP            ENDOF  \ FCNT E
         0C OF  PGUP              ENDOF  \ FCTN 4
         0D OF  ENTER             ENDOF  \ ENTER
         0F OF  ESCAPE            ENDOF  \ Esc
         81 OF  COPYALL           ENDOF  \ ^A
         83 OF  COPY-LINE         ENDOF  \ ^C
         84 OF  TOEND             ENDOF  \ ^D
         86 OF  LASTSRCH @ LOCATE ENDOF  \ ^F
         90 OF  APPENDALL         ENDOF  \ ^P
         93 OF  BSPACE            ENDOF  \ ^backspace
         95 OF  TOSTART           ENDOF  \ ^U / PC Home
         96 OF  PASTE             ENDOF  \ ^V
         99 OF  CUT               ENDOF  \ ^Y
         9B OF   1 +FILE          ENDOF  \ ^>
         B7 OF  -TAB              ENDOF  \ ^TAB
         80 OF  -1 +FILE          ENDOF  \ ^<
                HONK
      ENDCASE
      RKEY? DROP   \ clear any accidental keys
;

I had played around with something simpler and it seems to work just as well and saves over 100 bytes in the project.

And it is faster because it doesn't have to go through the whole chain to get out.  The BREAK; word use EXIT which is like an R> DROP  so it jumps out of the routine right away when a match is detected


: CASE:  ( -- )
          POSTPONE OVER   POSTPONE =
          POSTPONE IF POSTPONE DROP   ; IMMEDIATE

: BREAK;    POSTPONE EXIT POSTPONE THEN ; IMMEDIATE

 

The revised code version is very little different but the repeating key is faster now when cursoring around because of the faster CASE:

HEX
: KEYHANDLER ( char -- ) \ TI-99 BASIC key codes used
         01 CASE:  +TAB              BREAK;  \ TAB
         02 CASE:  PGDN              BREAK;  \ FCTN 6
         03 CASE:  DEL-CHAR          BREAK;  \ PC Delete / FCTN 1
         04 CASE:  TOGGLE            BREAK;  \ PC Insert / FCTN 2
         06 CASE:  NEW-LINE          BREAK;  \ FCTN 8
         07 CASE:  DEL-LINE          BREAK;  \ FCTN 3
         08 CASE:  LEFT              BREAK;  \ FCTN S
         09 CASE:  RIGHT             BREAK;  \ FCTN D
         0A CASE:  CURSDWN           BREAK;  \ FCTN X
         0B CASE:  CURSUP            BREAK;  \ FCNT E
         0C CASE:  PGUP              BREAK;  \ FCTN 4
         0D CASE:  ENTER             BREAK;  \ ENTER
         0F CASE:  ESCAPE            BREAK;  \ Esc
         81 CASE:  COPYALL           BREAK;  \ ^A
         83 CASE:  COPY-LINE         BREAK;  \ ^C
         84 CASE:  TOEND             BREAK;  \ ^D
         86 CASE:  LASTSRCH @ LOCATE BREAK;  \ ^F
         90 CASE:  APPENDALL         BREAK;  \ ^P
         93 CASE:  BSPACE            BREAK;  \ ^backspace
         95 CASE:  TOSTART           BREAK;  \ ^U / PC Home
         96 CASE:  PASTE             BREAK;  \ ^V
         99 CASE:  CUT               BREAK;  \ ^Y
         9B CASE:   1 +FILE          BREAK;  \ ^>
         B7 CASE:  -TAB              BREAK;  \ ^TAB
         80 CASE:  -1 +FILE          BREAK;  \ ^<
         HONK
         RKEY? DROP   \ clear any accidental keys
;

 

 

 

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...

  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...