home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / p3_26dc.seq < prev    next >
Text File  |  1990-04-05  |  2KB  |  78 lines
  1. \ Problem 3.26 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+1 ( guess# secret# old# new# -- guess#+1 secret# old# new# )
  60.         2SWAP SWAP 1+ SWAP 2SWAP ;
  61.  
  62. : .GUESSES ( guess# secret# old# new# -- guess#+1 secret# old# new# )
  63.         3 PICK . ;
  64.  
  65. : GUESS   ( -- )
  66.         0                \ number of guesses
  67.         100 RND 1+ 0     \ random a number ( 0 < rnd < 100 )
  68.                          \ and add a dummy old#
  69.         BEGIN CR ." GUESS " #IN SPACE                \ get user input
  70.         WINNER? IF ." GOT IT" 2DROP 2DROP EXIT THEN  \ winner ? => exit
  71.         HOT?    IF ." HOT "  ELSE                    \ hot ?
  72.         WARMER? IF ." WARMER " ELSE ." COLDER " THEN \ warmer ? or colder ?
  73.                 THEN GUESS+1                         \ inc guesses
  74.         .GUESSES ." GUESSES"  NIP                    \ out guess# and del old#
  75.         AGAIN ;                                      \ guess again
  76.  
  77.  
  78.