home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / bakers_game.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  7.8 KB  |  252 lines
  1. ; AisleRiot - bakers_game.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. (def-save-var free-reserves 0)
  20.  
  21. (define reserve '(0 1 2 3))
  22. (define foundation '(4 5 6 7))
  23. (define tableau '(8 9 10 11 12 13 14 15))
  24.  
  25. (define (new-game)
  26.   (initialize-playing-area)
  27.   (set-ace-low)
  28.   (make-standard-deck)
  29.   (shuffle-deck)
  30.  
  31.   (add-normal-slot DECK)
  32.   (add-normal-slot '())
  33.   (add-normal-slot '())
  34.   (add-normal-slot '())
  35.   (add-blank-slot)
  36.   (add-normal-slot '())
  37.   (add-normal-slot '())
  38.   (add-normal-slot '())
  39.   (add-normal-slot '())
  40.  
  41.   (add-carriage-return-slot)
  42.  
  43.   (set! HORIZPOS 0.5)
  44.  
  45.   (add-extended-slot '() down)
  46.   (add-extended-slot '() down)
  47.   (add-extended-slot '() down)
  48.   (add-extended-slot '() down)
  49.   (add-extended-slot '() down)
  50.   (add-extended-slot '() down)
  51.   (add-extended-slot '() down)
  52.   (add-extended-slot '() down)
  53.  
  54.   (deal-cards-face-up 0 '(8 9 10 11 12 13 14 15 8 9 10 11 12 13 14 15
  55.                 8 9 10 11 12 13 14 15 8 9 10 11 12 13 14
  56.                 15 8 9 10 11 12 13 14 15 8 9 10 11 12 13
  57.                 14 15 8 9 10 11))
  58.  
  59.   (set! free-reserves 4)
  60.  
  61.   (list 9 4))
  62.  
  63. (define (button-pressed slot-id card-list)
  64.   (and (not (empty-slot? slot-id))
  65.        (or (= (length card-list) 1)
  66.        (and (member slot-id tableau)
  67.         (< (length card-list) (+ 2 free-reserves))
  68.         (check-same-suit-list card-list)
  69.         (check-straight-descending-list card-list)))))
  70.  
  71. (define (droppable? start-slot card-list end-slot)
  72.   (cond ((= start-slot end-slot)
  73.      #f)
  74.     ((member end-slot tableau)
  75.      (and (or (and (empty-slot? end-slot)
  76.                (= (get-value (car (reverse card-list)))
  77.               king))
  78.           (and (not (empty-slot? end-slot))
  79.                (= (get-suit (get-top-card end-slot))
  80.               (get-suit (car card-list)))
  81.                (= (get-value (get-top-card end-slot))
  82.               (+ 1 (get-value (car (reverse card-list)))))))))
  83.     ((and (= (length card-list) 1)
  84.           (empty-slot? end-slot)
  85.           (member end-slot reserve))
  86.      #t)
  87.     ((and (= (length card-list) 1)
  88.           (member end-slot foundation))
  89.      (and (or (and (empty-slot? end-slot)
  90.                (= (get-value (car card-list)) ace))
  91.           (and (not (empty-slot? end-slot))
  92.                (= (get-suit (get-top-card end-slot))
  93.               (get-suit (car card-list)))
  94.                (= (+ 1 (get-value (get-top-card end-slot)))
  95.               (get-value (car card-list)))))))
  96.     (#t #f)))
  97.  
  98. (define (button-released start-slot card-list end-slot)
  99.   (and (droppable? start-slot card-list end-slot)
  100.        (move-n-cards! start-slot end-slot card-list)
  101.        (or (not (member start-slot reserve))
  102.            (set! free-reserves (+ free-reserves 1)))
  103.        (or (not (member end-slot reserve))
  104.            (set! free-reserves (- free-reserves 1)))
  105.        (or (not (member start-slot foundation))
  106.            (add-to-score! -1))
  107.        (or (not (member end-slot foundation))
  108.            (add-to-score! 1))))
  109.  
  110. (define (button-clicked slot-id)
  111.   #f)
  112.  
  113. (define (move-to-empty-foundation slot f-slots)
  114.   (cond ((eq? f-slots '())
  115.      #f)
  116.     ((empty-slot? (car f-slots))
  117.      (deal-cards slot (list (car f-slots))))
  118.     (#t (move-to-empty-foundation slot (cdr f-slots)))))
  119.  
  120. (define (move-to-foundation slot f-slots)
  121.   (cond ((eq? f-slots '())
  122.      #f)
  123.     ((and (not (empty-slot? (car f-slots)))
  124.           (= (get-suit (get-top-card slot))
  125.          (get-suit (get-top-card (car f-slots)))))
  126.      (and (= (get-value (get-top-card slot))
  127.          (+ 1 (get-value (get-top-card (car f-slots)))))
  128.           (deal-cards slot (list (car f-slots)))))
  129.     (#t (move-to-foundation slot (cdr f-slots)))))
  130.  
  131. (define (button-double-clicked slot-id)
  132.   (and (not (empty-slot? slot-id))
  133.        (or (member slot-id reserve)
  134.        (member slot-id tableau))
  135.        (or (and (= (get-value (get-top-card slot-id))
  136.            ace)
  137.         (move-to-empty-foundation slot-id foundation))
  138.        (move-to-foundation slot-id foundation))
  139.        (add-to-score! 1)
  140.        (or (member slot-id tableau)
  141.        (set! free-reserves (+ 1 free-reserves)))))
  142.  
  143. (define (game-continuable)
  144.   (and (not (game-won))
  145.        (get-hint)))
  146.  
  147. (define (check-full f-slots)
  148.   (or (eq? f-slots '())
  149.       (and (= (length (get-cards (car f-slots))) 13)
  150.            (check-full (cdr f-slots)))))
  151.  
  152. (define (game-won)
  153.   (check-full foundation))
  154.  
  155. (define (check-to-foundations? slots f-slots)
  156.   (cond ((eq? slots '())
  157.          #f)
  158.         ((or (empty-slot? (car slots))
  159.              (eq? f-slots '()))
  160.          (check-to-foundations? (cdr slots) foundation))
  161.     ((= (get-value (get-top-card (car slots))) ace)
  162.      (list 2 (get-name (get-top-card (car slots))) (_"an empty foundation")))
  163.     ((and (not (empty-slot? (car f-slots)))
  164.           (= (get-suit (get-top-card (car slots)))
  165.          (get-suit (get-top-card (car f-slots))))
  166.           (= (get-value (get-top-card (car slots)))
  167.          (+ 1 (get-value (get-top-card (car f-slots))))))
  168.      (list 1 (get-name (get-top-card (car slots))) (get-name (get-top-card (car f-slots)))))
  169.         (#t (check-to-foundations? slots (cdr f-slots)))))
  170.  
  171. (define (check-for-king card-list iter slot)
  172.   (cond ((= (length card-list) 0)
  173.      #f)
  174.     ((and (= (length card-list) 1)
  175.           (member slot tableau))
  176.      #f)
  177.     ((= (get-value (car card-list)) king)
  178.      (get-name (car card-list)))
  179.     ((= iter 0)
  180.      #f)
  181.     ((and (> (length card-list)1)
  182.           (= (get-suit (car card-list))
  183.          (get-suit (cadr card-list)))
  184.           (= (+ 1 (get-value (car card-list)))
  185.          (get-value (cadr card-list))))
  186.      (check-for-king (cdr card-list) (- iter 1) slot))
  187.     (#t #f)))
  188.  
  189. (define (check-for-spec-card card-list iter value)
  190.   (cond ((= (length card-list) 0)
  191.      #f)
  192.     ((= (get-value (car card-list)) value)
  193.      #t)
  194.     ((= iter 0)
  195.      #f)
  196.     ((and (> (length card-list) 1)
  197.           (= (get-suit (car card-list))
  198.          (get-suit (cadr card-list)))
  199.           (= (+ 1 (get-value (car card-list)))
  200.          (get-value (cadr card-list))))
  201.      (check-for-spec-card (cdr card-list) (- iter 1) value))
  202.     (#t #f)))
  203.  
  204. (define (check-to-tableau? slots t-slots)
  205.   (cond ((eq? slots '())
  206.          #f)
  207.         ((or (empty-slot? (car slots))
  208.              (eq? t-slots '()))
  209.          (check-to-tableau? (cdr slots) tableau))
  210.         ((= (car slots) (car t-slots))
  211.          (check-to-tableau? slots (cdr t-slots)))
  212.     ((and (empty-slot? (car t-slots))
  213.           (check-for-king (get-cards (car slots)) free-reserves (car slots)))
  214.      (list 2 
  215.            (check-for-king (get-cards (car slots)) free-reserves (car slots)) 
  216.            (_"an empty tableau")))
  217.     ((and (not (empty-slot? (car t-slots)))
  218.           (= (get-suit (get-top-card (car slots)))
  219.          (get-suit (get-top-card (car t-slots))))
  220.           (check-for-spec-card (get-cards (car slots))
  221.                    free-reserves 
  222.                    (- (get-value (get-top-card (car t-slots))) 1)))
  223.      (list 1 
  224.            (get-name (make-card (- (get-value (get-top-card (car t-slots))) 1)
  225.                     (get-suit (get-top-card (car t-slots)))))
  226.            (get-name (get-top-card (car t-slots)))))
  227.         (#t (check-to-tableau? slots (cdr t-slots)))))
  228.  
  229. (define (check-for-empty-reserve)
  230.   (and (> free-reserves 0)
  231.        (list 0 (_"Move something on to an empty reserve"))))
  232.  
  233. (define (get-hint)
  234.   (or (check-to-foundations? (append reserve tableau) foundation)
  235.       (check-to-tableau? (append reserve tableau) tableau)
  236.       (check-for-empty-reserve)))
  237.  
  238. (define (get-options) 
  239.   #f)
  240.  
  241. (define (apply-options options) 
  242.   #f)
  243.  
  244. (define (timeout) 
  245.   #f)
  246.  
  247. (set-features droppable-feature)
  248.  
  249. (set-lambda new-game button-pressed button-released button-clicked
  250. button-double-clicked game-continuable game-won get-hint get-options
  251. apply-options timeout droppable?)
  252.