apl-life-anno.fs

#! /usr/bin/gforth
		
		\ I love FORTH and hope to present reasons with this code.

		\ The original idea was to implement Conway's Game of Life as a one-liner in APL executed in FORTH.
		\ (APL is another weird-looking programming language). The goal is mostly reached, with few exceptions.
		\ Unary negation symbol ¯ not implemented. APL tokens must be whitespace-separated, as in FORTH.

		\ FORTH is a low-level language and has no type checking, structures, arrays, let alone higher-level 
		\ constructs. Instead, it provides a direct access to its interpreter and compiler. This comes to be
		\ an extremely powerful tool. It allows us to quickly jump from raw bytes into a world of a problem 
		\ domain. The code below contains an implementation of 
		\ - arrays
		\ - currying and closures
		\ - higher-order functions for collections
		\ - APL specific function application rules, such as pervasion
		\ - APL to FORTH translator (up to extend required to execute Conway's Game of Life)
		\ All of that is done in ~200 LOC and tooks < 2.5K words of memory.

		\ For these who had never met FORTH before, "word" in FORTH stays for function and "cell" for machine
		\ word. FORTH has no syntax restrictions: code is nothing but a stream of whitespace-separated words. 
		\ FORTH is interactive: the code below is not only a complete program but also a history of a
		\ development session.
		
		\ A coding style is affected by an intention to avoid stack manipulation words. Locals are mostly used 
		\ instead. Hope this might improve readability for people unfamiliar with FORTH.

		\ This code is written in gforth and contains Unicode symbols.

		\ References
		\ Conway's Game of Life https://en.wikipedia.org/wiki/Conway%27s_Game_of_Life
		\ Conway's Game of Life in APL in Ruby https://zverok.github.io/blog/2020-05-16-ruby-as-apl.html
		\ APL programming language https://en.wikipedia.org/wiki/APL_(programming_language)
		\ John Scholes' Conway's Game of Life in APL https://aplwiki.com/wiki/John_Scholes%27_Conway%27s_Game_of_Life
		\ online APL playground https://tryapl.org/
		\ FORTH programming language https://en.wikipedia.org/wiki/Forth_(programming_language)
		\ gforth docs https://www.complang.tuwien.ac.at/forth/gforth/Docs-html/

cr ." Available free space on the dictionary: " unused .   unused Constant unused0
cr ." Machine word size: " cell .

		\ 1. Arrays

		\ First we have to implement arrays. APL arrays are multi-dimensional and support nesting which is an 
		\ unrelated concept (a scalar is a 0-dimensional array, a vector is 1-dimensional, and matrix is 
		\ 2-dimensional, and a vector of vectors is not a matrix).

		\ The main idea of the implementation provided below is the fact that array's shape is itself an array,
		\ so any array can be represented as a reference to another array and a reference to raw data. 
		\ The FORTH word for dereferencing is "@" and for incrementing a pointer by one machine word is "cell+".

		\ Hereafter non-indented and single-idented lines contain the main program, while double-idented lines 
		\ contain examples and tests explaining what's going on, and these can be omitted. We will write code 
		\ in tiny steps and test every line just next to it. Sometimes we will first try things in interpreter 
		\ mode and then wrap a code in a word definition.

: shape   @ ;
: data   cell+ @ ;
: first   data @ ;

		\ We have no function for array creation right now, but as the whole thing is a matter of convention, 
		\ we can create the first array manually. Anywhere in a memory, suppose at address PTR, we will put a 
		\ triplet [PTR; PTR+2; 1], and according to the definition above (the words "shape", "data" and 
		\ "first"), this triplet can be understood as a 1-dimensional array with a single element, the 1.
		\ A triplet [1; PTR; PTR-1] would also do.

		\ In the line below, there are "Create", "here", and "," some of a most frequently used FORTH words. 
		\ There is a memory area called Dictionary hosting FORTH words and other program data. The Dictionary 
		\ is organized as a stack, so is filled continuously and incrementally. "here" is a pointer to free 
		\ space on top of the Dictionary. "," (comma) writes a machine word from the data stack to the 
		\ Dictionary and increments value of "here". "Create" introduces a new word (whatever is to the right 
		\ of it) whose meaning is the value of "here" at the moment of the definition).

		\ So the line below states the following:
		\ Create [1]		let the current value of "here" be called [1].
		\ here			put the value of "here" on the stack.
		\ ,			write the value from the stack to "here"; increment "here".
		\ here			put the value of "here" on the stack (now "here" is [1] + 1 machine word).
		\ cell+			increment the value on the stack by 1 machine word.
		\ ,			write the value from the stack to "here"; increment "here".
		\ 1			put 1 on the stack.
		\ ,			write the value from the stack to "here".
		\ Thus we have created the [PTR; PTR+2; 1] triplet and assign it a name, [1].

Create [1]  here ,  here cell+ ,  1 ,
		\ We can immediately examine this array with our accessor words:
		cr [1] .				\ PTR (some integer value of a pointer)
		cr [1] shape .				\ PTR (shape of [1] is [1])
		cr [1] data .				\ PTR+2
		cr [1] first .				\ 1

		\ Note the [1] is the only array whose shape is equal to the array itself, so it's naturally the only 
		\ choice for an array to be created first.

		\ The very important property of an array is its size. It is not very clear what is "size" in a general 
		\ case but what we need first is a size of memory chunk to allocate for array items. A scalar requires 
		\ 1 memory cell, a vector as many cells as there are items, and a matrix a product of rows and columns. 
		\ Right now we have no functions to iterate over shape, so let's define "size" for the simplest case of 
		\ 1-dimensional arrays, like this:
		: size   shape first ;

		\ FORTH allows us to redefine any word, and a new behavior hides an old one. But a words already 
		\ compiled still refer to the old implementation. In case we want not to hide but retroactively change 
		\ the meaning of a word, we have to declare at as "deferred", i.e. linked dynamically.

		\ The definition of deferred "size" looks like this:
defer size
:noname   shape first ;
is size

		\ Here is a word to create new arrays at run-time:
