home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / klondike.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  8.3 KB  |  273 lines
  1. ; AisleRiot - klondike.scm
  2. ; Copyright (C) 1998, 2003 Jonathan Blandford <jrb@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 deal-one #t)
  20. (define deal-three #f)
  21. (define no-redeal #f)
  22.  
  23. (define max-redeal 2)
  24.  
  25. ; The set up:
  26.  
  27. (define tableau '(6 7 8 9 10 11 12))
  28. (define foundation '(2 3 4 5))
  29. (define stock 0)
  30. (define waste 1)
  31.  
  32. (define (new-game)
  33.   (initialize-playing-area)
  34.   (set-ace-low)
  35.  
  36.   (make-standard-deck)
  37.   (shuffle-deck)
  38.   
  39.   (add-normal-slot DECK)
  40.  
  41.   (if deal-three
  42.       (add-partially-extended-slot '() right 3)
  43.       (add-normal-slot '()))
  44.  
  45.   (add-blank-slot)
  46.   (add-normal-slot '())
  47.   (add-normal-slot '())
  48.   (add-normal-slot '())
  49.   (add-normal-slot '())
  50.   (add-carriage-return-slot)
  51.   (add-extended-slot '() down)
  52.   (add-extended-slot '() down)
  53.   (add-extended-slot '() down)
  54.   (add-extended-slot '() down)
  55.   (add-extended-slot '() down)
  56.   (add-extended-slot '() down)
  57.   (add-extended-slot '() down)
  58.  
  59.   (deal-tableau tableau)
  60.   
  61.   (map flip-top-card tableau)
  62.  
  63.   (give-status-message)
  64.  
  65.   (list 7 3.1)
  66. )
  67.  
  68. (define (deal-tableau tableau)
  69.   (if (not (null? tableau))
  70.       (begin
  71.         (deal-cards stock tableau)
  72.         (deal-tableau (cdr tableau)))))
  73.  
  74. (define (give-status-message)
  75.   (set-statusbar-message (string-append (get-stock-no-string)
  76.                     "   "
  77.                     (get-redeals-string))))
  78.  
  79. (define (get-redeals-string)
  80.   (if (< max-redeal 0) ""
  81.       (string-append (_"Redeals left:") " "
  82.              (number->string (- max-redeal FLIP-COUNTER)))))
  83.  
  84. (define (get-stock-no-string)
  85.   (string-append (_"Stock left:") " " 
  86.          (number->string (length (get-cards 0)))))
  87.  
  88. (define (button-pressed slot-id card-list)
  89.   (and (or (> slot-id 1)
  90.        (and (= slot-id 1)
  91.         (= (length card-list) 1)))
  92.        (is-visible? (car (reverse card-list)))))
  93.  
  94. (define (complete-transaction start-slot card-list end-slot)
  95.   (move-n-cards! start-slot end-slot card-list)
  96.   (if (member start-slot foundation)
  97.       (add-to-score! -1))
  98.   (if (member end-slot foundation)
  99.       (add-to-score! 1))
  100.   (if (and (not (empty-slot? start-slot)) 
  101.        (member start-slot tableau))
  102.       (make-visible-top-card start-slot))
  103.   #t)
  104.  
  105. (define (button-released start-slot card-list end-slot)
  106.   (if (droppable? start-slot card-list end-slot)
  107.       (complete-transaction start-slot card-list end-slot) 
  108.   #f))
  109.  
  110. (define (droppable? start-slot card-list end-slot)
  111.   (and (not (= start-slot end-slot))
  112.        (or (and (member end-slot tableau)
  113.         (if (empty-slot? end-slot)
  114.             (= king (get-value (car (reverse card-list))))
  115.             (and (not (eq? (is-red? (get-top-card end-slot))
  116.                    (is-red? (car (reverse card-list)))))
  117.              (= (get-value (get-top-card end-slot))
  118.                 (+ (get-value (car (reverse card-list))) 1)))))
  119.        (and (member end-slot foundation)
  120.         (= 1 (length card-list))
  121.         (if (empty-slot? end-slot)
  122.             (= ace (get-value (car card-list)))
  123.             (and (= (get-suit (get-top-card end-slot))
  124.                 (get-suit (car card-list)))
  125.              (= (get-value (get-top-card end-slot)) 
  126.                 (- (get-value (car card-list)) 1))))))))
  127.  
  128. (define (button-clicked start-slot)
  129.   (and (= start-slot stock)
  130.        (flip-stock stock waste max-redeal 
  131.                                (if deal-three 3 1))))
  132.  
  133. (define (button-double-clicked start-slot)
  134.   (or (and (member start-slot foundation)
  135.        (autoplay-foundations))
  136.       (and (member start-slot (cons waste tableau))
  137.        (not (empty-slot? start-slot))
  138.        (let* ((target-card
  139.            (cond ((= (get-value(get-top-card start-slot)) ace) '())
  140.              (#t (add-to-value (get-top-card start-slot) -1))))
  141.           (end-slot (search-foundation target-card foundation)))
  142.          (and end-slot
  143.           (complete-transaction start-slot 
  144.                     (list (remove-card start-slot)) 
  145.                     end-slot))))))
  146.  
  147. (define (search-foundation card foundations)
  148.   (or-map (lambda (slot) (if (equal? card (get-top-card slot))
  149.                  slot
  150.                  #f)) foundations))
  151.  
  152. (define (autoplay-foundations)
  153.   (define (autoplay-foundations-tail)
  154.     (if (or-map button-double-clicked (cons waste tableau))
  155.         (delayed-call autoplay-foundations-tail)
  156.         #t))
  157.   (if (or-map button-double-clicked (cons waste tableau))
  158.       (autoplay-foundations-tail)
  159.       #f))
  160.  
  161. ; Global variables used in searching (keeping it simple):
  162.  
  163. (define card #f)
  164. (define color 0)
  165. (define suit 0)
  166. (define value 0)
  167. (define slot-id1 0)
  168.  
  169. (define (match? slot-id2)
  170.   (and (not (empty-slot? slot-id2))
  171.        (= suit (get-suit (get-top-card slot-id2)))
  172.        (= value (get-value (get-top-card slot-id2)))
  173.        (list 1 (get-name (get-top-card slot-id2)) (get-name card))))
  174.  
  175. (define (ploppable? slot-id)
  176.   (and (not (empty-slot? slot-id))
  177.        (set! card (get-top-card slot-id))
  178.        (set! suit (get-suit card))
  179.        (set! value (+ (get-value card) 1))
  180.        (or-map match? (cons waste tableau))))
  181.  
  182. (define (is-ace? slot-id)
  183.   (and (not (empty-slot? slot-id))
  184.        (= ace (get-value (get-top-card slot-id)))
  185.        (list 2 (get-name (get-top-card slot-id)) (_"an empty slot" ))))
  186.  
  187. (define (shiftable? slot-id2)
  188.   (and (not (= slot-id2 slot-id1))
  189.        (if (empty-slot? slot-id2)
  190.        (and (= value king)
  191.         (list 2 (get-name card) (_"an empty slot")))
  192.        (and (= (get-value (get-top-card slot-id2)) (+ 1 value))
  193.         (not (= (get-color (get-top-card slot-id2)) color))
  194.         (list 1 (get-name card) (get-name (get-top-card slot-id2)))))))
  195.  
  196. (define (check-visible card)
  197.   (and (is-visible? card) card))
  198.  
  199. (define (shiftable-iter slot-id)
  200.   (and (not (empty-slot? slot-id))
  201.        (let ((card-list (reverse (get-cards slot-id))))
  202.      (set! card (or-map check-visible card-list))
  203.      (set! color (get-color card))    
  204.      (set! value (get-value card))
  205.      (set! slot-id1 slot-id)
  206.      (and (not (and (= value king)
  207.             (eq? card (car card-list))))
  208.           (or-map shiftable? tableau)))))
  209.  
  210. (define (addable? slot-id)
  211.   (if (empty-slot? slot-id)
  212.       (and (= (get-value card) king)
  213.        (list 2 (get-name card) (_"an empty slot" )))
  214.       (and (= (get-value (get-top-card slot-id)) (+ 1 (get-value card)))
  215.        (not (= (get-color (get-top-card slot-id)) (get-color card)))
  216.        (list 1 (get-name card) (get-name (get-top-card slot-id))))))
  217.  
  218. (define (get-hint)
  219.   (or (or-map is-ace? (cons waste tableau))
  220.       (or-map shiftable-iter tableau)
  221.       (and (not (empty-slot? waste))
  222.        (set! card (get-top-card waste))
  223.        (or-map addable? tableau))
  224.       (or-map ploppable? foundation)
  225.       (and (or (and (or deal-three
  226.             (< FLIP-COUNTER max-redeal))
  227.             (not (empty-slot? waste)))
  228.            (not (empty-slot? stock))) 
  229.        (list 0 (_"Deal a new card from the deck")))
  230. ; FIXME: need to give proper hints for this case too ...
  231.       (and (not (and-map empty-slot? foundation))
  232.            (list 0 (_"Try moving cards down from the foundation")))
  233.       (list 0 (_"No hint available right now"))))
  234.  
  235. (define (game-won)
  236.   (and (= 13 (length (get-cards 2)))
  237.        (= 13 (length (get-cards 3)))
  238.        (= 13 (length (get-cards 4)))
  239.        (= 13 (length (get-cards 5)))))
  240.  
  241. ; The hints still miss some useful reversible moves:
  242. ;
  243. ; 1) unplopping cards to assist in shifting groups,
  244. ; 2) unplopping cards to assist in plopping cards in other suits, 
  245. ; 3) shifting groups to assist in plopping & unplopping cards.
  246. ;
  247. ; so we must NOT report game-over when they run out.
  248.  
  249. (define (game-over)
  250.   (give-status-message)
  251.   (not (game-won)))
  252.  
  253. (define (get-options)
  254.   (list 'begin-exclusive 
  255.     (list (_ "Three card deals") deal-three)
  256.     (list (_ "Single card deals") deal-one)
  257.     (list (_ "No redeals") no-redeal)
  258.     'end-exclusive))
  259.  
  260. (define (apply-options options)
  261.   (set! deal-three (cadr (list-ref options 1)))
  262.   (set! deal-one (cadr (list-ref options 2)))
  263.   (set! no-redeal (cadr (list-ref options 3)))
  264.   (set! max-redeal (cond (no-redeal 0)
  265.              (deal-one 2)
  266.              (#t -1))))
  267.  
  268. (define (timeout) #f)
  269.  
  270. (set-features droppable-feature)
  271.  
  272. (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?)
  273.