\ Haskell inspired data types and pattern matching.
\
\ Disclaimer: This code doesn't pretend to be
\ pretty, clever, useful or documented.
\ It doesn't do garbage collection either.

: cell-  [ 1 cells ] literal - ;

: constructor:  ( arity "name" -- )
   create ,
   does> dup @ if here >r dup , @ 0 do , loop r> then ;
: deconstruct  ( ref -- x1 .. xn )
   dup @ @ tuck cells + swap 0 do dup @ swap cell- loop drop ;
: (||0)  ( constructor -- )
   s" literal over = if drop" evaluate ;
: (||)  ( constructor -- )
   s" literal over @ = if deconstruct" evaluate ;
: ||  ( "constructor" -- )
   ' >body dup @ if (||) exit then (||0) ;  immediate
: ;;  s" exit then" evaluate ;  immediate

\ shared nil constructor
0 constructor: nil

\ list constructor
2 constructor: cons  ( list n )

\ tree constructor
3 constructor: tree  ( tree tree n )

: .list  ( list -- )
   || nil  ( -- )  ;;
   || cons  ( list x -- )  . recurse ;;
   ;
: lcount  ( list -- n )
   || nil  ( -- 0 )  0 ;;
   || cons  ( list x -- n )  drop recurse 1+ ;;
   ;
: lsum  ( list -- n )
   || nil  ( -- 0 )  0 ;;
   || cons  ( list n1 -- n2 )  swap recurse + ;;
   ;
: list+  ( n list1 -- list2 )
   || nil  ( n -- nil )  drop nil ;;
   || cons  ( n1 list1 n2 -- list2 )
      >r over >r recurse r> r> + cons ;;
   ;
: lmap  ( xt list1 -- list2 )
   || nil  ( xt -- nil )  drop nil ;;
   || cons  ( xt list1 x -- list2 )
      >r over >r recurse r> r> swap execute cons ;;
   ;
: (lappend)  ( list1 list2 -- list3 )
   || nil  ( list -- list ) ;;
   || cons  ( list1 list2 x -- list3 )
      >r recurse r> cons ;;
   ;
: lappend  swap (lappend) ;
: lreverse  ( list1 -- list2 )
   || nil  ( -- nil )  nil ;;
   || cons  ( list1 x -- list2 )
      nil swap cons swap recurse swap lappend ;;
   ;

: (.tree)
   || nil  ( n -- )  drop ;;
   || tree  ( n tree1 tree2 x -- )
      swap >r swap >r over spaces . cr 1+ dup r> recurse r> recurse ;;
   ;
: .tree  ( tree -- )  cr 0 swap (.tree) ;
: tcount  ( tree -- n )
   || nil  ( -- 0 )  0 ;;
   || tree  ( tree1 tree2 n1 -- n2 )
      drop recurse swap recurse + 1+ ;;
   ;
: tsum  ( tree -- n )
   || nil  ( -- 0 )  0 ;;
   || tree  ( tree1 tree2 n1 -- n2 )
      >r recurse swap recurse + r> + ;;
   ;
: tmap  ( xt tree1 -- tree2 )
   || nil  ( xt -- nil )  drop nil ;;
   || tree  ( xt tree1 tree2 x -- tree3 )
      >r >r over >r recurse r> dup r> recurse r> rot execute tree ;;
   ;

: testtree  nil nil 1 tree nil 2 tree nil swap 3 tree
   nil nil 6 tree nil 4 tree 5 tree ;
: testlist  nil 1 cons 2 cons 3 cons 4 cons 5 cons 6 cons 7 cons ;

testlist lreverse ' 2* swap lmap .list 2 4 6 8 10 12 14  ok

--
Julian V. Noble
Professor Emeritus of Physics
j...@lessspamformother.virginia.edu
    ^^^^^^^^^^^^^^^^^^
http://galileo.phys.virginia.edu/~jvn/

   "For there was never yet philosopher that could endure the
    toothache patiently."  

Have you looked at Joy, by any chance?
<URL: http://www.latrobe.edu.au/philosophy/phimvt/joy.html>

Cheers,

-- Joe