: array  { data shape -- a }  here  shape , data , ;
		\ Without locals, this could be written as:
		: array  ( data shape -- a )  here -rot , , ;
		\ Which is significantly shorter but not so explanatory.

		\ We can try it with following line:
here 0 ,  [1] array  Constant [0]
		\ Here we have first allocated a single cell of memory and saved 0 here (with a phrase "here 0 ,", 
		\ which is readable as well as plain English); then we've provided the array shape, [1]; then called 
		\ the constructor "array" and assigned a name "[0]". It is a one-dimensional array containing a single 
		\ value, 0.
		cr [0] .				\ some pointer
		cr [0] shape .				\ PTR (the pointer to [1])
		cr [0] first .				\ 0
		cr [0] size .				\ 1

		\ An empty array is even simplier, as it does not need allocated data so we can use 0 in place of data 
		\ pointer:
		0 [0] array  Constant []
		cr [] .					\ pointer to []
		cr [] shape .				\ pointer to [0]
		cr [] size .				\ 0
		\ But it is more convenient to reuse the data pointer of [1], so our (still incomplete) definition 
		\ of "size" will work properly:
here 1 ,  [0] array  Constant []
		cr [] first .				\ 1

 		\ Let's define some more convenient constructors.
		\ Scalar is a zero-dimensional array (i.e., its shape is an empty vector):
: scalar  { u -- a }  here u ,  []  array ;

		\ The following line creates a scalar with value "101":
		101 scalar  Constant tmp
		cr tmp shape .				\ pointer to []
		cr tmp first .				\ 101
		cr tmp size .				\ 1

		\ Vector is a one-dimensional array. Its shape is a single-element vector. A vector constructor accepts
		\ a pointer to a pre-allocated data area and a size. It creates a shape vector ("here u , [1] array") 
		\ and then calls "array":
: vector  { data u -- a }  data  here u ,  [1] array  array ;

		\ To see it working, we have to manually allocate data here and store some values:
		here  103 , 107 ,
		\ And then we call a vector constructor (the value of "here" is already on the stack):
		2 vector  Constant tmp
		cr tmp size .				\ 2
		cr tmp first .				\ 103
		cr tmp data cell+ @ .			\ 107

		\ Here is an utility word that allocates a data area for a given number of elements:
: new  { u -- data u }  here  u cells allot  u ;

		\ Examine it like this:
		5 new vector  Constant tmp
		cr tmp size .				\ 5
		cr tmp first .				\ (some value from an unassigned memory cell)
		\ The vector we've just created is ready but not populated, we can assign values with common memory 
		\ accessing words:
		109 tmp data !
		cr tmp first .				\ 109

		\ Now we can define how to iterate over items, that is, to implement the "for each" loop.

		\ There is several loop words in FORTH, such as "DO", "?DO", "LOOP", "+LOOP", and "I", which can be 
		\ used like this:
		cr 5 0 [DO] [i] . [LOOP]		\ 0 1 2 3 4
		cr 5 0 [?DO] [i] . 2 [+LOOP]		\ 0 2 4

		\ To iterate over our array items, we need to loop from data start to data end in one-machine-word 
		\ steps. Here is a word to get a data end:
: end  { a -- addr }  a data  a size cells + ;
		\ And here is a word to put on the stack both data end and data start, in this order:
: (for)  { a -- and data }  a end  a data ;
		\ Test it by creating two-element vector and definiting a printing function:
		here 113 , 127 , 2 vector  Constant tmp
		: fn   (for) ?DO i ? cell +LOOP ;
		cr tmp fn				\ 113 127

		\ This is not very readable, and is error-prone since we can easily forget the word "cell" before 
		\ "+LOOP", which would break the pointer arithmetic. But we can easily enhance the language syntax:
: FOR   POSTPONE (for) POSTPONE ?DO ; immediate
: EACH   POSTPONE cell POSTPONE +LOOP ; immediate

		\ And use it like this:
: .a   FOR i ? EACH ;

		cr tmp .a				\ 113 127
		
		\ What's going on here needs a more elaborate explanation. "immediate" words are words executed at 
		\ compile-time (contrary to words executed at run-time). The word "POSTPONE" says the following word 
		\ (e.g., "(for)") will not be normally executed when "FOR" executed but instead will be compiled into 
		\ the body of a word being defined during execution of "FOR", which is in our case ".a". So when 
		\ compiled the code of ".a" is exactly equivalent to this of "print". This can be seen with decompiler:
		cr see fn				\ : fn    (some code follows)
		cr see .a				\ : .a    (the same code)

		\ You may see this as a sort of macro. With two lines of code, we've extended language syntax with
		\ the new construction, "for each" loop working with our arrays. You may want to implement it in your 
		\ language.

		\ Here is a word to populate an existing array from the stack:
: !a  ( an .. a1 array -- )  FOR i ! EACH ;

		\ And a word to create an array and populate it from the stack:
: >a  ( an .. a1 u -- a )  new vector { a }  a !a  a ;

		4 3 2 1  4 >a  Constant 1_2_3_4
		cr 1_2_3_4 .a				\ 1 2 3 4
		\ Note the reversed element order.

		\ A word to create an array and fill it with single value:
: fill  { w u -- a }  u new vector { a }  a FOR w i ! EACH  a ;
		cr 5  4 fill .a				\ 5 5 5 5

		\ Some not-that-pretty-printer supporting recursive/nested arrays:
: number?   abs 32767 <= ;
: array?   number? 0= ;
: print  { a -- }
	a array? IF ." [" a shape .a ." | " a FOR i @ recurse EACH ." ] " ELSE a . THEN ;
		\ Here I assume our arrays will host only short ints and pointers to other arrays, and its ranges
		\ do not overlap.

		cr 131 print				\ 131
		cr 131 scalar print			\ [| 131]
		cr 131 1 >a print			\ [1| 131]
		cr 1_2_3_4 print			\ [4| 1 2 3 4]
		cr 4 3 2 2 >a 1 3 >a print		\ [3| 1 [2| 2 3] 4]

		\ Following functions perform partitioning/slicing, we will need it later.
		\ Note the data is not copied here, but pointers only.
