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