home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / canfield.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  8.8 KB  |  313 lines
  1.     ; AisleRiot - canfield.scm
  2. ; Copyright (C) 1998, 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 BASE-VAL 0)
  20.  
  21. (define (new-game)
  22.   (initialize-playing-area)
  23.   (make-standard-deck)
  24.   (shuffle-deck)
  25.  
  26.   (add-normal-slot DECK)         ; first row
  27.   (add-partially-extended-slot '() right 3)
  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 '())               ; second row
  36.   (add-blank-slot)
  37.   (add-blank-slot)
  38.   (add-extended-slot '() down)
  39.   (add-extended-slot '() down)
  40.   (add-extended-slot '() down)
  41.   (add-extended-slot '() down)
  42.  
  43.   (deal-cards 0 '(6 6 6 6 6 6 6 6 6 6 6 6 6 7 8 9 10 2))
  44.  
  45.   (flip-top-card 6)
  46.   (flip-top-card 7)
  47.   (flip-top-card 8)
  48.   (flip-top-card 9)
  49.   (flip-top-card 10)
  50.   (flip-top-card 2)
  51.  
  52.   (set! BASE-VAL (get-value (get-top-card 2)))
  53.   
  54.   (give-status-message)
  55.  
  56.   (add-to-score! 1)
  57.  
  58.   (list 7 4)
  59. )
  60.  
  61. (define (give-status-message)
  62.   (set-statusbar-message (string-append (get-stock-no-string)
  63.                     "   "
  64.                     (get-reserve-no-string)
  65.                     "   "
  66.                     (get-base-string))))
  67.  
  68. (define (get-stock-no-string)
  69.   (string-append (_"Stock left:") " "
  70.          (number->string (length (get-cards 0)))))
  71.  
  72. (define (get-reserve-no-string)
  73.   (string-append (_"Reserve left:") " "
  74.          (number->string (length (get-cards 6)))))
  75.  
  76. (define (get-base-string)
  77.   (cond ((and (> BASE-VAL 1)
  78.           (< BASE-VAL 11))
  79.      (string-append (_"Base Card: ") (number->string BASE-VAL)))
  80.     ((= BASE-VAL 1)
  81.      (_"Base Card: Ace"))
  82.     ((= BASE-VAL 11)
  83.      (_"Base Card: Jack"))
  84.     ((= BASE-VAL 12)
  85.      (_"Base Card: Queen"))
  86.     ((= BASE-VAL 13)
  87.      (_"Base Card: King"))
  88.     (#t "")))
  89.  
  90. (define (button-pressed slot-id card-list)
  91.   (cond ((= slot-id 0)
  92.      #f)
  93.     ((and (= slot-id 1) (> (length card-list) 1))
  94.      #f)
  95.     (else
  96.      (if card-list
  97.          (if (is-visible? (car (reverse card-list)))
  98.          (if (and (= slot-id 2)
  99.               (= (length (get-cards 2)) 1))
  100.              #f
  101.              #t)
  102.          #f)
  103.          #f))))
  104.  
  105. (define (complete-transaction start-slot card-list end-slot)
  106.   (if (and (> start-slot 1)
  107.        (< start-slot 6))
  108.       (begin
  109.     (if (= (get-value (car card-list))
  110.            BASE-VAL)
  111.         (if (empty-slot? 3)
  112.         (set! end-slot 3)
  113.         (if (empty-slot? 4)
  114.             (set! end-slot 4))))
  115.     (add-to-score! -1)))
  116.   (if (and (> end-slot 1)
  117.        (< end-slot 6))
  118.       (add-to-score! 1))
  119.   (move-n-cards! start-slot end-slot card-list)
  120.   (if (and (empty-slot? start-slot) 
  121.        (> start-slot 6)
  122.        (not (empty-slot? 6)))
  123.       (begin 
  124.     (let ((top-card (remove-card 6)))
  125.       (if (eq? top-card '())
  126.           #f
  127.           (add-card! start-slot top-card)))
  128.     (if (not (empty-slot? 6))
  129.         (make-visible-top-card 6))))
  130.   (if (and (not (empty-slot? start-slot)) 
  131.        (= start-slot 6))
  132.       (make-visible-top-card start-slot)
  133.       #f)
  134.   #t)
  135.  
  136. (define (button-released start-slot card-list end-slot)
  137.   (and (droppable? start-slot card-list end-slot)
  138.        (complete-transaction start-slot card-list end-slot)))
  139.  
  140. (define (droppable? start-slot card-list end-slot)
  141.   (and (not (= start-slot end-slot))
  142.        (or (and (empty-slot? end-slot)
  143.             (> end-slot 2) 
  144.             (< end-slot 6) 
  145.             (= 1 (length card-list))
  146.             (= BASE-VAL (get-value (car card-list))))
  147.        (and (empty-slot? end-slot)
  148.         (> end-slot 6))
  149.        (and (> end-slot 6)
  150.         (eq? (is-red? (get-top-card end-slot))
  151.              (is-black? (car (reverse card-list))))
  152.         (or (= (get-value (get-top-card end-slot))
  153.                (+ (get-value (car (reverse card-list))) 1))
  154.             (and (= (get-value (get-top-card end-slot)) ace)
  155.                      (= (get-value (car (reverse card-list))) king) )))
  156.        (and (> end-slot 1) 
  157.         (< end-slot 6)
  158.         (not (empty-slot? end-slot))
  159.         (= 1 (length card-list))
  160.         (= (get-suit (get-top-card end-slot))
  161.            (get-suit (car card-list)))
  162.         (or (= (get-value (get-top-card end-slot))
  163.                (- (get-value (car card-list)) 1))
  164.             (and (= (get-value (get-top-card end-slot)) king)
  165.                (= (get-value (car card-list)) ace)))) )))
  166.  
  167. (define (button-clicked slot-id)
  168.   (and (= slot-id 0)
  169.        (flip-stock 0 1 -1 3)))
  170.  
  171. (define (place-ace card slot)
  172.   (remove-card slot)
  173.   (if (empty-slot? 2)
  174.       (complete-transaction slot (list card) 2)
  175.       (if (empty-slot? 3)
  176.       (complete-transaction slot (list card) 3)
  177.       (if (empty-slot? 4)
  178.           (complete-transaction slot (list card) 4)
  179.           (complete-transaction slot (list card) 5)))))
  180.  
  181. (define (place-found slot top-card search)
  182.   (if (and (not (empty-slot? search))
  183.        (or (eq? (- (get-value top-card) 1) 
  184.             (get-value (get-top-card search)))
  185.            (and (eq? (get-value top-card) ace)
  186.             (eq? (get-value (get-top-card search)) king)))
  187.        (eq? (get-suit top-card) (get-suit (get-top-card search))))
  188.       (begin 
  189.     (remove-card slot)
  190.     (complete-transaction slot (list top-card) search))
  191.       (if (= search 5)
  192.       #f
  193.       (place-found slot top-card (+ search 1)))))
  194.  
  195. (define (button-double-clicked slot)
  196.   (if (and (or (> slot 5) (eq? slot 1))
  197.        (not (empty-slot? slot)))
  198.       (let ((top-card (get-top-card slot)))
  199.     (if (eq? (get-value top-card) BASE-VAL)
  200.         (place-ace top-card slot)
  201.         (place-found slot top-card 2)))))
  202.  
  203. (define (game-over)
  204.   (and (or (get-valid-move '(6 7 8 9 10 1))
  205.        (to-tableau? '(6 1))
  206.        (move-column? '(7 8 9 10))
  207.        (deal-possible?))
  208.        (give-status-message)
  209.        (not (game-won))))
  210.  
  211. (define (game-won)
  212.   (if (and (empty-slot? 0)
  213.        (empty-slot? 1)
  214.        (empty-slot? 6)
  215.        (empty-slot? 7)
  216.        (empty-slot? 8)
  217.        (empty-slot? 9)
  218.        (empty-slot? 10))
  219.       #t
  220.       #f))
  221.  
  222. (define (deal-possible?)
  223.   (if (not (empty-slot? 0))
  224.       (list 0 (_"Deal a new card from the deck"))
  225.       (list 0 (_"Move waste back to stock"))))
  226.  
  227. (define (move-up? card slot)
  228.   (or (if (empty-slot? slot)
  229.       (if (= (get-value card)
  230.          BASE-VAL)
  231.           (list 1 (get-name card) (_"empty slot on foundation"))
  232.           #f)
  233.       (and (= (get-suit card)
  234.           (get-suit (get-top-card slot)))
  235.            (or (and (= (get-value card) ace)
  236.             (= (get-value (get-top-card slot)) king))
  237.            (= (get-value card)
  238.               (+ 1 (get-value (get-top-card slot)))))
  239.            (list 2 (get-name card)
  240.              (get-name (get-top-card slot)))))
  241.       (if (< slot 5)
  242.       (move-up? card (+ 1 slot))
  243.       #f)))
  244.  
  245. (define (get-valid-move check-list)
  246.   (and (not (null? check-list))
  247.        (or (and (not (empty-slot? (car check-list)))
  248.         (move-up? (get-top-card (car check-list)) 2))
  249.        (get-valid-move (cdr check-list)))))
  250.  
  251. (define (tabled card slot)
  252.   (or (if (empty-slot? slot)
  253.       (list 1 (get-name card) (_"empty space on tableau"))
  254.       (and (eq? (is-black? card)
  255.             (is-red? (get-top-card slot)))
  256.            (or (and (= (get-value card) king)
  257.             (= (get-value (get-top-card slot)) ace))
  258.            (= (get-value card)
  259.               (- (get-value (get-top-card slot)) 1)))
  260.            (list 2 (get-name card)
  261.              (get-name (get-top-card slot)))))
  262.       (if (< slot 10)
  263.       (tabled card (+ 1 slot))
  264.       #f)))
  265.  
  266. (define (to-tableau? check-list)
  267.   (and (not (null? check-list))
  268.        (or (and (not (empty-slot? (car check-list)))
  269.         (tabled (get-top-card (car check-list)) 7))
  270.        (to-tableau? (cdr check-list)))))
  271.  
  272. (define (col-check card start-slot check-slot)
  273.   (if (> check-slot 10)
  274.       #f
  275.       (or 
  276.        (if (= start-slot check-slot)
  277.        (col-check card start-slot (+ 1 check-slot))
  278.        (and (not (empty-slot? check-slot))
  279.         (eq? (is-black? card)
  280.              (is-red? (get-top-card check-slot)))
  281.         (or (and (= (get-value card) king)
  282.              (= (get-value (get-top-card check-slot)) ace))
  283.             (= (get-value card)
  284.                (- (get-value (get-top-card check-slot)) 1)))
  285.         (list 2 (get-name card)
  286.               (get-name (get-top-card check-slot)))))
  287.        (col-check card start-slot (+ 1 check-slot)))))
  288.  
  289. (define (move-column? check-list)
  290.   (and (not (null? check-list))
  291.        (or (and (not (empty-slot? (car check-list)))
  292.         (col-check (car
  293.                 (reverse (get-cards (car check-list)))) 
  294.                (car check-list) 7))
  295.        (move-column? (cdr check-list)))))
  296.  
  297. (define (get-hint)
  298.   (or (get-valid-move '(6 7 8 9 10 1))
  299.       (to-tableau? '(6 1))
  300.       (move-column? '(7 8 9 10))
  301.       (deal-possible?)
  302.       (list 0 (_"Try rearranging the cards"))))
  303.  
  304. (define (get-options) #f)
  305.  
  306. (define (apply-options options) #f)
  307.  
  308. (define (timeout) #f)
  309.  
  310. (set-features droppable-feature)
  311.  
  312. (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?)
  313.