\ Gforth 0.7.0                           jgt 02jan12
\ ask (mit s>number?) kann eliminiert werden.

: head  ( --)  cr cr
  cr ."   Wahrscheinlichkeit gemeinsamer Geburtstage"
  cr ."   in einer Gruppe zufälliger Personen."
  cr ."   Dazu müssen viele Gruppen getestet werden." ;
: request  ( --)  cr
  cr ."   Geben Sie Anzahl der Gruppen und Personen"
  cr ."   sowie die Jahreslänge ein (oder return):" cr ;

   100000  value groups
       23  value persons
      365  value days

: ask  ( --)
    begin  cr ."   Gruppen:   [ " groups . ." ] "
                           pad 7 accept
           dup if          pad swap s>number?
                    if     d>s abs to groups  true
                    else   2drop              false
                    then
               else        0=  ( null string)
               then
    until
    begin  cr ."   Personen:  [ " persons . ." ] "
                           pad 3 accept  
           dup if          pad swap s>number?
                    if     d>s abs to persons true
                    else   2drop              false
                    then
               else        0=  ( null string)
               then
    until
    begin  cr ."   Tage/Jahr: [ " days . ." ] "
                           pad 3 accept  
           dup if          pad swap s>number?
                    if     d>s abs to days    true
                    else   2drop              false
                    then
               else        0=  ( null string)
               then
    until ;

   create date-array days allot
           variable  accu
           variable  flag

\ Random generator (1...2^32-1)
  1234567890 value (rnd) \ seed <> 0
: rnd32  ( -- n)
    (rnd) dup 13 lshift xor
    dup 17 rshift xor
    dup dup 5 lshift xor to (rnd) ;

\ Random generator (0...2^16-1)
: rnd16  ( -- n)  rnd32 65535 and ;

\ Random generator (0...days-1)
: rnd  ( -- n)  rnd16 days * 65536 / ;

: clear-array  ( --)
    days 0 do  0 date-array i + c!   loop ;

: fill-array  ( --)
    persons 0 do  date-array rnd +
                  dup c@ 1+ swap c!  loop ;

: doubles?  ( -- f)
    days 0 do  date-array i + c@
              1 > if -1 flag ! then  loop
              flag @ ;

: workout  ( -- n)  0 accu !
    groups 0 do  0 flag !  clear-array fill-array
                 doubles? if accu dup @ 1+ swap !
                          then
             loop         accu @ 10000 * groups / ;

: percent  ( n --)  s>d swap over dabs
                <# # # [char] . hold
                # #s rot sign #> type ."  % " ;

: tell  ( n --)  cr
    cr ."   " groups . ." Gruppen zu " persons .
            ." Personen ergaben " dup . ." Treffer."
    cr ."   Damit ist die Wahrscheinlichkeit für "
            ." mindestens"
    cr ."   einen gemeinsamen Geburtstag ungefähr "
            percent cr ;

: nomore?  ( -- f)  cr cr ."   nochmal? [ j/n ] "
                    key [char] n = ;

: wayout  ( --) 
    cr ."   QUIT - Neustart mit »go«.  ok" quit ;

: go  ( --)  head begin  request ask ."  ..."
                         workout tell nomore? 
                         if cr wayout then
                  again ;    go