home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / labyrinth.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  6.2 KB  |  217 lines
  1. ; AisleRiot - labyrinth.scm
  2. ; Copyright (C) 2001 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. (def-save-var first-row #f)
  20.  
  21. (define (new-game)
  22.   (initialize-playing-area)
  23.   (set-ace-low)
  24.   (set! DECK (make-deck-list-ace-low 2 2 club))
  25.   (shuffle-deck)
  26.  
  27.   (add-normal-slot DECK)
  28.   (add-blank-slot)
  29.   (add-normal-slot '())
  30.   (add-normal-slot '())
  31.   (add-normal-slot '())
  32.   (add-normal-slot '())
  33.   (add-carriage-return-slot)
  34.  
  35.   (add-normal-slot '())
  36.   (add-normal-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.  
  44.   (add-carriage-return-slot)
  45.  
  46.   (set! VERTPOS (- VERTPOS (/ 2 3)))
  47.  
  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.  
  57.   
  58.   (add-card! 1 (make-visible (make-card ace club)))
  59.   (add-card! 2 (make-visible (make-card ace diamond)))
  60.   (add-card! 3 (make-visible (make-card ace heart)))
  61.   (add-card! 4 (make-visible (make-card ace spade)))
  62.  
  63.   (deal-cards-face-up 0 '(5 6 7 8 9 10 11 12))
  64.   (set! first-row #t)
  65.  
  66.   (give-status-message)
  67.  
  68.   (list 8 4))
  69.  
  70. (define (give-status-message)
  71.   (set-statusbar-message (get-stock-no-string)))
  72.  
  73. (define (get-stock-no-string)
  74.   (string-append (_"Stock left:") " " 
  75.          (number->string (length (get-cards 0)))))
  76.  
  77. (define (button-pressed slot-id card-list)
  78.   (and (not (empty-slot? slot-id))
  79.        (> slot-id 4)
  80.        (= (length card-list) 1)))
  81.  
  82. (define (droppable? start-slot card-list end-slot)
  83.   (and (< end-slot 5)
  84.        (> end-slot 0)
  85.        (= (get-suit (get-top-card end-slot))
  86.       (get-suit (car card-list)))
  87.        (= (+ 1 (get-value (get-top-card end-slot)))
  88.       (get-value (car card-list)))))
  89.  
  90. (define (button-released start-slot card-list end-slot)
  91.   (and (droppable? start-slot card-list end-slot)
  92.        (move-n-cards! start-slot end-slot card-list)
  93.        (or (and (not first-row)
  94.         (or (> start-slot 12)
  95.             (empty-slot? (+ start-slot 8))
  96.             (and (set-cards! start-slot
  97.                      (list (car (reverse (get-cards (+ start-slot 8))))))
  98.              (set-cards! (+ start-slot 8)
  99.                      (reverse (cdr (reverse (get-cards (+ start-slot 8)))))))))
  100.        (empty-slot? 0)
  101.        (deal-cards-face-up 0 (list start-slot)))
  102.        (add-to-score! 1)))
  103.  
  104. (define (check-slot-and-deal slot)
  105.   (cond ((or (empty-slot? 0)
  106.          (= slot 21))
  107.      #t)
  108.     ((empty-slot? (- slot 8))
  109.      (and (deal-cards-face-up 0 (list (- slot 8)))
  110.           (check-slot-and-deal (+ 1 slot))))
  111.     (#t (and (deal-cards-face-up 0 (list slot))
  112.          (check-slot-and-deal (+ 1 slot))))))
  113.  
  114. (define (button-clicked slot-id)
  115.   (and (= slot-id 0)
  116.        (set! first-row #f)
  117.        (check-slot-and-deal 13)))
  118.  
  119. (define (button-double-clicked slot-id)
  120.   (and (> slot-id 4)
  121.        (not (empty-slot? slot-id))
  122.        (or (and (= (get-suit (get-top-card slot-id)) club)
  123.         (= (get-value (get-top-card slot-id))
  124.            (+ 1 (get-value (get-top-card 1))))
  125.         (deal-cards slot-id '(1))
  126.         (add-to-score! 1))
  127.        (and (= (get-suit (get-top-card slot-id)) diamond)
  128.         (= (get-value (get-top-card slot-id))
  129.            (+ 1 (get-value (get-top-card 2))))
  130.         (deal-cards slot-id '(2))
  131.         (add-to-score! 1))
  132.        (and (= (get-suit (get-top-card slot-id)) heart)
  133.         (= (get-value (get-top-card slot-id))
  134.            (+ 1 (get-value (get-top-card 3))))
  135.         (deal-cards slot-id '(3))
  136.         (add-to-score! 1))
  137.        (and (= (get-suit (get-top-card slot-id)) spade)
  138.         (= (get-value (get-top-card slot-id))
  139.            (+ 1 (get-value (get-top-card 4))))
  140.         (deal-cards slot-id '(4))
  141.         (add-to-score! 1)))
  142.        (or (and first-row
  143.         (not (empty-slot? 0))
  144.         (deal-cards-face-up 0 (list slot-id)))
  145.        (> slot-id 12)
  146.        (empty-slot? (+ 8 slot-id))
  147.        (and (set-cards! slot-id
  148.                 (list (car (reverse (get-cards (+ slot-id 8))))))
  149.         (set-cards! (+ slot-id 8)
  150.                 (reverse (cdr (reverse (get-cards (+ slot-id 8))))))))))
  151.  
  152. (define (game-continuable)
  153.   (give-status-message)
  154.   (and (not (game-won))
  155.        (get-hint)))
  156.  
  157. (define (game-won)
  158.   (and (= (length (get-cards 1)) 13)
  159.        (= (length (get-cards 2)) 13)
  160.        (= (length (get-cards 3)) 13)
  161.        (= (length (get-cards 4)) 13)))
  162.  
  163. (define (check-slot slot)
  164.   (cond ((= slot 21)
  165.      #f)
  166.     ((empty-slot? slot)
  167.      (check-slot (+ 1 slot)))
  168.     ((and (= (get-suit (get-top-card slot)) club)
  169.           (= (get-value (get-top-card slot))
  170.          (+ 1 (get-value (get-top-card 1)))))
  171.      (list 1 
  172.            (get-name (get-top-card slot))
  173.            (get-name (get-top-card 1))))
  174.     ((and (= (get-suit (get-top-card slot)) diamond)
  175.           (= (get-value (get-top-card slot))
  176.          (+ 1 (get-value (get-top-card 2)))))
  177.      (list 1 
  178.            (get-name (get-top-card slot))
  179.            (get-name (get-top-card 2))))
  180.     ((and (= (get-suit (get-top-card slot)) heart)
  181.           (= (get-value (get-top-card slot))
  182.          (+ 1 (get-value (get-top-card 3)))))
  183.      (list 1 
  184.            (get-name (get-top-card slot))
  185.            (get-name (get-top-card 3))))
  186.     ((and (= (get-suit (get-top-card slot)) spade)
  187.           (= (get-value (get-top-card slot))
  188.          (+ 1 (get-value (get-top-card 4)))))
  189.      (list 1 
  190.            (get-name (get-top-card slot))
  191.            (get-name (get-top-card 4))))
  192.     (#t (check-slot (+ 1 slot)))))
  193.  
  194. (define (dealable?)
  195.   (and (not (empty-slot? 0))
  196.        (list 0 (_"Deal more cards"))))
  197.  
  198. (define (get-hint)
  199.   (or (check-slot 5)
  200.       (dealable?)))
  201.  
  202. (define (get-options) 
  203.   #f)
  204.  
  205. (define (apply-options options) 
  206.   #f)
  207.  
  208. (define (timeout) 
  209.   #f)
  210.  
  211. (set-features droppable-feature)
  212.  
  213. (set-lambda new-game button-pressed button-released button-clicked
  214. button-double-clicked game-continuable game-won get-hint get-options
  215. apply-options timeout droppable?)
  216.  
  217.