home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / p4_5bs.seq < prev    next >
Encoding:
Text File  |  1990-04-14  |  1.5 KB  |  65 lines
  1. \ Balraj Sidhu   Set: 14D4
  2. \ Comp 462 - Forth
  3. \ Date: April 12, 1990
  4. \ Problem 4.5
  5.  
  6.  
  7. \ allocate memory for face cards
  8. create face_value 14 allot
  9.  
  10. \ Variables used
  11. variable heart
  12. variable diamond
  13. variable club
  14. variable spade
  15.  
  16. \ RND function
  17. \ ------------
  18. \ Lesson 4 - page 4
  19. variable seed         1234 seed !
  20.  
  21. \ Generate random number r between 0 and 65535
  22. : (rnd) ( -- r )
  23.         seed @ 259 * 3 + 32767 and dup seed ! ;
  24.  
  25. \ Generate random number r between 0 and n
  26. : rnd ( n -- r)           \ r is a random number 0 <= r < n
  27.         (rnd) 32767 */ ;
  28.  
  29.  
  30. : card ( -- suit value )
  31.         4 rnd 1+ 13 rnd 1+ ;
  32.  
  33. : suit_results ( -- )
  34.         cr
  35.         ." Number of Draws: " . cr
  36.         ."           Heart: " heart @ . cr
  37.         ."         Diamond: " diamond @ . cr
  38.         ."            Club: " club @ . cr
  39.         ."           Spade: " spade @ . cr ;
  40.  
  41. : value_results ( -- )
  42.         cr
  43.         13 0 do i dup ." Card #:" 1+ 2 .r face_value + ."     Drawn: " c@
  44.         . cr loop ;
  45.  
  46. : clear_variables ( -- )
  47.         0 heart !
  48.         0 diamond !
  49.         0 club !
  50.         0 spade !
  51.         face_value 14 erase ;
  52.  
  53. : cards ( n -- )
  54.         dup >r clear_variables
  55.         0 ?do
  56.                 card face_value + dup c@ 1+ swap c!
  57.                 dup 1 = if heart @ 1+ heart ! drop else
  58.                 dup 2 = if diamond @ 1+ diamond ! drop else
  59.                     3 = if club @ 1+ club ! else
  60.                         spade @ 1+ spade ! then then then
  61.         loop
  62.         r> suit_results value_results ;
  63.  
  64.  
  65.