home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / thumb_and_pouch.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  7.7 KB  |  275 lines
  1. ; AisleRiot - thumb_and_pouch.scm
  2. ; Copyright (C) 1999, 2003 Rosanna Yuen <rwsy@mit.edu>
  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 tableau '(6 7 8 9 10 11 12))
  20. (define foundation '(2 3 4 5))
  21.  
  22. (define (new-game)
  23.   (initialize-playing-area)
  24.   (set-ace-low)
  25.  
  26.   (make-standard-deck)
  27.   (shuffle-deck)
  28.   
  29.   (add-normal-slot DECK)
  30.  
  31.   (add-normal-slot '())
  32.  
  33.   (add-blank-slot)
  34.   (add-normal-slot '())
  35.   (add-normal-slot '())
  36.   (add-normal-slot '())
  37.   (add-normal-slot '())
  38.   (add-carriage-return-slot)
  39.   (add-extended-slot '() down)
  40.   (add-extended-slot '() down)
  41.   (add-extended-slot '() down)
  42.   (add-extended-slot '() down)
  43.   (add-extended-slot '() down)
  44.   (add-extended-slot '() down)
  45.   (add-extended-slot '() down)
  46.  
  47.   (deal-cards 0 '(6 7 8 9 10 11 12 7 8 9 10 11 12 8 9 10 11 12 9 10 11 12 10 11 12 11 12 12))
  48.  
  49.   (map flip-top-card tableau)
  50.  
  51.   (give-status-message)
  52.  
  53.   (list 7 3))
  54.  
  55. (define (give-status-message)
  56.   (set-statusbar-message (string-append (get-stock-no-string)
  57.                     "   "
  58.                     (get-redeals-string))))
  59.  
  60. (define (get-stock-no-string)
  61.   (string-append (_"Stock left:") " " 
  62.          (number->string (length (get-cards 0)))))
  63.  
  64. (define (get-redeals-string)
  65.   (string-append (_"Redeals left:") " "
  66.          (number->string (- 2 FLIP-COUNTER))))
  67.  
  68. (define (button-pressed slot-id card-list)
  69.   (and (or (> slot-id 1)
  70.        (and (= slot-id 1)
  71.         (= (length card-list) 1)))
  72.        (is-visible? (car (reverse card-list)))))
  73.  
  74. (define (complete-transaction start-slot card-list end-slot)
  75.   (move-n-cards! start-slot end-slot card-list)
  76.   (if (member start-slot foundation)
  77.       (add-to-score! -1))
  78.   (if (member end-slot foundation)
  79.       (add-to-score! 1))
  80.   (if (and (not (empty-slot? start-slot)) 
  81.        (member start-slot tableau))
  82.       (make-visible-top-card start-slot))
  83.   #t)
  84.  
  85. (define (droppable? start-slot card-list end-slot)
  86.   (and (not (= start-slot end-slot))
  87.        (or (and (member end-slot tableau)
  88.         (or (empty-slot? end-slot)
  89.             (and (not (eq? (get-suit (get-top-card end-slot))
  90.                    (get-suit (car (reverse card-list)))))
  91.              (= (get-value (get-top-card end-slot))
  92.                 (+ 1 (get-value (car (reverse card-list))))))))
  93.        (and (member end-slot foundation)
  94.         (= 1 (length card-list))
  95.         (or (and (empty-slot? end-slot)
  96.              (= ace (get-value (car card-list))))
  97.             (and (not (empty-slot? end-slot))
  98.              (eq? (get-suit (get-top-card end-slot))
  99.                   (get-suit (car card-list)))
  100.              (= (get-value (get-top-card end-slot))
  101.                 (- (get-value (car card-list)) 1))))))))
  102.  
  103. (define (button-released start-slot card-list end-slot)
  104.   (and (droppable? start-slot card-list end-slot)
  105.        (complete-transaction start-slot card-list end-slot)))
  106.  
  107. (define (button-clicked slot-id)
  108.   (and (= slot-id 0)
  109.        (flip-stock 0 1 2)
  110.        (give-status-message)))
  111.  
  112. (define (button-double-clicked slot-id)
  113.   (and (or (member slot-id tableau)
  114.        (= slot-id 1))
  115.        (not (empty-slot? slot-id))
  116.        (let* ((card (get-top-card slot-id))
  117.           (suit (get-suit card))
  118.           (value (get-value card)))
  119.      (let ((end-slot 
  120.         (cond ((if (empty-slot? 2)
  121.                (= ace value)
  122.                (= suit (get-suit (get-top-card 2)))) 2)
  123.               ((if (empty-slot? 3)
  124.                (= ace value)
  125.                (= suit (get-suit (get-top-card 3)))) 3)
  126.               ((if (empty-slot? 4)
  127.                (= ace value)
  128.                (= suit (get-suit (get-top-card 4)))) 4)
  129.               ((if (empty-slot? 5)
  130.                (= ace value)
  131.                (= suit (get-suit (get-top-card 5)))) 5)
  132.               (#t #f))))
  133.        (and end-slot
  134.         (or (= ace value)
  135.             (= (get-value (get-top-card end-slot)) (- value 1)))
  136.         (remove-card slot-id)
  137.         (complete-transaction slot-id (list card) end-slot))))))
  138.  
  139. (define (game-continuable)
  140.   (get-hint))
  141.  
  142. (define (game-won)
  143.   (and (= 13 (length (get-cards 2)))
  144.        (= 13 (length (get-cards 3)))
  145.        (= 13 (length (get-cards 4)))
  146.        (= 13 (length (get-cards 5)))))
  147.  
  148. (define (dealable?)
  149.   (or (and (not (empty-slot? 0))
  150.        (list 0 (_"Deal another round")))
  151.       (and (not (empty-slot? 1))
  152.        (< FLIP-COUNTER 2)
  153.        (list 0 (_"Move waste back to stock")))))
  154.  
  155. (define (empty-exist? slot-id)
  156.   (cond ((= slot-id 13)
  157.      #f)
  158.     ((empty-slot? slot-id)
  159.      #t)
  160.     (#t
  161.      (empty-exist? (+ 1 slot-id)))))
  162.  
  163. (define (check-waste-to-empty)
  164.   (and (not (empty-slot? 1))
  165.        (list 2 (get-name (get-top-card 1)) (_"an empty tableau pile"))))
  166.  
  167. (define (stripped card-list)
  168.   (if (not (is-visible? (cadr card-list)))
  169.       (car card-list)
  170.       (stripped (cdr card-list))))
  171.  
  172. (define (check-tableau-to-empty slot-id)
  173.   (cond ((= slot-id 13)
  174.      #f)
  175.     ((and (not (empty-slot? slot-id))
  176.           (not (is-visible? (car (reverse (get-cards slot-id))))))
  177.      (list 2 (get-name (stripped (get-cards slot-id))) (_"an empty tableau pile")))
  178.     (#t (check-tableau-to-empty (+ 1 slot-id)))))
  179.  
  180.  
  181. (define (check-empty?)
  182.   (and (empty-exist? 6)
  183.        (or (check-tableau-to-empty 6)
  184.        (check-waste-to-empty))))
  185.  
  186. (define (check-a-foundation slot-id card f-slot)
  187.   (cond ((or (> f-slot 5)
  188.          (or (< slot-id 0)
  189.          (empty-slot? slot-id)))
  190.      #f)
  191.     ((and (empty-slot? f-slot)
  192.           (= (get-value card) ace))
  193.      (if (< slot-id 0)
  194.          #t
  195.          (list 2
  196.            (get-name (get-top-card slot-id)) 
  197.            (_"an empty foundation pile"))))
  198.     ((and (not (empty-slot? f-slot))
  199.           (eq? (get-suit (get-top-card f-slot))
  200.            (get-suit card))
  201.           (= (get-value card)
  202.          (+ 1 (get-value (get-top-card f-slot)))))
  203.      (if (< slot-id 0)
  204.          #t
  205.          (list 1
  206.            (get-name (get-top-card slot-id))
  207.            (get-name (get-top-card f-slot)))))
  208.     (#t
  209.      (check-a-foundation slot-id card (+ 1 f-slot)))))
  210.  
  211. (define (check-to-foundations slot-id)
  212.   (cond ((> slot-id 12)
  213.      #f)
  214.     ((= slot-id 2)
  215.      (check-to-foundations 6))
  216.     (#t
  217.      (or (check-a-foundation slot-id (get-top-card slot-id) 2)
  218.          (check-to-foundations (+ 1 slot-id))))))
  219.  
  220. (define (check-a-tslot card card-list)
  221.   (and (not (or (= (length card-list) 0)
  222.         (not (is-visible? (car card-list)))
  223.         (>= (get-value (car card-list)) (get-value card))))
  224.        (or (and (= (get-value card)
  225.            (+ 1 (get-value (car card-list))))
  226.         (not (eq? (get-suit card)
  227.               (get-suit (car card-list))))
  228.         (or (= (length card-list) 1)
  229.             (not (is-visible? (cadr card-list)))
  230.             (check-a-foundation -1 (cadr card-list) 2))
  231.         (list 1 (get-name (car card-list)) (get-name card)))
  232.        (check-a-tslot card (cdr card-list)))))
  233.  
  234. (define (check-tslot to-slot from-slot)
  235.   (cond ((> from-slot 12)
  236.      #f)
  237.     ((= from-slot 2)
  238.      (check-tslot to-slot 6))
  239.     ((empty-slot? to-slot)
  240.      (check-tslot to-slot (+ 1 from-slot)))
  241.     (#t 
  242.      (or (and (= from-slot 1)
  243.           (not (empty-slot? 1))
  244.           (check-a-tslot (get-top-card to-slot)
  245.                  (list (get-top-card from-slot))))
  246.          (check-a-tslot (get-top-card to-slot)
  247.                 (get-cards from-slot))
  248.          (check-tslot to-slot (+ 1 from-slot))))))
  249.  
  250. (define (check-to-tableau slot-id)
  251.   (and (not (> slot-id 12))
  252.        (or (check-tslot slot-id 1)
  253.        (check-to-tableau (+ 1 slot-id)))))
  254.  
  255. (define (get-hint)
  256.   (or (check-to-foundations 1)
  257.       (check-to-tableau 6)
  258.       (check-empty?)
  259.       (dealable?)))
  260.  
  261. (define (get-options) 
  262.   #f)
  263.  
  264. (define (apply-options options) 
  265.   #f)
  266.  
  267. (define (timeout) 
  268.   #f)
  269.  
  270. (set-features droppable-feature)
  271.  
  272. (set-lambda new-game button-pressed button-released button-clicked
  273. button-double-clicked game-continuable game-won get-hint get-options
  274. apply-options timeout droppable?)
  275.