home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / bristol.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  7.6 KB  |  286 lines
  1. ; AisleRiot - bristol.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.  
  27.   (set! HORIZPOS (+ HORIZPOS 0.75))
  28.  
  29.   (add-normal-slot '())
  30.   (add-normal-slot '())
  31.   (add-normal-slot '())
  32.  
  33.   (set! HORIZPOS (+ HORIZPOS 0.75))
  34.   (add-normal-slot '())
  35.   (add-normal-slot '())
  36.   (add-normal-slot '())
  37.   (add-normal-slot '())
  38.  
  39.   (add-carriage-return-slot)
  40.  
  41.   (add-extended-slot '() right)
  42.   (add-blank-slot)
  43.   (set! HORIZPOS (+ HORIZPOS 0.75))
  44.   (add-extended-slot '() right)
  45.   (add-blank-slot)
  46.   (set! HORIZPOS (+ HORIZPOS 0.75))
  47.   (add-extended-slot '() right)
  48.   (add-blank-slot)
  49.   (set! HORIZPOS (+ HORIZPOS 0.75))
  50.   (add-extended-slot '() right)
  51.  
  52.   (add-carriage-return-slot)
  53.  
  54.   (add-extended-slot '() right)
  55.   (add-blank-slot)
  56.   (set! HORIZPOS (+ HORIZPOS 0.75))
  57.   (add-extended-slot '() right)
  58.   (add-blank-slot)
  59.   (set! HORIZPOS (+ HORIZPOS 0.75))
  60.   (add-extended-slot '() right)
  61.   (add-blank-slot)
  62.   (set! HORIZPOS (+ HORIZPOS 0.75))
  63.   (add-extended-slot '() right)
  64.  
  65.   (deal-cards-face-up 0 '(8 9 10 11 12 13 14 15 
  66.                 8 9 10 11 12 13 14 15 
  67.                 8 9 10 11 12 13 14 15))
  68.   (check-for-kings 8)
  69.  
  70.   (give-status-message)
  71.  
  72.   (list 11 3))
  73.  
  74. (define (give-status-message)
  75.   (set-statusbar-message (get-stock-no-string)))
  76.  
  77. (define (get-stock-no-string)
  78.   (string-append (_"Stock left:") " "
  79.          (number->string (length (get-cards 0)))))
  80.  
  81. (define (check-for-kings slot-id)
  82.   (if (> slot-id 15)
  83.       #f
  84.       (begin
  85.     (if (= (get-value (get-top-card slot-id)) king)
  86.         (begin
  87.           (let ((new-deck (get-cards slot-id)))
  88.         (set-cards! slot-id (list (cadr new-deck)
  89.                       (caddr new-deck)
  90.                       (car new-deck))))
  91.           (if (= (get-value (get-top-card slot-id)) king)
  92.           (begin
  93.             (let ((new-deck (get-cards slot-id)))
  94.               (set-cards! slot-id (list (cadr new-deck)
  95.                         (caddr new-deck)
  96.                         (car new-deck)))))))
  97.         (if (= (get-value (cadr (get-cards slot-id))) king)
  98.         (let ((new-deck (get-cards slot-id)))
  99.           (set-cards! slot-id (list (car new-deck)
  100.                         (caddr new-deck)
  101.                         (cadr new-deck))))))
  102.     (check-for-kings (+ 1 slot-id)))))
  103.  
  104. (define (button-pressed slot-id card-list)
  105.   (and (not (empty-slot? slot-id))
  106.        (not (= slot-id 0))
  107.        (not (and (> slot-id 3)
  108.          (< slot-id 8)))
  109.        (= (length card-list) 1)))
  110.  
  111. (define (droppable? start-slot card-list end-slot)
  112.   (cond ((and (> end-slot 3)
  113.           (< end-slot 8))
  114.      (cond ((empty-slot? end-slot)
  115.         (= (get-value (car card-list)) ace))
  116.            (#t
  117.             (= (+ 1 (get-value (get-top-card end-slot)))
  118.            (get-value (car card-list))))))
  119.     (#t (and (> end-slot 7)
  120.           (not (empty-slot? end-slot))
  121.           (= (get-value (get-top-card end-slot))
  122.          (+ 1 (get-value (car card-list))))))))
  123.  
  124. (define (button-released start-slot card-list end-slot)
  125.   (and (droppable? start-slot card-list end-slot)
  126.        (or (< end-slot 4)
  127.        (> end-slot 7)
  128.        (add-to-score! 1))
  129.        (move-n-cards! start-slot end-slot card-list)))
  130.  
  131. (define (button-clicked slot-id)
  132.   (if (and (= slot-id 0)
  133.        (not (empty-slot? 0)))
  134.       (if (> (length (get-cards slot-id)) 3)
  135.       (deal-cards-face-up 0 '(1 2 3))
  136.       (deal-cards-face-up 0 '(1)))
  137.       #f))
  138.  
  139. (define (move-to-foundations? slot-id f-slot)
  140.   (cond ((= f-slot 8)
  141.      #f)
  142.     ((and (not (empty-slot? f-slot))
  143.           (= (get-value (get-top-card slot-id))
  144.          (+ 1 (get-value (get-top-card f-slot)))))
  145.      (begin
  146.        (add-to-score! 1)
  147.        (deal-cards slot-id (list f-slot))))
  148.     (#t
  149.      (move-to-foundations? slot-id (+ 1 f-slot)))))
  150.  
  151. (define (button-double-clicked slot-id)
  152.   (if (and (> slot-id 0)
  153.        (or (< slot-id 4)
  154.            (> slot-id 7))
  155.        (not (empty-slot? slot-id)))
  156.       (if (= ace  (get-value (get-top-card slot-id)))
  157.       (begin
  158.         (add-to-score! 1)
  159.         (cond ((empty-slot? 4)
  160.            (deal-cards slot-id '(4)))
  161.           ((empty-slot? 5)
  162.            (deal-cards slot-id '(5)))
  163.           ((empty-slot? 6)
  164.            (deal-cards slot-id '(6)))
  165.           (#t
  166.            (deal-cards slot-id '(7)))))
  167.       (move-to-foundations? slot-id 4))
  168.       #f))
  169.  
  170. (define (game-continuable)
  171.   (give-status-message)
  172.   (and (not (game-won))
  173.        (get-hint)))
  174.  
  175. (define (game-won)
  176.   (and (= 13 (length (get-cards 4)))
  177.        (= 13 (length (get-cards 5)))
  178.        (= 13 (length (get-cards 6)))
  179.        (= 13 (length (get-cards 7)))))
  180.  
  181. (define (check-a-foundation slot-id foundation-id)
  182.   (if (or (> foundation-id 7)
  183.       (empty-slot? slot-id))
  184.       #f
  185.       (cond ((and (empty-slot? foundation-id)
  186.           (= (get-value (get-top-card slot-id)) ace))
  187.          (list 2
  188.            (get-name (get-top-card slot-id)) 
  189.            (_"an empty foundation pile")))
  190.         ((and (not (empty-slot? foundation-id))
  191.           (= (+ 1 (get-value (get-top-card foundation-id)))
  192.              (get-value (get-top-card slot-id))))
  193.          (list 1
  194.            (get-name (get-top-card slot-id))
  195.            (get-name (get-top-card foundation-id))))
  196.         (#t (check-a-foundation slot-id (+ 1 foundation-id))))))
  197.  
  198. (define (check-to-foundations slot-id)
  199.   (cond ((> slot-id 15)
  200.      #f)
  201.     ((= slot-id 4)
  202.      (check-to-foundations 8))
  203.     ((check-a-foundation slot-id 4)
  204.      (check-a-foundation slot-id 4))
  205.     (#t
  206.      (check-to-foundations (+ 1 slot-id)))))
  207.  
  208. (define (check-reserve slot-id)
  209.   (if (> slot-id 3)
  210.       #f
  211.       (or (and (not (empty-slot? slot-id))
  212.            (check-a-tslot slot-id 
  213.                   (get-cards slot-id)
  214.                   1
  215.                   8))
  216.       (check-reserve (+ 1 slot-id)))))
  217.  
  218. (define (deepness card-list temp-deepness)
  219.   (if (and (> (length card-list) 1)
  220.        (= (+ 1 (get-value (car card-list)))
  221.           (get-value (cadr card-list))))
  222.       (deepness (cdr card-list) (+ 1 temp-deepness))
  223.       temp-deepness))
  224.  
  225. (define (check-a-tslot slot1 card-list depth slot2)
  226.   (if (or (> slot2 15)
  227.       (and (= (length card-list) depth)
  228.            (> slot1 7)))
  229.       #f
  230.       (if (and (not (empty-slot? slot2))
  231.            (not (= slot1 slot2))
  232.            (= (+ 1 (get-value (car card-list)))
  233.           (get-value (get-top-card slot2))))
  234.       (if (= depth 1)
  235.           (list 1 
  236.             (get-name (get-top-card slot1))
  237.             (get-name (get-top-card slot2)))
  238.  
  239.           (and (check-a-tslot slot1 
  240.                   (cdr card-list)
  241.                   (- depth 1)
  242.                   8)
  243.            (list 1 
  244.              (get-name (get-top-card slot1))
  245.              (get-name (get-top-card slot2)))))
  246.       (check-a-tslot slot1 card-list depth (+ 1 slot2)))))
  247.  
  248. (define (check-tableau slot-id)
  249.   (if (> slot-id 15)
  250.       #f
  251.       (if (and (not (empty-slot? slot-id))
  252.            (check-a-tslot slot-id 
  253.                   (get-cards slot-id) 
  254.                   (deepness (get-cards slot-id) 1) 
  255.                   8))
  256.       (check-a-tslot slot-id 
  257.                   (get-cards slot-id) 
  258.                   (deepness (get-cards slot-id) 1) 
  259.                   8)
  260.       (check-tableau (+ 1 slot-id)))))
  261.  
  262. (define (dealable?)
  263.   (and (not (empty-slot? 0))
  264.        (list 0 (_"Deal another round"))))
  265.  
  266. (define (get-hint)
  267.   (or (check-to-foundations 1)
  268.       (check-reserve 1)
  269.       (check-tableau 8)
  270.       (dealable?)))
  271.  
  272. (define (get-options) 
  273.   #f)
  274.  
  275. (define (apply-options options) 
  276.   #f)
  277.  
  278. (define (timeout) 
  279.   #f)
  280.  
  281. (set-features droppable-feature)
  282.  
  283. (set-lambda new-game button-pressed button-released button-clicked
  284. button-double-clicked game-continuable game-won get-hint get-options
  285. apply-options timeout droppable?)
  286.