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