home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / poker.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  7.8 KB  |  306 lines
  1. ; AisleRiot - poker.scm
  2. ; Copyright (C) 2001, 2003 Rosanna Yuen <zana@webwynk.net>
  3. ;
  4. ; This game is free software; you can redistribute it and/or modify
  5. ; it under the terms of the GNU General Public License as published by
  6. ; the Free Software Foundation; either version 2, or (at your option)
  7. ; any later version.
  8. ;
  9. ; This program is distributed in the hope that it will be useful,
  10. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ; GNU General Public License for more details.
  13. ;
  14. ; You should have received a copy of the GNU General Public License
  15. ; along with this program; if not, write to the Free Software
  16. ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  17. ; USA
  18.  
  19. (define shuffle-mode #f)
  20.  
  21. (define ORDERED-LIST '())
  22.  
  23. (define (new-game)
  24.   (initialize-playing-area)
  25.   (set-ace-low)
  26.   (make-standard-deck)
  27.   (shuffle-deck)
  28.  
  29.   (add-normal-slot DECK)
  30.   (add-normal-slot '())
  31.  
  32.   (add-blank-slot)
  33.  
  34.   (add-normal-slot '())
  35.   (add-normal-slot '())
  36.   (add-normal-slot '())
  37.   (add-normal-slot '())
  38.   (add-normal-slot '())
  39.  
  40.   (add-carriage-return-slot)
  41.  
  42.   (add-blank-slot)
  43.   (add-blank-slot)
  44.   (add-blank-slot)
  45.  
  46.   (add-normal-slot '())
  47.   (add-normal-slot '())
  48.   (add-normal-slot '())
  49.   (add-normal-slot '())
  50.   (add-normal-slot '())
  51.   (add-carriage-return-slot)
  52.  
  53.   (add-blank-slot)
  54.   (add-blank-slot)
  55.   (add-blank-slot)
  56.  
  57.   (add-normal-slot '())
  58.   (add-normal-slot '())
  59.   (add-normal-slot '())
  60.   (add-normal-slot '())
  61.   (add-normal-slot '())
  62.   (add-carriage-return-slot)
  63.  
  64.   (add-blank-slot)
  65.   (add-blank-slot)
  66.   (add-blank-slot)
  67.  
  68.   (add-normal-slot '())
  69.   (add-normal-slot '())
  70.   (add-normal-slot '())
  71.   (add-normal-slot '())
  72.   (add-normal-slot '())
  73.   (add-carriage-return-slot)
  74.  
  75.   (add-blank-slot)
  76.   (add-blank-slot)
  77.   (add-blank-slot)
  78.  
  79.   (add-normal-slot '())
  80.   (add-normal-slot '())
  81.   (add-normal-slot '())
  82.   (add-normal-slot '())
  83.   (add-normal-slot '())
  84.   (deal-cards-face-up 0 '(1))
  85.   (list 8 5))
  86.  
  87. (define (button-pressed slot-id card-list)
  88.   (and (not (empty-slot? slot-id))
  89.        (if shuffle-mode
  90.            (> slot-id 0)
  91.            (= slot-id 1))))
  92.  
  93. (define (check-straight-flush card1 card2 card3 card4 card5)
  94.   (and (check-straight)
  95.        (check-flush card1 card2 card3 card4 card5)
  96.        (add-to-score! 13)))
  97.  
  98. (define (caddddr some-list)
  99.   (cadddr (cdr some-list)))
  100.  
  101. (define (check-four)
  102.   (and (= (cadr ORDERED-LIST)
  103.       (caddr ORDERED-LIST)
  104.       (cadddr ORDERED-LIST))
  105.        (or (= (car ORDERED-LIST)
  106.           (cadr ORDERED-LIST))
  107.        (= (caddddr ORDERED-LIST))
  108.        (cadr ORDERED-LIST))
  109.        (add-to-score! 16)))
  110.  
  111. (define (checking-straight-list num-list)
  112.   (if (= (length num-list) 1)
  113.       #t
  114.       (or (and (= (+ 1 (car num-list))
  115.           (cadr num-list))
  116.            (checking-straight-list (cdr num-list)))
  117.       (and (= (car num-list) 1)
  118.            (= (cadr num-list) 10)
  119.            (checking-straight-list (cdr num-list))))))
  120.  
  121. (define (get-ordered-list card1 card2 card3 card4 card5)
  122.   (set! ORDERED-LIST (sort (list (get-value card1)
  123.                  (get-value card2)
  124.                  (get-value card3)
  125.                  (get-value card4)
  126.                  (get-value card5))
  127.                (lambda (x y) (< x y)))))
  128.  
  129. (define (check-straight)
  130.   (if (checking-straight-list ORDERED-LIST)
  131.       (add-to-score! 12)
  132.       #f))
  133.  
  134. (define (check-full)
  135.   (and (= (car ORDERED-LIST)
  136.       (cadr ORDERED-LIST))
  137.        (= (cadddr ORDERED-LIST)
  138.       (caddddr ORDERED-LIST))
  139.        (or (= (car ORDERED-LIST)
  140.           (caddr ORDERED-LIST))
  141.        (= (caddddr ORDERED-LIST)
  142.           (caddr ORDERED-LIST)))
  143.        (add-to-score! 10)))
  144.  
  145. (define (check-three)
  146.   (and (or (= (car ORDERED-LIST)
  147.           (cadr ORDERED-LIST)
  148.           (caddr ORDERED-LIST))
  149.        (= (cadr ORDERED-LIST)
  150.           (caddr ORDERED-LIST)
  151.           (cadddr ORDERED-LIST))
  152.        (= (caddr ORDERED-LIST)
  153.           (cadddr ORDERED-LIST)
  154.           (caddddr ORDERED-LIST)))
  155.        (add-to-score! 6)))
  156.  
  157. (define (check-flush card1 card2 card3 card4 card5)
  158.   (and (= (get-suit card1)
  159.       (get-suit card2)
  160.       (get-suit card3)
  161.       (get-suit card4)
  162.       (get-suit card5))
  163.        (add-to-score! 5)))
  164.  
  165. (define (check-two)
  166.   (and (or (and (= (car ORDERED-LIST)
  167.            (cadr ORDERED-LIST))
  168.         (= (caddr ORDERED-LIST)
  169.            (cadddr ORDERED-LIST)))
  170.        (and (= (car ORDERED-LIST)
  171.            (cadr ORDERED-LIST))
  172.         (= (cadddr ORDERED-LIST)
  173.            (caddddr ORDERED-LIST)))
  174.        (and (= (cadr ORDERED-LIST)
  175.            (caddr ORDERED-LIST))
  176.         (= (cadddr ORDERED-LIST)
  177.            (caddddr ORDERED-LIST))))
  178.        (add-to-score! 3)))
  179.  
  180. (define (check-one)
  181.   (and (or (= (car ORDERED-LIST)
  182.           (cadr ORDERED-LIST))
  183.        (= (cadr ORDERED-LIST)
  184.           (caddr ORDERED-LIST))
  185.        (= (caddr ORDERED-LIST)
  186.           (cadddr ORDERED-LIST))
  187.        (= (cadddr ORDERED-LIST)
  188.           (caddddr ORDERED-LIST)))
  189.        (add-to-score! 1)))
  190.  
  191. (define (check-hand card1 card2 card3 card4 card5)
  192.   (get-ordered-list card1 card2 card3 card4 card5)
  193.   (or (check-straight-flush card1 card2 card3 card4 card5)
  194.       (check-four)
  195.       (check-full)
  196.       (check-three)
  197.       (check-flush card1 card2 card3 card4 card5)
  198.       (check-two)
  199.       (check-one)
  200.       #t))
  201.  
  202. (define (check-a-horiz buffer)
  203.   (and (not (empty-slot? (+ 2 buffer)))
  204.        (not (empty-slot? (+ 3 buffer)))
  205.        (not (empty-slot? (+ 4 buffer)))
  206.        (not (empty-slot? (+ 5 buffer)))
  207.        (not (empty-slot? (+ 6 buffer)))
  208.        (check-hand (get-top-card (+ 2 buffer))
  209.            (get-top-card (+ 3 buffer))
  210.            (get-top-card (+ 4 buffer))
  211.            (get-top-card (+ 5 buffer))
  212.            (get-top-card (+ 6 buffer))))
  213.   (or (= buffer 20)
  214.       (check-a-horiz (+ buffer 5))))
  215.  
  216. (define (check-a-vert buffer)
  217.   (and (not (empty-slot? (+ 2 buffer)))
  218.        (not (empty-slot? (+ 7 buffer)))
  219.        (not (empty-slot? (+ 12 buffer)))
  220.        (not (empty-slot? (+ 17 buffer)))
  221.        (not (empty-slot? (+ 22 buffer)))
  222.        (check-hand (get-top-card (+ 2 buffer))
  223.            (get-top-card (+ 7 buffer))
  224.            (get-top-card (+ 12 buffer))
  225.            (get-top-card (+ 17 buffer))
  226.            (get-top-card (+ 22 buffer))))
  227.   (or (= buffer 4)
  228.       (check-a-vert (+ buffer 1))))
  229.  
  230. (define (check-diags)
  231.   (and (not (empty-slot? 2))
  232.        (not (empty-slot? 8))
  233.        (not (empty-slot? 14))
  234.        (not (empty-slot? 20))
  235.        (not (empty-slot? 26))
  236.        (check-hand (get-top-card 2)
  237.            (get-top-card 8)
  238.            (get-top-card 14)
  239.            (get-top-card 20)
  240.            (get-top-card 26)))
  241.   (and (not (empty-slot? 6))
  242.        (not (empty-slot? 10))
  243.        (not (empty-slot? 14))
  244.        (not (empty-slot? 18))
  245.        (not (empty-slot? 22))
  246.        (check-hand (get-top-card 6)
  247.            (get-top-card 10)
  248.            (get-top-card 14)
  249.            (get-top-card 18)
  250.            (get-top-card 22))))
  251.  
  252. (define (recalculate-score)
  253.   (set-score! 0)
  254.   (check-diags)
  255.   (check-a-vert 0)
  256.   (check-a-horiz 0))
  257.  
  258. (define (droppable? start-slot card-list end-slot)
  259.   (and (or shuffle-mode
  260.            (empty-slot? end-slot))
  261.        (> end-slot 1)
  262.        (or (> start-slot 1)
  263.            (empty-slot? end-slot))))
  264.  
  265. (define (button-released start-slot card-list end-slot)
  266.   (and (droppable? start-slot card-list end-slot)
  267.        (or (empty-slot? end-slot)
  268.            (deal-cards end-slot (list start-slot)))
  269.        (move-n-cards! start-slot end-slot card-list)
  270.        (or (> start-slot 1)
  271.            (deal-cards-face-up 0 '(1)))
  272.        (recalculate-score)))
  273.  
  274. (define (button-clicked slot-id)
  275.   #f)
  276.  
  277. (define (button-double-clicked slot-id)
  278.   #f)
  279.  
  280. (define (game-continuable)
  281.   (or (> (length (get-cards 0)) 27)
  282.       (not (empty-slot? 1))))
  283.  
  284. (define (game-won)
  285.   (if shuffle-mode
  286.       (> (get-score) 119)
  287.       (> (get-score) 74)))
  288.  
  289. (define (get-hint)
  290.   (list 0 (_"Place cards on to the Tableau to form poker hands")))
  291.  
  292. (define (get-options)
  293.   (list (list (_"Shuffle mode") shuffle-mode)))
  294.  
  295. (define (apply-options options)
  296.   (set! shuffle-mode (cadar options)))
  297.  
  298. (define (timeout) 
  299.   #f)
  300.  
  301. (set-features droppable-feature)
  302.  
  303. (set-lambda new-game button-pressed button-released button-clicked
  304. button-double-clicked game-continuable game-won get-hint get-options
  305. apply-options timeout droppable?)
  306.