FORTH & HP: where to start?

[floppy]

(05-08-2023 06:04 PM)mfleming Wrote:  1. Transfer finished files to the 71B using a PIL-Box.

2. Never tried this. The repo is six years old, so probably not even supported by the author anymore.

Do a search on "Forth IDE" and you'll find links to SwiftForth by Forth Inc, or VFX Forth for Windows by MPE (MicroProcessor Engineering Ltd). Both are freely downloadable but may time out and request a license.

Note that emacs has a Forth mode for files with the '.fs' extension. Has keyword coloring support but little else. Hit F10 to access menu bar. The command M-x shell will spawn a shell you can interact with to run gforth and feed it commands.

Old (ahem, 'seasoned') programmers like me would consider emacs a perfectly good IDE.

1. HowTo?
EMU71 & Forth, ILPER, Virtual drive on PC
HP71B w/ FORTH with pilbox (ilpilbox, ilper..) connection to that PC (one time I just uploaded so far JF Garnier "reversi" into the HP71B)

This file tt.fth

Code:

\
\ tt.pfe    Tetris for terminals, redone in ANSI-Forth.
\        Written 05Apr94 by Dirk Uwe Zoller,
\            e-mail duz@roxi.rz.fht-mannheim.de.
\        Look&feel stolen from Mike Taylor's "TETRIS FOR TERMINALS"
\
\        Please copy and share this program, modify it for your system
\        and improve it as you like. But don't remove this notice.
\
\        Thank you.
\


only forth also definitions
s" forget-tt" drop 1- find nip [if] forget-tt [then] marker forget-tt

vocabulary tetris  tetris also definitions

decimal

\ Variables, constants

bl bl 2constant empty        \ an empty position
variable wiping            \ if true: wipe brick, else draw brick
 2 constant col0        \ position of the pit
 0 constant row0

10 constant wide        \ size of pit in brick positions
20 constant deep

char J    value left-key        \ customize if you don't like them
char K    value rot-key
char L    value right-key
bl    value drop-key
char P    value pause-key
12    value refresh-key
char Q    value quit-key

variable score
variable pieces
variable levels
variable delay

variable brow            \ where the brick is
variable bcol


\ stupid random number generator

variable seed

: randomize    time&date + + + + + seed ! ;

: random    \ max --- n ; return random number < max
        seed @ 13 * [ hex ] 07FFF [ decimal ] and
        dup seed !  swap mod ;


\ Access pairs of characters in memory:

: 2c@        dup 1+ c@ swap c@ ;
: 2c!        dup >r c! r> 1+ c! ;

\ : d<>        d= not ;  \ kForth
  : d<>        d= 0=  ;  \ gForth: use 0= instead of NOT. 



\ Drawing primitives:

: 2emit        emit emit ;

: position    \ row col --- ; cursor to the position in the pit
        2* col0 + swap row0 + at-xy ;

: stone        \ c1 c2 --- ; draw or undraw these two characters
        wiping @ if  2drop 2 spaces  else  2emit  then ;


\ Define the pit where bricks fall into:

: def-pit    create    wide deep * 2* allot
        does>    rot wide * rot + 2* + ;

def-pit pit

: empty-pit    deep 0 do wide 0 do  empty j i pit 2c!
        loop loop ;


\ Displaying:

: draw-bottom    \ --- ; redraw the bottom of the pit
        deep -1 position
        [char] + dup stone
        wide 0 do  [char] = dup stone  loop
        [char] + dup stone ;

: draw-frame    \ --- ; draw the border of the pit
        deep 0 do
            i -1   position [char] | dup stone
            i wide position [char] | dup stone
        loop  draw-bottom ;

: bottom-msg    \ addr cnt --- ; output a message in the bottom of the pit
        deep over 2/ wide swap - 2/ position type ;

: draw-line    \ line ---
        dup 0 position  wide 0 do  dup i pit 2c@ 2emit  loop  drop ;

: draw-pit    \ --- ; draw the contents of the pit
        deep 0 do  i draw-line  loop ;

