home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / backbone.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  8.3 KB  |  289 lines
  1. ; AisleRiot - backbone.scm
  2. ; Copyright (C) 1998, 2003 Jonathan Blandford <jrb@mit.edu>,
  3. ;                      2005 Vincent Povirk <madewokherd@gmail.com>
  4. ;
  5. ; This game is free software; you can redistribute it and/or modify
  6. ; it under the terms of the GNU General Public License as published by
  7. ; the Free Software Foundation; either version 2, or (at your option)
  8. ; any later version.
  9. ;
  10. ; This program is distributed in the hope that it will be useful,
  11. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ; GNU General Public License for more details.
  14. ;
  15. ; You should have received a copy of the GNU General Public License
  16. ; along with this program; if not, write to the Free Software
  17. ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  18. ; USA
  19.  
  20. (define tableau '(0 1 6 7 12 13 16 17))
  21. (define foundation '(2 3 4 5 8 9 10 11))
  22. (define stock 14)
  23. (define waste 15)
  24. (define reserve '(18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36))
  25.  
  26. (define (reserve? slot) (> slot 17))
  27. (define (playable? slot)
  28.   (or 
  29.     (= slot 17)
  30.     (member slot tableau)
  31.     (reserve? slot)))
  32.  
  33. ;list of lists of slots obscuring a slot
  34. (define obscured '())
  35.  
  36. (define (padded-list n tail)
  37.   (if (= n 0)
  38.       tail
  39.       (padded-list (- n 1) (cons '() tail))))
  40.  
  41. (define (make-backbone n)
  42.   (add-normal-slot '())
  43.   (set! HORIZPOS (- HORIZPOS 1))
  44.   (set! VERTPOS (+ VERTPOS (/ 1 3)))
  45.   (set-car! (list-tail obscured n) (list (+ n 1)))
  46.   (if (>= VERTPOS 3)
  47.       n
  48.       (make-backbone (+ n 1))))
  49.  
  50. (define (deal-cards-face-up-to-reserve-from n)
  51.   (deal-cards-face-up stock (list n))
  52.   (if (>= n 36)
  53.       #t
  54.       (deal-cards-face-up-to-reserve-from (+ n 1))))
  55.  
  56. (define (deal-cards-face-up-to-reserve)
  57.   (deal-cards-face-up-to-reserve-from 18))
  58.  
  59. (define (new-game)
  60.   (initialize-playing-area)
  61.   (set-ace-low)
  62.   (set! obscured (padded-list 41 '()))
  63.  
  64.   (make-standard-double-deck)
  65.   (shuffle-deck)
  66.   
  67.   (add-normal-slot '())
  68.   (add-blank-slot)
  69.   (add-blank-slot)
  70.   (add-normal-slot '())
  71.   (add-normal-slot '())
  72.   (add-normal-slot '())
  73.   (add-normal-slot '())
  74.   (add-normal-slot '())
  75.   
  76.   (add-carriage-return-slot)
  77.   (add-normal-slot '())
  78.   (add-blank-slot)
  79.   (add-blank-slot)
  80.   (add-normal-slot '())
  81.   (add-normal-slot '())
  82.   (add-normal-slot '())
  83.   (add-normal-slot '())
  84.   (add-normal-slot '())
  85.   
  86.   (add-carriage-return-slot)
  87.   (add-normal-slot '())
  88.   (add-blank-slot)
  89.   (add-blank-slot)
  90.   (add-normal-slot '())
  91.   (add-blank-slot)
  92.   (add-normal-slot DECK)
  93.   (add-normal-slot '())
  94.  
  95.   (add-carriage-return-slot)
  96.   (add-normal-slot '())
  97.   (add-blank-slot)
  98.   (add-blank-slot)
  99.   (add-normal-slot '())
  100.  
  101.   (deal-cards-face-up stock tableau)
  102.  
  103.   (set! HORIZPOS 1)
  104.   (set! VERTPOS 0)
  105.   (set-car! (list-tail obscured (make-backbone 18)) (list 36))
  106.  
  107.   (set! HORIZPOS 2)
  108.   (set! VERTPOS 0)
  109.   (make-backbone 27)
  110.   
  111.   (set! HORIZPOS 1.5)
  112.   (add-normal-slot '())
  113.   
  114.   (deal-cards-face-up-to-reserve)
  115.  
  116.   (give-status-message)
  117.   
  118.   (list 8 4)
  119. )
  120.  
  121. (define (give-status-message)
  122.   (set-statusbar-message (string-append (get-stock-no-string)
  123.                     "   "
  124.                     (get-redeals-string))))
  125.  
  126. (define (get-redeals-string)
  127.   (string-append (_"Redeals left:") " "
  128.          (number->string (- 1 FLIP-COUNTER))))
  129.  
  130. (define (get-stock-no-string)
  131.   (string-append (_"Stock left:") " " 
  132.          (number->string (length (get-cards stock)))))
  133.  
  134. (define (empty-slots? slots)
  135.   (if (eq? slots '())
  136.       #t
  137.       (and
  138.          (empty-slot? (car slots))
  139.          (empty-slots? (cdr slots)))))
  140.  
  141. (define (is-playable? slot)
  142.   (and (or
  143.          (member slot tableau)
  144.          (= slot waste)
  145.          (reserve? slot))
  146.        (empty-slots? (list-ref obscured slot))))
  147.  
  148. (define (is-legal-move? start-slot card-list end-slot)
  149.   (and (not (= start-slot end-slot))
  150.        (not (eq? card-list '()))
  151.        (is-playable? start-slot)
  152.        (or (and (member end-slot foundation)
  153.                 (if (empty-slot? end-slot)
  154.                     (= (get-value (car card-list)) 1)
  155.                     (and 
  156.                       (= (get-suit (car card-list))
  157.                          (get-suit (get-top-card end-slot)))
  158.                       (= (get-value (car card-list))
  159.                          (+ (get-value (get-top-card end-slot)) 1)))))
  160.            (and (member end-slot tableau)
  161.                 (if (empty-slot? end-slot)
  162.                     (not (reserve? start-slot))
  163.                     (and
  164.                       (= (get-suit (car card-list))
  165.                          (get-suit (get-top-card end-slot)))
  166.                       (= (get-value (car card-list))
  167.                          (- (get-value (get-top-card end-slot)) 1))))))))
  168.  
  169. (define (button-pressed slot-id card-list)
  170.   (is-playable? slot-id))
  171.  
  172. (define (complete-transaction start-slot card-list end-slot)
  173.   (move-n-cards! start-slot end-slot card-list)
  174.   (if (member start-slot foundation)
  175.       (add-to-score! -1))
  176.   (if (member end-slot foundation)
  177.       (add-to-score! 1))
  178.   #t)
  179.  
  180. (define (button-released start-slot card-list end-slot)
  181.   (and (not (= start-slot end-slot))
  182.        (is-legal-move? start-slot card-list end-slot)
  183.        (complete-transaction start-slot card-list end-slot)))
  184.  
  185. (define (button-clicked start-slot)
  186.   (and (= start-slot stock)
  187.        (flip-stock stock waste 1 1)))
  188.  
  189. (define (move-if-possible start-slot end-slots)
  190.   (and (not (empty-slot? start-slot))
  191.        (let ((card (get-top-card start-slot)))
  192.          (if (is-legal-move? start-slot (list card) (car end-slots))
  193.              (begin (remove-card start-slot)
  194.                   (complete-transaction start-slot (list card) (car end-slots)))
  195.              (if (eq? (cdr end-slots) '())
  196.                  #f
  197.                  (move-if-possible start-slot (cdr end-slots)))))))
  198.  
  199. (define (button-double-clicked start-slot)
  200.   (move-if-possible start-slot foundation))
  201.  
  202. (define (non-empty-piles-helper piles result)
  203.   (if (eq? piles '())
  204.       result
  205.       (non-empty-piles-helper
  206.         (cdr piles)
  207.         (if (empty-slot? (car piles))
  208.             result
  209.             (cons (car piles) result)))))
  210.  
  211. (define (non-empty-piles piles)
  212.   (non-empty-piles-helper piles '()))
  213.  
  214. (define (empty-piles piles)
  215.   (define (empty-piles piles result)
  216.     (if (eq? piles '())
  217.         result
  218.         (empty-piles
  219.           (cdr piles)
  220.           (if (empty-slot? (car piles))
  221.               (cons (car piles) result)
  222.               result))))
  223.   (empty-piles piles '()))
  224.  
  225. (define (describe-pile pile)
  226.    (if (empty-slot? pile)
  227.        (cond
  228.          ((member pile tableau) (_"an empty slot on the tableau"))
  229.          ((member pile foundation) (_"an empty slot on the foundation")))
  230.        (get-name (car (get-cards pile)))))
  231.  
  232. (define (get-legal-move-from-source source targets)
  233.   (if (eq? targets '())
  234.       #f
  235.       (if (and (not (empty-slot? source))
  236.                (is-legal-move? source (list (car (get-cards source))) (car targets)))
  237.           (list source (car targets))
  238.           (get-legal-move-from-source source (cdr targets)))))
  239.  
  240. (define (get-legal-move sources targets)
  241.   (if (eq? sources '())
  242.       #f
  243.       (or (get-legal-move-from-source (car sources) targets)
  244.           (get-legal-move (cdr sources) targets))))
  245.  
  246. (define (get-hint)
  247.   (or 
  248.     (let
  249.          ((move (or 
  250.                    (get-legal-move
  251.                      (append reserve (list waste) tableau)
  252.                      (append foundation (non-empty-piles tableau) (list waste)))
  253.                    (get-legal-move-from-source
  254.                      waste
  255.                      (empty-piles tableau)))))
  256.         (if move
  257.             (list 1 (describe-pile (car move)) (describe-pile (cadr move)))
  258.             #f))
  259.     (and (or (not (empty-slot? stock))
  260.              (and (< FLIP-COUNTER 1)
  261.                   (not (empty-slot? waste))))
  262.          (list 0 (_"Deal a new card from the deck")))
  263.     (and (get-legal-move tableau tableau)
  264.          (list 0 (_"Try rearranging the cards")))))
  265.  
  266. (define (full-piles? piles)
  267.   (and (= 13 (length (get-cards (car piles))))
  268.        (or (eq? (cdr piles) '())
  269.            (full-piles? (cdr piles)))))
  270.  
  271. (define (game-won)
  272.   (full-piles? foundation))
  273.  
  274. (define (game-over)
  275.   (give-status-message)
  276.   (and (not (game-won)))
  277.        (get-hint))
  278.  
  279. (define (get-options)
  280.   '())
  281.  
  282. (define (apply-options options) #f)
  283.  
  284. (define (timeout) #f)
  285.  
  286. (set-features droppable-feature)
  287.  
  288. (set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint get-options apply-options timeout is-legal-move?)
  289.