Easy 4tH

    \ Easy4tH  V1.0b             A 4tH to ANS Forth interface

    \ Typical usage:
    \    4096 constant /string-space
    \    s" easy4th.f" included

    \ This is an ANS Forth program requiring:
    \      1. The word NIP in the Core Ext. word set
    \      2. The word /STRING in the String word set
    \      3. The word D>S in the Double word set
    \      4. The words MS and TIME&DATE in the Facility Ext. word set.

    \ (c) Copyright 1997 Wil Baden, Hans Bezemer.  Permission is granted by the
    \ authors to use this software for any application provided this
    \ copyright notice is preserved.

    \ Uncomment the next line if REFILL does not funtion properly
    \ : refill query cr true ;

    \ 4tH datatypes
    : ARRAY CREATE CELLS ALLOT ;
    : STRING CREATE CHARS ALLOT ;
    : TABLE CREATE ;

    \ 4tH constants
    : (ERROR) S" MAX-N" ENVIRONMENT? DROP NEGATE 1- ;
    : MAX-N S" MAX-N" ENVIRONMENT? DROP ;
    : STACK-CELLS S" STACK-CELLS" ENVIRONMENT? DROP ;
    : /PAD S" /PAD" ENVIRONMENT? DROP ;

    \ 4tH wordset
    : TH CELLS + ;
    : @' @ ;
    : COPY ( a b -- b ) >R  DUP C@ 1+ R@ SWAP MOVE  R> ;
    : WAIT 1000 * MS ;

    : NUMBER             ( a -- n)
      0. ROT DUP 1+ C@ [CHAR] - = >R COUNT R@ IF 1 /STRING THEN >NUMBER NIP 0=
      IF D>S R> IF NEGATE THEN ELSE R> DROP 2DROP (ERROR) THEN
    ;

    \ 4tHs C" runtime semantics emulation

    ( Reserve  STRING-SPACE  in data-space. )
    CREATE STRING-SPACE           /STRING-SPACE CHARS ALLOT
    VARIABLE NEXT-STRING          0 NEXT-STRING !

    ( caddr n addr -- )
    : PLACE OVER OVER >R >R CHAR+ SWAP CHARS MOVE R> R> C! ;

    ( " ccc" -- caddr )
    : " [CHAR] " PARSE
      DUP 1+ NEXT-STRING @ + /STRING-SPACE >
            ABORT" String Space Exhausted. "
      STRING-SPACE NEXT-STRING @ CHARS + >R
      DUP 1+ NEXT-STRING +!
      R@ PLACE
      R>
    ;

    \ 4tHs Random generator

    ( Default RNG from the C Standard.  `RAND' has reasonable
    ( properties, plus the advantage of being widely used. )
    VARIABLE RANDSEED

    32767 CONSTANT MAX-RAND

    : RAND                                 ( -- random )
      RANDSEED @ ( random) 1103515245 *   12345 +   DUP RANDSEED !
      16 RSHIFT   MAX-RAND AND
    ;

    : SRAND ( n -- ) RANDSEED ! ;  1 SRAND

    ( Don't mumble. )
    : random        ( -- n )        RAND ;

    : set-random    ( n -- )        SRAND ;

    ( Mix 'em up. )
    : randomize                                     ( -- )
      TIME&DATE  12 * + 31 * + 24 * + 60 * + 60 * +  set-random
    ;

    randomize