Noodlings of a Forth beginner

[ekipan]

As requested, here's my compare from #520. See the standard.

: memcmp ( a1 a2 n -- diff )
0 ?do over c@ over c@ - ?dup
if  nip nip unloop exit  then
swap 1+ swap 1+ loop  2drop 0 ;

: strcmp ( a1 n1 a2 n2 -- diff )
rot swap 2dup - >r min memcmp r>
over if drop else nip then ;

: signum ( n -- -1/0/1 )
dup 0 > if drop 1 else 0< then ;

: compare  strcmp signum ;

And tests:

: assert  0= abort" fail" '.' emit ;
: abc  s" abc" drop ;
: abd  s" abd" drop ;
abc 0 abd 0 compare 0= assert
abc 3 abc 3 compare 0= assert
abc 2 abd 2 compare 0= assert
abc 3 abd 2 compare 1 = assert
abc 3 abd 3 compare -1 = assert

For anyone interested. Probably not suitable for inclusion in durexForth as-is.

Not sure if this should be added to #428? Probably relevant at least.

[jkotlinski]

Looks nice and tidy!

[ekipan]

Rather than spam topics, I'll post my noodlings here.

Here's a Game of Life I ported to durex and just about noodled into paste:

1
\ conway's game of life.
\ for durexforth on the c64.
\ also tested with gforth.