In Haskell you can create your own list type like this (the 'a' in the
data definition means it's a polymorphic type)

   data List a = Nil | Cons a (List a)

   lcount Nil = 0
   lcount (Cons x xs) = 1 + lcount xs

My version looks like this (the argument to constructor is the arity)

   0 constructor: nil
   2 constructor: cons  ( list n )

   : lcount  ( list -- n )
     || nil  ( -- 0 )  0 ;;
     || cons  ( list x -- n )  drop recurse 1+ ;;
     ;

Basically, a data type consists of a number of constructors. When you
write a function for that data type you provide an action for each
constructor.

Here's a slightly updated version with a different example

\ Haskell inspired data types and pattern matching.
\
\ Disclaimer: This code doesn't pretend to be
\ pretty, clever, useful or documented.

\ memory allocation -- allot, no gc
\ : reserve  ( n -- a )  here swap cells allot ;
\ : release  ( a -- )  drop ;
\ memory allocation -- allocate, memory shouldn't leak
: reserve  ( n -- a )  cells allocate drop ;
: release  ( a -- )  free drop ;

: @#  ( a n -- x1 .. xn )
   tuck 1- cells + swap 0
   do dup @ swap [ 1 cells ] literal - loop drop ;
: !#  ( x1 .. xn a n -- )  0 do tuck ! cell+ loop drop ;

: constructor:  ( arity "name" -- )
   create ,
   does> dup @ if dup @ 1+ dup reserve dup >r swap !# r> then ;
: deconstruct  ( ref -- x1 .. xn )
   dup >r dup cell+ swap @ @ @# r> release ;
: (||0)  ( constructor -- )
   s" literal over = if drop" evaluate ;
: (||)  ( constructor -- )
   s" literal over @ = if deconstruct" evaluate ;
: ||  ( "constructor" -- )
   ' >body dup @ if (||) exit then (||0) ;  immediate
: ;;  s" exit then" evaluate ;  immediate

\ expression tree
1 constructor: num
3 constructor: binop  ( left right xt )

: calc  ( expr -- value )
   || num  ( value -- value )  ;;
   || binop  ( left right xt -- value )
      >r recurse swap recurse swap r> execute ;;
   ;

: testexpr  5 num 6 num ['] + binop 7 num ['] * binop ;

testexpr calc . 77  ok

--
GST+NPT=JOBS

I.e., a Goods and Services Tax (or almost any other broad based production
tax), with a Negative Payroll Tax, promotes employment.

1. You have more documentation :)

2. You seem to be concentrating on lists where I can create many types.

3. I'm going to avoid garbage collection in a similar manner to Henry
Baker's Linear Lisp <http://home.pipeline.com/~hbaker1/LinearLisp.html>.
The data structures will be destroyed as they are used. It's not going
to be fast; allocate and free are going to get a serious workout.

You have made me think that this thing might actually be useful. Pretty
good for something I hacked together in a couple of hours :).

Here's a list data structure that can cope with lists within lists.

\ Haskell inspired data types and pattern matching.
\
\ Disclaimer: This code doesn't pretend to be
\ pretty, clever, useful or documented.

\ memory allocation -- allot, no gc
\ : reserve  ( n -- a )  here swap cells allot ;
\ : release  ( a -- )  drop ;
\ memory allocation -- allocate, memory shouldn't leak
: reserve  ( n -- a )  cells allocate drop ;
: release  ( a -- )  free drop ;

: @#  ( a n -- x1 .. xn )
   tuck 1- cells + swap 0
   do dup @ swap [ 1 cells ] literal - loop drop ;
: !#  ( x1 .. xn a n -- )  0 do tuck ! cell+ loop drop ;

: constructor:  ( arity "name" -- )
   create ,
   does> dup @ if dup @ 1+ dup reserve dup >r swap !# r> then ;
: deconstruct  ( ref -- x1 .. xn )
   dup >r dup cell+ swap @ @ @# r> release ;
: (||0)  ( constructor -- )
   s" literal over = if drop" evaluate ;
: (||)  ( constructor -- )
   s" literal over @ = if deconstruct" evaluate ;
: ||  ( "constructor" -- )
   ' >body dup @ if (||) exit then (||0) ;  immediate
: ;;  s" exit then" evaluate ;  immediate

\ list constructors
0 constructor: nil
1 constructor: atom  ( n )
2 constructor: cons  ( list x )

defer .list  \ .list copied from Haskell showList :)
: ((.list))  ( list -- )
   || nil  ( -- )  ." ]" ;;
   || atom  ( n -- )  1 .r ;;  \ this should never happen
   || cons  ( list x -- )  ." ," .list recurse ;;
   ;
: (.list)  ( list -- )
   || nil  ( -- )  ." []" ;;
   || atom  ( n -- )  1 .r ;;
   || cons  ( list x -- )  ." [" .list ((.list)) ;;
   ;
' (.list) is .list

: lgen  ( n1 n2 -- list)
   nil -rot tuck 1+ swap do tuck atom cons swap 1- loop drop ;
