home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / easthaven.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  7.1 KB  |  252 lines
  1. ; AisleRiot - easthaven.scm
  2. ; Copyright (C) 2001, 2003 Rosanna Yuen <zana@webwynk.net>
  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-blank-slot)
  27.   (add-blank-slot)
  28.  
  29.   (add-normal-slot '())
  30.   (add-normal-slot '())
  31.   (add-normal-slot '())
  32.   (add-normal-slot '())
  33.  
  34.   (add-carriage-return-slot)
  35.  
  36.   (add-extended-slot '() down)
  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.  
  44.   (deal-cards 0 '(5 6 7 8 9 10 11 5 6 7 8 9 10 11))
  45.  
  46.   (deal-cards-face-up 0 '(5 6 7 8 9 10 11 ))
  47.  
  48.   (give-status-message)
  49.  
  50.   (list 7 4))
  51.  
  52. (define (give-status-message)
  53.   (set-statusbar-message (string-append (get-stock-no-string))))
  54.  
  55. (define (get-stock-no-string)
  56.   (string-append (_"Stock left:") " "
  57.          (number->string (length (get-cards 0)))))
  58.  
  59. (define (button-pressed slot-id card-list)
  60.   (and (> slot-id 4)
  61.        (not (empty-slot? slot-id))
  62.        (or (= (length card-list) 1)
  63.        (and (check-straight-descending-list card-list)
  64.         (is-visible? (car (reverse card-list)))
  65.         (check-alternating-color-list card-list)))))
  66.  
  67. (define (droppable? start-slot card-list end-slot)
  68.   (and (not (= start-slot end-slot))
  69.        (cond ((> end-slot 4)
  70.           (and (or (and (empty-slot? end-slot)
  71.                 (= (get-value (car (reverse card-list))) king))
  72.                (and (not (empty-slot? end-slot))
  73.                 (eq? (is-red? (get-top-card end-slot))
  74.                  (is-black? (car (reverse card-list))))
  75.                 (= (get-value (get-top-card end-slot))
  76.                    (+ 1 (get-value (car (reverse card-list)))))))))
  77.          ((> end-slot 0)
  78.           (and (= (length card-list) 1)
  79.            (or (and (empty-slot? end-slot)
  80.                 (= (get-value (car card-list)) ace))
  81.                (and (not (empty-slot? end-slot))
  82.                 (= (get-suit (car card-list))
  83.                    (get-suit (get-top-card end-slot)))
  84.                 (= (get-value (car card-list))
  85.                    (+ 1 (get-value (get-top-card end-slot))))))))
  86.          (#t #f))))
  87.  
  88. (define (button-released start-slot card-list end-slot)
  89.   (and (droppable? start-slot card-list end-slot)
  90.        (move-n-cards! start-slot end-slot card-list)
  91.        (or (and (< start-slot 5)
  92.         (add-to-score! -1))
  93.        (empty-slot? start-slot)
  94.        (make-visible-top-card start-slot))
  95.        (or (> end-slot 4)
  96.        (= end-slot 0)
  97.        (add-to-score! 1))))
  98.  
  99. (define (try-dealing slot)
  100.   (or (= slot 12)
  101.       (empty-slot? 0)
  102.       (and (deal-cards-face-up 0 (list slot))
  103.        (try-dealing (+ 1 slot)))))
  104.  
  105. (define (stripped card-list)
  106.   (if (= (length card-list) 1)
  107.       (car card-list)
  108.       (if (and (is-visible? (car (reverse card-list)))
  109.            (check-straight-descending-list card-list)
  110.            (check-alternating-color-list card-list))
  111.       (car (reverse card-list))
  112.       (stripped (reverse (cdr (reverse card-list)))))))
  113.  
  114. (define (kings-avail slot)
  115.   (cond ((= slot 12)
  116.      #f)
  117.     ((and (not (empty-slot? slot))
  118.           (not (is-visible? (car (reverse (get-cards slot)))))
  119.           (= (get-value (stripped (get-cards slot))) king))
  120.      slot)
  121.     (#t (kings-avail (+ 1 slot)))))
  122.  
  123. (define (button-clicked slot-id)
  124.   (and (= slot-id 0)
  125.        (not (empty-slot? 0))
  126.        (or (and (not (empty-slot? 5))
  127.         (not (empty-slot? 6))
  128.         (not (empty-slot? 7))
  129.         (not (empty-slot? 8))
  130.         (not (empty-slot? 9))
  131.         (not (empty-slot? 10))
  132.         (not (empty-slot? 11)))
  133.        (not (kings-avail 5))
  134.        (> (+ (length (get-cards 0))
  135.          (get-score)) 45))
  136.        (try-dealing 5)))
  137.  
  138. (define (move-double-click slot f-slot)
  139.   (cond ((= f-slot 5)
  140.      #f)
  141.     ((and (empty-slot? f-slot)
  142.           (= (get-value (get-top-card slot)) ace))
  143.      (and (deal-cards slot (list f-slot))
  144.           (add-to-score! 1)
  145.           (or (empty-slot? slot)
  146.           (make-visible-top-card slot))))
  147.     ((and (not (empty-slot? f-slot))
  148.           (= (get-suit (get-top-card f-slot))
  149.          (get-suit (get-top-card slot))))
  150.      (and (= (get-value (get-top-card slot))
  151.          (+ 1 (get-value (get-top-card f-slot))))
  152.           (deal-cards slot (list f-slot))
  153.           (add-to-score! 1)
  154.           (or (empty-slot? slot)
  155.           (make-visible-top-card slot))))
  156.     (#t (move-double-click slot (+ 1 f-slot)))))
  157.  
  158. (define (button-double-clicked slot-id)
  159.   (and (not (empty-slot? slot-id))
  160.        (> slot-id 4)
  161.        (move-double-click slot-id 1)))
  162.  
  163. (define (game-continuable)
  164.   (give-status-message)
  165.   (and (not (game-won))
  166.        (get-hint)))
  167.  
  168. (define (game-won)
  169.   (and (empty-slot? 0)
  170.        (empty-slot? 5)
  171.        (empty-slot? 6)
  172.        (empty-slot? 7)
  173.        (empty-slot? 8)
  174.        (empty-slot? 9)
  175.        (empty-slot? 10)
  176.        (empty-slot? 11)))
  177.  
  178. (define (to-foundations? slot f-slot)
  179.   (cond ((= slot 12)
  180.      #f)
  181.     ((or (empty-slot? slot)
  182.          (= f-slot 5))
  183.      (to-foundations? (+ 1 slot) 1))
  184.     ((and (empty-slot? f-slot)
  185.           (= (get-value (get-top-card slot)) ace))
  186.      (list 2
  187.            (get-name (get-top-card slot))
  188.            (_"an empty foundation")))
  189.     ((and (not (empty-slot? f-slot))
  190.           (= (get-suit (get-top-card f-slot))
  191.          (get-suit (get-top-card slot)))
  192.           (= (+ 1 (get-value (get-top-card f-slot)))
  193.          (get-value (get-top-card slot))))
  194.      (list 1
  195.            (get-name (get-top-card slot))
  196.            (get-name (get-top-card f-slot))))
  197.     (#t (to-foundations? slot (+ 1 f-slot)))))
  198.  
  199. (define (check-a-tab-slot card slot2)
  200.   (and (eq? (is-red? card)
  201.         (is-black? (get-top-card slot2)))
  202.        (= (+ 1 (get-value card))
  203.       (get-value (get-top-card slot2)))))
  204.  
  205. (define (check-tableau slot1 slot2)
  206.   (cond ((= slot1 12)
  207.      #f)
  208.     ((or (empty-slot? slot1)
  209.          (= slot2 12))
  210.      (check-tableau (+ 1 slot1) 5))
  211.     ((and (not (= slot1 slot2))
  212.           (not (empty-slot? slot2))
  213.           (check-a-tab-slot (stripped (get-cards slot1)) slot2))
  214.      (list 1
  215.            (get-name (stripped (get-cards slot1)))
  216.            (get-name (get-top-card slot2))))
  217.     (#t (check-tableau slot1 (+ 1 slot2)))))
  218.  
  219. (define (fill-empties slot)
  220.   (cond ((= slot 12)
  221.      #f)
  222.     ((and (empty-slot? slot)
  223.           (kings-avail 5))
  224.      (list 0 (_"Move a King on to the empty tableau slot")))
  225.     (#t (fill-empties (+ 1 slot)))))
  226.  
  227. (define (dealable?)
  228.   (and (not (empty-slot? 0))
  229.        (list 0 (_"Deal more cards"))))
  230.  
  231. (define (get-hint)
  232.   (or (to-foundations? 5 1)
  233.       (check-tableau 5 6)
  234.       (fill-empties 5)
  235.       (dealable?)
  236.       (list 0 (_"No hint available right now"))))
  237.  
  238. (define (get-options) 
  239.   #f)
  240.  
  241. (define (apply-options options) 
  242.   #f)
  243.  
  244. (define (timeout) 
  245.   #f)
  246.  
  247. (set-features droppable-feature)
  248.  
  249. (set-lambda new-game button-pressed button-released button-clicked
  250. button-double-clicked game-continuable game-won get-hint get-options
  251. apply-options timeout droppable?)
  252.