\ $Id: ackermann.bigforth,v 1.2 2001/06/25 00:34:05 doug Exp $
\ ackermann's function
\ http://www.bagley.org/~doug/shootout/
\ from James Hague

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

: ack  
   over 0=
   if nip 1+
   else
       dup 0=
       if drop 1- 1 recurse
       else
           1- over swap recurse  swap 1- swap recurse
       then
   then ;

\ run ack(3, NUM) and print result from stack
." Ack: " 3 NUM ack 1 u.r cr

bye

\ $Id: ary3.bigforth,v 1.1 2001/06/19 16:20:45 doug Exp $
\ http://www.bagley.org/~doug/shootout/

decimal

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

variable X
NUM cells allocate drop X !
variable Y
NUM cells allocate drop Y !

: ary 
  NUM 0 do
    1 i + i cells X @ + !
  loop
  1000 0 do
    NUM 0 do
      i cells Y @ +       
      dup @
      i cells X @ +       
      @ + swap !
    loop
  loop ;

ary

Y @ @ 1 u.r ."  " NUM 1 - cells Y @ + @ 1 u.r cr

bye \ th-th-that's all folks!

\ -*- mode: forth -*-
\ $Id: wc.bigforth,v 1.1 2001/06/24 22:27:35 doug Exp $
\ http://www.bagley.org/~doug/shootout/

variable  nn       0       nn !       \ number of newlines
variable  nw       0       nw !       \ number of words
variable  nc       0       nc !       \ number of chars
variable  in_word  0       in_word !  \ flag: "in word"

10  constant  nl_ch
9   constant  tab_ch
32  constant  space_ch

4096 constant MAXREAD
create buff MAXREAD allot

\ scan the buffer and count lines, words, chars
: scanbuff 
    dup nc +!                 \ update nc with amount of chars in buffer
    buff + buff           \ from start of buff to buff + n
    do
    i c@
    case
        nl_ch    of  0 in_word !  1 nn +!  endof
        tab_ch   of  0 in_word !  endof
        space_ch of  0 in_word !  endof
        \ otherwise:
        in_word @ 0=
        if
        1 in_word !
        1 nw +!
        then
    endcase
    loop ;

: wc 
    buff
    begin
        buff MAXREAD stdin read-file throw dup
    while
    scanbuff
    repeat ;

wc nn @ . nw @ . nc @ 1 u.r cr

bye \ th-th-that's all folks!

\ -*- mode: forth -*-
\ $Id: except.bigforth,v 1.1 2001/06/20 19:04:07 doug Exp $
\ http://www.bagley.org/~doug/shootout/
\ from Anton Ertl

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

1 constant *hi*
2 constant *lo*

variable lo
variable hi

: blowup 
    1 and if
        *lo* throw
    else
        *hi* throw
    then ;

