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