: lcount  ( list -- n )
   || nil  ( -- 0 )  0 ;;
   || atom  ( n -- 1 )  drop 1 ;;
   || cons  ( list x -- n )  recurse swap recurse + ;;
   ;
: lsum  ( list -- n )
   || nil  ( -- 0 )  0 ;;
   || atom  ( n -- n )  ;;
   || cons  ( list x -- n )  recurse swap recurse + ;;
   ;
: ldup  ( list1 -- list2 list3 )
   || nil  ( -- nil nil )  nil nil ;;
   || atom  ( n -- atom atom )  dup atom swap atom ;;
   || cons  ( list1 x -- list2 list3 )
      >r recurse r> recurse >r cons swap r> cons ;;
   ;
: ldrop  ( list -- )
   || nil  ( -- )  ;;
   || atom  ( n -- )  drop ;;
   || cons  ( list x -- )  recurse recurse ;;
   ;
: lmap  ( xt list1 -- list2 )
   || nil  ( xt -- nil )  drop nil ;;
   || atom  ( xt n -- atom )  swap execute atom ;;
   || cons  ( xt list1 x -- list2 )
      >r over >r recurse r> r> recurse cons ;;
   ;
: (lappend)  ( list1 list2 -- list3 )
   || nil  ( list -- list ) ;;
   || cons  ( list1 list2 x -- list3 )
      >r recurse r> cons ;;
   ;
: lappend  swap (lappend) ;
: (lflatten)  ( list1 -- list2 ) ;
: lflatten  ( list1 -- list2 )
   || nil  ( -- nil )  nil ;;
   || atom  ( n -- list )  nil swap atom cons ;;
   || cons  ( list x -- list2 )
      recurse swap recurse lappend ;;
   ;
: lreverse  ( list1 -- list2 )
   || nil  ( -- nil )  nil ;;
   || atom  ( n -- atom )  atom ;;
   || cons  ( list1 x -- list2 )
      recurse nil swap cons swap recurse swap lappend ;;
   ;

: testlist  nil 1 atom cons 2 atom cons 3 atom cons 4 atom cons nil 10
atom cons 11 atom cons cons 5 atom cons ;

1 10 lgen .list [1,2,3,4,5,6,7,8,9,10] ok
1 10 lgen lsum . 55  ok
testlist .list [5,[11,10],4,3,2,1] ok

 The differences with my system are:

--
GST+NPT=JOBS

I.e., a Goods and Services Tax (or almost any other broad based production
tax), with a Negative Payroll Tax, promotes employment.

I think it is really good, but I'm not pretending to understand it
right of your postings, without more examples.

I tried your latest code with all your examples. This fails, while
it worked originally (with a simpler list!):

: testlist  nil 1 atom cons 2 atom cons 3 atom cons 4 atom cons nil
            10 atom cons 11 atom cons cons 5 atom cons ;
testlist .list   ( gives [5,[11,10],4,3,2,1] ok )
testlist lreverse ' 2* swap lmap .list ( crashes )

I want to put it onto a web page and am considering a wiki; any
recommendations?

\ FunForth: Functional Forth
\ Haskell inspired data types and pattern matching.
\
\ Disclaimer: This code doesn't pretend to be
\ pretty, clever, useful or documented.

\ memory allocation -- allocate, memory shouldn't leak
: reserve  ( n -- a )  cells allocate drop ;
: release  ( a -- )  free drop ;

: @#  ( a n -- x1 .. xn )
   tuck 1- cells + swap 0
   do dup @ swap [ 1 cells ] literal - loop drop ;
: !#  ( x1 .. xn a n -- )  0 do tuck ! cell+ loop drop ;

: constructor:  ( arity "name" -- )
   create ,
   does> dup @ if dup @ 1+ dup reserve dup >r swap !# r> then ;
: deconstruct  ( ref -- x1 .. xn )
   dup >r dup cell+ swap @ @ @# r> release ;
: (||0)  ( constructor -- )
   s" literal over = if drop" evaluate ;
: (||)  ( constructor -- )
   s" literal over @ = if deconstruct" evaluate ;
: ||  ( "constructor" -- )
   ' >body dup @ if (||) exit then (||0) ;  immediate
: ;;  s" exit then" evaluate ;  immediate

\ list constructors
0 constructor: nil
2 constructor: cons  ( tail x )
\ for lists of lists
2 constructor: lcons  ( tail list )

defer .list  \ .list copied from Haskell showList :)
: ((.list))  ( list -- )
   || nil  ( -- )  ."  } " ;;
   || cons  ( tail x -- )  space 1 .r recurse ;;
   || lcons  ( tail list -- )  .list recurse ;;
   ;
