home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / first_law.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  5.7 KB  |  199 lines
  1. ; AisleRiot - first_law.scm
  2. ; Copyright (C) 1999, 2003 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.  
  27.   (add-blank-slot)
  28.  
  29.   (add-normal-slot '())
  30.   (add-normal-slot '())
  31.   (add-normal-slot '())
  32.   (add-normal-slot '())
  33.  
  34.   (give-status-message)
  35.  
  36.   (list 6 2))
  37.  
  38. (define (give-status-message)
  39.   (set-statusbar-message (get-stock-no-string)))
  40.  
  41. (define (get-stock-no-string)
  42.   (string-append (_"Stock left:") " "
  43.          (number->string (length (get-cards 0)))))
  44.  
  45. (define (button-pressed slot-id card-list)
  46.   #f)
  47.  
  48. (define (release-move-off? start-slot card-list check-slot)
  49.   (if (or (= start-slot check-slot)
  50.       (and (not (empty-slot? check-slot))
  51.            (= (get-value (car card-list))
  52.           (get-value (get-top-card check-slot)))))
  53.       (or (> check-slot 4)
  54.       (release-move-off? start-slot card-list (+ 1 check-slot)))
  55.       #f))
  56.  
  57. (define (no-more-left? slot1 slot2)
  58.   (cond ((= slot1 slot2)
  59.      #t)
  60.     ((and (not (empty-slot? slot2))
  61.           (= (get-value (get-top-card slot1))
  62.          (get-value (get-top-card slot2))))
  63.      #f)
  64.     (#t (no-more-left? slot1 (+ 1 slot2)))))
  65.  
  66. (define (button-released start-slot card-list end-slot)
  67. #f)
  68.  
  69. (define (move-off?)
  70.   (and (not (empty-slot? 1))
  71.        (not (empty-slot? 2))
  72.        (not (empty-slot? 3))
  73.        (not (empty-slot? 4))       
  74.        (= (get-value (get-top-card 1))
  75.       (get-value (get-top-card 2))
  76.       (get-value (get-top-card 3))
  77.       (get-value (get-top-card 4)))
  78.        (remove-card 1)
  79.        (remove-card 2)
  80.        (remove-card 3)
  81.        (remove-card 4)
  82.        (add-to-score! 1)))
  83.  
  84. (define (move-left? slot1 slot2)
  85.   (cond ((= slot1 slot2)
  86.      #f)
  87.     ((and (not (empty-slot? slot2))
  88.           (= (get-value (get-top-card slot1))
  89.          (get-value (get-top-card slot2))))
  90.      (and (add-card! slot2 (get-top-card slot1))
  91.           (remove-card slot1)))
  92.     (#t (move-left? slot1 (+ 1 slot2)))))
  93.  
  94. (define (button-clicked slot-id)
  95.   (or (and (= slot-id 0)
  96.        (or (and (not (empty-slot? 0))
  97.             (deal-cards-face-up 0 '(1 2 3 4))
  98.             (give-status-message))
  99.            (and (or (empty-slot? 4)
  100.             (flip-deck 0 4))
  101.             (or (empty-slot? 3)
  102.             (flip-deck 0 3))
  103.             (or (empty-slot? 2)
  104.             (flip-deck 0 2))
  105.             (or (empty-slot? 1)
  106.             (flip-deck 0 1))
  107.             (give-status-message))))
  108.       (and (not (empty-slot? slot-id))
  109.        (or (move-off?)
  110.            (move-left? slot-id 1)))))
  111.  
  112. (define (button-double-clicked slot-id)
  113.   #f)
  114.  
  115. (define (game-continuable)
  116.   (not (game-won)))
  117.  
  118. (define (game-won)
  119.   (and (empty-slot? 0)
  120.        (empty-slot? 1)
  121.        (empty-slot? 2)
  122.        (empty-slot? 3)
  123.        (empty-slot? 4)))
  124.  
  125. (define (dealable?)
  126.   (and (not (empty-slot? 0))
  127.        (list 0 (_"Deal another round"))))
  128.  
  129. (define (removable?)
  130.   (and (not (empty-slot? 1))
  131.        (not (empty-slot? 2))
  132.        (not (empty-slot? 3))
  133.        (not (empty-slot? 4))
  134.        (= (get-value (get-top-card 1))
  135.       (get-value (get-top-card 2))
  136.       (get-value (get-top-card 3))
  137.       (get-value (get-top-card 4)))
  138.        (list 0 (cond ((= (get-value (get-top-card 1)) 1)
  139.                       (_"Remove the aces"))
  140.                      ((= (get-value (get-top-card 1)) 2)
  141.                       (_"Remove the twos"))
  142.                      ((= (get-value (get-top-card 1)) 3)
  143.                       (_"Remove the threes"))
  144.                      ((= (get-value (get-top-card 1)) 4)
  145.                       (_"Remove the fours"))
  146.                      ((= (get-value (get-top-card 1)) 5)
  147.                       (_"Remove the fives"))
  148.                      ((= (get-value (get-top-card 1)) 6)
  149.                       (_"Remove the sixes"))
  150.                      ((= (get-value (get-top-card 1)) 7)
  151.                       (_"Remove the sevens"))
  152.                      ((= (get-value (get-top-card 1)) 8)
  153.                       (_"Remove the eights"))
  154.                      ((= (get-value (get-top-card 1)) 9)
  155.                       (_"Remove the nines"))
  156.                      ((= (get-value (get-top-card 1)) 10)
  157.                       (_"Remove the tens"))
  158.                      ((= (get-value (get-top-card 1)) 11)
  159.                       (_"Remove the jacks"))
  160.                      ((= (get-value (get-top-card 1)) 12)
  161.                       (_"Remove the queens"))
  162.                      ((= (get-value (get-top-card 1)) 13)
  163.                       (_"Remove the kings"))
  164.                      (#t
  165.                       (_"I'm not sure"))))))
  166.  
  167. (define (move-leftable? slot1 slot2)
  168.   (cond ((= slot1 4)
  169.      #f)
  170.     ((= slot2 5)
  171.      (move-leftable? (+ 1 slot1) (+ 2 slot1)))
  172.     ((and (not (empty-slot? slot1))
  173.           (not (empty-slot? slot2))
  174.           (= (get-value (get-top-card slot1))
  175.          (get-value (get-top-card slot2))))
  176.      (list 1 (get-name (get-top-card slot2))
  177.            (get-name (get-top-card slot1))))
  178.     (#t
  179.      (move-leftable? slot1 (+ 1 slot2)))))
  180.  
  181. (define (get-hint)
  182.   (or (removable?)
  183.       (move-leftable? 1 2)
  184.       (dealable?)
  185.       (list 0 (_"Return cards to stock"))))
  186.  
  187. (define (get-options) 
  188.   #f)
  189.  
  190. (define (apply-options options) 
  191.   #f)
  192.  
  193. (define (timeout) 
  194.   #f)
  195.  
  196. (set-lambda new-game button-pressed button-released button-clicked
  197. button-double-clicked game-continuable game-won get-hint get-options
  198. apply-options timeout)
  199.