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