: (.list)  ( list -- )
   || nil  ( -- )  ." { } " ;;
   || cons  ( tail x -- )  ." { " 1 .r ((.list)) ;;
   || lcons  ( tail list -- )  ." { " .list ((.list)) ;;
;
' (.list) is .list

: ldup  ( list1 -- list2 list3 )
   || nil  ( -- nil nil )  nil nil ;;
   || cons  ( tail x -- list1 list2 )
      >r recurse r@ cons swap r> cons ;;
   || lcons  ( tail list1 -- list2 )
      >r recurse r> recurse >r lcons swap r> lcons ;;
   ;
: ldrop  ( list -- )
   || nil  ( -- )  ;;
   || cons  ( tail x -- )  drop recurse ;;
   || lcons  ( tail list -- )  recurse recurse ;;
   ;

: lfoldl  ( x1 xt list -- x2 )
   || nil  ( x1 xt -- x1 )  drop ;;
   || cons  ( x1 xt tail x2 -- x3 )
      swap >r over >r swap execute r> r> recurse ;;
   ;
: lfoldr  ( x1 xt list -- x2 )
   || nil  ( x1 xt -- x1 )  drop ;;
   || cons  ( x1 xt tail x2 -- x3 )
      rot tuck 2>r swap recurse 2r> execute ;;
   ;
: lmap  ( xt list1 -- list2 )
   || nil  ( xt -- nil )  drop nil ;;
   || cons  ( xt tail x -- list )
      -rot over swap 2>r execute 2r> recurse swap cons ;;
   ;
: lfilter  ( xt list1 -- list2 )
   || nil  ( xt -- nil )  drop nil ;;
   || cons  ( xt tail x -- list )
      >r over >r recurse r> r> tuck swap execute
      if cons exit then drop ;;
   ;
: (lappend)  ( list1 list2 -- list3 )
   || nil  ( list -- list ) ;;
   || cons  ( list1 list2 x -- list3 )
      >r recurse r> cons ;;
   ;
: lappend  swap (lappend) ;
: ltake  ( n list1 -- list2 )
   || nil  ( n -- nil )  drop nil ;;
   || cons  ( n tail x -- list )
      >r swap ?dup if 1- swap recurse r> cons exit then
      ldrop nil r> drop ;;
   ;
: ldiscard  ( n list1 -- list2 )
   || nil  ( n -- nil )  drop nil ;;
   || cons  ( n tail x -- list )
      rot ?dup if nip 1- swap recurse exit then cons ;;
   ;
: l>stack  ( list -- x1 .. xn )
   || nil  ( -- )  ;;
   || cons  ( tail x1 -- x1 x2 .. xn )  swap recurse ;;
   ;

: lgen  ( n1 n2 -- list )
   nil -rot tuck 1+ swap do tuck cons swap 1- loop drop ;
