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