home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / chessboard.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  7.9 KB  |  287 lines
  1. ; AisleRiot - chessboard.scm
  2. ; Copyright (C) 2001, 2003 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 BASE-VAL 0)
  20. (def-save-var base-set? #f)
  21.  
  22. (define (new-game)
  23.   (initialize-playing-area)
  24.   (set-ace-low)
  25.   (make-standard-deck)
  26.   (shuffle-deck)
  27.  
  28.   (set! base-set? #f)
  29.  
  30.   (add-extended-slot '() right)
  31.  
  32.   (add-blank-slot)
  33.   (add-blank-slot)
  34.   (add-blank-slot)
  35.   (add-blank-slot)
  36.   (add-blank-slot)
  37.   (add-extended-slot '() right)
  38.  
  39.   (add-carriage-return-slot)
  40.  
  41.   (add-extended-slot '() right)
  42.   (add-blank-slot)
  43.   (add-blank-slot)
  44.   (add-blank-slot)
  45.   (add-normal-slot DECK)
  46.   (add-blank-slot)
  47.   (add-extended-slot '() right)
  48.  
  49.   (add-carriage-return-slot)
  50.  
  51.   (add-extended-slot '() right)
  52.   (add-blank-slot)
  53.   (add-blank-slot)
  54.   (add-blank-slot)
  55.   (add-normal-slot '())
  56.   (add-blank-slot)
  57.   (add-extended-slot '() right)
  58.  
  59.   (add-carriage-return-slot)
  60.  
  61.   (add-extended-slot '() right)
  62.   (add-blank-slot)
  63.   (add-blank-slot)
  64.   (add-blank-slot)
  65.   (add-normal-slot '())
  66.   (add-blank-slot)
  67.   (add-extended-slot '() right)
  68.   (add-carriage-return-slot)
  69.  
  70.   (add-extended-slot '() right)
  71.   (add-blank-slot)
  72.   (add-blank-slot)
  73.   (add-blank-slot)
  74.   (add-normal-slot '())
  75.   (add-blank-slot)
  76.   (add-extended-slot '() right)
  77.  
  78.   (deal-cards-face-up 3 '(0 2 5 8 11 1 4 7 10 13 0 2 5 8 11 1 4 7 10 13 0 2 5 8 11 1 4 7 10 13 0 2 5 8 11 1 4 7 10 13 0 2 5 8 11 1 4 7 10 13 0 1))
  79.  
  80.   (give-status-message)
  81.  
  82.   (list 10 5))
  83.  
  84. (define (give-status-message)
  85.   (if (not base-set?)
  86.       (set-statusbar-message " ")
  87.       (set-statusbar-message (get-base-string))))
  88.  
  89. (define (get-base-string)
  90.   (cond ((and (> BASE-VAL 1)
  91.           (< BASE-VAL 11))
  92.      (string-append (_"Base Card: ") (number->string BASE-VAL)))
  93.     ((= BASE-VAL 1)
  94.      (_"Base Card: Ace"))
  95.     ((= BASE-VAL 11)
  96.      (_"Base Card: Jack"))
  97.     ((= BASE-VAL 12)
  98.      (_"Base Card: Queen"))
  99.     ((= BASE-VAL 13)
  100.      (_"Base Card: King"))
  101.     (#t "")))
  102.  
  103. (define (button-pressed slot-id card-list)
  104.   (and (not (empty-slot? slot-id))
  105.        (not (= slot-id 3))
  106.        (not (= slot-id 6))
  107.        (not (= slot-id 9))
  108.        (not (= slot-id 12))
  109.        (= (length card-list) 1)))
  110.  
  111. (define (droppable? start-slot card-list end-slot)
  112.   (cond ((= start-slot end-slot) #f)
  113.         ((member end-slot '(3 6 9 12))
  114.      (and (or (and (empty-slot? end-slot)
  115.                (or (not base-set?)
  116.                (= (get-value (car card-list)) BASE-VAL)))
  117.           (and (not (empty-slot? end-slot))
  118.                (= (get-suit (get-top-card end-slot))
  119.               (get-suit (car card-list)))
  120.                (or (= (get-value (car card-list))
  121.                   (+ 1 (get-value (get-top-card end-slot))))
  122.                (and (= (get-value (car card-list)) ace)
  123.                 (= (get-value (get-top-card end-slot)) king)))))))
  124.     (#t (or (empty-slot? end-slot)
  125.          (and (= (get-suit (get-top-card end-slot))
  126.              (get-suit (car card-list)))
  127.           (or (= (get-value (get-top-card end-slot))
  128.              (+ 1 (get-value (car card-list))))
  129.               (and (= (get-value (get-top-card end-slot)) king)
  130.                (= (get-value (car card-list)) ace))
  131.               (and (= (get-value (get-top-card end-slot)) ace)
  132.                (= (get-value (car card-list)) king))
  133.               (= (+ 1 (get-value (get-top-card end-slot)))
  134.              (get-value (car card-list)))))))))
  135.  
  136. (define (button-released start-slot card-list end-slot)
  137.   (and (droppable? start-slot card-list end-slot)
  138.        (move-n-cards! start-slot end-slot card-list)
  139.        (or (not (member end-slot '(3 6 9 12)))
  140.            (and (add-to-score! 1)
  141.                 (or base-set?
  142.                     (and (set! BASE-VAL (get-value (car card-list)))
  143.                          (set! base-set? #t)))))))
  144.  
  145. (define (button-clicked slot-id)
  146.   #f)
  147.  
  148. (define (move-to-foundation slot f-slot)
  149.   (cond ((= f-slot 15)
  150.      #f)
  151.     ((not base-set?)
  152.      (and (set! base-set? #t)
  153.           (set! BASE-VAL (get-value (get-top-card slot)))
  154.           (deal-cards slot '(3))
  155.           (add-to-score! 1)))
  156.     ((and (empty-slot? f-slot)
  157.           (= (get-value (get-top-card slot)) BASE-VAL))
  158.      (and (deal-cards slot (list f-slot))
  159.           (add-to-score! 1)))
  160.     ((and (not (empty-slot? f-slot))
  161.           (= (get-suit (get-top-card f-slot))
  162.          (get-suit (get-top-card slot)))
  163.           (or (and (= (get-value (get-top-card f-slot)) king)
  164.                (= (get-value (get-top-card slot)) ace))
  165.           (= (+ 1 (get-value (get-top-card f-slot)))
  166.              (get-value (get-top-card slot)))))
  167.      (and (deal-cards slot (list f-slot))
  168.           (add-to-score! 1)))
  169.     (#t (move-to-foundation slot (+ 3 f-slot)))))
  170.  
  171. (define (button-double-clicked slot-id)
  172.   (and (not (empty-slot? slot-id))
  173.        (or (= slot-id 0)
  174.        (not (= (modulo slot-id 3) 0)))
  175.        (move-to-foundation slot-id 3)))
  176.  
  177. (define (game-continuable)
  178.   (give-status-message)
  179.   (and (not (game-won))
  180.        (get-hint)))
  181.  
  182. (define (game-won)
  183.   (and (empty-slot? 0)
  184.        (empty-slot? 1)
  185.        (empty-slot? 2)
  186.        (empty-slot? 4)
  187.        (empty-slot? 5)
  188.        (empty-slot? 7)
  189.        (empty-slot? 8)
  190.        (empty-slot? 10)
  191.        (empty-slot? 11)
  192.        (empty-slot? 13)))
  193.  
  194. (define (to-foundations? slot f-slot)
  195.   (cond ((= slot 14)
  196.      #f)
  197.     ((not base-set?)
  198.      (list 0 (_"Move a card to the Foundation")))
  199.     ((or (empty-slot? slot)
  200.          (= slot 3)
  201.          (= slot 6)
  202.          (= slot 9)
  203.          (= slot 12)
  204.          (= f-slot 15))
  205.      (to-foundations? (+ 1 slot) 3))
  206.     ((and (empty-slot? f-slot)
  207.           (= (get-value (get-top-card slot))
  208.          BASE-VAL))
  209.      (list 2
  210.            (get-name (get-top-card slot))
  211.            (_"an empty foundation")))
  212.     ((and (not (empty-slot? f-slot))
  213.           (= (get-suit (get-top-card f-slot))
  214.          (get-suit (get-top-card slot)))
  215.           (or (and (= (get-value (get-top-card slot)) ace)
  216.                (= (get-value (get-top-card f-slot)) king))
  217.           (= (get-value (get-top-card slot))
  218.              (+ 1 (get-value (get-top-card f-slot))))))
  219.      (list 1
  220.            (get-name (get-top-card slot))
  221.            (get-name (get-top-card f-slot))))
  222.     (#t (to-foundations? slot (+ 3 f-slot)))))
  223.  
  224. (define (to-tableau? slot1 slot2)
  225.   (cond ((= slot1 14)
  226.      #f)
  227.     ((or (empty-slot? slot1)
  228.          (= slot2 14)
  229.          (= slot1 3)
  230.          (= slot1 6)
  231.          (= slot1 9)
  232.          (= slot1 12))
  233.      (to-tableau? (+ 1 slot1) (+ 2 slot1)))
  234.     ((and (not (or (= slot2 3)
  235.                (= slot2 6)
  236.                (= slot2 9)
  237.                (= slot2 12)))
  238.           (not (empty-slot? slot2))
  239.           (= (get-suit (get-top-card slot1))
  240.          (get-suit (get-top-card slot2)))
  241.           (or (= (get-value (get-top-card slot1))
  242.              (+ 1 (get-value (get-top-card slot2))))
  243.           (and (= (get-value (get-top-card slot1)) king)
  244.                (= (get-value (get-top-card slot2)) ace))
  245.           (and (= (get-value (get-top-card slot1)) ace)
  246.                (= (get-value (get-top-card slot2)) king))
  247.           (= (get-value (get-top-card slot2))
  248.              (+ 1 (get-value (get-top-card slot1))))))
  249.      (list 1
  250.            (get-name (get-top-card slot1))
  251.            (get-name (get-top-card slot2))))
  252.     (#t
  253.      (to-tableau? slot1 (+ 1 slot2)))))
  254.  
  255. (define (empties?)
  256.   (and (or (empty-slot? 0)
  257.        (empty-slot? 1)
  258.        (empty-slot? 2)
  259.        (empty-slot? 4)
  260.        (empty-slot? 5)
  261.        (empty-slot? 7)
  262.        (empty-slot? 8)
  263.        (empty-slot? 10)
  264.        (empty-slot? 11)
  265.        (empty-slot? 13))
  266.        (list 0 (_"Move something into the empty Tableau slot"))))
  267.  
  268. (define (get-hint)
  269.   (or (to-foundations? 0 3)
  270.       (to-tableau? 0 1)
  271.       (empties?)))
  272.  
  273. (define (get-options) 
  274.   #f)
  275.  
  276. (define (apply-options options) 
  277.   #f)
  278.  
  279. (define (timeout) 
  280.   #f)
  281.  
  282. (set-features droppable-feature)
  283.  
  284. (set-lambda new-game button-pressed button-released button-clicked
  285. button-double-clicked game-continuable game-won get-hint get-options
  286. apply-options timeout droppable?)
  287.