home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / ten_across.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  12.8 KB  |  378 lines
  1. ; AisleRiot - ten-across.scm
  2. ;; base on klondike.scm
  3. ; Copyright (C) 1998, 2003 Jonathan Blandford <jrb@mit.edu>
  4. ; Copyright (C) 1999 James LewisMoss <dres@debian.org>
  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. (define allow-two-spot-use #t)
  22.  
  23. ; The set up:
  24.  
  25. (define tableau '(2 3 4 5 6 7 8 9 10 11))
  26. (define tmp-spots '(0 1))
  27. (define stock 0)
  28.  
  29. (define (new-game)
  30.   (initialize-playing-area)
  31.   (set-ace-low)
  32.   
  33.   (make-standard-deck)
  34.   (shuffle-deck)
  35.   
  36.   (add-blank-slot)
  37.   (add-normal-slot DECK)
  38.   (add-normal-slot '())
  39.   (add-carriage-return-slot)
  40.   (map (lambda (ignore) (add-extended-slot '() down)) tableau)
  41.   (map (lambda (slot)
  42.          (set-slot-y-expansion!
  43.           slot 0.25))
  44.        tableau)
  45.   (deal-ten-across-cards)
  46.  
  47.   (deal-cards-face-up stock '(1))
  48.  
  49.   (flip-top-card stock)
  50.   
  51.   (list 10 4))
  52.  
  53. (define (deal-ten-across-cards)
  54.   (let* ((deal-len (length tableau))
  55.          (direction #t)
  56.          (deal-ten-across-int
  57.           (lambda (num)
  58.             (if direction
  59.                 (begin
  60.                   (deal-cards-face-up stock (list-head tableau num))
  61.                   (deal-cards stock
  62.                               (list-head
  63.                                (list-tail tableau num) (- deal-len num num)))
  64.                   (deal-cards-face-up stock (list-tail tableau (- deal-len num))))
  65.                 (begin
  66.                   (deal-cards-face-up stock
  67.                                       (reverse (list-tail tableau
  68.                                                           (- deal-len num))))
  69.                   (deal-cards stock
  70.                               (reverse (list-head
  71.                                         (list-tail tableau num)
  72.                                         (- deal-len num num))))
  73.                   (deal-cards-face-up stock (reverse (list-head tableau num)))))
  74.             (set! direction (not direction)))))
  75.   (map (lambda (num-now) (deal-ten-across-int num-now)) '(1 2 3 4 5))))
  76.  
  77. ;; testing functions
  78. ;;(define deal-cards (lambda (num slot-list) (map (lambda (num1) (display "dealing face-down to ")(display num1)(display "\n")) slot-list)))
  79. ;;(define deal-cards-face-up (lambda (num slot-list) (map (lambda (num1) (display "dealing face-up to ") (display num1) (display "\n")) slot-list)))
  80. ;;(deal-ten-across-cards)
  81.  
  82. (define (button-pressed slot-id card-list)
  83.   (and (or (> slot-id 1)
  84.            (and (member slot-id tmp-spots)
  85.                 (= (length card-list) 1)))
  86.        (is-visible? (car (reverse card-list)))))
  87.  
  88. (define (complete-transaction start-slot card-list end-slot)
  89.   (move-n-cards! start-slot end-slot card-list)
  90.   (if (and (not (empty-slot? start-slot)) 
  91.            (member start-slot tableau))
  92.       (make-visible-top-card start-slot))
  93.   #t)
  94.  
  95. (define (is-ok-to-place card1 card2)
  96.   (and (= (get-suit card1)
  97.           (get-suit card2))
  98.        (= (get-value card2)
  99.           (+ (get-value card1) 1))))
  100.  
  101. (define (droppable? start-slot card-list end-slot)
  102.   (and (not (= start-slot end-slot))
  103.        (or (and (member end-slot tableau)
  104.                 (if (empty-slot? end-slot)
  105.                     (= king (get-value (car (reverse card-list))))
  106.                     (is-ok-to-place (car (reverse card-list))
  107.                                     (get-top-card end-slot))))
  108.            (and allow-two-spot-use
  109.                 (member end-slot tmp-spots)
  110.                 (= 1 (length card-list))
  111.                 (empty-slot? end-slot)))))
  112.  
  113. (define (button-released start-slot card-list end-slot)
  114.   (and (droppable? start-slot card-list end-slot)
  115.        (complete-transaction start-slot card-list end-slot)))
  116.  
  117. (define (button-clicked start-slot)
  118.   #f)
  119.  
  120. (define (button-double-clicked start-slot)
  121.   ;; uncomment for some debugging output :)
  122. ;;  (display (get-cards 0))
  123. ;;  (newline)
  124. ;;  (display (get-cards 1))
  125. ;;  (newline)
  126. ;;  (display (get-cards 2))
  127. ;;  (newline)
  128. ;;  (display (get-cards 3))
  129. ;;  (newline)
  130. ;;  (display (get-cards 4))
  131. ;;  (newline)
  132. ;;  (display (get-cards 5))
  133. ;;  (newline)
  134. ;;  (display (get-cards 6))
  135. ;;  (newline)
  136. ;;  (display (get-cards 7))
  137. ;;  (newline)
  138. ;;  (display (get-cards 8))
  139. ;;  (newline)
  140. ;;  (display (get-cards 9))
  141. ;;  (newline)
  142. ;;  (display (get-cards 10))
  143. ;;  (newline)
  144. ;;  (display (get-cards 11))
  145. ;;  (newline)
  146.   #f)
  147.  
  148. ;; three things to test for
  149. ;; 1) empty slot and a king not currently in an empty slot
  150. ;; 2) a visible card that will fit on the end of a current row
  151. ;; 3) a single card at the top of a stack either of non-visible cards
  152. ;;    or non-connected cards and an empty temporary spot.
  153.  
  154. ;;----------------------------------------------------------------------
  155. (define (have-empty-slot? slot-list)
  156.   (or-map (lambda (item) (= 0 (length (get-cards item)))) slot-list))
  157.  
  158. (define (king? card)
  159.   (= (get-value card) king))
  160.  
  161. (define (get-good-king-for-empty-move slot-list)
  162.   (or-map (lambda (item)
  163.             (let ((cards1 (get-cards item)))
  164.                    ;; cut out the last card because if it's a king we
  165.                    ;; don't want to move it
  166.               (if (> (length cards1) 0)
  167.                   (or-map (lambda (item) (if (and (is-visible? item)
  168.                                               (king? item))
  169.                                              item
  170.                                          #f))
  171.                       (list-head cards1 (- (length cards1) 1)))
  172.                   #f)))
  173.           slot-list))
  174.  
  175. ;; ** 3 **
  176. (define (test-king-move slot-list)
  177.   (if (have-empty-slot? slot-list)
  178.       (let ((good-king (get-good-king-for-empty-move slot-list)))
  179.         (if (list? good-king)
  180.             (list 2 (get-name good-king) (_"an empty slot"))
  181.             #f))
  182.       #f))
  183.  
  184. ;;----------------------------------------------------------------------
  185. (define (find-card-for item slot-num slot-list)
  186.   (or-map (lambda (slot)
  187.             (or-map (lambda (card)
  188.                       (if (and (not (= slot-num slot))
  189.                                (is-visible? card)
  190.                                (is-ok-to-place card item))
  191.                           (list card item)
  192.                           #f))
  193.                       (get-cards slot)))
  194.           slot-list))
  195.  
  196. ;; ** 2 **
  197. (define (test-stack-move slot-list tmp-list)
  198.   (let ((cards (or-map
  199.                 (lambda (slot)
  200.                   (let ((card-list (get-cards slot)))
  201.                     (if (not (null? card-list))
  202.                         (find-card-for (car card-list) slot slot-list)
  203.                         #f)))
  204.                 slot-list)))
  205.         (if (list? cards)
  206.             (list 2 (get-name (car cards)) (get-name (cadr cards)))
  207.             #f)))
  208.  
  209. ;;----------------------------------------------------------------------
  210. (define (get-top-cards slot-list)
  211.   (map (lambda (slot)
  212.          (let ((cards (get-cards slot)))
  213.            (if (null? cards)
  214.                '()
  215.                (car cards))))
  216.        slot-list))
  217.  
  218. ;; ** 1 **
  219. (define (test-for-tmp-move-down slot-list tmp-list)
  220.   (let* ((move-to-cards (get-top-cards slot-list))
  221.          (move-from-cards (get-top-cards tmp-list))
  222.          (cards (or-map (lambda (card1)
  223.                           (or-map (lambda (card2)
  224.                                     (cond ((and (null? card2)
  225.                                                 (not (null? card1))
  226.                                                 (king? card1))
  227.                                            (list card1 (_"an empty slot")))
  228.                                           ((and (not (null? card1))
  229.                                                 (not (null? card2))
  230.                                                 (is-ok-to-place card1 card2))
  231.                                            (list card1 card2))
  232.                                           (#t #f)))
  233.                                   move-to-cards))
  234.                         move-from-cards)))
  235.     (if (list? cards)
  236.         (list 1
  237.               (get-name (car cards))
  238.               (if (list? (cadr cards))
  239.                   (get-name (cadr cards))
  240.                   (cadr cards)))
  241.         #f)))
  242.  
  243. ;;----------------------------------------------------------------------
  244. (define (add-up-open-slots tmp-list)
  245.   (if (null? tmp-list)
  246.       0
  247.       (+ (if (= (length (get-cards (car tmp-list))) 0) 1 0)
  248.          (add-up-open-slots (cdr tmp-list)))))
  249.  
  250. (define (all-in-order-showing-helper card-list suit value)
  251.   (if (null? card-list)
  252.       #t
  253.       (let ((card (car card-list)))
  254.         (if (or (not (= (get-suit card) suit))
  255.                 (not (= (get-value card) value)))
  256.             #f
  257.             (all-in-order-showing-helper (cdr card-list) suit (+ 1 value))))))
  258.  
  259. (define (all-in-order-showing card-list)
  260.   (all-in-order-showing-helper (cdr card-list) (get-suit (car card-list))
  261.                                (+ 1 (get-value (car card-list)))))
  262.  
  263. (define (same-stack-smaller-helper card-list suit value num)
  264.   (if (or (null? card-list)
  265.           (<= 1 num))
  266.       #f
  267.       (let ((card (car card-list)))
  268.         (if (or (and (not (null? (cdr card-list)))
  269.                      (not (is-visible? (cadr card-list))))
  270.                 (not (= suit (get-suit card)))
  271.                 (not (= value (get-value card))))
  272.             card
  273.             (same-stack-smaller-helper (cdr card-list)
  274.                                        suit (+ 1 value) (- 1 num))))))
  275.  
  276. (define (same-stack-smaller card-list num)
  277.   (let ((card (car card-list)))
  278.     (same-stack-smaller-helper (cdr card-list) (get-suit card)
  279.                                (+ 1 (get-value card)) (- 1 num))))
  280.  
  281.  
  282. (define (has-no-hidden card-list)
  283.   (if (null? card-list)
  284.       #t
  285.       (if (not (is-visible? (car card-list)))
  286.           (has-no-hidden (cdr card-list))
  287.           #f)))
  288.  
  289. (define (less-than-same-cards card-list num)
  290.   (if (or (null? card-list)
  291.           (all-in-order-showing card-list)
  292.           (has-no-hidden card-list))
  293.       #f
  294.       (same-stack-smaller card-list num)))
  295.  
  296.           
  297.           
  298. (define (find-good-move-to-tmp-list slot-list num)
  299.   (or-map (lambda (one-slot)
  300.             (let ((cards (get-cards one-slot)))
  301.               (less-than-same-cards cards num)))
  302.           slot-list))
  303.  
  304. (define (prepare-move-response card)
  305.   (list 2 (string-append (get-name card) " " (_"and all cards below it"))
  306.         (_"empty slot(s)")))
  307.  
  308. ;; ** 4 **
  309. (define (test-for-good-tmp-move slot-list tmp-list)
  310.   (let ((num-open-tmp-slots (add-up-open-slots tmp-list)))
  311.     (if (> num-open-tmp-slots 0)
  312.         (let ((good-card-list (find-good-move-to-tmp-list slot-list
  313.                                                           num-open-tmp-slots)))
  314.           (if (list? good-card-list)
  315.               (prepare-move-response good-card-list)
  316.               #f))
  317.         #f)))
  318.  
  319. (define should-we-do-tmp-move-test #f)
  320.  
  321. ;;----------------------------------------------------------------------
  322. (define (get-hint)
  323.   (or
  324.    (test-for-tmp-move-down tableau tmp-spots)
  325.    (test-stack-move tableau tmp-spots) 
  326.    (test-king-move tableau) 
  327.    (if should-we-do-tmp-move-test
  328.        (test-for-good-tmp-move tableau tmp-spots)
  329.        (if (have-empty-slot? tmp-spots)
  330.            (list 0 (_"Move a card to an empty temporary slot"))
  331.            (list 0 (_"No hint available"))))
  332.    (list 0 (_"No hint available"))))
  333.  
  334. (define final-stack-helper
  335.   (lambda (the-list num suit)
  336.     (if (null? the-list)
  337.         #t
  338.         (let ((card (car the-list))
  339.               (rest (cdr the-list)))
  340.           (if (and (is-visible? card)
  341.                    (= suit (get-suit card))
  342.                    (= num (get-value card)))
  343.               (final-stack-helper rest (+ 1 num) suit)
  344.               #f)))))
  345.  
  346. (define (final-stack? card-list)
  347.     (final-stack-helper card-list 1 (get-suit (car card-list))))
  348.  
  349. (define won-tester
  350.   (lambda (slot-list)
  351.     (let ((to-test (car slot-list))
  352.           (to-cont (cdr slot-list)))
  353.       (if (or (and (= 13 (length (get-cards to-test)))
  354.                    (final-stack? (get-cards to-test)))
  355.               (= 0 (length (get-cards to-test))))
  356.           (if (equal? to-cont '())
  357.               #t
  358.               (won-tester to-cont))
  359.           #f))))
  360.   
  361. (define (game-won)
  362.   (won-tester tableau))
  363.  
  364. (define (game-over)
  365.   (not (game-won)))
  366.  
  367. (define (get-options)
  368.   (list (list (_"Allow temporary spots use") allow-two-spot-use)))
  369.  
  370. (define (apply-options options)
  371.   (set! allow-two-spot-use (cadar options)))
  372.  
  373. (define (timeout) #f)
  374.  
  375. (set-features droppable-feature scores-disabled)
  376.  
  377. (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?)
  378.