\
\ taxi4p.fs - Ramanujan's Taxi
\     Author: Helmar Wodtke
\       Year: 2007
\
\ This is a nice candidate for a benchmark.
\ Usage:
\
\ 4p -j -a taxi4p.fs
\ gforth -m 30M taxi4p.fs
\ vfxlin include taxi4p.fs
\
\ Note: How to deconstruct into X^3 sums I leave as an exercise to the
\       reader. Everything needed is already implemented. One part of the
\       sum is stored with "sums,". The other part can be reconstructed
\       using "bsearch".
\
               1289 constant UB
   32 1024 * 1024 * constant MEM4SUMS
[UNDEFINED] :: [IF]
            1 cells constant 1#c
            2 cells constant 2#c
            8 cells constant 8#c
  : c2/             2/ dup 1#c mod - ;
  : ::              :noname ;
  [UNDEFINED] rdrop [IF]
    : rdrop         postpone r> postpone drop ; immediate
  [THEN]
[THEN]
: size[             here ;
: ]:                here swap - constant ;
defer precedes
: bsearch           over if >r
                      2dup c2/ + @ r@ precedes if c2/
                      else dup c2/ cell+ tuck - -rot + swap then
                    r> recurse exit then 2drop ;
: insert            >r 2dup r@ bsearch
                    >r + r@ tuck cell+ tuck - cell+ move
                    r> r> swap ! ;
: sort'             >r 1#c begin r@ over > while
                      2dup 2dup + @ insert
                    cell+ repeat 2drop rdrop ;
defer sort
::                  dup 8#c < if sort' exit then
                    2dup + -rot 2dup c2/ + here
                    { pe p c p' p0 }
                    p' c p over c2/ tuck sort - sort
                    p p' begin
                      over p' u< over pe u< and while
                      over @ over @ 2dup precedes if
                        , drop cell+
                      else drop , swap cell+ swap then
                    repeat
                    pe swap ?do i @ , 1#c +loop
                    p' swap ?do i @ , 1#c +loop
                    p0 p c move c negate allot ; is sort
: pow3,             1+ 1 do i dup dup * * , loop ;

  UB cells constant UB#c
             create pow3 UB pow3,

: mhash             pow3 UB#c bounds do
                      i @ 7 and over = if i , then
                    1#c +loop drop ;

             create h0 size[ 0 mhash ]: /h0
             create h1 size[ 1 mhash ]: /h1
             create h3 size[ 3 mhash ]: /h3
             create h5 size[ 5 mhash ]: /h5
             create h7 size[ 7 mhash ]: /h7

MEM4SUMS allocate throw
           constant sums
            0 value /sums

: sum,              sums /sums + ! /sums 1#c + to /sums ;
: (sums,)           bounds do
                      2dup bounds do
                        i @ dup @ j @ @ + sum, sum,
                      1#c +loop
                    1#c +loop 2drop ;
: (=sums,)          2dup + -rot bounds do
                      dup i do
                        i @ dup @ j @ @ + sum, sum,
                      1#c +loop
                    1#c +loop drop ;
: sums,             h0 /h0       (=sums,)
                    h1 /h1 h0 /h0 (sums,)
                    h3 /h3 h0 /h0 (sums,)
                    h5 /h5 h0 /h0 (sums,)
                    h7 /h7 h0 /h0 (sums,)
                    h1 /h1       (=sums,)
                    h3 /h3 h1 /h1 (sums,)
                    h5 /h5 h1 /h1 (sums,)
                    h7 /h7 h1 /h1 (sums,)
                    h3 /h3       (=sums,)
                    h5 /h5 h3 /h3 (sums,)
                    h7 /h7 h3 /h3 (sums,)
                    h5 /h5       (=sums,)
                    h7 /h7 h5 /h5 (sums,)
                    h7 /h7       (=sums,) ; sums,
: index,            bounds do i , 2#c +loop ;
             create index size[ sums /sums index, ]: /index
::                  @ swap @ u< ; is precedes index /index sort
: .results          index /index bounds cell+ do
                      i @ @ i 1#c - @ @
                      = if i @ @ 1 u.r cr then
                    1#c +loop ;
cr
.results
bye
