home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / p4_5dc.seq < prev    next >
Encoding:
Text File  |  1990-04-11  |  2.8 KB  |  93 lines
  1. \ Problem 4.5    04/10/90 18:56:59.54
  2.  
  3.  
  4. VARIABLE SEED  1234 SEED !
  5.  
  6. VARIABLE HEART
  7. VARIABLE DIAMOND
  8. VARIABLE CLUB
  9. VARIABLE SPADE
  10.  
  11. VARIABLE ONE
  12. VARIABLE TWO
  13. VARIABLE THREE
  14. VARIABLE FOUR
  15. VARIABLE FIVE
  16. VARIABLE SIX
  17. VARIABLE SEVEN
  18. VARIABLE EIGHT
  19. VARIABLE NINE
  20. VARIABLE TEN
  21. VARIABLE ELEVEN
  22. VARIABLE TWELVE
  23. VARIABLE THIRTEEN
  24.  
  25.  
  26. : (RND)         ( -- r )
  27.         SEED @ 259 * 3 + 32767 AND DUP SEED ! ;
  28.  
  29. : RND           ( n -- r )
  30.         (RND) 32767 */ ;
  31.  
  32. : DRAW          ( -- suit value )
  33.         4 RND 1+ 13 RND 1+ ;
  34.  
  35. : INIT          ( -- )
  36.         0 HEART !  0 DIAMOND ! 0 CLUB !    0 SPADE !
  37.         0 ONE !    0 TWO !     0 THREE !   0 FOUR !  0 FIVE !
  38.         0 SIX !    0 SEVEN !   0 EIGHT !   0 NINE !  0 TEN !
  39.         0 ELEVEN ! 0 TWELVE !  0 THIRTEEN ! ;
  40.  
  41. : UPDATE_VALUE  ( value -- )
  42.         DUP  1 = IF ONE      @ 1+ ONE      ! ELSE
  43.         DUP  2 = IF TWO      @ 1+ TWO      ! ELSE
  44.         DUP  3 = IF THREE    @ 1+ THREE    ! ELSE
  45.         DUP  4 = IF FOUR     @ 1+ FOUR     ! ELSE
  46.         DUP  5 = IF FIVE     @ 1+ FIVE     ! ELSE
  47.         DUP  6 = IF SIX      @ 1+ SIX      ! ELSE
  48.         DUP  7 = IF SEVEN    @ 1+ SEVEN    ! ELSE
  49.         DUP  8 = IF EIGHT    @ 1+ EIGHT    ! ELSE
  50.         DUP  9 = IF NINE     @ 1+ NINE     ! ELSE
  51.         DUP 10 = IF TEN      @ 1+ TEN      ! ELSE
  52.         DUP 11 = IF ELEVEN   @ 1+ ELEVEN   ! ELSE
  53.         DUP 12 = IF TWELVE   @ 1+ TWELVE   ! ELSE
  54.                     THIRTEEN @ 1+ THIRTEEN !
  55.         THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN DROP ;
  56.  
  57. : UPDATE_SUIT ( suit -- )
  58.         DUP 1 = IF HEART   @ 1+ HEART !   ELSE
  59.         DUP 2 = IF DIAMOND @ 1+ DIAMOND ! ELSE
  60.         DUP 3 = IF CLUB    @ 1+ CLUB !    ELSE
  61.                    SPADE   @ 1+ SPADE !
  62.         THEN THEN THEN DROP ;
  63.  
  64.  
  65. : CARD          ( n -- )
  66.         CLS INIT
  67.         ABS DUP 0 ?DO
  68.                 DRAW UPDATE_VALUE UPDATE_SUIT
  69.         LOOP
  70.         CR ." Number of draw : " 3 .R
  71.         CR
  72.         CR ."          Heart : " HEART    @ 3 .R
  73.         CR ."        Diamond : " DIAMOND  @ 3 .R
  74.         CR ."           Club : " CLUB     @ 3 .R
  75.         CR ."          Spade : " SPADE    @ 3 .R
  76.         CR CR
  77.         CR ."            One : " ONE      @ 3 .R
  78.         CR ."            Two : " TWO      @ 3 .R
  79.         CR ."          Three : " THREE    @ 3 .R
  80.         CR ."           Four : " FOUR     @ 3 .R
  81.         CR ."           Five : " FIVE     @ 3 .R
  82.         CR ."            Six : " SIX      @ 3 .R
  83.         CR ."          Seven : " SEVEN    @ 3 .R
  84.         CR ."          Eight : " EIGHT    @ 3 .R
  85.         CR ."           Nine : " NINE     @ 3 .R
  86.         CR ."            Ten : " TEN      @ 3 .R
  87.         CR ."         Eleven : " ELEVEN   @ 3 .R
  88.         CR ."         Twelve : " TWELVE   @ 3 .R
  89.         CR ."       Thirteen : " THIRTEEN @ 3 .R
  90.         CR ;
  91.  
  92.  
  93.