home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / union_square.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  15.3 KB  |  487 lines
  1. ; AisleRiot - union_square.scm
  2. ; Copyright (C) 1999 Rosanna Yuen <rwsy@mit.edu>
  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.   (add-normal-slot '())
  27.  
  28.   (add-blank-slot)
  29.  
  30.   (add-partially-extended-slot '() right 2)
  31.   (add-partially-extended-slot '() right 2)
  32.   (add-partially-extended-slot '() right 2)
  33.   (add-partially-extended-slot '() right 2)
  34.  
  35.   (add-blank-slot)
  36.  
  37.   (add-partially-extended-slot '() right 2)
  38.  
  39.   (add-carriage-return-slot)
  40.   (add-blank-slot)
  41.   (add-blank-slot)
  42.   (add-blank-slot)
  43.  
  44.   (add-partially-extended-slot '() right 2)
  45.   (add-partially-extended-slot '() right 2)
  46.   (add-partially-extended-slot '() right 2)
  47.   (add-partially-extended-slot '() right 2)
  48.  
  49.   (add-blank-slot)
  50.  
  51.   (add-partially-extended-slot '() right 2)
  52.  
  53.   (add-carriage-return-slot)
  54.   (add-blank-slot)
  55.   (add-blank-slot)
  56.   (add-blank-slot)
  57.  
  58.   (add-partially-extended-slot '() right 2)
  59.   (add-partially-extended-slot '() right 2)
  60.   (add-partially-extended-slot '() right 2)
  61.   (add-partially-extended-slot '() right 2)
  62.  
  63.   (add-blank-slot)
  64.  
  65.   (add-partially-extended-slot '() right 2)
  66.   (add-carriage-return-slot)
  67.   (add-blank-slot)
  68.   (add-blank-slot)
  69.   (add-blank-slot)
  70.  
  71.   (add-partially-extended-slot '() right 2)
  72.   (add-partially-extended-slot '() right 2)
  73.   (add-partially-extended-slot '() right 2)
  74.   (add-partially-extended-slot '() right 2)
  75.  
  76.   (add-blank-slot)
  77.  
  78.   (add-partially-extended-slot '() right 2)
  79.  
  80.   (deal-cards-face-up 0 '(2 3 4 5 7 8 9 10 12 13 14 15 17 18 19 20))
  81.  
  82.   (give-status-message)
  83.  
  84.   (list 10 4)
  85. )
  86.  
  87. (define (give-status-message)
  88.   (set-statusbar-message (get-stock-no-string)))
  89.  
  90. (define (get-stock-no-string)
  91.   (string-append (_"Stock left:") " " 
  92.          (number->string (length (get-cards 0)))))
  93.  
  94.  
  95. (define (button-pressed slot-id card-list)
  96.   (and (not (empty-slot? slot-id))
  97.        (is-visible? (car card-list))
  98.        (= (length card-list) 1)
  99.        (not (or (= slot-id 6)
  100.         (= slot-id 11)
  101.         (= slot-id 16)
  102.         (= slot-id 21)))))
  103.  
  104. (define (to-foundation? card-list end-slot)
  105.   (if (empty-slot? end-slot)
  106.       (and (eq? (get-value (car card-list)) ace)
  107.        (or (= end-slot 6)
  108.            (empty-slot? 6)
  109.            (not (eq? (get-suit (get-top-card 6))
  110.              (get-suit (car card-list)))))
  111.        (or (= end-slot 11)
  112.            (empty-slot? 11)
  113.            (not (eq? (get-suit (get-top-card 11))
  114.              (get-suit (car card-list)))))
  115.        (or (= end-slot 16)
  116.            (empty-slot? 16)
  117.            (not (eq? (get-suit (get-top-card 16))
  118.              (get-suit (car card-list)))))
  119.        (or (= end-slot 21)
  120.            (empty-slot? 21)
  121.            (not (eq? (get-suit (get-top-card 21))
  122.              (get-suit (car card-list))))))
  123.       (if (eq? (get-suit (get-top-card end-slot))
  124.            (get-suit (car card-list)))
  125.       (cond ((< (length (get-cards end-slot)) 13)
  126.          (= (+ 1 (get-value (get-top-card end-slot)))
  127.             (get-value (car card-list))))
  128.         ((= (length (get-cards end-slot)) 13)
  129.          (= (get-value (car card-list)) 13))
  130.         (#t
  131.          (= (get-value (get-top-card end-slot))
  132.             (+ 1 (get-value (car card-list))))))
  133.       #f)))
  134.  
  135. (define (to-tableau? card-list end-slot)
  136.   (if (empty-slot? end-slot)
  137.       #t
  138.       (if (eq? (get-suit (get-top-card end-slot))
  139.            (get-suit (car card-list)))
  140.       (cond ((= (length (get-cards end-slot)) 1)
  141.          (or (= (get-value (car card-list))
  142.             (+ 1 (get-value (get-top-card end-slot))))
  143.              (= (+ 1 (get-value (car card-list)))
  144.             (get-value (get-top-card end-slot)))))
  145.         ((= (get-value (get-top-card end-slot))
  146.             (+ 1 (get-value (cadr (get-cards end-slot)))))
  147.          (= (get-value (car card-list))
  148.             (+ 1 (get-value (get-top-card end-slot)))))
  149.         ((= (+ 1 (get-value (get-top-card end-slot)))
  150.             (get-value (cadr (get-cards end-slot))))
  151.          (= (+ 1 (get-value (car card-list)))
  152.             (get-value (get-top-card end-slot))))
  153.         (#t #f))
  154.       #f)))
  155.  
  156. (define (droppable? start-slot card-list end-slot)
  157.   (cond ((or (= end-slot start-slot)
  158.              (= end-slot 0)
  159.          (= end-slot 1))
  160.      #f)
  161.     ((or (= end-slot 6)
  162.          (= end-slot 11)
  163.          (= end-slot 16)
  164.          (= end-slot 21))
  165.      (to-foundation? card-list end-slot))
  166.     (#t
  167.      (to-tableau? card-list end-slot))))
  168.  
  169. (define (button-released start-slot card-list end-slot)
  170.   (and (droppable? start-slot card-list end-slot)
  171.        (cond ((or (= end-slot 6)
  172.                   (= end-slot 11)
  173.               (= end-slot 16)
  174.               (= end-slot 21))
  175.           (and (move-n-cards! start-slot end-slot card-list)
  176.            (add-to-score! 1)))
  177.          (#t
  178.           (move-n-cards! start-slot end-slot card-list)))))
  179.  
  180. (define (button-clicked slot-id)
  181.   (and (= slot-id 0)
  182.        (not (empty-slot? 0))
  183.        (deal-cards-face-up 0 '(1))))
  184.  
  185. (define (play-foundation-helper start-slot end-slots)
  186.   (define card (get-top-card start-slot))
  187.   (if (to-foundation? (list card) (car end-slots))
  188.       (and (remove-card start-slot)
  189.            (move-n-cards! start-slot (car end-slots) (list card))
  190.            (add-to-score! 1))
  191.       (if (eq? (cdr end-slots) '())
  192.           #f
  193.           (play-foundation-helper start-slot (cdr end-slots)))))
  194.  
  195. (define (button-double-clicked slot-id)
  196.   (cond ((member slot-id '(1 2 3 4 5 7 8 9 10 12 13 14 15 17 18 19 20))
  197.          (and (not (empty-slot? slot-id))
  198.               (play-foundation-helper slot-id '(6 11 16 21))))
  199.         ((member slot-id '(6 11 16 21))
  200.          (autoplay-foundations))
  201.         (#t #f)))
  202.  
  203. (define (autoplay-foundations)
  204.   (define (autoplay-foundations-tail)
  205.     (if (or-map button-double-clicked '(1 2 3 4 5 7 8 9 10 12 13 14 15 17 18 19 20))
  206.         (delayed-call autoplay-foundations-tail)
  207.         #t))
  208.   (if (or-map button-double-clicked '(1 2 3 4 5 7 8 9 10 12 13 14 15 17 18 19 20))
  209.       (autoplay-foundations-tail)
  210.       #f))
  211.  
  212. (define (game-continuable)
  213.   (give-status-message)
  214.   (not (game-won)))
  215.  
  216. (define (game-won)
  217.   (and (= (length (get-cards 6)) 26)
  218.        (= (length (get-cards 11)) 26)
  219.        (= (length (get-cards 16)) 26)
  220.        (= (length (get-cards 21)) 26)))
  221.  
  222. (define (check-a-foundation card-list end-slot)
  223.   (if (> end-slot 21)
  224.       #f
  225.       (if (to-foundation? card-list end-slot)
  226.       #t
  227.       (check-a-foundation card-list (+ 5 end-slot)))))
  228.  
  229. (define (check-to-foundations slot-id)
  230.   (if (> slot-id 20)
  231.       #f
  232.       (if (or (empty-slot? slot-id)
  233.           (= slot-id 6)
  234.           (= slot-id 11)
  235.           (= slot-id 16)
  236.           (not (check-a-foundation (list (get-top-card slot-id)) 6)))
  237.       (check-to-foundations (+ 1 slot-id))
  238.       (list 2 (get-name (get-top-card slot-id)) (_"appropriate foundation pile")))))
  239.  
  240. (define (check-imbedded card-list foundation-id)
  241.   (if (> (length card-list) 0)
  242.       (if (to-foundation? card-list foundation-id)
  243.       #t
  244.       (check-imbedded (cdr card-list) foundation-id))
  245.       #f))
  246.  
  247. (define (check-slot-contents slot-id)
  248.   (cond ((and (not (empty-slot? 6))
  249.           (eq? (get-suit (get-top-card slot-id))
  250.            (get-suit (get-top-card 6)))
  251.           (check-imbedded (get-cards slot-id) 6))
  252.      (check-imbedded (get-cards slot-id) 6))
  253.     ((and (not (empty-slot? 11))
  254.           (eq? (get-suit (get-top-card slot-id))
  255.            (get-suit (get-top-card 11)))
  256.           (check-imbedded (get-cards slot-id) 11))
  257.      (check-imbedded (get-cards slot-id) 11))
  258.     ((and (not (empty-slot? 16))
  259.           (eq? (get-suit (get-top-card slot-id))
  260.            (get-suit (get-top-card 16)))
  261.           (check-imbedded (get-cards slot-id) 16))
  262.      (check-imbedded (get-cards slot-id) 16))
  263.     ((and (not (empty-slot? 21))
  264.           (eq? (get-suit (get-top-card slot-id))
  265.            (get-suit (get-top-card 21)))
  266.           (check-imbedded (get-cards slot-id) 21))
  267.      (check-imbedded (get-cards slot-id) 21))
  268.     ((and (empty-slot? 6)
  269.           (check-imbedded (get-cards slot-id) 6))
  270.      (check-imbedded (get-cards slot-id) 6))
  271.     ((and (empty-slot? 11)
  272.           (check-imbedded (get-cards slot-id) 11))
  273.      (check-imbedded (get-cards slot-id) 11))
  274.     ((and (empty-slot? 16)
  275.           (check-imbedded (get-cards slot-id) 16))
  276.      (check-imbedded (get-cards slot-id) 16))
  277.     ((and (empty-slot? 21)
  278.           (check-imbedded (get-cards slot-id) 21))
  279.      (check-imbedded (get-cards slot-id) 21))
  280.     ((and (> (length (get-cards slot-id)) 1)
  281.           (or (and (not (= slot-id 2))
  282.                (not (empty-slot? 2))
  283.                (to-tableau? (reverse (get-cards slot-id)) 2)
  284.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  285.                    (get-value (get-top-card 2)))))
  286.           (and (not (= slot-id 3))
  287.                (not (empty-slot? 3))
  288.                (to-tableau? (reverse (get-cards slot-id)) 3)
  289.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  290.                    (get-value (get-top-card 3)))))
  291.           (and (not (= slot-id 4))
  292.                (not (empty-slot? 4))
  293.                (to-tableau? (reverse (get-cards slot-id)) 4)
  294.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  295.                    (get-value (get-top-card 4)))))
  296.           (and (not (= slot-id 5))
  297.                (not (empty-slot? 5))
  298.                (to-tableau? (reverse (get-cards slot-id)) 5)
  299.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  300.                    (get-value (get-top-card 5)))))
  301.           (and (not (= slot-id 7))
  302.                (not (empty-slot? 7))
  303.                (to-tableau? (reverse (get-cards slot-id)) 7)
  304.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  305.                    (get-value (get-top-card 7)))))
  306.           (and (not (= slot-id 8))
  307.                (not (empty-slot? 8))
  308.                (to-tableau? (reverse (get-cards slot-id)) 8)
  309.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  310.                    (get-value (get-top-card 8)))))
  311.           (and (not (= slot-id 9))
  312.                (not (empty-slot? 9))
  313.                (to-tableau? (reverse (get-cards slot-id)) 9)
  314.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  315.                    (get-value (get-top-card 9)))))
  316.           (and (not (= slot-id 10))
  317.                (not (empty-slot? 10))
  318.                (to-tableau? (reverse (get-cards slot-id)) 10)
  319.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  320.                    (get-value (get-top-card 10)))))
  321.           (and (not (= slot-id 12))
  322.                (not (empty-slot? 12))
  323.                (to-tableau? (reverse (get-cards slot-id)) 12)
  324.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  325.                    (get-value (get-top-card 12)))))
  326.           (and (not (= slot-id 13))
  327.                (not (empty-slot? 13))
  328.                (to-tableau? (reverse (get-cards slot-id)) 13)
  329.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  330.                    (get-value (get-top-card 13)))))
  331.           (and (not (= slot-id 14))
  332.                (not (empty-slot? 14))
  333.                (to-tableau? (reverse (get-cards slot-id)) 14)
  334.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  335.                    (get-value (get-top-card 14)))))
  336.           (and (not (= slot-id 15))
  337.                (not (empty-slot? 15))
  338.                (to-tableau? (reverse (get-cards slot-id)) 15)
  339.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  340.                    (get-value (get-top-card 15)))))
  341.           (and (not (= slot-id 17))
  342.                (not (empty-slot? 17))
  343.                (to-tableau? (reverse (get-cards slot-id)) 17)
  344.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  345.                    (get-value (get-top-card 17)))))
  346.           (and (not (= slot-id 18))
  347.                (not (empty-slot? 18))
  348.                (to-tableau? (reverse (get-cards slot-id)) 18)
  349.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  350.                    (get-value (get-top-card 18)))))
  351.           (and (not (= slot-id 19))
  352.                (not (empty-slot? 19))
  353.                (to-tableau? (reverse (get-cards slot-id)) 19)
  354.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  355.                    (get-value (get-top-card 19)))))
  356.           (and (not (= slot-id 20))
  357.                (not (empty-slot? 20))
  358.                        (to-tableau? (reverse (get-cards slot-id)) 20)
  359.                (not (= (get-value (cadr (reverse (get-cards slot-id))))
  360.                    (get-value (get-top-card 20)))))))
  361.      #t)
  362.     (#t #f)))
  363.  
  364. (define (check-a-tslot slot1 slot2)
  365.   (if (> slot2 20)
  366.       #f
  367.       (if (and (not (= slot2 6))
  368.            (not (= slot2 11))
  369.            (not (= slot2 16))
  370.            (not (empty-slot? slot2))
  371.            (not (= slot1 slot2))
  372.            (not (empty-slot? slot1))
  373.            (to-tableau? (list (get-top-card slot1)) slot2)
  374.            (or (= slot1 1)
  375.            (= (length (get-cards slot1)) 1)
  376.            (not (= (get-value (cadr (get-cards slot1)))
  377.                (get-value (get-top-card slot2))))))
  378.       (if (and (not (= slot1 1))
  379.            (not (empty-slot? slot2))
  380.            (to-tableau? (list (get-top-card slot2)) slot1)
  381.            (check-slot-contents slot2))
  382.           (list 1 (get-name (get-top-card slot2))
  383.             (get-name (get-top-card slot1)))
  384.           (list 1 (get-name (get-top-card slot1))
  385.             (get-name (get-top-card slot2))))
  386.       (check-a-tslot slot1 (+ 1 slot2)))))
  387.  
  388. (define (check-tableau slot-id)
  389.   (if (= slot-id 1)
  390.       (and (not (empty-slot? 1))
  391.        (check-a-tslot 1 2))
  392.       (if (or (= slot-id 6)
  393.           (= slot-id 11)
  394.           (= slot-id 16))
  395.       (check-tableau (- slot-id 1))
  396.       (or (check-a-tslot slot-id 2)
  397.           (check-tableau (- slot-id 1))))))
  398.  
  399. (define (check-for-empty slot-id)
  400.   (if (= slot-id 21)
  401.       #f
  402.       (if (and (not (= slot-id 6))
  403.            (not (= slot-id 11))
  404.            (not (= slot-id 16))
  405.            (empty-slot? slot-id))
  406.       slot-id
  407.       (check-for-empty (+ 1 slot-id)))))
  408.  
  409. (define (check-rev-tableau slot1 slot2)
  410.   (if (= slot2 21)
  411.       #f
  412.       (if (or (empty-slot? slot2)
  413.           (= slot1 slot2)
  414.           (= slot2 6)
  415.           (= slot2 11)
  416.           (= slot2 16))
  417.       (check-rev-tableau slot1 (+ 1 slot2))
  418.       (if (and (to-tableau? (reverse (get-cards slot1)) slot2)
  419.            (= (abs (- (get-value (cadr (reverse (get-cards slot1))))
  420.                   (get-value (get-top-card slot2))))
  421.               2))
  422.           slot1
  423.           (check-rev-tableau slot1 (+ 1 slot2))))))
  424.  
  425. (define (check-for-bottom slot-id)
  426.   (if (= slot-id 21)
  427.       #f
  428.       (if (or (empty-slot? slot-id)
  429.           (= 1 (length (get-cards slot-id)))
  430.           (= slot-id 6)
  431.           (= slot-id 11)
  432.           (= slot-id 16))
  433.       (check-for-bottom (+ 1 slot-id))
  434.       (or (check-rev-tableau slot-id 2)
  435.           (check-for-bottom (+ 1 slot-id))))))
  436.           
  437. (define (contents-check slot-id)
  438.   (if (= slot-id 21)
  439.       #f
  440.       (if (and (not (= slot-id 6))
  441.            (not (= slot-id 11))
  442.            (not (= slot-id 16))
  443.            (not (empty-slot? slot-id))
  444.            (check-slot-contents slot-id))
  445.       slot-id
  446.       (contents-check (+ 1 slot-id)))))
  447.  
  448. (define (check-empty-slot)
  449.   (if (not (check-for-empty 2))
  450.       #f
  451.       (cond ((contents-check 2)
  452.          (list 2 (get-name (get-top-card (contents-check 2)))
  453.            (_"an empty slot")))
  454.         ((check-for-bottom 2)
  455.          (list 2 (get-name (get-top-card (check-for-bottom 2)))
  456.            (_"an empty slot")))
  457.         ((not (empty-slot? 1))
  458.          (list 2 (get-name (get-top-card 1)) (_"an empty slot")))
  459.         (#t #f))))
  460.  
  461. (define (dealable?)
  462.   (if (not (empty-slot? 0))
  463.       (list 0 (_"Deal a card"))
  464.       #f))
  465.  
  466. (define (get-hint)
  467.   (or (check-to-foundations 1)
  468.       (check-tableau 20)
  469.       (check-empty-slot)
  470.       (dealable?)))
  471.  
  472. (define (get-options) 
  473.   #f)
  474.  
  475. (define (apply-options options) 
  476.   #f)
  477.  
  478. (define (timeout) 
  479.   #f)
  480.  
  481. (set-features droppable-feature)
  482.  
  483. (set-lambda new-game button-pressed button-released button-clicked
  484. button-double-clicked game-continuable game-won get-hint get-options
  485. apply-options timeout droppable?)
  486.  
  487.