home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / gnome-games / aisleriot / games / spider.scm < prev    next >
Encoding:
Text File  |  2009-04-14  |  9.5 KB  |  301 lines
  1. ; AisleRiot - spider.scm
  2. ; Copyright (C) 1998 Jonathan Blandford <jrb@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 suits-one #f)
  20. (define suits-two #f)
  21. (define suits-four #t)
  22.  
  23. ;set up the deck
  24. (set-ace-low)
  25.  
  26. (define stock 0)
  27. (define foundation '(1 2 3 4 5 6 7 8))
  28. (define tableau '(9 10 11 12 13 14 15 16 17 18))
  29. (define initial-deal '(9 10 11 12 13 14 15 16 17 18 9 10 11 12 13 14 15 16 17 18 9 10 11 12 13 14 15 16 17 18 9 10 11 12 13 14 15 16 17 18 9 10 11 12 13 14 15 16 17 18 9 12 15 18))
  30. (define (make-deck)
  31.   (cond
  32.     (suits-one (set! DECK (append (make-standard-deck-list-ace-low ace spade)
  33.              (make-standard-deck-list-ace-low ace spade) 
  34.              (make-standard-deck-list-ace-low ace spade) 
  35.              (make-standard-deck-list-ace-low ace spade) 
  36.              (make-standard-deck-list-ace-low ace spade) 
  37.              (make-standard-deck-list-ace-low ace spade) 
  38.              (make-standard-deck-list-ace-low ace spade) 
  39.              (make-standard-deck-list-ace-low ace spade))))
  40.     (suits-two (set! DECK (append (make-standard-deck-list-ace-low ace heart)
  41.              (make-standard-deck-list-ace-low ace heart) 
  42.              (make-standard-deck-list-ace-low ace heart) 
  43.              (make-standard-deck-list-ace-low ace heart))))
  44.     (else (make-standard-double-deck))))
  45.  
  46. (define winning-score 96)
  47.  
  48. (define allow-empty-slots #f)
  49.  
  50. (define (new-game)
  51.   (initialize-playing-area)
  52.   (make-deck)
  53.   (shuffle-deck)
  54.  
  55.   ;set up the board
  56.   (add-normal-slot DECK)
  57.   (add-blank-slot)
  58.   (add-normal-slot '())
  59.   (add-normal-slot '())
  60.   (add-normal-slot '())
  61.   (add-normal-slot '())
  62.   (add-normal-slot '())
  63.   (add-normal-slot '())
  64.   (add-normal-slot '())
  65.   (add-normal-slot '())
  66.   (add-carriage-return-slot)
  67.   (add-extended-slot '() down)
  68.   (add-extended-slot '() down)
  69.   (add-extended-slot '() down)
  70.   (add-extended-slot '() down)
  71.   (add-extended-slot '() down)
  72.   (add-extended-slot '() down)
  73.   (add-extended-slot '() down)
  74.   (add-extended-slot '() down)
  75.   (add-extended-slot '() down)
  76.   (add-extended-slot '() down)
  77.   (deal-initial-setup)
  78.  
  79.   (give-status-message)
  80.   
  81.   (list 10 4))
  82.  
  83. (define (give-status-message)
  84.   (set-statusbar-message (get-stock-no-string)))
  85.  
  86. (define (get-stock-no-string)
  87.   (format (_"Stock left: ~a")
  88.       (number->string (length (get-cards stock)))))
  89.  
  90. ;internal procedures/variables
  91.  
  92. (define (flip-top-card-slots slots)
  93.   (or (eq? slots '())
  94.       (and (flip-top-card (car slots))
  95.            (flip-top-card-slots (cdr slots)))))
  96.  
  97. (define (deal-initial-setup)
  98.   (deal-cards stock initial-deal)
  99.   (flip-top-card-slots tableau))
  100.  
  101. ;additional functions.
  102.  
  103. (define (complete-transaction start-slot card-list end-slot)
  104.   (if (and (not (empty-slot? start-slot))
  105.        (is-visible? (get-top-card start-slot))
  106.        (eq? (get-suit (get-top-card start-slot))
  107.         (get-suit (car (reverse card-list))))
  108.        (= (get-value (get-top-card start-slot))
  109.           (+ 1 (get-value (car (reverse card-list))))))
  110.       (add-to-score! -1))
  111.   (if (and (not (empty-slot? end-slot))
  112.        (is-visible? (get-top-card end-slot))
  113.        (eq? (get-suit (get-top-card end-slot))
  114.         (get-suit (car (reverse card-list))))
  115.        (= (get-value (get-top-card end-slot))
  116.           (+ 1 (get-value (car (reverse card-list))))))
  117.       (add-to-score! 1))
  118.   (move-n-cards! start-slot end-slot card-list)
  119.   (if (and (not (empty-slot? start-slot)) (member start-slot tableau))
  120.       (make-visible-top-card start-slot)
  121.       #f)
  122.   #t)
  123.  
  124. (define (check-for-points slot)
  125.   (and (> (length (get-cards slot)) 1)
  126.        (is-visible? (cadr (get-cards slot)))
  127.        (eq? (get-suit (get-top-card slot))
  128.             (get-suit (cadr (get-cards slot))))
  129.        (= (+ 1 (get-value (get-top-card slot)))
  130.           (get-value (cadr (get-cards slot))))
  131.        (add-to-score! 1)))
  132.  
  133. (define (deal-new-cards slots)
  134.   (and (not (eq? slots '()))
  135.        (> (length (get-cards stock)) 0)
  136.        (begin
  137.           (deal-cards-face-up stock (list (car slots)))
  138.           (check-for-points (car slots))
  139.           (deal-new-cards (cdr slots)))))
  140.  
  141. (define (button-pressed slot card-list)
  142.   (give-status-message)
  143.   (if (or (empty-slot? slot)
  144.       (= slot stock)
  145.       (member slot foundation))
  146.       #f
  147.       (if (not (eq? '() card-list))
  148.       (if (is-visible? (car (reverse card-list)))
  149.           (if (check-same-suit-list card-list)
  150.           (if (check-straight-descending-list card-list)
  151.               #t
  152.               #f)
  153.           #f)
  154.           #f)
  155.       #f)))
  156.  
  157. (define (droppable? start-slot card-list end-slot)
  158.   (and (not (= start-slot end-slot))
  159.        (if (empty-slot? end-slot)
  160.         (or (and (member end-slot foundation) 
  161.             (= 13 (length card-list)))
  162.            (member end-slot tableau))
  163.        (and (member end-slot tableau)
  164.             (= (get-value (get-top-card end-slot))
  165.             (+ (get-value (car (reverse card-list))) 1))))))
  166.  
  167. (define (button-released start-slot card-list end-slot)
  168.   (and (droppable? start-slot card-list end-slot)
  169.        (complete-transaction start-slot card-list end-slot)))
  170.  
  171. (define (button-clicked slot)
  172.   (and (= stock slot)
  173.        (not (empty-slot? stock))
  174.        (if (and (not allow-empty-slots)
  175.                 (any-slot-empty? tableau))
  176.        (begin
  177.              (set-statusbar-message (_"Please fill in empty pile first."))
  178.              #f)
  179.        (begin
  180.          (deal-new-cards tableau)
  181.          (give-status-message)
  182.          #t))))
  183.  
  184.  
  185. (define (is-playable-stack cards suit n)
  186.   (and (not (null? cards))
  187.        (= (get-value (car cards)) n)
  188.        (is-visible? (car cards))
  189.        (eq? (get-suit (car cards)) suit)
  190.        (or (= n 13)
  191.            (is-playable-stack (cdr cards) suit (+ n 1)))))
  192.  
  193. (define (button-double-clicked slot)
  194.   (and (member slot tableau)
  195.        (not (empty-slot? slot))
  196.        (is-playable-stack (get-cards slot) (get-suit (car (get-cards slot))) 1)
  197.        (let ((card-list (list-head (get-cards slot) 13)))
  198.             (remove-n-cards slot 13)
  199.             (complete-transaction slot card-list (find-empty-slot foundation)))
  200.        #t))
  201.  
  202. (define (game-over)
  203.   (and (not (game-won))
  204.        (get-hint)))
  205.  
  206. (define (all-slots-empty? slots)
  207.   (or (eq? slots '())
  208.       (and (empty-slot? (car slots))
  209.            (all-slots-empty? (cdr slots)))))
  210.  
  211. ; Game can be won on two conditions.  Either all the cards being moved
  212. ; to the top slots, or by stacking all the cards (score of 96)
  213. (define (game-won)
  214.   (or
  215.    (and (= (get-score) winning-score)
  216.         (all-slots-empty? foundation))
  217.    (and (empty-slot? 0)
  218.     (all-slots-empty? tableau))))
  219.  
  220. (define (depth-card card-list)
  221.   (if (and (> (length card-list) 1)
  222.        (is-visible? (cadr card-list))
  223.        (eq? (get-suit (car card-list))
  224.         (get-suit (cadr card-list)))
  225.        (eq? (+ 1 (get-value (car card-list)))
  226.         (get-value (cadr card-list))))
  227.       (depth-card (cdr card-list))
  228.       card-list))
  229.  
  230. (define (check-a-slot source card-to-move targets same-suit?)
  231.   (if (eq? targets '())
  232.       #f
  233.       (if (and (not (= source (car targets)))
  234.            (not (empty-slot? (car targets)))
  235.            (eq? same-suit?
  236.             (eq? (get-suit card-to-move)
  237.              (get-suit (get-top-card (car targets)))))
  238.            (= (+ 1 (get-value card-to-move))
  239.           (get-value (get-top-card (car targets)))))
  240.       (list 1
  241.         (get-name card-to-move)
  242.         (get-name (get-top-card (car targets))))
  243.       (check-a-slot source card-to-move (cdr targets) same-suit?))))
  244.  
  245. (define (same-suit-check slots)
  246.   (if (eq? slots '())
  247.       #f
  248.       (if (and (not (empty-slot? (car slots)))
  249.            (check-a-slot (car slots) (car (depth-card (get-cards (car slots)))) tableau #t))
  250.       (check-a-slot (car slots) (car (depth-card (get-cards (car slots)))) tableau #t)
  251.       (same-suit-check (cdr slots)))))
  252.  
  253. (define (not-same-suit-check slots)
  254.   (if (eq? slots '())
  255.       #f
  256.       (if (and (not (empty-slot? (car slots)))
  257.            (or (= 1 (length (depth-card (get-cards (car slots)))))
  258.            (not (eq? (+ 1 (get-value (car (depth-card (get-cards (car slots))))))
  259.                  (get-value (cadr (depth-card (get-cards (car slots))))))))
  260.            (check-a-slot (car slots) (car (depth-card (get-cards (car slots)))) tableau #f))
  261.       (check-a-slot (car slots) (car (depth-card (get-cards (car slots)))) tableau #f)
  262.       (not-same-suit-check (cdr slots)))))
  263.  
  264. (define (open-slots? slots)
  265.   (if (eq? slots '())
  266.       #f
  267.       (if (empty-slot? (car slots))
  268.       (list 0 (_"Place something on empty slot"))
  269.       (open-slots? (cdr slots)))))
  270.  
  271. (define (dealable?)
  272.   (if (not (empty-slot? stock))
  273.       (list 0 (_"Deal another round"))
  274.       #f))
  275.  
  276. (define (get-hint)
  277.   (or (same-suit-check tableau)
  278.       (not-same-suit-check tableau)
  279.       (open-slots? tableau)
  280.       (dealable?)
  281. ; this isn't great, but it will get around the premature end-of-game call
  282.       (list 0 (_"Try moving card piles around"))))
  283.  
  284. (define (get-options)
  285.   (list 'begin-exclusive 
  286.     (list (_"Four Suits") suits-four)
  287.     (list (_"Two Suits") suits-two)
  288.     (list (_"One Suit") suits-one)
  289.     'end-exclusive))
  290.  
  291. (define (apply-options options)
  292.   (set! suits-four (cadr (list-ref options 1)))
  293.   (set! suits-two (cadr (list-ref options 2)))
  294.   (set! suits-one (cadr (list-ref options 3))))
  295.  
  296. (define (timeout) #f)
  297.  
  298. (set-features droppable-feature)
  299.  
  300. (set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint get-options apply-options timeout droppable?)
  301.