home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / athena.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  9.1 KB  |  285 lines
  1. ;; AisleRiot - athena.scm  -*-scheme-*- 
  2. ;; Copyright (C) Alan Horkan, 2005.  
  3. ;; based on klondike.scm
  4. ; Copyright (C) 1998, 2003 Jonathan Blandford <jrb@mit.edu>
  5. ;
  6. ; This game is free software; you can redistribute it and/or modify
  7. ; it under the terms of the GNU General Public License as published by
  8. ; the Free Software Foundation; either version 2, or (at your option)
  9. ; any later version.
  10. ;
  11. ; This program is distributed in the hope that it will be useful,
  12. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ; GNU General Public License for more details.
  15. ;
  16. ; You should have received a copy of the GNU General Public License
  17. ; along with this program; if not, write to the Free Software
  18. ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  19. ; USA
  20.  
  21. ;; Athena differs from Klondike only in the intial layout
  22. ;; including 1 or 3 card deal, and any other options like ...
  23. ;; Optional "King Only" enabled by default [TODO]
  24. ;; TODO rewrite in a way less redundant way and share code with Klondike
  25. ;; As seen in Pretty Good Solitaire 10  http://goodsol.com  2005.  
  26.  
  27. (define deal-three #f)
  28.  
  29. ; The set up:
  30.  
  31. (define tableau '(6 7 8 9 10 11 12))
  32. (define foundation '(2 3 4 5))
  33. (define stock 0)
  34. (define waste 1)
  35.  
  36. (define (new-game)
  37.   (initialize-playing-area)
  38.   (set-ace-low)
  39.  
  40.   (make-standard-deck)
  41.   (shuffle-deck)
  42.   
  43.   (add-normal-slot DECK)
  44.  
  45.   (if deal-three
  46.       (add-partially-extended-slot '() right 3)
  47.       (add-normal-slot '()))
  48.  
  49.   (add-blank-slot)
  50.   (add-normal-slot '())
  51.   (add-normal-slot '())
  52.   (add-normal-slot '())
  53.   (add-normal-slot '())
  54.   (add-carriage-return-slot)
  55.   (add-extended-slot '() down)
  56.   (add-extended-slot '() down)
  57.   (add-extended-slot '() down)
  58.   (add-extended-slot '() down)
  59.   (add-extended-slot '() down)
  60.   (add-extended-slot '() down)
  61.   (add-extended-slot '() down)
  62.  
  63. ;;; start: the layout should be the only real difference from Klondike
  64.  
  65. ;; can do this lots of different ways.  
  66. ;; can do it this way: 
  67.   (deal-cards stock '(6 7 8 9 10 11 12)) 
  68.   (deal-cards-face-up stock '(6 7 8 9 10 11 12)) 
  69.   (deal-cards stock '(6 7 8 9 10 11 12)) 
  70.   (deal-cards-face-up stock '(6 7 8 9 10 11 12)) 
  71.  
  72. ;; or maybe this way  
  73. ;  (deal-cards stock tableau) 
  74. ;  (deal-cards-face-up stock tableau) 
  75. ;  (deal-cards stock tableau) 
  76. ;  (deal-cards-face-up stock tableau) 
  77. ;; or all manner of other more elegant ways which could be equally effective... 
  78. ;; which is most readable and maintainable? delete the other
  79.   
  80. ;; this would rehide the cards, dont want that.    
  81. ;  (map flip-top-card tableau)
  82.  
  83. ;;; end of changes, same as Klondike from here.  
  84.  
  85.   (give-status-message)
  86.  
  87.   (list 7 3)
  88. )
  89.  
  90. (define (give-status-message)
  91.   (set-statusbar-message (string-append (get-stock-no-string)
  92.                     "   "
  93.                     (get-redeals-string))))
  94.  
  95. (define (get-redeals-string)
  96.   (string-append (_"Redeals left:") " "
  97.          (number->string (- 2 FLIP-COUNTER))))
  98.  
  99. (define (get-stock-no-string)
  100.   (string-append (_"Stock left:") " " 
  101.          (number->string (length (get-cards 0)))))
  102.  
  103. (define (button-pressed slot-id card-list)
  104.   (and (or (> slot-id 1)
  105.        (and (= slot-id 1)
  106.         (= (length card-list) 1)))
  107.        (is-visible? (car (reverse card-list)))))
  108.  
  109. (define (complete-transaction start-slot card-list end-slot)
  110.   (move-n-cards! start-slot end-slot card-list)
  111.   (if (member start-slot foundation)
  112.       (add-to-score! -1))
  113.   (if (member end-slot foundation)
  114.       (add-to-score! 1))
  115.   (if (and (not (empty-slot? start-slot)) 
  116.        (member start-slot tableau))
  117.       (make-visible-top-card start-slot))
  118.   #t)
  119.  
  120. (define (button-released start-slot card-list end-slot)
  121.   (if (droppable? start-slot card-list end-slot)
  122.       (complete-transaction start-slot card-list end-slot)
  123.   #f))
  124.  
  125. (define (droppable? start-slot card-list end-slot)
  126.   (and (not (= start-slot end-slot))
  127.        (or (and (member end-slot tableau)
  128.         (if (empty-slot? end-slot)
  129.             (= king (get-value (car (reverse card-list))))
  130.             (and (not (eq? (is-red? (get-top-card end-slot))
  131.                    (is-red? (car (reverse card-list)))))
  132.              (= (get-value (get-top-card end-slot))
  133.                 (+ (get-value (car (reverse card-list))) 1)))))
  134.        (and (member end-slot foundation)
  135.         (= 1 (length card-list))
  136.         (if (empty-slot? end-slot)
  137.             (= ace (get-value (car card-list)))
  138.             (and (= (get-suit (get-top-card end-slot))
  139.                 (get-suit (car card-list)))
  140.              (= (get-value (get-top-card end-slot)) 
  141.                 (- (get-value (car card-list)) 1))))))))
  142.  
  143. (define (button-clicked start-slot)
  144.   (and (= start-slot stock)
  145.        (flip-stock stock waste 2 (if deal-three 3 1))))
  146.  
  147. (define (button-double-clicked start-slot)
  148.   (or (and (member start-slot foundation)
  149.             (autoplay-foundations))
  150.       (and (member start-slot (cons waste tableau))
  151.        (not (empty-slot? start-slot))
  152.        (let* ((card (get-top-card start-slot))
  153.           (suit (get-suit card))
  154.           (value (get-value card)))
  155.          (let ((end-slot 
  156.             (cond ((if (empty-slot? 2)
  157.                    (= ace value)
  158.                    (= suit (get-suit (get-top-card 2)))) 2)
  159.               ((if (empty-slot? 3)
  160.                    (= ace value)
  161.                    (= suit (get-suit (get-top-card 3)))) 3)
  162.               ((if (empty-slot? 4)
  163.                    (= ace value)
  164.                    (= suit (get-suit (get-top-card 4)))) 4)
  165.               ((if (empty-slot? 5)
  166.                    (= ace value)
  167.                    (= suit (get-suit (get-top-card 5)))) 5)
  168.               (#t #f))))
  169.            (and end-slot
  170.             (or (= ace value)
  171.             (= (get-value (get-top-card end-slot)) (- value 1)))
  172.             (remove-card start-slot)
  173.             (complete-transaction start-slot (list card) end-slot)))))))
  174. (define (autoplay-foundations)
  175.   (define (autoplay-foundations-tail)
  176.     (if (or-map button-double-clicked (cons waste tableau))
  177.         (delayed-call autoplay-foundations-tail)
  178.         #t))
  179.   (if (or-map button-double-clicked (cons waste tableau))
  180.       (autoplay-foundations-tail)
  181.       #f))
  182.  
  183. ; Global variables used in searching (keeping it simple):
  184.  
  185. (define card #f)
  186. (define color 0)
  187. (define suit 0)
  188. (define value 0)
  189. (define slot-id1 0)
  190.  
  191. (define (match? slot-id2)
  192.   (and (not (empty-slot? slot-id2))
  193.        (= suit (get-suit (get-top-card slot-id2)))
  194.        (= value (get-value (get-top-card slot-id2)))
  195.        (list 1 (get-name (get-top-card slot-id2)) (get-name card))))
  196.  
  197. (define (ploppable? slot-id)
  198.   (and (not (empty-slot? slot-id))
  199.        (set! card (get-top-card slot-id))
  200.        (set! suit (get-suit card))
  201.        (set! value (+ (get-value card) 1))
  202.        (or-map match? (cons waste tableau))))
  203.  
  204. (define (is-ace? slot-id)
  205.   (and (not (empty-slot? slot-id))
  206.        (= ace (get-value (get-top-card slot-id)))
  207.        (list 2 (get-name (get-top-card slot-id)) (_"an empty slot" ))))
  208.  
  209. (define (shiftable? slot-id2)
  210.   (and (not (= slot-id2 slot-id1))
  211.        (if (empty-slot? slot-id2)
  212.        (and (= value king)
  213.         (list 2 (get-name card) (_"an empty slot")))
  214.        (and (= (get-value (get-top-card slot-id2)) (+ 1 value))
  215.         (not (= (get-color (get-top-card slot-id2)) color))
  216.         (list 1 (get-name card) (get-name (get-top-card slot-id2)))))))
  217.  
  218. (define (check-visible card)
  219.   (and (is-visible? card) card))
  220.  
  221. (define (shiftable-iter slot-id)
  222.   (and (not (empty-slot? slot-id))
  223.        (let ((card-list (reverse (get-cards slot-id))))
  224.      (set! card (or-map check-visible card-list))
  225.      (set! color (get-color card))    
  226.      (set! value (get-value card))
  227.      (set! slot-id1 slot-id)
  228.      (and (not (and (= value king)
  229.             (eq? card (car card-list))))
  230.           (or-map shiftable? tableau)))))
  231.  
  232. (define (addable? slot-id)
  233.   (if (empty-slot? slot-id)
  234.       (and (= (get-value card) king)
  235.        (list 2 (get-name card) (_"an empty slot" )))
  236.       (and (= (get-value (get-top-card slot-id)) (+ 1 (get-value card)))
  237.        (not (= (get-color (get-top-card slot-id)) (get-color card)))
  238.        (list 1 (get-name card) (get-name (get-top-card slot-id))))))
  239.  
  240. (define (get-hint)
  241.   (or (or-map is-ace? (cons waste tableau))
  242.       (or-map shiftable-iter tableau)
  243.       (and (not (empty-slot? waste))
  244.        (set! card (get-top-card waste))
  245.        (or-map addable? tableau))
  246.       (or-map ploppable? foundation)
  247.       (and (or (and (< FLIP-COUNTER 2)
  248.             (not (empty-slot? waste)))
  249.            (not (empty-slot? stock))) 
  250.        (list 0 (_"Deal a new card from the deck")))
  251. ; FIXME: need to give proper hints for this case too ...
  252.       (and (not (and-map empty-slot? '(2 3 4 5)))
  253.            (list 0 (_"Try moving cards down from the foundation")))
  254.       (list 0 (_"No hint available right now"))))
  255.  
  256. (define (game-won)
  257.   (and (= 13 (length (get-cards 2)))
  258.        (= 13 (length (get-cards 3)))
  259.        (= 13 (length (get-cards 4)))
  260.        (= 13 (length (get-cards 5)))))
  261.  
  262. ; The hints still miss some useful reversible moves:
  263. ;
  264. ; 1) unplopping cards to assist in shifting groups,
  265. ; 2) unplopping cards to assist in plopping cards in other suits, 
  266. ; 3) shifting groups to assist in plopping & unplopping cards.
  267. ;
  268. ; so we must NOT report game-over when they run out.
  269.  
  270. (define (game-over)
  271.   (give-status-message)
  272.   (not (game-won)))
  273.  
  274. (define (get-options)
  275.   (list (list (_"Three card deals") deal-three)))
  276.  
  277. (define (apply-options options)
  278.   (set! deal-three (cadar options)))
  279.  
  280. (define (timeout) #f)
  281.  
  282. (set-features droppable-feature)
  283.  
  284. (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?)
  285.