: before  { a n -- a' }  a data  n vector ;
: after  { a n -- a' }  a data n cells +  a size n -  vector ;
: slice  { a from count -- a' }  a from after  count before ;
		cr 1_2_3_4  2 before .a			\ 1 2
		cr 1_2_3_4  2 after .a			\ 3 4
		cr 1_2_3_4  1 2 slice .a		\ 2 3




		\ 2. Currying and closures

		\ There is nothing related to functional programming in FORTH. But as we know the FP is a powerful 
		\ paradigm we will implement some of its features here. Namely: currying, runtime function composition,
		\ and closures.

		\ Currying is implemented by binding together a function and its last argument.

		\ Here is how such binding looks like if done at compile time:
		: 10+ 10 + ;
		cr see 10+				\ : 10+ 10 + ;
		cr 9 10+ .				\ 19
		\ Basically, this is nothing but creating a new short function. The main point is that we want this 
		\ to happens at run-time, not at compile-time.

		\ First, our run-time-created function should be unnamed, like this:
		:noname 10 + ;
		cr xt-see				\ noname: 10 + ;

		\ Second, the argument value and the function value has to be provided at run-time. Here we will 
		\ rewrite the previous definition, separating run-time-provided values from the rest of the function 
		\ body:
		:noname  [ 10 ] literal [ ' + compile, ] ;
		cr xt-see				\ noname: 10 + ;
		\ The result is equivalent but the source looks differently. The words [ and ] switch the FORTH state 
		\ from compilation to interpretation and back. So the phrase above could be read like:
		\ :noname		start the definition of a new unnamed word
		\ [ 10 ]		at compile-time, put 10 on the stack
		\ literal		what is on the stack at compile-time gets compiled into
		\			the unnamed word we are currently compiling
		\ [ ' +			at compile-time, put the function + on the stack
		\ compile,		at compile-time, compile what is on the stack
		\			into the unnamed word we are currenly compiling
		\ ]			...go back to compilation state
		\ ;			end of the word
		\ As you can see with xt-see, this word is decompiled extacly as the previous one.

		\ The word "'" (tick) is one of few so-called parsing words. It takes an input not from the data stack
		\ but from the input stream. In the code above, the tick consumes the following "+" from the input 
		\ stream, so instead of execute "+", the interpreter put reference to "+" on the stack.

		\ Values 10 and ' + could be moved out to some variables:
		10 Value w
		' + Value xt
		:noname  [ w ] literal [ xt compile, ] ;
		cr xt-see				\ noname: 10 +

		\ And the last step is to make it all to be performed at run-time. Keep in mind the run-time 
		\ of "curry" is a compile-time of its derived unnamed word.
		: curry { w xt -- xt' }
			:noname  w  POSTPONE literal  xt compile,  POSTPONE ;
		;
		\ What was previously done at compile-time ("w", "xt compile,") now is done at run-time, so not 
		\ enclosed in [ ]. What must be done at run-time of the derived unnamed word is POSTPONEd.

		w xt curry
		cr xt-see				\ noname: 10 +
		11 ' - curry
		cr xt-see				\ noname: 11 -
		\ It works!
		\ As our definition of "curry" is somewhat long, we will split into 3 words:
: literal,  ( w -- )  POSTPONE literal ;
: compile-curried,  { w xt -- }  w literal,  xt compile, ;
: curry  { w xt -- xt' }  :noname  w xt compile-curried,  POSTPONE ; ;

		\ In the same way we implement a function composition:
: compose  { xt2 xt1 -- xt' }  :noname  xt1 compile, xt2 compile,  POSTPONE ; ;
		\ Test it by composing the increment `1+` with the output '.'.
		cr ' . ' 1+ compose Constant tmp
		cr tmp xt-see				\ noname : 1+ . ;
		cr 211 tmp execute			\ 212

		\ In case we need to curry not the last but second-from-last argument, we can flip function arguments
		\ by composing it with the word "swap", and then bind the last argument as before:
: flip  ( xt -- xt' )  ['] swap compose ;
		\ Let's check it with the assymetrical two-argument function "divide":
		\ Divide by 10:
		10 ' / curry Constant /10
		cr 30 /10 execute .			\ 3
		\ Divide 10 by:
		10 ' / flip curry Constant 10/
		cr 5 10/ execute .			\ 2

		\ Closures bind a function to a variable. As we don't use variables, we will use pointers, i.e. bind 
		\ function directly to a memory cell. A bound function is an unnamed function which first reads a value
		\ from the cell, then executes a body of the target function, then writes a value back into the cell.
: bind-addr  { addr xt -- xt' }
	:noname  
		addr ['] @ compile-curried,  xt compile,  addr ['] ! compile-curried,
	POSTPONE ; ;
: bind  { w xt -- xt' }  here w , xt bind-addr ;

		\ "bind-addr" binds function to a provided memory cell.
		\ "bind" allocates a memory cell and writes an initial value here, then bounds.

		\ In the example below, we create a cell with a value "223" in it, then bind a function "1+" to it.
		\ The new function, referenced by "xt", will increment the value in the cell every time it is called.
		Create tmp 223 ,
		tmp ' 1+ bind-addr  Constant xt
		cr tmp ?				\ 223
		cr xt execute tmp ?			\ 224
		cr xt execute tmp ?			\ 225

		\ Note: implemented this way, closures require a function to left on top of the stack a value 
		\ semantically equivalent to a value on top of the stack at function start, i.e. the last argument 
		\ value. In the example above, binding works as expected because "1+" has the required stack effect
		\ ( w -- w ). It will also work with "+":
		tmp ' + bind-addr  Constant xt
		cr 100 xt execute tmp ?			\ 325
		cr 200 xt execute tmp ?			\ 525

		\ Words which don't follow this pattern must be wrapped accordingly. The "." word which is ( w -- )
		\ need to be wrapped like this:
		: fn  ( w -- w )  dup . ;
		tmp ' fn bind-addr  Constant xt
		cr xt execute				\ 525
		\ -- end of note.




		\ 3. Higher-order collection functions

		\ Now let's implement collection functions such as map. We already have a way to iterate over 
		\ a collection (the for each loop), but this seems to be not enough, as some functions have to iterate
		\ over two or more collections simultaneously. We will implement another well-known solution called 
		\ an iterator. Actually, the iterator's functionaly overlaps with this of the for each loop, so we 
		\ would not need the for each if we have full-scale iterators. But we will implement only very basic 
		\ iterators without any range checkings, and rely on loops for a counting.
		
		\ A simple iterator is a pointer that increases its value every time it is read.

		\ The reading word is "@", the writing is "!", and the pointer increment is "cell+". Here we define 
		\ words for "read and increment pointer" and "write and increment pointer":
: !+  { n addr -- addr' }  n addr !  addr cell+ ;
: @+  { addr -- n addr' }  addr @  addr cell+ ;
		\ (By the way, it can be written much simpler without locals, but stack manipulation words make code 
		\ look somewhat creepy, or at least cryptic:
		: !+  tuck ! cell+ ;
		: @+  dup @ swap cell+ ;

		\ Try it with the following code. Here we allocate two memory cells with values 101 and 103 and create 
		\ a pointer "tmp" to the first. After the call to "107 tmp !+" the value 107 is written over the 101, 
		\ and the incremented value of the pointer is left on the stack. After the next call, "109 swap !+",
		\ the value 109 is written over the 103.
		Create tmp 101 , 103 ,
		cr tmp ?  tmp cell+ ?			\ 101 103
		cr tmp .				\ some ptr
		107 tmp !+
		cr dup .				\ ptr to next cell
		109 swap !+
		cr .					\ ptr to yet next cell
		cr tmp ?  tmp cell+ ?			\ 107 109

		\ The iterator is made of "!+" or "@+" bound with a pointer, and the initial pointer value is the data
		\ pointer of the target array:
		1_2_3_4 data ' @+ bind  Constant tmp
		cr tmp execute .			\ 1
		cr tmp execute .			\ 2
		cr tmp execute .			\ 3
: iterator  ( a -- xt' )  data  ['] @+ bind ;
: inserter  ( a -- xt' )  data  ['] !+ bind ;

		\ As we need something with counter to provide range checking, we'll wrap the for each loop into 
		\ a functional-style iteration: let the word "iter" accept a function and an array and apply 
		\ the function to every item:
: iter  { xt a -- }  a FOR i @ xt execute EACH ;
		
		cr ' .  1_2_3_4 iter			\ 1 2 3 4
		\ We could define a "clone" function like this:
		: clone  { a -- a' }
			a size new vector { a' }
			a' inserter
			a iter
			a' ;
		cr 1_2_3_4 clone .a			\ 1 2 3 4
		\ Since many of collection functions we need (map, zip, product...) follow the pattern 
		\ "create array - create inserter - do something - return newly created array", we will extract
		\ the logic into a word:
		: construct  { u -- a' xt }  u new vector { a' }  a'  a' inserter ;
		\ The sequence "{ a' } a' a'" looks especially silly, as it just duplicates a value on the stack, so
		\ with your permission I'm going to use one of stack manipulation words, "DUP":
: construct  ( u -- a' xt)  new vector dup inserter ;

		\ Finally, in the definition of the "clone" above, the resulting array is always a vector, while 
		\ the function input can have some other shape.
		\ The word to change a shape of an existing array is trivial:
		: shape!  ( shape a -- )  ! ;
		\ But it is more suitable for our needs to left the array on the stack:
		: shape!  { a shape -- a }  shape a !  a ;
		\ Or without locals:
: shape!  ( a shape -- a)  over ! ;
		\ The word to copy shape from one array to another can looks like this:
: shape-as  ( a other -- a )  shape shape! ;

		\ So there are some basic collection functions.
: map  { a xt -- a' }  a size construct  xt compose  a iter  a shape-as ;
: zip  { al ar xt -- a' }
	al size construct  xt compose  al iterator compose  ar iter  al shape-as ;
: inject  { a xt zero -- w }  here { accum } zero ,  accum xt bind-addr  a iter  accum @ ;
: fold  { a xt -- w }  a 1 after  xt  a first  inject ;
: contains  { a w -- f }  a  w ['] = curry  map  ['] or  false inject ;
		\ Any function could be tested immediately:
		cr 1_2_3_4  ' 1+ map .a			\ 2 3 4 5
		cr 1_2_3_4 1_2_3_4 ' + zip .a		\ 2 4 6 8
		cr 1_2_3_4 ' + 10 inject .		\ 20
		cr 1_2_3_4 ' + fold .			\ 10
		cr 1_2_3_4 2 contains .			\ -1
		cr 1_2_3_4 5 contains .			\ 0

		\ Now we can provide the correct implementation for "size". Note we use "inject" and not "fold" because
		\ a shape of a scalar is an empty vector but its size is defined as 1.
		cr 2 3 2 >a  ' * 1 inject .		\ 6
		
		\ Also, we have to protect it from infinite recursion on [1]:
:noname  { a -- u }  a [1] = IF 1 ELSE a shape  ['] *  1 inject THEN ;  is size

		\ Check it:
		cr [1] size .				\ 1
		cr 1_2_3_4 size .			\ 4
		6 5 4 3 2 1 6 >a   3 2 2 >a shape!  Constant _m2x3
		cr _m2x3 size .				\ 6
		cr [] size .				\ 0
		cr 1 [] array size .			\ 1
		\ Note items of nested arrays doesn't count, as expected:
		cr 1_2_3_4 1_2_3_4 2 >a size .		\ 2

		\ Some more collection functions, implemented just for purpose of Game of Life.

		\ "flat" accepts a homogeneous vector of vectors, and returns a new vector:
: flat  { a -- a' }  a ['] size map ['] + fold  construct  ['] iter flip curry  a iter ;
		cr 1_2_3_4 1_2_3_4 2 >a flat print	\ [8| 1 2 3 4 1 2 3 4]

		\ "product" accepts two vectors and returns a matrix:
: (product)  { w xt al -- }  w xt curry  al iter ;
: product  { al ar xt -- a' }
	al size ar size * construct
	xt compose  al  ['] (product) curry curry  ar iter
	al size ar size 2 >a shape! ;
		cr 1_2_3_4 20 10 2 >a ' + product print	\ [2 4| 11 12 13 14 21 22 23 24]
		cr 20 10 2 >a 1_2_3_4 ' + product print	\ [4 2| 11 21 12 22 13 23 14 24]

		\ "rotate" rotates element of a vector:
: rotate  { a offset -- a' }  offset a size mod { n }  a n before  a n after  2 >a  flat ;
		cr 1_2_3_4 1 rotate .a			\ 2 3 4 1
		cr 1_2_3_4 -1 rotate .a			\ 4 1 2 3

		\ "integers" is a constructor that creates a sequence from 0 to u-1:
: integers  { u -- a }  u construct { xt }  u 0 ?DO i xt execute LOOP ;
		cr 4 integers .a			\ 0 1 2 3
		
		\ "rows" accepts a matrix and returns a vector of vectors:
: second   data cell+ @ ;
: height  shape first ;
: width  shape second ;
: rows  { a -- a' }
	a height integers  a width ['] * curry map
	a  a width ['] slice curry  flip curry  map ;
		cr _m2x3 print				\ [2 3| 1 2 3 4 5 6]
		cr _m2x3 rows print			\ [2| [3| 1 2 3 ] [3| 4 5 6]]




		\ 4. APL specific functions

		\ Here we get closer to the APL world. In APL, the array is a basic object. Any numeric value is 
		\ a scalar an therefore an array (of rank 0). Every item of every array, unless it is a scalar 
		\ containing a numeric value, is also an array. This is not true in our model. Our arrays can contain 
		\ not only arrays (including scalars) but also naked numeric values, like this:
		cr 1_2_3_4 print			\ [4| 1 2 3 4]
		\ While the array-only model would represent the same value as follows:
		cr 1_2_3_4 ' scalar map print		\ [4| [| 1] [| 2] [| 3] [| 4]]

		\ Here we update some array functions to work properly with plain numbers.
: size  { a -- u }     a array? IF a size   ELSE 1  THEN ;
: shape  { a -- a' }   a array? IF a shape  ELSE [] THEN ;

		\ According to APL rules, we can wrap any array into a scalar, but a number wrapped in a scalar is
		\ equal to the number itself.
: wrap  { a -- a' }    a array? IF a scalar ELSE a  THEN ;
: unwrap  { a -- a' }  a array? IF a first  ELSE a  THEN ;

		\ Here are definitions for basic array properties "rank" and "depth":
: rank   shape shape first ;
: 'recurse   latestxt literal, ; immediate
: depth  { a -- a' }   a array? IF a 'recurse map ['] max 0 inject 1+ ELSE 0 THEN ;
: scalar?   rank 0= ;

		cr 1 wrap print				\ 1
		cr [1] wrap print			\ [| [1| 1]]
		cr 1 unwrap print			\ 1
		cr 1 scalar unwrap print		\ 1
		cr 1 rank .				\ 0
		cr [1] scalar rank .			\ 0
		cr [1] rank .				\ 1
		cr _m2x3 rank .				\ 2
	
		cr 1 depth .				\ 0
		cr [1] depth .				\ 1
		cr _m2x3 depth .			\ 1
		cr [1] scalar depth .			\ 2
		cr [1] scalar scalar depth .		\ 3

		\ Conversion from an arbitrary-shaped array into a 1-dimensional vector:
: ravel  { a -- a' }  a data  a size vector ;

		\ One of APL features important for our task is the pervasive function application. If there is 
		\ a function defined on scalars, such as +, it can be applied to arrays, and its behavior is
		\ to traverse thru array elements and apply to each.
		\ First, we implement the pervasive application of unary function:
: uperv  ( a xt -- a' )  over number? IF execute ELSE 'recurse curry map THEN ;
		
		cr 1 ' 1+ uperv print			\ 2
		cr [1] ' 1+ uperv print			\ [1| 2]
		cr 1_2_3_4 ' 1+ uperv print		\ [4| 2 3 4 5]
		4  3 2 2 >a  1 3 >a  Constant tmp
		cr tmp ' 1+ uperv print			\ [3| 2 [2| 3 4] 5]

		\ The binary pervasive application is a bit more complicated. It both arguments are arrays, 
		\ the function is applied to corresponding pairs (as "zip"). If one argument is an array and another 
		\ is a scalar, the scalar is "extended" as if it is an array of a required size. In the our case we 
		\ don't have to create a new array representing this "extended" scalar but will curry the function 
		\ with the scalar and then "map" over the array.

		\ The implementation going to take more than one word and contain a mutual recursion, so "defer":
defer perv

		\ If both arguments are numbers,
: both-numbers?  { al ar -- f }  al number? ar number? and ;
		\ then simply "execute", and this is our first runnable version of "perv":
		:noname  { al ar xt -- a' }
			al ar both-numbers? IF al ar xt execute EXIT THEN
			s" not implemented yet" exception throw ;
		is perv

		cr 1 2 ' + perv print			\ 3

		\ If both arguments can be iterated over,
: both-iterable?  { al ar -- f }  al array? ar array? and al rank ar rank = and ;
		\ then zip:
: pairwise  ( al ar xt -- a' )  ['] perv curry zip ;
		\ Update the definition of "perv" to test it:
		:noname  { al ar xt -- a' }
			al ar both-numbers? IF al ar xt execute EXIT THEN
			al ar both-iterable? IF al ar xt pairwise EXIT THEN
			s" not implemented yet" exception throw ;
		is perv

		cr 1_2_3_4 1_2_3_4 ' + perv print	\ [4| 2 4 6 8]

		\ If the right argument is a scalar and the left is iterable,
: left-iterable?  { al ar -- f }  al array? ar scalar? and ;
		\ then curry xt with the scalar and then map over the array:
: extend  { al ar xt -- a' }  al ar unwrap xt ['] perv curry curry map ;
		\ Update the "perv":
		:noname  { al ar xt -- a' }
			al ar both-numbers? IF al ar xt execute EXIT THEN
			al ar both-iterable? IF al ar xt pairwise EXIT THEN
			al ar left-iterable? IF al ar xt extend EXIT THEN
			s" not implemented yet" exception throw ;
		is perv
	
		cr 1_2_3_4 4 ' + perv print		\ [4| 5 6 7 8]
		\ Finally, if the left argument is a scalar and the right is iterable, just swap the arguments and flip
		\ the "xt", then fall to "extend" as above.

		\ The complete code follows:
:noname  { al ar xt -- a' }
	al ar both-numbers? IF al ar xt execute EXIT THEN
	al ar both-iterable? IF al ar xt pairwise EXIT THEN
	al ar left-iterable? 0= IF ar al xt flip ELSE al ar xt THEN extend ;
	is perv

		\ Examine its behavior:
		cr 1 2 ' + perv print			\ 3
		cr 1  1_2_3_4  ' + perv print		\ [4| 2 3 4 5]
		cr 1  1_2_3_4 wrap ' + perv print	\ [| [4| 2 3 4 5]]
		cr [1]  1_2_3_4 wrap ' + perv print	\ [1| [4| 2 3 4 5]]
		cr 2 1 2 >a  1_2_3_4 wrap ' + perv print		\ [2| [4| 2 3 4 5] [4| 3 4 5 6]]
		cr 1_2_3_4  1_2_3_4  ' + perv print			\ [4| 2 4 6 8]
		cr 1_2_3_4  1_2_3_4 wrap ' + perv print			\ [4| [4| 2 3 4 5] [4| 3 4 5 6] [4| 4 5 6 7] [4| 5 6 7 8]]
		cr [1] 2 ' + perv print			\ [1| 3]
		cr 2 [1] ' + perv print			\ [1| 3]
		cr [1] [1] ' + perv print		\ [1| 2]
		cr 2 1 2 >a  1 ' + perv print		\ [2| 2 3]
		cr 2 1 2 >a  4 3 2 >a  ' + perv print	\ [2| 4 6]
		cr 2 1 2 >a  4 3 2 >a wrap  ' + perv print		\ [2| [2| 4 5] [2| 5 6]]
		cr 2 1 2 >a wrap  4 3 2 >a wrap  ' + perv print		\ [| [2| 4 6]]
		cr 2 1 2 >a wrap  4 3 2 >a wrap wrap  ' + perv print	\ [| [2| [2| 4 5] [2| 5 6]]]
		cr 2 1 2 >a wrap  1 ' + perv print			\ [| [2| 2 3]]
		cr 2 1 2 >a wrap wrap  1 ' + perv print			\ [| [| [2| 2 3]]]
		cr 2 1 2 >a  4 3 2 >a wrap wrap  ' + perv print		\ [2| [| [2| 4 5]] [| [2| 5 6]]]
		\ and so on.

		\ Finally, to simplify calls, we can curry the last argument of "perv":
: perv-+   ['] + perv ;
		cr 1 2 perv-+ print			\ 3
		cr [1] [1] perv-+ print			\ [1| 2]

		\ Some other functions we need pervasive:
: perv-and   ['] and perv ;
: perv-or   ['] or perv ;
: perv-*   ['] * perv ;

		\ The test for equality returns 0|1 in APL but 0|-1 in FORTH, so we have to modify it first:
: apl-=   = 1 and ;
: perv-=   ['] apl-= perv ;

		\ Some more trivial APL array functions:
: hrotate  { a u -- a' }  a rows  u ['] rotate curry map  flat  a shape-as ;
: vrotate  { a u -- a' }  a rows  u rotate flat  a shape-as ;
: reduce  ( a xt -- a' )  fold wrap ;
: hreduce  { a xt -- a' }  a rows xt ['] reduce curry map ;
: vreduce  { a xt -- a' }  a rows xt fold ;
: vector?   rank 1 = ;
: hrotate  { a u -- a' }  a u  a vector? IF rotate ELSE hrotate THEN ;
: hreduce  { a xt -- a' }  a xt  a vector? IF reduce ELSE hreduce THEN ;

		\ The simplified version of the inner product:
: inner-product  { * + -- a' }  * zip + reduce ;

		\ The generic inner/outer product whose behavior depends on the value of a right-hand function:
: apl-product  { al * + ar -- }
	+ ['] noop = IF al ar * product ELSE al ar * + inner-product THEN ;

		cr _m2x3 ' perv-+ hreduce print		\ [2 |6 15 ]
		cr _m2x3 ' perv-+ vreduce print		\ [3 |5 7 9 ]
		2 1 2 >a Constant _v12
		4 3 2 >a Constant _v34
		cr _v12  ' perv-+  reduce print		\ 3
		cr _v12 _v34 ' perv-+ execute print	\ [2| 4 6 ]
		cr _v12 _v34  2 >a ' perv-+  reduce print	\ [| [2| 4 6 ] ]

		\ At this point we are very close to the Game of Life itself, let's prepare the grid and nice output:
0 0 0 0 0 0
0 0 1 0 0 0
0 0 0 1 0 0
0 1 1 1 0 0
0 0 0 0 0 0
0 0 0 0 0 0 36 >a Constant grid
6 6 2 >a  grid !
		\ This configuration is called a "glider".

: show  { a -- }
	a array? 0= IF a . EXIT THEN
	a scalar? IF a unwrap recurse EXIT THEN
	a vector? IF a FOR i @ recurse EACH EXIT THEN
	'recurse ['] cr compose  a rows iter ;



		\ 5. APL to FORTH translator

		\ Our final part is a translator for the APL syntax. We want to convert an input string
		\ "↑ 1 ⍵ ∨ . ∧ 3 4 = + / , -1 0 1 ∘ . ⊖  -1 0 1 ∘ . ⌽ ⊂ ⍵"
		\ into a FORTH code equivalent to following:
		grid 
		wrap
		-1 0 1 3 >a  ' hrotate product
		-1 0 1 3 >a  ' vrotate product
		ravel
		' perv-+ reduce
		3 4 2 >a perv-=
		1 grid 2 >a  ' perv-and ' perv-or  inner-product
		first
		\ This code performs a single step of Game of Life, and
		show
		\ shows a second stage of a glider evolution.

		\ There is little job to be done during the translation phase. We have to change the execution order 
		\ from APL (right-to-left with infix functions and operators) into FORTH (left-to-right with postfix 
		\ functions). Also, we need to append array size to every array literal. -1 0 1 in APL is represented 
		\ as 1 0 -1 3 in our program.

		\ The translator work is two-phase. First, it tokenizes the input string: words are consumed from left 
		\ to right and every word put a token on the stack. Second, it compiles the token sequence starting 
		\ from the top, emitting a FORTH code for every token. For infix functions/operators, the translator 
		\ will look ahead for one or two lexemes.

		\ We will represent most tokens with a pair {token value, token class}. The token value is a function 
		\ implementing the operation and token class is a function that compiles the operation into a FORTH 
		\ code. E.g.,
: ⍵   ['] @local0 ['] compile, ; 
		\ So the omega (stays for a right operand in APL) is a token, its value is "@local0" (the FORTH word 
		\ to access an argument of a word with single local), and its class is "compile,". Being executed, 
		\ the class will compile token value into the current definition:

		: _test_dup { _ } [ ⍵ execute ⍵ execute ] ;
		cr see _test_dup			\ : _test_dup >l @local0 @local0 lp+ ; 
		cr 3 _test_dup . .			\ 3 3

		\ The token representing number is the number itself, see "number?" above.
		
		\ Below is the core translator function.
		\ If a token is a number, compile it into a current word as a literal.
		\ Otherwise, execute the token class and let it do what it wants.
: continue  ( token -- )  dup number? IF literal, ELSE execute THEN ;
		\ Apart from numbers, we'll define the following token classes:
		\ function
		\ dyadic-op
		\ monadic-op
		\ open			), an opening parenthesis, start of a sub-expression
		\ close			(, a closing parenthesis, end of a sub-expression
		\ compile,		special symbols directly mapped to FORTH, such as identifier ⍵

		\ Let's implement the abovementioned "-1 0 1" -> "1 0 -1 3" conversion.

		\ The definition of syntax is often recursive, so define a placeholder for mutually-recursive functions
		\ below:
defer open

		\ What considered to be a "value" is a number, or a subexpression, or an identifier:
: subexpression?   ['] open = ;
: identifier?   ['] compile, = ;
: value?  { t -- f }  t number?  t subexpression? or  t identifier? or ;

		\ A strand is a sequence of values:
: strand  ( .. -- u )  0  BEGIN { t cnt } t value? WHILE t continue cnt 1+ REPEAT t cnt ;
		\ Here we iterate over values, incrementing a counter in progress. Examine it:

		Create mark
		: _t [ mark 5 4 3 2 1 strand ] literal [ drop ] ;
		cr see _t				\ : _t 1 2 3 4 5 5 ;
		\ Here, "5 4 3 2 1 strand" compiled into "1 2 3 4 5 5" (what is sufficient for our array creation). 
		\ The "[ drop ]" in the end is required because the value of "mark" was left on the stack and we need 
		\ to throw it away before the end of the definition.

		\ To complete the array creation, we have to add the call to array constructor, ">a":
: value   strand  { size }  size 1 > IF size ['] >a compile-curried, THEN ;

		\ Check it works:
		: _t [ mark 5 4 3 2 1 value drop ] ;
		cr see _t 				\ : _t 1 2 3 4 5 5 >a ;
		: _t [ mark 1 value drop ] ;
		cr see _t 				\ : _t 1 ;
		: _t [ mark value drop ] ;
		cr see _t				\ : _t ;
		\ The multiple-element array had been wrapped as an array creation. The single number interpreted 
		\ as a scalar. An empty strand emits nothing.

		\ Below is the rest of the supported token classes. Note we have to differ between function references
		\ (tokens left and right from operator symbol) and function applications (all other cases). For 
		\ function references, we simply compile the reference into the current word:
: function-ref  { t -- }  literal, ;

		\ For an operator, we read the next function-ref (one to the left from an operator), then a value 
		\ (which may be empty in case of monadic operator), then we "compile," an operator (the "xt"), then 
		\ we continue:
: operator  { xt -- }  function-ref  value  xt compile,  continue ;
: dyadic-op   operator ;
: monadic-op   operator ;

		\ For a function, we check if there is a dyadic operator to the left, and then either compile the 
		\ reference ("literal,"), or read the next value and then compile an application ("compile,"), and 
		\ then continue:
: function  { t xt -- }
	t ['] dyadic-op = IF t  xt literal, ELSE t value  xt compile, THEN  continue ;
		\ Note: here we assume all functions are either unary or binary (APL monadic or dyadic) which is 
		\ not true in APL. Information about the arity of any given call is lost precisely here.

		\ An opening parenthesis (an expression) is a value and then optional anything:
:noname   value continue ;  is open

		\ A closing parenthesis is a no-op.
: close ;

		\ Now the fragment can be tested as a whole; in the following example, we put on the stack the list 
		\ of tokens: "close", "1", "function +", "2", "open", and then call "continue" to initiate
		\ the compilation:
		: _t [ ' close  1  ' + ' function  2  ' open  continue ] ;
		cr see _t				\ _t : 2 1 + ;

		\ As effect of "open" is to "continue", we need no explicit call the latter:
		: _t [ ' close  1 2 3 4  open ] ;
		cr see _t				\ _t : 4 3 2 1 4 >a ;

		\ We're almost there, now let's define APL symbols for tokens. We have already defined ⍵, others are 
		\ very similar, e.g. there is a ⊂ which is a "wrap" function:
		: ⊂  ['] wrap ['] function ;
		\ To avoid repetitions, we create a new word to define such tokens:

: apl:  { xt -- }  : xt literal, ['] function literal, POSTPONE ; ;
		\ We can use it as follows:
		' size apl: ≢
		: _t [ ' close  ≢ 1 2 3 4  open ] ;
		cr see _t				\ _t : 4 3 2 1 4 >a size ;
		cr _t .					\ 4
		\ (Really, APL ≢ is not "size").

		\ We don't want our APL symbols to hide useful FORTH words, so let them live in its own namespace:
wordlist Constant apl
		\ The phrase above just creates a new namespace but does not "opens" it. In FORTH there are separated 
		\ concept of "current" wordlist (the namespace to where newly created words go) and "search order" 
		\ (the namespace sequence to perform word search). The current wordlist accessed/changed with 
		\ "get-current" and "set-current", the search order with ">order" and "previous".

		\ So first we'll save the default current wordlist:
get-current 

		\ And then set the current wordlist to be "apl":
apl set-current

		\ And now define APL symbols.
		\ Symbols for functions are:
	' first apl: ↑		' perv-or apl: ∨	' perv-and apl: ∧	
	' perv-= apl: =		' perv-+ apl: +		' ravel apl: ,	
	' noop apl: ∘		' vrotate apl: ⊖	' hrotate apl: ⌽	
	' wrap apl: ⊂		' perv-* apl: ×		' size apl: ≢
	
		\ Symbols for operators:
	: / ['] hreduce ['] monadic-op ;
	: . ['] apl-product ['] dyadic-op ;

		\ And the parenthesis, most simple:
	' close Constant (
	' open Constant )

		\ And switch back to the default wordlist:
set-current

		\ Now, in the beginning of an APL section, we will add the apl wordlist to the search order, and in
		\ the end of section will drop it with "previous":
		: _t [ apl >order ( -1 0 1 ∘ . ⌽ ⊂ 0 1 0 ) continue previous ] ;
		cr _t print				\ [3 1 |[3 |0 0 1 ] [3 |0 1 0 ] [3 |1 0 0 ] ]

		\ In the code above, starting from "apl >order" the words "(", ")" and "." (and others) have APL
		\ meaning, and after "previous" the FORTH meaning restored. Both APL and FORTH parts of the function
		\ compiled into FORTH code; FORTH part by FORTH rules, APL part by APL rules.

		\ As all our APL-syntax function will have the same prefix and postfix, make it a words:
: ←{   apl >order  ['] close  POSTPONE [ ; immediate
: }   open  previous  ] ; immediate

		: _t ←{ -1 0 1 ∘ . ⌽ ⊂ 0 1 0 } ;

		cr _t print				\ [3 1 |[3 |0 0 1 ] [3 |0 1 0 ] [3 |1 0 0 ] ]
		\ Take a moment to decompile the function and look at its FORTH code:
		cr see _t
		\ (two big integers here are pointers to "rotate" and "noop").

		\ So, naturally we've translated APL into FORTH.




		\ Playground

		\ Please note an APL wordlist is just an ordinary FORTH wordlist, so we can extend it incrementally
		\ as we define new functions.

		\ Just to be sure every APL word will go to the apl wordlist, let's add a wordlist switching into 
		\ the definition of "apl:"
		: apl:  ( xt "name" -- )  { xt }  get-current apl set-current  xt apl:  set-current ;

		\ Let's do some experiments, probably memory-consuming, so mark a memory area to be thrown away later:
		marker gc

		\ Some examples from tryapl.org.
		\ The pervasive behavior of addition:
		: _t ←{ 4 2 3 + 8 5 7 } ;
		cr _t print				\ [3 |12 7 10 ]

		\ To implement "fac", we first need to implement "iota". We have "integers" which creates integers
		\ from 0 to n-1 but iota must create integers from 1 to n:
		: iota  integers  1 ['] + curry map ;
		cr 4 iota .a				\ 1 2 3 4

		\ Alternatively, we could implement "iota" in APL:
		' integers  apl: integers
		: iota ←{ 1 + integers } ;
		' iota  apl: ⍳

		: fac { _ } ←{ × / ⍳ ⍵ } ;
		cr 5 fac print				\ 120
		\ The ugly thing above is "{ _ }". This is required to make function argument accessible thru locals.
		\ Of course this can be automated but a chase for perfection would never ends.

		\ To implement "avg", we need a division with correct argument order:
		:noname  swap / ;
		\ Make it pervasive:
		' perv curry
		\ Make it available in APL:
		apl: ÷
		
		: avg { _ } ←{ ( + / ⍵ ) ÷ ≢ ⍵ } ;
		cr 40 30 20 10 4 >a avg print		\ 25

		\ To implement the frequency counter, we need a pseudorandom number generator:
		variable (rnd)
		utime drop (rnd) !
		: rnd   (rnd) @ dup 13 lshift xor dup 17 rshift xor dup dup 5 lshift xor (rnd) ! ;
		cr rnd . rnd . rnd .			\ (3 pseudorandom numbers)

		\ A word to return a pseudorandom in range:
		:noname  ( n -- n )  rnd swap mod 1+ ;
		\ Make it pervasive:
		' uperv curry
		\ Make it available in APL:
		apl: ?

		\ APL rho stays for shape, but in this specific example the constructor "fill" will do:
		' fill apl: ⍴

		: dices ←{ + / ( ⍳ 6 ) ∘ . = ? 1000 ⍴ 6 } ;
		cr dices print				\ [6| (6 numbers, totals to 1000)]
		gc




		\ The Game of Life

: life { _ } ←{ ↑ 1 ⍵ ∨ . ∧ 3 4 = + / , -1 0 1 ∘ . ⊖  -1 0 1 ∘ . ⌽ ⊂ ⍵ } ;

cr ." Memory used by code: " unused0 unused - cell / . ." words"

marker gc
cr ." The glider:" grid show
cr ." The glider after 4 steps:" grid life life life life show  
cr ." Free space on dictionary after a run: " unused .
gc
cr ." Free space on dictionary after gc: " unused .

bye

\ apl-life-anno.fs, Conway's Game of Life in APL in FORTH
\ Copyright (c) 2020 Alexander Serkov

\ This program is free software; you can redistribute it and/or modify it under the terms of
\ the GNU General Public License version 2 as published by the Free Software Foundation.
\ This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 
\ without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
\ See the GNU General Public License for more details.