home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / westhaven.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  9.3 KB  |  332 lines
  1. ; AisleRiot - westhaven.scm
  2. ; Copyright (C) 1999 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.   (make-standard-deck)
  23.   (shuffle-deck)
  24.  
  25.   (add-normal-slot DECK)
  26.   (add-normal-slot '())
  27.  
  28.   (add-blank-slot)
  29.  
  30.   (add-normal-slot '())
  31.   (add-normal-slot '())
  32.   (add-normal-slot '())
  33.   (add-normal-slot '())
  34.  
  35.   (add-carriage-return-slot)
  36.  
  37.   (add-extended-slot '() down)
  38.   (add-extended-slot '() down)
  39.   (add-extended-slot '() down)
  40.   (add-extended-slot '() down)
  41.   (add-extended-slot '() down)
  42.   (add-extended-slot '() down)
  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 7 8 9 10 11 12 13 14 15))
  49.   (deal-cards 0 '(6 7 8 9 10 11 12 13 14 15))
  50.   (deal-cards-face-up 0 '(6 7 8 9 10 11 12 13 14 15))
  51.  
  52.   (give-status-message)
  53.  
  54.   (list 10 4)
  55. )
  56.  
  57. (define (give-status-message)
  58.   (set-statusbar-message (get-stock-no-string)))
  59.  
  60. (define (get-stock-no-string)
  61.   (string-append (_"Stock left:") " " 
  62.          (number->string (length (get-cards 0)))))
  63.  
  64. (define (next-card card-list number)
  65.   (if (= number 0)
  66.       (car card-list)
  67.       (next-card (cdr card-list) (- number 1))))
  68.  
  69. (define (button-pressed slot-id card-list)
  70.   (and (not (empty-slot? slot-id))
  71.        (or (= slot-id 1)
  72.        (> slot-id 5))
  73.        (is-visible? (car (reverse card-list)))
  74.        (or (= (length card-list) 1)
  75.        (= (length card-list)
  76.           (length (get-cards slot-id)))
  77.        (not (is-visible? (next-card (get-cards slot-id)
  78.                     (length card-list)))))))
  79.  
  80. (define (droppable? start-slot card-list end-slot)
  81.   (cond ((> end-slot 5)
  82.      (or (empty-slot? end-slot)
  83.          (and (not (eq? (is-red? (get-top-card end-slot))
  84.                 (is-red? (car (reverse card-list)))))
  85.           (= (get-value (get-top-card end-slot))
  86.              (+ 1 (get-value (car (reverse card-list))))))))
  87.     ((and (> end-slot 1)
  88.           (= 1 (length card-list)))
  89.      (if (= (get-value (car card-list)) ace)
  90.          (empty-slot? end-slot)
  91.          (and (not (empty-slot? end-slot))
  92.           (= (get-suit (car card-list))
  93.              (get-suit (get-top-card end-slot)))
  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.        (begin
  101.      (move-n-cards! start-slot end-slot card-list)
  102.      (and (< end-slot 6)
  103.           (> end-slot 1)
  104.           (add-to-score! 1))
  105.      (or (empty-slot? start-slot)
  106.          (make-visible-top-card start-slot)))))
  107.  
  108. (define (button-clicked slot-id)
  109.   (and (= slot-id 0)
  110.        (not (empty-slot? 0))
  111.        (deal-cards-face-up 0 '(1))))
  112.  
  113. (define (double-clicked-move start-slot end-slot card-list)
  114.   (move-n-cards! start-slot end-slot card-list)
  115.   (remove-card start-slot)
  116.   (add-to-score! 1)
  117.   (if (not (empty-slot? start-slot))
  118.       (make-visible-top-card start-slot)
  119.       #t))
  120.  
  121. (define (button-double-clicked slot-id)
  122.   (if (and (not (empty-slot? slot-id))
  123.        (or (= slot-id 1)
  124.            (> slot-id 5)))
  125.       (if (= (get-value (get-top-card slot-id)) ace)
  126.       (cond ((empty-slot? 2)
  127.          (double-clicked-move slot-id 
  128.                       2 
  129.                       (list (get-top-card slot-id))))
  130.         ((empty-slot? 3)
  131.          (double-clicked-move slot-id 
  132.                       3
  133.                       (list (get-top-card slot-id))))
  134.         ((empty-slot? 4)
  135.          (double-clicked-move slot-id 
  136.                       4 
  137.                       (list (get-top-card slot-id))))
  138.         (#t
  139.          (double-clicked-move slot-id 
  140.                       5 
  141.                       (list (get-top-card slot-id)))))
  142.       (cond ((and (not (empty-slot? 2))
  143.               (= (get-suit (get-top-card slot-id))
  144.              (get-suit (get-top-card 2)))
  145.               (= (get-value (get-top-card slot-id))
  146.              (+ 1 (get-value (get-top-card 2)))))
  147.          (double-clicked-move slot-id 
  148.                       2 
  149.                       (list (get-top-card slot-id))))
  150.         ((and (not (empty-slot? 3))
  151.               (= (get-suit (get-top-card slot-id))
  152.              (get-suit (get-top-card 3)))
  153.               (= (get-value (get-top-card slot-id))
  154.              (+ 1 (get-value (get-top-card 3)))))
  155.          (double-clicked-move slot-id 
  156.                       3
  157.                       (list (get-top-card slot-id))))
  158.         ((and (not (empty-slot? 4))
  159.               (= (get-suit (get-top-card slot-id))
  160.              (get-suit (get-top-card 4)))
  161.               (= (get-value (get-top-card slot-id))
  162.              (+ 1 (get-value (get-top-card 4)))))
  163.          (double-clicked-move slot-id 
  164.                       4
  165.                       (list (get-top-card slot-id))))
  166.         ((and (not (empty-slot? 5))
  167.               (= (get-suit (get-top-card slot-id))
  168.              (get-suit (get-top-card 5)))
  169.               (= (get-value (get-top-card slot-id))
  170.              (+ 1 (get-value (get-top-card 5)))))
  171.          (double-clicked-move slot-id 
  172.                       5
  173.                       (list (get-top-card slot-id))))))
  174.       #f))
  175.  
  176. (define (game-continuable)
  177.   (give-status-message)
  178.   (and (not (game-won))
  179.        (get-hint)))
  180.  
  181. (define (game-won)
  182.   (and (= (length (get-cards 2)) 13)
  183.        (= (length (get-cards 3)) 13)
  184.        (= (length (get-cards 4)) 13)
  185.        (= (length (get-cards 5)) 13)))
  186.  
  187. (define (dealable?)
  188.   (if (not (empty-slot? 0))
  189.       (list 0 (_"Deal a card"))
  190.       #f))
  191.  
  192. (define (to-foundations? slot-id)
  193.   (cond ((> slot-id 15)
  194.      #f)
  195.     ((= slot-id 2)
  196.      (to-foundations? 6))
  197.     ((empty-slot? slot-id)
  198.      (to-foundations? (+ 1 slot-id)))
  199.     ((= (get-value (get-top-card slot-id)) ace)
  200.      (list 2 (get-name (get-top-card slot-id)) (_"an empty foundation")))
  201.     ((and (not (empty-slot? 2))
  202.           (eq? (get-suit (get-top-card 2))
  203.            (get-suit (get-top-card slot-id)))
  204.           (= (+ 1 (get-value (get-top-card 2)))
  205.          (get-value (get-top-card slot-id))))
  206.      (list 1 
  207.            (get-name (get-top-card slot-id)) 
  208.            (get-name (get-top-card 2))))
  209.     ((and (not (empty-slot? 5))
  210.           (eq? (get-suit (get-top-card 5))
  211.            (get-suit (get-top-card slot-id)))
  212.           (= (+ 1 (get-value (get-top-card 5)))
  213.          (get-value (get-top-card slot-id))))
  214.      (list 1 
  215.            (get-name (get-top-card slot-id)) 
  216.            (get-name (get-top-card 5))))
  217.     ((and (not (empty-slot? 3))
  218.           (eq? (get-suit (get-top-card 3))
  219.            (get-suit (get-top-card slot-id)))
  220.           (= (+ 1 (get-value (get-top-card 3)))
  221.          (get-value (get-top-card slot-id))))
  222.      (list 1 
  223.            (get-name (get-top-card slot-id)) 
  224.            (get-name (get-top-card 3))))
  225.     ((and (not (empty-slot? 4))
  226.           (eq? (get-suit (get-top-card 4))
  227.            (get-suit (get-top-card slot-id)))
  228.           (= (+ 1 (get-value (get-top-card 4)))
  229.          (get-value (get-top-card slot-id))))
  230.      (list 1 
  231.            (get-name (get-top-card slot-id)) 
  232.            (get-name (get-top-card 4))))
  233.     (#t
  234.      (to-foundations? (+ 1 slot-id)))))
  235.  
  236. (define (waste-to-tableau? end-slot)
  237.   (if (or (> end-slot 15)
  238.       (empty-slot? 1))
  239.       #f
  240.       (if (and (not (empty-slot? end-slot))
  241.            (not (eq? (is-red? (get-top-card 1))
  242.              (is-red? (get-top-card end-slot))))
  243.            (= (+ 1 (get-value (get-top-card 1)))
  244.           (get-value (get-top-card end-slot))))
  245.       (list 1
  246.         (get-name (get-top-card 1))
  247.         (get-name (get-top-card end-slot)))
  248.       (waste-to-tableau? (+ 1 end-slot)))))
  249.  
  250. (define (strip-invisible card-list)
  251.   (if (is-visible? (car card-list))
  252.       (car card-list)
  253.       (strip-invisible (cdr card-list))))
  254.  
  255. (define (get-available-bottom slot-id)
  256.   (strip-invisible (reverse (get-cards slot-id))))
  257.  
  258. (define (check-move card slot-id)
  259.   (and (not (eq? (is-red? card)
  260.          (is-red? (get-top-card slot-id))))
  261.        (= (+ 1 (get-value card))
  262.       (get-value (get-top-card slot-id)))))
  263.  
  264. (define (tableau-to-tableau? slot1 slot2)
  265.   (cond ((= slot1 16)
  266.      #f)
  267.     ((or (empty-slot? slot1)
  268.          (= slot2 16))
  269.      (tableau-to-tableau? (+ 1 slot1) 6))
  270.     ((or (empty-slot? slot2)
  271.          (= slot1 slot2))
  272.      (tableau-to-tableau? slot1 (+ 1 slot2)))
  273.     ((check-move (get-available-bottom slot1) slot2)
  274.      (list 1
  275.            (get-name (get-available-bottom slot1))
  276.            (get-name (get-top-card slot2))))
  277.     (#t
  278.      (tableau-to-tableau? slot1 (+ 1 slot2)))))
  279.  
  280. (define (check-for-empty slot-id)
  281.   (cond ((> slot-id 15)
  282.      #f)
  283.     ((empty-slot? slot-id)
  284.      slot-id)
  285.     (#t
  286.      (check-for-empty (+ 1 slot-id)))))
  287.  
  288. (define (check-invisible slot-id)
  289.   (cond ((> slot-id 15)
  290.      #f)
  291.  
  292.     ((and (not (empty-slot? slot-id))
  293.           (not (is-visible? (car (reverse (get-cards slot-id))))))
  294.      (get-available-bottom slot-id))
  295.     (#t
  296.      (check-invisible (+ 1 slot-id)))))
  297.  
  298. (define (check-empty-slot)
  299.   (if (not (check-for-empty 6))
  300.       #f
  301.       (cond ((check-invisible 6)
  302.          (list 2 
  303.            (get-name (check-invisible 6))
  304.            (_"an empty tableau pile")))
  305.         ((not (empty-slot? 1))
  306.          (list 2
  307.            (get-name (get-top-card 1))
  308.            (_"an empty tableau pile")))
  309.         (#t #f))))
  310.  
  311. (define (get-hint)
  312.   (or (to-foundations? 1)
  313.       (waste-to-tableau? 6)
  314.       (tableau-to-tableau? 6 7)
  315.       (check-empty-slot)
  316.       (dealable?)))
  317.  
  318. (define (get-options) 
  319.   #f)
  320.  
  321. (define (apply-options options) 
  322.   #f)
  323.  
  324. (define (timeout) 
  325.   #f)
  326.  
  327. (set-features droppable-feature)
  328.  
  329. (set-lambda new-game button-pressed button-released button-clicked
  330. button-double-clicked game-continuable game-won get-hint get-options
  331. apply-options timeout droppable?)
  332.