: lo-function 
    ['] blowup catch           
    dup *lo* <> tuck and throw 
    1+ lo +! ;

: hi-function 
    ['] lo-function catch      
    dup *hi* <> tuck and throw 
    1+ hi +! ;

: some-function 
    ['] hi-function catch abort" We shouldn't get here" ;

: main 
    NUM 0 ?do
        i some-function drop
        loop
    ." Exceptions: HI=" hi ? ." / LO=" lo @ 1 u.r cr ;

main bye

\ $Id: fibo.bigforth,v 1.1 2001/06/19 16:20:46 doug Exp $
\ fibonacci numbers
\ http://www.bagley.org/~doug/shootout/

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

\ compute fibonacci numbers
: fib  recursive
    dup 2 <
    if
    drop 1
    else
    dup
        2 - fib
    swap
    1 - fib
    +
    then ;

NUM fib 1 u.r cr

bye \ th-th-that's all folks!

\ $Id: hello.bigforth,v 1.1 2001/06/19 16:20:46 doug Exp $
\ http://www.bagley.org/~doug/shootout/

." hello world" cr bye

\ -*- mode: forth -*-
\ $Id: lists.bigforth,v 1.1 2001/06/19 16:20:46 doug Exp $
\ http://www.bagley.org/~doug/shootout/
\ from Anton Ertl

0. argc @ 1- arg >number 2drop drop constant NUM

10000 constant SIZE

struct
    cell% field list-next
    cell% field list-val
end-struct list%

: make-list 
    0 0 SIZE -do 
    list% %alloc
    i over list-val !
    tuck list-next !
    1 -loop
;

: copy-list 
    0 { w^ list2 }
    list2 begin 
    over
    while
    list% %alloc dup >r swap ! 
    dup list-val @ r@ list-val !
    list-next @ r> list-next 
    repeat
    off drop list2 @ ;

: move-head-to-tail 
    \ somehow this is an expensive noop
    0 { w^ list2 }
    list2 begin 
    over
    while
    \ move one element
    over list-next dup @ 2>r 
    over list-next off
    ! r> r>
    repeat
    off drop list2 @ ;

: nreverse 
    \ destructive reverse
    0 swap begin 
    dup
    while
    dup list-next @ >r 
    tuck list-next ! r> 
    repeat
    drop ;

: move-tail-to-tail 
    \ use head-to-tail instead of head-to-head nreverse
    nreverse move-head-to-tail ;

: list-equals 
    begin 
    dup
    while
    over
    while
    over list-val @ over list-val @ <> if
        2drop false exit
    endif
    list-next @ swap list-next @ 
    repeat then
    = ;

: list-length 
    0 begin 
    over
    while
    1+ swap list-next @ swap
    repeat
    nip ;

s" wrong result" exception constant wrong-result

: main 
    0 NUM 0 ?do
    drop
    make-list dup copy-list 
    move-head-to-tail move-tail-to-tail swap nreverse 
    dup list-val @ SIZE <> wrong-result and throw
    tuck list-equals 0= wrong-result and throw
    list-length
    loop ;

main 0 .r cr bye

\ -*- mode: forth -*-
\ $Id: methcall.bigforth,v 1.2 2001/06/24 23:22:53 doug Exp $
\ http://www.bagley.org/~doug/shootout/

\ from Bernd Paysan:
\ I'm using oof.fs here (native OOF for bigforth), code using one of
\ the other OO Forth extensions will look different.

0. argc @ 1- arg >number 2drop drop constant NUM

include oof.fb

object class Toggle
    cell var state
  public:
    method activate 
    method value 
  how:
    : init   state ! ;
    : value   state @ ;
    : activate   state @ invert state ! ;
class;

Toggle class NthToggle
    cell var count-max
    cell var counter
  how:
    : init 
    super init  count-max ! 0 counter ! ;
    : activate 
    1 counter +!
    counter @ count-max @ >= if
        state @ invert state !
        0 counter !
    then ;
class;

: flag. 
    if ." true" else ." false" then cr ;

: mainloop 
    true NUM 0 ?do
    drop dup toggle with activate value endwith
    loop
    flag.  drop ;

: main 
    true Toggle new mainloop
    3 true NthToggle new mainloop ;

main bye

\ $Id: nestedloop.bigforth,v 1.1 2001/06/19 16:20:46 doug Exp $
\ http://www.bagley.org/~doug/shootout/

decimal

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

: nestedloops 
  NUM 0 do
    NUM 0 do
      NUM 0 do
        NUM 0 do
          NUM 0 do
            NUM 0 do
              1+
            loop
          loop
        loop
      loop
    loop
  loop ;

\ run test and print result
0 nestedloops 1 u.r cr

bye \ th-th-that's all folks!

\ -*- mode: forth -*-
\ $Id: objinst.bigforth,v 1.3 2001/06/25 20:54:09 doug Exp $
\ http://www.bagley.org/~doug/shootout/

\ from Bernd Paysan:
\ I'm using oof.fs here (native OOF for bigforth), code using one of
\ the other OO Forth extensions will look different.

0. argc @ 1- arg >number 2drop drop constant NUM

include oof.fb

object class Toggle
    cell var state
  public:
    method activate 
    method value 
  how:
    : init   state ! ;
    : value   state @ ;
    : activate   state @ invert state ! ;
class;

Toggle class NthToggle
    cell var count-max
    cell var counter
  how:
    : init 
    super init  count-max ! 0 counter ! ;
    : activate 
    1 counter +!
    counter @ count-max @ >= if
        state @ invert state !
        0 counter !
    then ;
class;

: flag. 
    if ." true" else ." false" then cr ;

: mainloop 
    true swap 0 ?do
    drop dup toggle with activate value endwith dup flag.
    loop
    drop ;

: main 
    true Toggle new 5 mainloop
    NUM 0 ?do
    true Toggle new toggle with dispose endwith \ like the C version
    loop
    cr
    3 true NthToggle new 8 mainloop
    NUM 0 ?do
    3 true NthToggle new toggle with dispose endwith \ like the C version
    loop ;

main bye

\ $Id: prodcons.bigforth,v 1.1 2001/06/20 20:55:43 doug Exp $
\ http://www.bagley.org/~doug/shootout/
\ from Bernd Paysan

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

Variable count
Variable data
Variable produced
Variable consumed

\ note: no mutex is needed here. bigFORTH's tasker is cooperative
\ and switches tasks only with PAUSE.

: producer 
  up@ swap 2 $1000 dup NewTask pass
  0 ?DO
     BEGIN  count @ 1 =  WHILE  pause  REPEAT
     1 count ! I data !
     1 produced +!
  LOOP wake ;

: consumer 
  up@ swap 2 $1000 dup NewTask pass
  0 swap 0 ?DO
     BEGIN  count @ 0=  WHILE  pause  REPEAT
     0 count ! drop data @
     1 consumed +!
  LOOP drop wake ;

NUM producer
NUM consumer

\ There is no "main" task - to synchronize, each of the two new
\ threads get the task address of the starting task, and wake it
\ when they are done. The main task therefore has to stop twice
\ (and wait to be woken up)

stop stop

produced @ .
consumed @ 1 u.r cr

bye \ th-th-that's all folks!

\ -*- mode: forth -*-
\ $Id: random.bigforth,v 1.1 2001/06/20 23:23:29 doug Exp $
\ http://www.bagley.org/~doug/shootout/
\ based on code from Marcel Hendrix

\needs float  import float  float also

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

 139968     CONSTANT IM 
   3877     CONSTANT IA
  29573     CONSTANT IC
IM S>D D>F 
1e FSWAP F/ FCONSTANT FIM 
     42     VALUE seed

: format-float  ff$ type ;

: IM_mod  
    S" DUP $001DF757 UM* NIP  $FFFFFFC0 AND  2187 *  - " 
    EVALUATE ; IMMEDIATE

: gen_random  
    S" seed IA *  IC +  IM_mod  DUP TO seed 0 D>F " EVALUATE
     S" FIM F* F* " EVALUATE ; IMMEDIATE

: MAIN 
    NUM
    10 SET-PRECISION
    0e  BEGIN  ?DUP  
        WHILE  1- FDROP 100e0 gen_random  
        REPEAT
    format-float cr ;

MAIN 
bye

\ -*- mode: forth -*-
\ $Id: reversefile.bigforth,v 1.2 2001/06/24 22:53:06 doug Exp $
\ http://www.bagley.org/~doug/shootout/

\ Idea by albert@spenarnc.xs4all.nl (Albert van der Horst) in
\ news:<GFDtFA.Lwz.1.spenarn@spenarnc.xs4all.nl>

2000000 constant size \ maximum size of input
size allocate throw constant buf
4096 constant linesize
create line linesize 2 + allot

: revfile   >r
    line buf size + begin 
        1-
        line linesize r@ read-line throw
    while  \ !! handle line buf overflows
        >r #lf over c! 
        r@ - 2dup r> move 
    repeat
    drop nip 1+ buf size + over -  rdrop ;

stdin revfile type bye

\ $Id: sieve.bigforth,v 1.1 2001/06/19 16:20:46 doug Exp $
\ http://www.bagley.org/~doug/shootout/
\ adapted from a program in the gforth distribution 
\ modified and annotated by doug bagley

\ find and count all primes from 2 to 8192

decimal

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

\ we search for primes up to this SIZE
8192 constant SIZE

\ Flags is an array of chars of length SIZE
\ we'll mark all non-prime indexes in this array as false
\ the remaining indexes will be prime numbers
create Flags SIZE allot

\ EndFlags points to end of array Flags
Flags SIZE + constant EndFlags

\ FLAGMULTS
\ flag all multiples of n in array as not prime
\ array has address range: fromaddr toaddr
\ starting value for fromaddr should be
\   arraystart n n + +
: flagmults 
    do
    0 i c! dup
    +loop ;
\ END FLAGMULTS


\ PRIMES
\ find all primes from 2 to SIZE
: primes  
\ fill array Flags with 1's
    Flags SIZE 1 fill
    0 2
    \ index i ranges from Flags to EndFlags
    EndFlags Flags
    do
    i c@
    \ If the current Flags[i] is true (i.e. i is prime)
    if
        dup i + dup EndFlags <
        \ If we aren't at end of flags array yet
        if
        EndFlags swap flagmults
        else
        drop
            then
        \ Increment our Count of Primes
            swap 1+ swap
    then
    1+
    loop
    drop \ your pants!
    ;
\ END PRIMES (Returns: Count)

\ BENCHMARK
\ run the test NUM times
: benchmark  0 NUM 0 do  primes nip loop ;


\ now print count of how many Flags are now "true"
." Count: " benchmark  1 u.r cr


\ PPRIMES
\ for testing, we can print out all the prime numbers
: pprimes 
    SIZE 0 do Flags i + c@ if i 2 + . then loop cr ;

\ uncomment the following to print the primes or debug
\ pprimes
\ flags 100 dump

bye \ th-th-that's all folks!

\ -*- mode: forth -*-
\ $Id: strcat.bigforth,v 1.2 2001/06/24 17:08:56 doug Exp $
\ http://www.bagley.org/~doug/shootout/

\ read NUM from last command line argument
0. argc @ 1- arg >number 2drop drop constant NUM

variable hsiz    32                       hsiz !  \ buffer can hold this much
variable hbuf    hsiz @ allocate throw    hbuf !  \ start of buffer
variable hoff    0                        hoff !  \ current offset in buffer

: STUFF s" hello." ;

: strcat 
    dup                              \ dup strlen on stack
    hsiz @ hoff @ - >                \ if strlen > remaining space
    if                               \ reallocate buffer
    hsiz @ 2* hsiz !             \ double size
    hbuf @ hsiz @ resize throw   \ reallocate buffer
    hbuf !                       \ store (possibly new) buffer start
    then
    swap over                        \ stack: strlen straddr strlen
    hbuf @ hoff @ +
    swap cmove>                      \ append from straddr to hbuf+hoff
    hoff @ + hoff !                  \ update hoff
    ;

: main 
    NUM 0
    do
    STUFF strcat
    loop
    \ as a final result push the resultant string on the stack as if we
    \ were going to use it for something.
    hbuf @ hoff @
    \ and print out the length
    1 u.r cr drop ;

main

bye \ th-th-that's all folks!

\ -*- mode: forth -*-
\ $Id: sumcol.bigforth,v 1.1 2001/06/24 22:23:53 doug Exp $
\ http://www.bagley.org/~doug/shootout/

256 constant max-line
create line-buffer max-line 1 + allot

: sumcol 
    0
    begin
    0.0 line-buffer
    line-buffer max-line stdin read-line throw
    while
    >number drop drop d>s +
    repeat
    drop drop drop drop 1 u.r cr ;

sumcol

bye