A Little Forth, A Little Evolution

With a handful of Forth examples implemented, I wanted to try my hand at a slightly beefier challenge. So I busted out the Dawkins' Weasel example, and went to work.

Recall that Dawkins' Weasel is a programming exercise that demonstrates a core concept of evolution; mainly that random chance can lead to a non-random seeming result. The exercise shows how you can go from gibberish text to a meaningful statement via random mutation.

From a programming perspective, the challenge requires little more than basic array handling and random number generation. Luckily, Gforth provides both of these.

While I'm still wrapping my head around Forth, I was pleased to see that my final 'word' was deliciously simple:

: bang! ( -- )
 make-tick
 begin
  tick ..tick
  keep-ticking? while
 repeat ; 

It boggles my mind how Forth effectively doesn't have, nor need, a string (or even array) type. Simply storing characters in a raw block of memory works surprisingly well. I haven't done anything like this since I working with C pointers, and that was considered risky business. But in Forth, it's just business as usual.

I also found that my initial style of creating new instances of strings and workspaces¹ for every generation caused me to run out of memory (technically I was using alot. and I hit a stack overflow). I ended up rewriting the program to overwrite memory. While this triggers all my functional programming alarm bells, it does result in a program that uses very little memory. I suppose I could have found a middle ground and used immutable structures with either garbage collection or explicitly freeing memory, that seemed like more hassle than it was worth.

From a performance perspective, the program is blazingly fast. My scheme implementation took minutes to run on my cell phone, whereas the Forth implementation below runs nearly instantly on the same device. I'm printing out the generation as they tick by, so most of the time is probably spent refreshing the screen. Here's what it looks like:

Without a doubt, the Scheme program is slow because of the way I coded it, not because Gambit Scheme is some how fundamentally slow.

This all has me wondering: what's the practical implication of having a highly efficient, yet esoteric, programming option on Android? I can't imagine ever implementing production code using Forth on Android, but maybe I should be. For the right app, it just make work.

Finally here's two Gforth app tips: (1) the up and down arrows will take you backwards and forwards in the history, and (2) there's tab-completion on words! Try it to see how well it works.

¹A workspace is defined as a collection of strings that start from the same source, but are mutated. Every tick creates a new workspace, mutates it, and then selects the best scoring entry.

---

require random.fs

: 3dup ( x y z -- x y z x y z )
 2 pick 2 pick 2 pick ;
 
: between? { x lower upper -- bool }
 x lower >= and
 x upper <=  ;

: rand-between { lower upper -- n }
 upper lower -
 random lower + ;

: rand-char ( -- c )
 0 27 rand-between
 dup 26 = IF
  drop bl
 else
  [char] A + 
 endif ;
 
: rand-fill { addr length -- }
 length 0
 u+do
  rand-char addr i + c!
 loop  ;
 
: rand-string { length -- addr length }
 here length chars allot
 dup
 length rand-fill
 length ;

: rand-bool { percent-true -- n }
 100 random
 0 percent-true between? ;

: clone-string { addr length -- addr }
 here length chars allot { new-addr }
 addr new-addr length cmove
 new-addr ;

: overwrite-string ( from to length -- to )
 cmove ;

\ -------------------------------------
s" METHINKS IT IS LIKE A WEASEL"
Constant GOAL-LENGTH

here GOAL-LENGTH chars allot
Constant GOAL-STRING

GOAL-STRING GOAL-LENGTH cmove

5 Constant MUTATE-PERCENT
GOAL-LENGTH Constant GOAL-SCORE

: make-attempt ( -- addr )
 GOAL-LENGTH rand-string drop ;
 
: clone-attempt ( addr -- new-addr )
 GOAL-LENGTH clone-string ;

: overwrite-attempt ( from to -- )
 GOAL-LENGTH overwrite-string ;
 
: mutate? ( -- yes-or-no )
 MUTATE-PERCENT rand-bool ;

: mutate-char ( addr -- )
 mutate? IF
  rand-char swap c!
 else
  drop
 endif ;
 
: mutate-attempt { addr -- }
 GOAL-LENGTH 0 u+do
   addr i + mutate-char
 loop ;
 
: spawn-attempt ( addr -- new-addr )
 clone-attempt dup mutate-attempt ;

: install-attempt { from to -- }
 from to overwrite-attempt
 to mutate-attempt ;
   
: score-attempt-char { addr index -- score }
 addr index + c@
 GOAL-STRING index + c@
 = if 1 else 0 endif ;

: score-attempt { addr -- score }
 0 GOAL-LENGTH 0 u+do
  addr i score-attempt-char +
 loop ;  

: attempt-winner { attempt1 attempt2 -- winner }
 attempt1 score-attempt
 attempt2 score-attempt
 > if attempt1 else attempt2 endif ;


: .attempt ( addr -- )
 dup score-attempt . ." : "
 GOAL-LENGTH type ;

100 Constant WORKSPACE-SIZE

: workspace-range ( ws-addr )
 dup WORKSPACE-SIZE cells + swap ;

: fill-workspace { ws-addr attempt-addr -- }
 ws-addr workspace-range u+do
  attempt-addr spawn-attempt i ! 
 cell +loop ;

: install-workspace { workspace attempt -- }
 workspace workspace-range u+do
  attempt i @ install-attempt
 cell +loop ;

: make-workspace { attempt -- }
 here WORKSPACE-SIZE cells allot
 dup attempt fill-workspace ;

: workspace-attempt ( ws-addr index -- attempt-addr )
  cells + @ ;
  
: workspace-winner { ws-addr -- attemp-addr }
 ws-addr 0 workspace-attempt
 WORKSPACE-SIZE 0 u+do
   ws-addr i workspace-attempt attempt-winner
  loop ;

: .workspace ( ws-addr -- )
 cr workspace-range u+do
  i @ .attempt cr
 cell +loop ;
 
 
: make-tick ( -- workspace generation attempt )
 make-attempt
 dup make-workspace
 swap 0 swap  ;
 
: tick { workspace generation attempt -- workspace gen+1 attempt }
 workspace
 generation 1+
 workspace attempt install-workspace
 workspace workspace-winner ;
 
: .tick ( workspace gen attempt )
 swap ." G:" . .attempt cr drop ;

: ..tick ( workspace gen attempt -- workspace gen attempt )
 3dup .tick ;

: keep-ticking? ( workspace gen attempt -- workspace gen attempt )
 dup score-attempt
 GOAL-SCORE <> ;
 
: bang! ( -- )
 make-tick
 begin
  tick ..tick
  keep-ticking? while
 repeat ;