marker ---life---
( see line 1 ) value tests
$ffff 0< constant 16bit
: \( tests if cr hex here u. latest
  u. decimal depth . postpone .(
  else '.' emit postpone ( then ;

\( syntax )

: ?\ ( 10) if postpone \ then ;
: \c 16bit 0= ?\ ; immediate \ c64
: \g 16bit    ?\ ; immediate \ gforth
: \t tests 0= ?\ ; immediate \ testing

: !! ( 10) 0= abort" fail" '.' emit ;
: d= ( 41) rot = -rot = and ;
: t= ( 61) >r rot >r d= r> r> = and ;
\ ( 41) means ( a b c d -- e )

\t 1 !!  2 3 + 5 = !! \ test assert
\t 1 2 1 2 d= !! 1 2 3 1 2 3 t= !!

\( mach )

\c -1 $d40e ! $80 $d412 c! \ init sid
\c : noise ( 01) $d41b c@  \ and read
\c   $d41b c@ 8 lshift or ;
\c : lcg ( 11) $7abd * $1b0f + ;
\c : v ( 00) ---life--- v ;

\g : lcg ( 11) $5851f42d4c957f2d *
\g   $14057b7ef767814f + ;
\g : noise ( 01) utime + here + lcg ;

\( pure )

: nop ( 00) ;
: pow2 ( 11) 1 swap lshift ;
: %max ( 11) -1 1 rshift 50 */ ;
: lif ( 11) if '#' else '.' then ;
: near ( 12) 2 + dup 3 - ;
: rule ( cur nbors -- next )
  2 - ?dup if nip 1 = 1 and then ;

\t 8 pow2 256 = !!
\t \c 25 %max $3fff = !!
\t 6 near 8 5 d= !! \ neighbor bounds
\t 1 2 rule 1 = !! 0 3 rule 1 = !!
\t 1 3 rule 1 = !! 1 5 rule 0 = !!

\( vals )

\ call a life cell a 'lif'.
\ x mod wid, y mod hgt would simulate
\ repeating grid, but 2div 1mul * 11
\ indexes per lif per gen, too much.

0 value wlog \ so restrict to pow2
0 value x&   \ dimens and precalc
0 value y&   \ bitmasks to mod with.
0 value bck  \ already drawn grid.
0 value frn  \ next grid to draw.
' nop value 'draw \ exec'd on store.
  ( lif x y -- lif x y )

: life! ( wlog hlog bck frn -- )
  to frn  to bck  2dup + pow2 frn
  swap 0 fill  pow2 1- to y&
  dup to wlog  pow2 1- to x& ;

\t : 84p!  3 2 pad pad 32 + life! ;
\t 84p! y& 3 = !! x& 7 = !! wlog 3 = !!

\( basic )

: cols ( 02) x& 1+ 0 ;
: rows ( 02) y& 1+ 0 ;
: flip ( 00) frn bck to frn to bck ;
: ?cr ( 10) if cr then ;
\g : ?home ( 10) ?cr ;
\c : ?home ( 10) if 19 emit then ;
: put ( lif x y -- lif x y )
  2dup or 0= ?home >r
  2dup 0= ?cr lif emit r> ; \ to 'draw

\t 84p! cols 8 0 d= !! rows 4 0 d= !!
\t bck pad = !! flip frn pad = !!
\t 1 2 3 put 1 2 3 t= !!

\( index )

: offs ( x y -- offset )
  >r x& and r> y& and wlog lshift or ;
: bck@ ( 21) offs bck + c@ ;
: frn! ( 30) 'draw execute
  offs frn + >r 1 and r> c! ;
\ 1 lif = 1 byte. i wrote bit-addr'ed
\ ver but it was slooow. todo asm?

\t 84p! 2 3 offs 26 = !!
\t    -5 11 offs 27 = !!
\t 1 2 3 frn! flip 2 3 bck@ 1 = !!

\( store )

: seeded ( density seed1 -- seed2 )
  rows do cols do lcg 2dup u>
  i j frn! loop loop nip ;
: pct ( 10) %max noise seeded drop ;
: step ( 00) flip rows do cols do
  i j bck@  0 j near do j near do
    i j bck@ + loop loop  over - rule
  i j frn! loop loop ;

\t 84p! 50 %max 42 seeded drop flip
\t \g 1 0 bck@ !! 0 0 bck@ 0= !!
\t \c 0 1 bck@ !! 1 1 bck@ 0= !!
\t step flip .( todo )

\( user )

: glider ( 00) 1 1 0 frn! 1 2 1 frn!
  1 0 2 frn! 1 1 2 frn! 1 2 2 frn! ;

create buf  9 1+ pow2 allot
: buf! ( 20) 2dup + pow2
  buf + buf life! ;
: small ( 00) 3 3 buf! ;
: wide ( 00) 5 3 buf! ;
: medium ( 00) 4 4 buf! ;
: big ( 00) 5 4 buf! ;

\g : kik ( 01) 0 ;
\c : kik ( 01) 0 key? if key + then ;
: go ( 00) begin step kik until ;
: gens ( 10) 0 ?do step kik
  if unloop exit then loop ;

\( intro )

\g (
: help ."
conway's game of life.

some words and phrases
  help [this text]  v [edit program]
  words [everything available]
  small  medium  big
  20 pct  glider  3 gens  go

examples to try
  small glider 5 gens
  big 33 pct go
" ;
\g )

\( ok. key?) \t key drop
small glider ' put to 'draw
\c help
\g 5 gens big 33 pct go

[Whammo]

I can't speak for Johan, but please spam topics.
I'm thinking we want code examples to be inspiring and found by others. 😃

[jkotlinski]

That's interesting code! Good stuff!

[ekipan]

It occurs to me that while I've certainly shown, I haven't done any telling.

It amuses me that github's syntax colorer ignores \c but treats \g as a comment, as durexForth would.

\( isn't a very good name. I originally had t( since its behavior depends on tests. I also considered something like section( but I prefer terseness.

I think the tests inline like this is great. Do you agree that a quick demo of each word makes it more readily apparent? Plus a quick gr0 F7 in v lets me compile without tests, halving the time.

The abbreviated arity comments are an unusual convention, sure, but I think 5 columns of source is a great compromise for the cramped screen of the C64. Knowing at least the arity of a word is much better than nothing, and I've tried to use actual stack effect comments where I think they'd be helpful.

Within offs do you think it's worth changing >r x& and r> into swap x& and swap? A glance at core.asm and the r-words certainly look more expensive than swap. I suppose I should at least give it a try.

The conditional comment around help is because gforth croaks when ." is multiline. I assume durexForth allows it intentionally. The standard doesn't seem to say either way.

I wish key? worked like kik. A little extra noise every time you want to have a keypress break from a loop. I suppose it's to allow for a keycode of 0 distinct from "no keys"?

[ekipan]

As you can see I prefer to indent the bodies of my words, which is a bit cumbersome to deal with in v. I almost want to feature request that J delete leading blanks in the next line. Not sure if worth.

[IanWitham]

It amuses me that the v shortcuts "change word" and "delete word" do literally that in forth 😆 (I'm easily amused)

[ekipan]

Continuing a Youtube comment thread. Ultimately the branch proves faster than futzing with computing addresses and the like.

hex
marker ---
: v    [ 0 lda,# tax, ] --- v ;
: rvs  c7 c! ;
: rndf d41b c@ 80 < ;
: tri  IF a9 9b ELSE df 97 THEN ;
: one  dup rvs rndf tri emit emit ;
: row  0= #40 0 DO 0= one LOOP ;
: go   0 BEGIN row AGAIN ;
-1 d40e  ! 80 d412 c! \ sid3 noise
0c d021 c! 15 d018 c! \ bg, gfx cset
go

Context from the video: this prints a pattern of triangles I think resembles a mountain range. It derives from 10print but I'd like to call it "Ian Mountains" after the original author.

[Whammo]

I like to nest my loops inside a begin key? until.

[ekipan]

I do as well, this is just following along with the style of the original.

In Vice F12 and PageUp are mapped to Restore, interrupting the program and my v word finishes cleaning up.

[IanWitham]

Apparently recurse doesn't get tailcall optimized, so this blows the rstack after about 3 screens.

Oops I didn't know that about recurse. Makes sense I guess.

[jkotlinski]

I think RECURSE ought be tail call optimized.

Right now, no IMMEDIATE words are subject to tail call optimization. Maybe that logic could be improved, so that tail call optimization happens if COMPILE, is the last executed word before ; .

[Whammo]

Nice, well-factored code.

[ekipan]

A couple noodles today, the first is definitely more practical.

: .name name>string type space ;
:noname more .name 1 ;
: words page literal dowords ;

:noname ( xt nt -- xt 1 )
  2dup swap execute
  IF more .name ELSE drop THEN 1 ;
: wordset ( xt -- ) ( xt: nt -- flag )
  page literal dowords drop ;

\ nametoken range predicates (v4)
: nt parse-name find-name ;
nt does> nt -branch nt :noname
: mine? literal < ;
: asm? literal literal within ;
: base? dup mine? swap asm? or 0= ;

: mywords ['] mine? wordset ;
: asmwords ['] asm? wordset ;
: basewords ['] base? wordset ;
hide mine? hide asm? hide base?

words is as in debug.fs, just with .name extracted. I've often wished for a mywords, and both basewords and asmwords fit on one screen, so maybe page and more should be omitted?

The second one started with the thought that the extra load/store pair in nip nip seems a bit wasteful, and then I got totally carried away 😆

: cmv, tuck + lda,x + sta,x ;
: mv,  2dup lsb cmv, msb cmv, ;
: nipdup   [ 1 0 mv, ] ;    \  ab-bb
: drpdup   [ 0 1 mv, ] ;    \  ab-aa
: >nipdup> [ 2 1 mv, ] ;    \ abc-bbc
: >drpdup> [ 1 2 mv, ] ;    \ abc-aac
: drpovr   [ 0 2 mv, ] ;    \ abc-aba
: >nip>tck [ 2 0 mv, ] ;    \ abc-cbc
: nipovr   nipdup drpovr ;  \ abc-aca
: >nip>    >nipdup> nipdup drop ;
: nipnip   >nip>tck 2drop ;
: ovrswp   [ dex, ] drpdup >drpdup> ;
: 2pck     [ dex, 0 3 mv, ] ;
: 3dup     2pck 2pck 2pck ;

I started to write crot, and rot, for optimized versions of swap rot and rot swap and such but it's definitely less trivial. Uses 3dup though!

[jkotlinski]

Do I understand it right... it classifies words based on their xt addresses? While not standard, that is pretty clever.

[ekipan]

wordset takes a filter predicate and only types words that result in true. You could do something silly like :noname drop rnd 0< ; wordset and get a random list of about half the words. The three predicates here compare nametoken addresses, mine? is words defined after :noname, asm? is words after does> up to -branch and base? is neither of those.

[ekipan]

I was thinking about transient compile-time-only constants and came up with this, haven't tested it yet:

latest
( ... main program ... )

here 4000 allot
: eq create , immediate 
 does> @ postpone literal ;
40 eq w  25 eq h  1000 eq wh
( ... more constants ... )
to here

( ... use w h wh ... )
to latest

[jkotlinski]

There is a setup for transient words already, check v for example.

header v
latest
...
define v ... ;
...
to latest

[ekipan]

That idea is to reclaim the 7 bytes for the create code. Or any other temporary words you only need while compiling. here is jumped forward to compile the temporary words and then back again. You'd need to make sure 4000 is enough space to compile the program before to latest deletes their names as well.

[jkotlinski]

OK, I see now.

[ekipan]

Although now that I think about it, the 3 bytes to JSR a value word is less than the 4 or 5 using eq words to generate literals, so this is a net loss if you use them enough times. I guess it could be useful for more complicated immediate syntax words.

[ekipan]

I wrote these fast, control-code-safe printing loops for my editor:

: 1em  [ w lda,(y)  $a1 cmp,#  10 bcs,
 $7f cmp,#  4 bcs,  bl cmp,#   2 bcs,
 '?' lda,#  iny,  $e716 jmp, ] ;
: 39em  [ lsb lda,x  w sta,
 msb lda,x  w 1+ sta,  0 ldy,# ]
 1em [ 39 cpy,#  -7 bne, ] ;
: lines  1- 0 ?DO 39em 1em 40 + LOOP
 39em drop ;

It's fun to use them to browse through memory:

: at-xy  xr ! yr ! $e50c sys ;
: bb dup 0 0 at-xy 25 lines
 999 + 0 22 at-xy ;
$2e2e 0 bb

The $2e2e on the bottom of the stack shows up as two dots near the beginning of zeropage. Press [down]bb[return] to continue paging forward.