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