home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / jumbo.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  11.1 KB  |  374 lines
  1. ; AisleRiot - jumbo.scm
  2. ; Copyright (C) 2001, 2003 Rosanna Yuen <zana@webwynk.net>
  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 (new-game)
  20.   (initialize-playing-area)
  21.   (set-ace-low)
  22.   (make-standard-double-deck)
  23.   (shuffle-deck)
  24.  
  25.  
  26.   (add-normal-slot DECK)
  27.   (add-normal-slot '())
  28.  
  29.   (add-blank-slot)
  30.  
  31.   (add-normal-slot '())
  32.   (add-normal-slot '())
  33.   (add-normal-slot '())
  34.   (add-normal-slot '())
  35.   (add-normal-slot '())
  36.   (add-normal-slot '())
  37.   (add-normal-slot '())
  38.   (add-normal-slot '())
  39.   (add-carriage-return-slot)
  40.  
  41.   (add-blank-slot)
  42.  
  43.   (add-extended-slot '() down)
  44.   (add-extended-slot '() down)
  45.   (add-extended-slot '() down)
  46.   (add-extended-slot '() down)
  47.   (add-extended-slot '() down)
  48.   (add-extended-slot '() down)
  49.   (add-extended-slot '() down)
  50.   (add-extended-slot '() down)
  51.   (add-extended-slot '() down)
  52.  
  53.   (deal-cards 0 '(10 11 12 13 14 15 16 17 18 10 11 12 13 14 15 16 17
  54.              10 11 12 13 14 15 16 10 11 12 13 14 15 10 11 12
  55.              13 14 10 11 12 13 10 11 12 10 11 10))
  56.  
  57.   (map flip-top-card '(10 11 12 13 14 15 16 17 18))
  58.  
  59.   (give-status-message)
  60.   (list 11 4))
  61.  
  62. (define (give-status-message)
  63.   (set-statusbar-message (string-append (get-stock-no-string)
  64.                     "   "
  65.                     (get-redeals-string))))
  66.  
  67. (define (get-redeals-string)
  68.   (string-append (_"Redeals left:") " "
  69.          (number->string (- 1 FLIP-COUNTER))))
  70.  
  71. (define (get-stock-no-string)
  72.   (string-append (_"Stock left:") " " 
  73.          (number->string (length (get-cards 0)))))
  74.  
  75. (define (button-pressed slot-id card-list)
  76.   (and (or (> slot-id 1)
  77.        (and (= slot-id 1)
  78.         (= (length card-list) 1)))
  79.        (is-visible? (car (reverse card-list)))))
  80.  
  81. (define (complete-transaction start-slot card-list end-slot)
  82.   (move-n-cards! start-slot end-slot card-list)
  83.   (if (and (> start-slot 1)
  84.        (< start-slot 10))
  85.       (add-to-score! -1))
  86.   (if (and (> end-slot 1)
  87.        (< end-slot 10))
  88.       (add-to-score! 1))
  89.   (if (and (not (empty-slot? start-slot))
  90.        (> start-slot 9))
  91.       (make-visible-top-card start-slot))
  92.   #t)
  93.  
  94. (define (droppable? start-slot card-list end-slot)
  95.   (cond ((and (> end-slot 1)
  96.           (< end-slot 10))
  97.      (and (= (length card-list) 1)
  98.           (not (= start-slot end-slot))
  99.           (or (and (= (get-value (car card-list)) ace)
  100.                (empty-slot? end-slot))
  101.           (and (not (empty-slot? end-slot))
  102.                (= (get-suit (car card-list))
  103.               (get-suit (get-top-card end-slot)))
  104.                (= (get-value (car card-list))
  105.               (+ 1 (get-value (get-top-card end-slot))))))))
  106.     ((> end-slot 9)
  107.      (and (not (= start-slot end-slot))
  108.           (or (and (empty-slot? end-slot)
  109.                (= (get-value (car (reverse card-list))) king))
  110.           (and (not (empty-slot? end-slot))
  111.                (not (eq? (is-red? (get-top-card end-slot))
  112.                  (is-red? (car (reverse card-list)))))
  113.                (= (get-value (get-top-card end-slot))
  114.               (+ (get-value (car (reverse card-list))) 1))))))
  115.     (#t #f)))
  116.  
  117. (define (button-released start-slot card-list end-slot)
  118.   (if (droppable? start-slot card-list end-slot)
  119.       (complete-transaction start-slot card-list end-slot)
  120.       #f))
  121.  
  122. (define (button-clicked slot-id)
  123.   (and (= slot-id 0)
  124.        (flip-stock 0 1 1)))
  125.  
  126. (define (check-to-foundation card f-slot)
  127.   (cond ((= f-slot 10)
  128.      #f)
  129.     ((or (and (empty-slot? f-slot)
  130.           (= (get-value card) ace))
  131.          (and (not (empty-slot? f-slot))
  132.           (= (get-suit card)
  133.              (get-suit (get-top-card f-slot)))
  134.           (= (get-value card)
  135.              (+ 1 (get-value (get-top-card f-slot))))))
  136.      f-slot)
  137.     (#t (check-to-foundation card (+ 1 f-slot)))))
  138.  
  139. (define (button-double-clicked slot-id)
  140.   (cond ((or (= slot-id 1)
  141.          (> slot-id 9))
  142.          (and (not (empty-slot? slot-id))
  143.               (check-to-foundation (get-top-card slot-id) 2)
  144.               (deal-cards slot-id (list (check-to-foundation (get-top-card slot-id) 2)))
  145.               (or (empty-slot? slot-id)
  146.               (make-visible-top-card slot-id))
  147.               (add-to-score! 1)))
  148.         ((> slot-id 1)
  149.          (autoplay-foundations))
  150.         (#t #f)))
  151.  
  152. (define (autoplay-foundations)
  153.   (define (autoplay-foundations-tail)
  154.     (if (or-map button-double-clicked '(1 10 11 12 13 14 15 16 17 18))
  155.         (delayed-call autoplay-foundations-tail)
  156.         #t))
  157.   (if (or-map button-double-clicked '(1 10 11 12 13 14 15 16 17 18))
  158.       (autoplay-foundations-tail)
  159.       #f))
  160.  
  161. (define (game-continuable)
  162.   (give-status-message)
  163.   (and (not (game-won))
  164.        (get-hint)))
  165.  
  166. (define (game-won)
  167.   (and (empty-slot? 0)
  168.        (empty-slot? 1)
  169.        (empty-slot? 10)
  170.        (empty-slot? 11)
  171.        (empty-slot? 12)
  172.        (empty-slot? 13)
  173.        (empty-slot? 14)
  174.        (empty-slot? 15)
  175.        (empty-slot? 16)
  176.        (empty-slot? 17)
  177.        (empty-slot? 18)))
  178.  
  179. (define (get-name-from-tableau slot)
  180.   (if (empty-slot? slot)
  181.       (_"an empty tableau slot")
  182.       (get-name (get-top-card slot))))
  183.  
  184. (define (strip card-list)
  185.   (if (not (is-visible? (cadr card-list)))
  186.       (car card-list)
  187.       (strip (cdr card-list))))
  188.  
  189. (define (check-plop card t-slot)
  190.   (cond ((= t-slot 19)
  191.      #f)
  192.     ((and (not (empty-slot? t-slot))
  193.           (eq? (is-red? card)
  194.            (is-black? (get-top-card t-slot)))
  195.           (= (+ 1 (get-value card))
  196.          (get-value (get-top-card t-slot))))
  197.      t-slot)
  198.     ((and (empty-slot? t-slot)
  199.           (= (get-value card)
  200.          king))
  201.      t-slot)
  202.     (#t (check-plop card (+ 1 t-slot)))))
  203.  
  204. (define (check-uncover t-slot)
  205.   (cond ((= t-slot 19)
  206.      #f)
  207.     ((and (not (empty-slot? t-slot))
  208.           (not (is-visible? (car (reverse (get-cards t-slot)))))
  209.           (check-plop (strip (get-cards t-slot)) 10))
  210.      (list 1 
  211.        (get-name (strip (get-cards t-slot)))
  212.        (get-name-from-tableau (check-plop (strip (get-cards t-slot)) 
  213.                            10))))
  214.     ((and (not (empty-slot? t-slot))
  215.           (> (length (get-cards t-slot)) 1)
  216.           (not (is-visible? (cadr (get-cards t-slot))))
  217.           (check-a-slot-to-foundations t-slot 2))
  218.      (check-a-slot-to-foundations t-slot 2))
  219.     (#t (check-uncover (+ 1 t-slot)))))
  220.  
  221. (define (check-a-foundation-for-uncover card f-slot)
  222.   (cond ((= f-slot 10)
  223.      #f)
  224.     ((and (not (empty-slot? f-slot))
  225.           (eq? (is-red? card)
  226.            (is-black? (get-top-card f-slot)))
  227.           (= (+ 1 (get-value card))
  228.          (get-value (get-top-card f-slot)))
  229.           (check-plop (get-top-card f-slot) 10))
  230.      (list 1 
  231.            (get-name (get-top-card f-slot))
  232.            (get-name-from-tableau (check-plop (get-top-card f-slot) 10))))
  233.     (#t (check-a-foundation-for-uncover card (+ 1 f-slot)))))
  234.  
  235. (define (check-foundation-for-uncover t-slot)
  236.   (cond ((= t-slot 19)
  237.      #f)
  238.     ((and (not (empty-slot? t-slot))
  239.           (not (is-visible? (car (reverse (get-cards t-slot)))))
  240.           (check-a-foundation-for-uncover (strip (get-cards t-slot)) 2))
  241.      (check-a-foundation-for-uncover (strip (get-cards t-slot)) 2))
  242.     (#t (check-foundation-for-uncover (+ 1 t-slot)))))
  243.  
  244. (define (check-empty-tslot t-slot)
  245.   (cond ((= t-slot 19)
  246.      #f)
  247.     ((and (not (empty-slot? t-slot))
  248.           (is-visible? (car (reverse (get-cards t-slot))))
  249.           (check-plop (car (reverse (get-cards t-slot))) 10))
  250.      (if (empty-slot? (check-plop (car (reverse (get-cards t-slot))) 10))
  251.          (check-empty-tslot (+ 1 t-slot))
  252.          (list 1
  253.            (get-name (car (reverse (get-cards t-slot))))
  254.            (get-name-from-tableau (check-plop (car (reverse (get-cards t-slot)))
  255.                                10)))))
  256.     (#t (check-empty-tslot (+ 1 t-slot)))))
  257.  
  258. (define (check-move-waste t-slot)
  259.   (cond ((or (= t-slot 19)
  260.          (empty-slot? 1))
  261.      #f)
  262.     ((and (not (empty-slot? t-slot))
  263.           (eq? (is-red? (get-top-card 1))
  264.            (is-black? (get-top-card t-slot)))
  265.           (= (+ 1 (get-value (get-top-card 1)))
  266.          (get-value (get-top-card t-slot))))
  267.      (list 1 
  268.            (get-name (get-top-card 1))
  269.            (get-name (get-top-card t-slot))))
  270.     ((and (empty-slot? t-slot)
  271.           (= (get-value (get-top-card 1)) king))
  272.      (list 2
  273.            (get-name (get-top-card 1))
  274.            (_"an empty tableau slot")))
  275.     ((check-a-slot-to-foundations 1 2)
  276.      (check-a-slot-to-foundations 1 2))
  277.     (#t (check-move-waste (+ 1 t-slot)))))
  278.  
  279. (define (check-to-foundations slot f-slot)
  280.   (cond ((= slot 19)
  281.      #f)
  282.     ((empty-slot? slot)
  283.      (check-to-foundations (+ 1 slot) f-slot))
  284.     ((= slot 2)
  285.      (check-to-foundations 10 2))
  286.     ((check-a-slot-to-foundations slot f-slot)
  287.      (check-a-slot-to-foundations slot f-slot))
  288.     (#t (check-to-foundations (+ 1 slot) f-slot))))
  289.  
  290. (define (check-a-slot-to-foundations slot f-slot)
  291.   (cond ((= f-slot 10)
  292.      #f)
  293.     ((= (get-value (get-top-card slot))
  294.         ace)
  295.      (list 2
  296.            (get-name (get-top-card slot))
  297.            (_"an empty foundation")))
  298.     ((and (not (empty-slot? f-slot))
  299.           (= (get-suit (get-top-card slot))
  300.          (get-suit (get-top-card f-slot)))
  301.           (= (get-value (get-top-card slot))
  302.          (+ 1 (get-value (get-top-card f-slot)))))
  303.      (list 1
  304.            (get-name (get-top-card slot))
  305.            (get-name (get-top-card f-slot))))
  306.     (#t (check-a-slot-to-foundations slot (+ 1 f-slot)))))
  307.     
  308. (define (check-simple-foundation slot happynum)
  309.   (cond ((= slot 19)
  310.      #f)
  311.     ((= slot 2)
  312.      (check-simple-foundation 10 happynum))
  313.     ((and (not (empty-slot? slot))
  314.           (<= (get-value (get-top-card slot)) happynum)
  315.           (check-a-slot-to-foundations slot 2))
  316.      (check-a-slot-to-foundations slot 2))
  317.     (#t (check-simple-foundation (+ 1 slot) happynum))))
  318.  
  319. (define (dealable?)
  320.   (or (and (not (empty-slot? 0))
  321.        (list 0 (_"Deal another card")))
  322.       (and (not (empty-slot? 1))
  323.        (< FLIP-COUNTER 1)
  324.        (list 0 (_"Move waste to stock")))))
  325.  
  326. (define (get-min-happy-foundation fslot value)
  327.   (cond ((= fslot 10)
  328.      value)
  329.     ((empty-slot? fslot)
  330.      2)
  331.     (#t (get-min-happy-foundation (+ 1 fslot) 
  332.                       (min value (+ 2 (get-value (get-top-card fslot))))))))
  333.  
  334. (define (check-foundation-for-waste f-slot)
  335.   (cond ((or (= f-slot 10)
  336.          (empty-slot? 1))
  337.      #f)
  338.     ((and (not (empty-slot? f-slot))
  339.           (eq? (is-red? (get-top-card f-slot))
  340.            (is-black? (get-top-card 1)))
  341.           (= (get-value (get-top-card f-slot))
  342.          (+ 1 (get-value (get-top-card 1))))
  343.           (check-plop (get-top-card f-slot) 10))
  344.      (list 1
  345.            (get-name (get-top-card f-slot))
  346.            (get-name-from-tableau (check-plop (get-top-card f-slot) 10))))
  347.     (#t (check-foundation-for-waste (+ 1 f-slot)))))
  348.  
  349. (define (get-hint)
  350.   (or (check-simple-foundation 1 (get-min-happy-foundation 2 king))
  351.       (check-uncover 10)
  352.       (check-empty-tslot 10)
  353.       (check-move-waste 10)
  354.       (check-foundation-for-uncover 10)
  355.       (check-foundation-for-waste 2)
  356.       (dealable?)
  357.       (check-to-foundations 1 2)
  358.       (list 0 (_"Try rearranging the cards"))))
  359.  
  360. (define (get-options) 
  361.   #f)
  362.  
  363. (define (apply-options options) 
  364.   #f)
  365.  
  366. (define (timeout) 
  367.   #f)
  368.  
  369. (set-features droppable-feature)
  370.        
  371. (set-lambda new-game button-pressed button-released button-clicked
  372. button-double-clicked game-continuable game-won get-hint get-options
  373. apply-options timeout droppable?)
  374.