home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / odessa.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  8.8 KB  |  271 lines
  1. ; AisleRiot - odessa.scm
  2. ; Copyright (C) 1998, 2003 Rosanna Yuen <rwsy@mit.edu>
  3. ;                    Felix Bellaby <felix@pooh.u-net.com>
  4. ;
  5. ; This game is free software; you can redistribute it and/or modify
  6. ; it under the terms of the GNU General Public License as published by
  7. ; the Free Software Foundation; either version 2, or (at your option)
  8. ; any later version.
  9. ;
  10. ; This program is distributed in the hope that it will be useful,
  11. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ; GNU General Public License for more details.
  14. ;
  15. ; You should have received a copy of the GNU General Public License
  16. ; along with this program; if not, write to the Free Software
  17. ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  18. ; USA
  19.  
  20.  
  21. ;set up the deck
  22. (set-ace-low)
  23.  
  24.  
  25. (define (new-game) 
  26.   (initialize-playing-area)
  27.   (make-standard-deck)
  28.   (shuffle-deck)
  29.   
  30.   (add-normal-slot DECK)            ;Slot 0
  31.   (add-extended-slot '() down)        ;Slot 1
  32.   (add-extended-slot '() down)        ;Slot 2
  33.   (add-extended-slot '() down)        ;Slot 3
  34.   (add-extended-slot '() down)        ;Slot 4
  35.   (add-extended-slot '() down)        ;Slot 5
  36.   (add-extended-slot '() down)        ;Slot 6
  37.   (add-extended-slot '() down)        ;Slot 7
  38.   (add-carriage-return-slot)
  39.   (add-normal-slot '())            ;Slot 8
  40.   (add-carriage-return-slot)
  41.   (add-normal-slot '())            ;Slot 9
  42.   (add-carriage-return-slot)
  43.   (add-normal-slot '())            ;Slot 10
  44.   
  45.   (deal-cards 0 '(1 2 3 4 5 6 7 1 2 3 4 5 6 7  1 2 3 4 5 6 7 ))
  46.   (deal-cards-face-up 0 '(1 2 3 4 5 6 7 1 2 3 4 5 6 7  1 2 3 4 5 6 7 2 3 4 5 6 2 3 4 5 6))
  47.  
  48.   (begin-score (reverse (get-cards 1)) #f)
  49.   (begin-score (reverse (get-cards 2)) #f)
  50.   (begin-score (reverse (get-cards 3)) #f)
  51.   (begin-score (reverse (get-cards 4)) #f)
  52.   (begin-score (reverse (get-cards 5)) #f)
  53.   (begin-score (reverse (get-cards 6)) #f)
  54.   (begin-score (reverse (get-cards 7)) #f)
  55.  
  56.   (list 8 4)
  57. )
  58.  
  59. (define (begin-score card-list first-run?)
  60.   (if (not (is-visible? (car card-list)))
  61.       (begin-score (cdr card-list) #f)
  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.         (if first-run?
  68.         (add-to-score! 1)
  69.         (begin
  70.           (add-to-score! 2)
  71.           (set! first-run? #t)))
  72.         (set! first-run? #f))
  73.     (if (> (length card-list) 2)
  74.         (begin-score (cdr card-list) first-run?)
  75.         #f))))
  76.  
  77. (define (button-pressed slot-id card-list)
  78.   (and (not (empty-slot? slot-id))
  79.        (> slot-id 0)
  80.        (< slot-id 8)
  81.        (not (null? card-list))
  82.        (is-visible? (car (reverse card-list)))))
  83.  
  84. (define (num-in-a-row value suit rest)
  85.   (if (and (not (null? rest)) 
  86.        (eq? suit (get-suit (car rest)))
  87.        (eq? 1 (abs (- value (get-value (car rest))))))
  88.       (+ 1 (num-in-a-row (get-value (car rest)) suit (cdr rest)))
  89.       0))
  90.  
  91. (define (complete-transaction start-slot card-list rcards end-slot)
  92.                          ;prevents earning easy points moving kings!
  93.   (if (and (not (empty-slot? end-slot))
  94.        (> end-slot 0)
  95.        (< end-slot 8))
  96.       (let* ((cards (get-cards end-slot))
  97.          (value (get-value (car cards)))
  98.          (suit  (get-suit  (car cards))))
  99.     (add-to-score! (+ 1
  100.               (num-in-a-row value suit (cdr cards))
  101.               (num-in-a-row value suit rcards)))))
  102.   (if (or (= end-slot 0)
  103.       (> end-slot 7))
  104.       (add-to-score! (length card-list)))
  105.   (move-n-cards! start-slot end-slot card-list)
  106.   (if (not (empty-slot? start-slot)) 
  107.       (make-visible-top-card start-slot))
  108.   #t)
  109.  
  110. (define (droppable? start-slot cards end-slot)
  111.   (and (not (= start-slot end-slot))
  112.        (let ((rcards (reverse cards)))
  113.      (if (and (> end-slot 0) (< end-slot 8))
  114.          (if (empty-slot? end-slot)
  115.          (= king (get-value (car rcards)))
  116.          (and (= (get-suit (get-top-card end-slot))
  117.              (get-suit (car rcards)))
  118.               (= (get-value (get-top-card end-slot))
  119.              (+ (get-value (car rcards)) 1))))
  120.          (and (if (empty-slot? end-slot)
  121.               (= ace (get-value (car cards)))
  122.               (and (= (get-suit (get-top-card end-slot))
  123.                   (get-suit (car cards)))
  124.                (= (get-value (get-top-card end-slot))
  125.                   (- (get-value (car cards)) 1))))
  126.           (check-same-suit-list cards)
  127.           (check-straight-descending-list cards))))))
  128.  
  129. (define (button-released start-slot cards end-slot)
  130.   (and (droppable? start-slot cards end-slot)
  131.        (if (and (> end-slot 0) (< end-slot 8))
  132.            (complete-transaction start-slot cards (reverse cards) end-slot)
  133.            (complete-transaction start-slot (reverse cards) cards end-slot))))
  134.  
  135. (define (button-clicked slot)
  136.   #f)
  137.  
  138. (define (move-to-foundations? slot f-slot)
  139.   (cond ((= f-slot 11)
  140.      #f)
  141.     ((= f-slot 1)
  142.      (move-to-foundations? slot 8))
  143.     ((and (not (empty-slot? f-slot))
  144.           (eq? (get-suit (get-top-card slot))
  145.            (get-suit (get-top-card f-slot)))
  146.           (= (get-value (get-top-card slot))
  147.          (+ 1 (get-value (get-top-card f-slot)))))
  148.      (begin
  149.        (add-to-score! 1)
  150.        (deal-cards slot (list f-slot))
  151.        (if (and (not (empty-slot? slot))
  152.             (not (is-visible? (get-top-card slot))))
  153.            (flip-top-card slot))))
  154.  
  155.     (#t
  156.      (move-to-foundations? slot (+ 1 f-slot)))))
  157.  
  158. (define (button-double-clicked slot)
  159.   (if (and (> slot 0)
  160.        (< slot 8)
  161.        (not (empty-slot? slot)))
  162.       (if (= ace (get-value (get-top-card slot)))
  163.       (begin
  164.         (add-to-score! 1)
  165.         (cond ((empty-slot? 0)
  166.            (deal-cards slot '(0)))
  167.           ((empty-slot? 8)
  168.            (deal-cards slot '(8)))
  169.           ((empty-slot? 9)
  170.            (deal-cards slot '(9)))
  171.           (#t
  172.            (deal-cards slot '(10))))
  173.         (if (not (empty-slot? slot))
  174.         (make-visible-top-card slot)))
  175.       (move-to-foundations? slot 0))
  176.       #f))
  177.  
  178. (define (is-ploppable card value suit)
  179.   (or (and (= ace (get-value card))
  180.        (list 2 (get-name card) (_"an empty slot") ))
  181.       (and (or (and (not (empty-slot? 0))
  182.             (= value (get-value (get-top-card 0)))
  183.             (= suit (get-suit (get-top-card 0))))
  184.            (and (not (empty-slot? 8))
  185.             (= value (get-value (get-top-card 8)))
  186.             (= suit (get-suit (get-top-card 8))))
  187.            (and (not (empty-slot? 9))
  188.             (= value (get-value (get-top-card 9)))
  189.             (= suit (get-suit (get-top-card 9))))
  190.            (and (not (empty-slot? 10))
  191.             (= value (get-value (get-top-card 10)))
  192.             (= suit (get-suit (get-top-card 10)))))
  193.        (list 1 (get-name card) (get-name (make-card value suit))))))
  194.  
  195. (define (is-visible-card cards card value suit)
  196.   (and (not (null? cards))
  197.        (if (and (= (get-value (car cards)) value)
  198.         (= (get-suit (car cards)) suit))
  199.        (and (is-visible? (car cards))
  200.         (list 1 (get-name (make-card value suit)) (get-name card)))
  201.        (is-visible-card (cdr cards) card value suit))))
  202.  
  203. (define (is-extendable slot-id2 slot-id card value suit)
  204.   (and (< slot-id2 8)
  205.        (or (and (not (= slot-id2 slot-id))
  206.         (is-visible-card (get-cards slot-id2) card value suit))
  207.        (is-extendable (+ 1 slot-id2) slot-id card value suit))))
  208.  
  209. (define (is-visible-king cards)
  210.   (and (not (null? cards))
  211.        (or (and (= (get-value (car cards)) king)
  212.         (is-visible? (car cards))
  213.         (not (null? (cdr cards)))
  214.         (list 2 (get-name (car cards)) (_"an empty slot")))
  215.        (is-visible-king (cdr cards)))))
  216.  
  217. (define (find-king slot-id)
  218.   (and (< slot-id 8)
  219.        (or (is-visible-king (get-cards slot-id))
  220.        (find-king (+ 1 slot-id)))))
  221.  
  222. ; Checks to see if any moves can be made in the tableau
  223. (define (check-game-over-move slot-id check-kings)
  224.   (and (< slot-id 8)
  225.        (or (if (empty-slot? slot-id)
  226.            (or (and check-kings (find-king 1))
  227.            (check-game-over-move (+ 1 slot-id) #f))           
  228.            (let* ((card (get-top-card slot-id))
  229.               (suit (get-suit card))
  230.               (value (- (get-value card) 1)))
  231.          (is-extendable 1 slot-id card value suit)))
  232.        (check-game-over-move (+ 1 slot-id) check-kings))))
  233.  
  234. ; Check to see if any cards can be moved up to the foundation
  235. (define (check-game-over-foundation slot-id check-kings)
  236.   (cond ((> slot-id 7) #f) 
  237.     ((empty-slot? slot-id) 
  238.      (check-game-over-foundation (+ 1 slot-id) check-kings))
  239.     (#t (or (let* ((card (get-top-card slot-id))
  240.                (suit (get-suit card))
  241.                (value (- (get-value card) 1)))
  242.           (is-ploppable card value suit))
  243.         (check-game-over-foundation (+ 1 slot-id) check-kings)))))
  244.  
  245. ; We want to always check to see if moves can be moved among the
  246. ; tableau before checking if cards can be moved up to the foundation,
  247. ; as the former is a more useful hint, and gets a higher score
  248. (define (game-over)
  249.   (or (check-game-over-move 1 #t)
  250.       (check-game-over-foundation 1 #t)))
  251.  
  252. (define (game-won)
  253.   (and (= 13 (length (get-cards 0)))
  254.        (= 13 (length (get-cards 8)))
  255.        (= 13 (length (get-cards 9)))
  256.        (= 13 (length (get-cards 10)))))
  257.  
  258. (define (get-hint)
  259.   (game-over))
  260.  
  261. (define (get-options) 
  262.   #f)
  263.  
  264. (define (apply-options options) #f)
  265.  
  266. (define (timeout) #f)
  267.  
  268. (set-features droppable-feature)
  269.  
  270. (set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint get-options apply-options timeout droppable?)
  271.