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