: show-key    \ char --- ; visualization of that character
        dup bl <
        if  [char] @ or  [char] ^ emit  emit  space
        else  [char] ` emit  emit  [char] ' emit
        then ;

: show-help    \ --- ; display some explanations
        30  1 at-xy ." ***** T E T R I S *****"
        30  2 at-xy ." ======================="
        30  4 at-xy ." Use keys:"
        32  5 at-xy left-key    show-key ."  Move left"
        32  6 at-xy rot-key    show-key ."  Rotate"
        32  7 at-xy right-key    show-key ."  Move right"
        32  8 at-xy drop-key    show-key ."  Drop"
        32  9 at-xy pause-key    show-key ."  Pause"
        32 10 at-xy refresh-key    show-key ."  Refresh"
        32 11 at-xy quit-key    show-key ."  Quit"
        32 13 at-xy ." -> "
        30 16 at-xy ." Score:"
        30 17 at-xy ." Pieces:"
        30 18 at-xy ." Levels:"
         0 22 at-xy ."  ==== This program was written 1994 in pure dpANS Forth by Dirk Uwe Zoller ===="
         0 23 at-xy ."  =================== Copy it, port it, play it, enjoy it! =====================" ;

: update-score    \ --- ; display current score
        38 16 at-xy score @ 3 .r
        38 17 at-xy pieces @ 3 .r
        38 18 at-xy levels @ 3 .r ;

: refresh    \ --- ; redraw everything on screen
        page draw-frame draw-pit show-help update-score ;


\ Define shapes of bricks:

: def-brick    create    4 0 do
                ' execute  0 do  dup i chars + c@ c,  loop drop
                refill drop
            loop
        does>    rot 4 * rot + 2* + ;

def-brick brick1    s"         "
            s" ######  "
            s"   ##    "
            s"         "

def-brick brick2    s"         "
            s" <><><><>"
            s"         "
            s"         "

def-brick brick3    s"         "
            s"   {}{}{}"
            s"   {}    "
            s"         "

def-brick brick4    s"         "
            s" ()()()  "
            s"     ()  "
            s"         "

def-brick brick5    s"         "
            s"   [][]  "
            s"   [][]  "
            s"         "

def-brick brick6    s"         "
            s" @@@@    "
            s"   @@@@  "
            s"         "

def-brick brick7    s"         "
            s"   %%%%  "
            s" %%%%    "
            s"         "

\ this brick is actually in use:

def-brick brick        s"         "
            s"         "
            s"         "
            s"         "

def-brick scratch    s"         "
            s"         "
            s"         "
            s"         "

create bricks    ' brick1 ,  ' brick2 ,  ' brick3 ,  ' brick4 ,
        ' brick5 ,  ' brick6 ,  ' brick7 ,

create brick-val 1 c, 2 c, 3 c, 3 c, 4 c, 5 c, 5 c,


: is-brick    \ brick --- ; activate a shape of brick
        >body ['] brick >body 32 cmove ;

: new-brick    \ --- ; select a new brick by random, count it
        1 pieces +!  7 random
        bricks over cells + @ is-brick
        brick-val swap chars + c@ score +! ;

: rotleft    4 0 do 4 0 do
            j i brick 2c@  3 i - j scratch 2c!
        loop loop
        ['] scratch is-brick ;

: rotright    4 0 do 4 0 do
            j i brick 2c@  i 3 j - scratch 2c!
        loop loop
        ['] scratch is-brick ;

: draw-brick    \ row col ---
        4 0 do 4 0 do
            j i brick 2c@  empty d<>
            if  over j + over i +  position
            j i brick 2c@  stone
            then
        loop loop  2drop ;

: show-brick    wiping off draw-brick ;
: hide-brick    wiping on  draw-brick ;

: put-brick    \ row col --- ; put the brick into the pit
        4 0 do 4 0 do
            j i brick 2c@  empty d<>
            if  over j +  over i +  pit
            j i brick 2c@  rot 2c!
            then
        loop loop  2drop ;

: remove-brick    \ row col --- ; remove the brick from that position
        4 0 do 4 0 do
            j i brick 2c@  empty d<>
            if  over j + over i + pit empty rot 2c!  then
        loop loop  2drop ;

: test-brick    \ row col --- flag ; could the brick be there?
        4 0 do 4 0 do
            j i brick 2c@ empty d<>
            if  over j +  over i +
            over dup 0< swap deep >= or
            over dup 0< swap wide >= or
            2swap pit 2c@  empty d<>
            or or if  unloop unloop 2drop false  exit  then
            then
        loop loop  2drop true ;

: move-brick    \ rows cols --- flag ; try to move the brick
        brow @ bcol @ remove-brick
        swap brow @ + swap bcol @ + 2dup test-brick
        if  brow @ bcol @ hide-brick
            2dup bcol ! brow !  2dup show-brick put-brick  true
        else  2drop brow @ bcol @ put-brick  false
        then ;

: rotate-brick    \ flag --- flag ; left/right, success
        brow @ bcol @ remove-brick
        dup if  rotright  else  rotleft  then
        brow @ bcol @ test-brick
        over if  rotleft  else  rotright  then
        if  brow @ bcol @ hide-brick
            if  rotright  else  rotleft  then
            brow @ bcol @ put-brick
            brow @ bcol @ show-brick  true
        else  drop false  then ;

: insert-brick    \ row col --- flag ; introduce a new brick
        2dup test-brick
        if  2dup bcol ! brow !
            2dup put-brick  draw-brick  true
        else  false  then ;

: drop-brick    \ --- ; move brick down fast
        begin  1 0 move-brick 0=  until ;

: move-line    \ from to ---
        over 0 pit  over 0 pit  wide 2*  cmove  draw-line
        dup 0 pit  wide 2*  blank  draw-line ;

: line-full    \ line-no --- flag
        true  wide 0
        do  over i pit 2c@ empty d=
            if  drop false  leave  then
        loop nip ;

: remove-lines    \ ---
        deep deep
        begin
            swap
            begin  1- dup 0< if  2drop exit  then  dup line-full
            while  1 levels +!  10 score +!  repeat
            swap 1-
            2dup <> if  2dup move-line  then
        again ;

: to-upper    \ char --- char ; convert to upper case
        dup [char] a >= over [char] z <= and if  bl -  then ;

: interaction    \ --- flag
        case  key to-upper
            left-key    of  0 -1 move-brick drop  endof
            right-key    of  0  1 move-brick drop  endof
            rot-key    of  0 rotate-brick drop  endof
            drop-key    of  drop-brick  endof
            pause-key    of  S"  paused " bottom-msg  key drop
                    draw-bottom  endof
            refresh-key    of  refresh  endof
            quit-key    of  false exit  endof
        endcase  true ;

: initialize    \ --- ; prepare for playing
        randomize empty-pit refresh
        0 score !  0 pieces !  0 levels !  100 delay ! ;

: adjust-delay    \ --- ; make it faster with increasing score
        levels @
        dup  50 < if  100 over -  else
        dup 100 < if   62 over 4 / -  else
        dup 500 < if   31 over 16 / -  else  0  then then then
        delay !  drop ;

: play-game    \ --- ; play one tetris game
        begin
            new-brick
            -1 3 insert-brick
        while
            begin  4 0
            do  35 13 at-xy
                delay @ ms key?
                if  interaction 0=
                if  unloop exit  then
                then
            loop
            1 0 move-brick  0=
            until
            remove-lines
            update-score
            adjust-delay
        repeat ;

forth definitions

: tt        \ --- ; play the tetris game
        initialize
        s"  Press any key " bottom-msg key drop draw-bottom
        begin
            play-game
            s"  Again? " bottom-msg key to-upper [char] Y =
        while  initialize  repeat
        0 23 at-xy cr ;

only forth also definitions

2. emacs looks good. I keep it.