: lsum  ( list -- sum )  0 ['] + rot lfoldl ;
: (lcount)  drop 1+ ;
: lcount  ( list -- count )  0 ['] (lcount) rot lfoldl ;
: (lreverse)  ( tail x -- list2 )  nil swap cons lappend ;
: lreverse  ( list1 -- list2 )  nil ['] (lreverse) rot lfoldr ;

: }  ( flag list -- flag list )  nip 0 swap ;
: ..}  2 swap ltake l>stack swap lgen } lreverse ;
: {  ( "n1 .. nm }" -- list )
   -1 nil begin over while bl word count evaluate
   over if cons then repeat nip lreverse ;

\ Examples
\   { 7 5 3 1 } ' 2* swap lmap .list
\   { 10 20 ..} ldup .list lsum .

\ Apply execute to a list of xts
\   1 2 3 4 ' execute
\   nil ' lshift cons ' * cons ' + cons
\   lfoldl .
\ Equivalent to
\   1 2 3 4 + * lshift .

\ : odd  1 and ;
\ ' odd 1 15 lgen lfilter .list

A data type is defined by a number of constructors. Here is the
definition of a linked list. The number passed to 'constructor:' is the
arity, the number of arguments the constructor takes.
   0 constructor: nil
   2 constructor: cons ( tail x )

We can create a list using the constructors:
   nil 3 cons 2 cons 1 cons
When the constructor is applied it allocates memory, moves the arguments
to that memory and leaves a pointer to it on the stack.

Words which act on data types follow the same pattern; an action is
supplied for each constructor. Actions have the form
   || <constructor> .. ;;
Here's a disection of 'lmap'.

   : lmap  ( xt list1 -- list2 )
     || nil  ( xt -- nil )  drop nil ;;
     || cons  ( xt tail x -- list )
        -rot over swap 2>r execute 2r> recurse swap cons ;;
     ;

The data item we're applying this word to has to be on top of the stack.
Note that the original data item is consumed; the result is a completely
new list.
   : lmap  ( xt list1 -- list2 )

The action for 'nil' is pretty simple; applying the xt to an empty list
gives us an empty list. We drop the xt and return 'nil'.
     || nil  ( xt -- nil )  drop nil ;;

Upon entry to an action, the data item is deconstructed (contents placed
on the stack) and it's memory released.
     || cons  ( xt tail x -- list )

Shuffle the stack and store away the tail and a copy of the xt for later
recursion.
        -rot over swap 2>r
Apply the xt to the head.
        execute
Apply the xt to the tail.
        2r> recurse
Construct the list result and return it.
        swap cons ;;

End of lmap.
     ;

I've just seen a better way of doing lreverse
   : lreverse  ( list1 -- list2 )  nil ['] cons rot lfoldl ;

The Haskell way (using list append) is more efficient in Haskell because
it uses lazy evaluation. Serves me right for copying :).

You need not answer those questions in particular.
But maybe it helps to understand how to get into the mindset
of Haskell newsbies.

This makes no sense.

So I guess this is more to the point.

\ A list is represented by a list handle (h)
\ Leave an empty LIST .
nil ( -- h )
\ Append to the front of the LIST a NUMBER, leave the longer LIST
cons ( h1 n -- h2 )

So this is the code to create a list in Funforth that contains
{1;2;3}
nil 3 cons 2 cons 1 cons

(For the Stallman-impaired I have left in the ugly stack comments.)
I couldn't care less what you do with your memory at this stage
where I wonder what it is all about.

Note that I only got the idea that it is to the front
of the list, because of your using the number 3 2 1 in reverse
order. And some vague recollection of LISP.
<SNIP>

For those folks, it might be helpful to say:

Haskell is a "functional" language in the mathematical sense of
"function": all Haskell constructs are referentially transparent,
which means that when invoked with a given set of arguments, a Haskell
function will *always* evaluate to the same value. Furthermore,
Haskell functions have no side effects; it is not possible, for
example, to change the value of a variable after it is defined. As
a consequence, formal mathematical proofs of correctness can be
applied to Haskell code.

Many people also find Haskell code to be nice to read. George's
FunForth is simply a Forth implementation of some key bits of Haskell
syntax, namely "pattern matching" and "type constructors". This syntax
allows the programmer to write the discriminated function definitions
we so fondly remember from high-school algebra, things like:

  f(x) = x    if x > 0
         x-1  if x <= 0

Except in Haskell (or maybe ML, I get my functional languages
confused sometimes), you'd write

  f x = x>0  | x
        x<=0 | x-1

The argument passed to the "f" function is tested against the
left-hand sides of the | symbols until a match is found, at which
point the right-hand side of the | is evaluated. Patterns are more
generally applied to "constructors", which are just notations for
expressing values of a data type. The List data type, for example,
could be defined as follows:

data List t = Nil   |   L t (List t)

IOW, a List of type "t" is either Nil, or an L struct whose first
element is of type "t" and whose second element is of type "List t".
Haskell doesn't treat the word List specially; we could have used
GiantWombat instead, or whatever. The important thing is that we've
defined a data type whose instances can have one of two forms: Nil, or
a structure with two elements with specified characteristics.  Each of
those two forms is called a "constructor"; Nil is a 0-ary constructor,
and L is a 2-ary constructor.  We could write down some values of type
"List Integer" by saying

myListWithThreeElements = L 1 (L 2 (L 3 Nil))
myEmptyList = Nil

The "pattern matching" comes in when we want to write a function that
computes over lists. For example, the length function can be written:

  length l =
              l == Nil            | 0
              l == L first rest   | 1 + (length rest)

That is, when l is Nil, its length is 0; otherwise its length is 1 +
the length of its second element, which according to the List
constructor must be another List (and a Haskell compiler would enforce
that constraint). The *form of the constructor* passed in to the
length function is what we're matching against. In Haskell, length
could also be written:

  length Nil = 0

  length (L head tail) = 1 + length tail

In this case, the argument matches directly against the LHS of the =
signs, so

 length Nil

immediately matches the first equation and evaluates to 0, and

 length (L 42 (L 54 Nil))

matches the second, then (recursively) the second again, then the
first, evaluating to 2.

Cheers,

-- Joe

Keep asking questions and I'll keep trying to answer them.

See also the post in the FUN-Forth thread,

--
GST+NPT=JOBS

I.e., a Goods and Services Tax (or almost any other broad based production
tax), with a Negative Payroll Tax, promotes employment.