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