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