home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / p3_25dc.seq < prev    next >
Text File  |  1990-04-05  |  2KB  |  70 lines
  1. \ Problem 3.25 by Dickson Cheng  04/05/90 21:12:50.93
  2.  
  3.  
  4.  
  5. \ (IN) leaves a true flag if a < x < b , otherwise false.
  6. : (IN)          ( x a b -- flag )
  7.         OVER 1 PICK > IF SWAP THEN
  8.         -ROT OVER < -ROT > AND ;
  9.  
  10. \ [IN] leaves a true flag if a <= x <= b
  11. : [IN]          ( x a b -- flag )
  12.         1+ SWAP 1- SWAP (IN) ;
  13.  
  14. : DIGIT?        ( n -- flag )
  15.         48 ( ASCII 0 ) 57 ( ASCII 9 ) [IN] ;
  16.  
  17. : RUBOUT        ( -- )
  18.         8 EMIT SPACE 8 EMIT ;
  19.  
  20. : -DIGIT        ( n -- n/10 )
  21.         10 / ;
  22.  
  23. : +DIGIT        ( n c -- 10n+c-48 )
  24.         48 - SWAP 10 * + ;
  25.  
  26. : #IN           ( -- n )
  27.       0 BEGIN KEY
  28.         DUP 13 ( enter ) =
  29.         IF DROP EXIT THEN
  30.         DUP 8 ( backspace ) =
  31.         IF DROP RUBOUT -DIGIT
  32.         ELSE DUP DIGIT?
  33.              IF  DUP EMIT
  34.                  +DIGIT
  35.              ELSE DROP
  36.                   7 ( bell ) EMIT
  37.              THEN
  38.         THEN
  39.         AGAIN ;
  40.  
  41.  
  42. VARIABLE SEED  12345 SEED !
  43. : (RND) SEED @ 259 * 3 + 32767 AND DUP SEED ! ;
  44.  
  45. \ r is a random number 0 <= r < n
  46. : RND           ( n -- r )
  47.         (RND) 32767 */ ;
  48.  
  49. : WINNER? ( secret old# new# -- secret old# new# flag )
  50.         2 PICK OVER = ;
  51.  
  52. : HOT?    ( secret old# new# -- secred old# new# flag )
  53.         2 PICK OVER - ABS 3 < ;
  54.  
  55. : WARMER? ( secret old# new# -- secret old# new# flag )
  56.         2 PICK OVER - ABS
  57.         3 PICK 3 PICK - ABS < ;
  58.  
  59. : GUESS   ( -- )
  60.         100 RND 1+ 0     \ random a number ( 0 < rnd < 100 )
  61.                          \ and add a dummy old#
  62.         BEGIN CR ." GUESS " #IN SPACE                \ get user input
  63.         WINNER? IF ." GOT IT" DROP 2DROP EXIT THEN   \ winner ? => exit
  64.         HOT?    IF ." HOT "  ELSE                    \ hot ?
  65.         WARMER? IF ." WARMER " ELSE ." COLDER " THEN \ warmer ? or colder ?
  66.                 THEN NIP                             \ del old#
  67.         AGAIN ;                                      \ guess again
  68.  
  69.  
  70.