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