home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / carpet.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  5.7 KB  |  198 lines
  1. ; AisleRiot - carpet.scm
  2. ; Copyright (C) 2005 Vincent Povirk <madewokherd@gmail.com>
  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 (tableau? slot-id)
  20.   (< 5 slot-id))
  21. (define foundation '(2 3 4 5))
  22. (define stock 0)
  23. (define waste 1)
  24.  
  25. (define (remove-aces cards foundation-ids remaining-cards)
  26.   (if (eq? cards '())
  27.       remaining-cards
  28.       (if (= (get-value (car cards)) ace)
  29.           (and (move-n-cards! stock (car foundation-ids) (list (make-visible (car cards))))
  30.                (remove-aces (cdr cards) (cdr foundation-ids) remaining-cards))
  31.           (remove-aces (cdr cards) foundation-ids (cons (car cards) remaining-cards)))))
  32.  
  33. (define (deal-cards-to-tableau slot-id)
  34.   (and (< slot-id 26)
  35.        (deal-cards-face-up stock (list slot-id))
  36.        (deal-cards-to-tableau (+ slot-id 1))))
  37.  
  38. (define (new-game)
  39.   (initialize-playing-area)
  40.   (set-ace-low)
  41.  
  42.   (make-standard-deck)
  43.   (shuffle-deck)
  44.   
  45.   (add-normal-slot '())
  46.   (add-normal-slot '())
  47.  
  48.   (add-blank-slot)
  49.   (add-normal-slot '())
  50.   (add-normal-slot '())
  51.   (add-normal-slot '())
  52.   (add-normal-slot '())
  53.   (add-carriage-return-slot)
  54.  
  55.   (add-blank-slot)
  56.   (add-blank-slot)
  57.   (add-normal-slot '())
  58.   (add-normal-slot '())
  59.   (add-normal-slot '())
  60.   (add-normal-slot '())
  61.   (add-normal-slot '())
  62.   (add-carriage-return-slot)
  63.   
  64.   (add-blank-slot)
  65.   (add-blank-slot)
  66.   (add-normal-slot '())
  67.   (add-normal-slot '())
  68.   (add-normal-slot '())
  69.   (add-normal-slot '())
  70.   (add-normal-slot '())
  71.   (add-carriage-return-slot)
  72.   
  73.   (add-blank-slot)
  74.   (add-blank-slot)
  75.   (add-normal-slot '())
  76.   (add-normal-slot '())
  77.   (add-normal-slot '())
  78.   (add-normal-slot '())
  79.   (add-normal-slot '())
  80.   (add-carriage-return-slot)
  81.   
  82.   (add-blank-slot)
  83.   (add-blank-slot)
  84.   (add-normal-slot '())
  85.   (add-normal-slot '())
  86.   (add-normal-slot '())
  87.   (add-normal-slot '())
  88.   (add-normal-slot '())
  89.   
  90.   (set-cards! stock (remove-aces DECK foundation '()))
  91.  
  92.   (deal-cards-to-tableau 6)
  93.  
  94.   (give-status-message)
  95.  
  96.   (list 7 5)
  97. )
  98.  
  99. (define (give-status-message)
  100.   (set-statusbar-message (string-append (get-stock-no-string))))
  101.  
  102. (define (get-stock-no-string)
  103.   (string-append (_"Stock left:") " " 
  104.          (number->string (length (get-cards 0)))))
  105.  
  106. (define (button-pressed slot-id card-list)
  107.   (or (tableau? slot-id)
  108.       (= slot-id waste)))
  109.  
  110. (define (complete-transaction start-slot card-list end-slot)
  111.   (move-n-cards! start-slot end-slot card-list)
  112.   (add-to-score! 1)
  113.   (or (not (tableau? start-slot))
  114.       (and (not (empty-slot? waste))
  115.            (move-n-cards! waste start-slot (list (get-top-card waste)))
  116.            (remove-n-cards waste 1))
  117.       (and (not (empty-slot? stock))
  118.            (move-n-cards! stock start-slot (list (make-visible (get-top-card stock))))
  119.            (remove-n-cards stock 1))
  120.   #t))
  121.  
  122. (define (button-released start-slot card-list end-slot)
  123.   (if (droppable? start-slot card-list end-slot)
  124.       (complete-transaction start-slot card-list end-slot) 
  125.   #f))
  126.  
  127. (define (droppable? start-slot card-list end-slot)
  128.   (and (member end-slot foundation)
  129.        (= (get-suit (car card-list)) (get-suit (get-top-card end-slot)))
  130.        (= (get-value (car card-list)) (+ 1 (get-value (get-top-card end-slot))))))
  131.  
  132. (define (button-clicked start-slot)
  133.   (and (= start-slot stock)
  134.        (flip-stock stock waste 0 1)))
  135.  
  136. (define (play-to-foundation start-slot end-slots)
  137.   (if (or (eq? end-slots '())
  138.           (empty-slot? start-slot))
  139.       #f
  140.       (if (droppable? start-slot (list (get-top-card start-slot)) (car end-slots))
  141.           (letrec ((card (get-top-card start-slot)))
  142.             (remove-n-cards start-slot 1)
  143.             (complete-transaction start-slot (list card) (car end-slots)))
  144.           (play-to-foundation start-slot (cdr end-slots)))))
  145.  
  146. (define (button-double-clicked slot-id)
  147.   (and (or (= waste slot-id)
  148.            (tableau? slot-id))
  149.        (play-to-foundation slot-id foundation)))
  150.  
  151. (define (hint-to-foundation start-slot end-slots)
  152.   (if (or (eq? end-slots '())
  153.           (empty-slot? start-slot))
  154.       #f
  155.       (if (droppable? start-slot (list (get-top-card start-slot)) (car end-slots))
  156.           (list 1
  157.             (get-name (get-top-card start-slot))
  158.             (get-name (get-top-card (car end-slots))))
  159.           (hint-to-foundation start-slot (cdr end-slots)))))
  160.  
  161. (define (hint-tableau-to-foundation start-slot)
  162.   (if (= start-slot 26)
  163.       #f
  164.       (or (hint-to-foundation start-slot foundation)
  165.           (hint-tableau-to-foundation (+ start-slot 1)))))
  166.  
  167. (define (hint-flip-stock)
  168.   (and (not (empty-slot? stock))
  169.        (list 0 (_"Deal a new card from the deck"))))
  170.  
  171. (define (get-hint)
  172.   (or (hint-tableau-to-foundation 6)
  173.       (hint-to-foundation waste foundation)
  174.       (hint-flip-stock)))
  175.  
  176. (define (game-won)
  177.   (and (= 13 (length (get-cards 2)))
  178.        (= 13 (length (get-cards 3)))
  179.        (= 13 (length (get-cards 4)))
  180.        (= 13 (length (get-cards 5)))))
  181.  
  182. (define (game-over)
  183.   (give-status-message)
  184.   (and (not (game-won))
  185.        (get-hint)))
  186.  
  187. (define (get-options)
  188.   #f)
  189.  
  190. (define (apply-options options)
  191.   #f)
  192.  
  193. (define (timeout) #f)
  194.  
  195. (set-features droppable-feature)
  196.  
  197. (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?)
  198.