home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / monte_carlo.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  6.1 KB  |  230 lines

  1. ; AisleRiot - monte_carlo.scm
  2. ; Copyright (C) 2001 Rosanna Yuen <zana@webwynk.net>
  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-blank-slot)
  27.   (add-normal-slot '()) 
  28.   (add-normal-slot '()) 
  29.   (add-normal-slot '()) 
  30.   (add-normal-slot '()) 
  31.   (add-normal-slot '()) 
  32.   (add-carriage-return-slot)
  33.   (add-blank-slot)
  34.   (add-blank-slot)
  35.   (add-normal-slot '()) 
  36.   (add-normal-slot '()) 
  37.   (add-normal-slot '()) 
  38.   (add-normal-slot '()) 
  39.   (add-normal-slot '()) 
  40.   (add-carriage-return-slot)
  41.   (add-blank-slot)
  42.   (add-blank-slot)
  43.   (add-normal-slot '()) 
  44.   (add-normal-slot '()) 
  45.   (add-normal-slot '()) 
  46.   (add-normal-slot '()) 
  47.   (add-normal-slot '()) 
  48.   (add-carriage-return-slot)
  49.   (add-blank-slot)
  50.   (add-blank-slot)
  51.   (add-normal-slot '()) 
  52.   (add-normal-slot '()) 
  53.   (add-normal-slot '()) 
  54.   (add-normal-slot '()) 
  55.   (add-normal-slot '()) 
  56.   (add-carriage-return-slot)
  57.   (add-blank-slot)
  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.   (deal-cards-face-up 0 '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
  65.                 19 20 21 22 23 24 25))
  66.  
  67.   (give-status-message)
  68.  
  69.   (list 7 5))
  70.  
  71. (define (give-status-message)
  72.   (set-statusbar-message (get-stock-no-string)))
  73.  
  74. (define (get-stock-no-string)
  75.   (string-append (_"Stock left:") " " 
  76.          (number->string (length (get-cards 0)))))
  77.  
  78. (define (button-pressed slot-id card-list)
  79.   (and (> slot-id 0)
  80.        (not (empty-slot? slot-id))))
  81.  
  82. (define (adjacent? slot1 slot2)
  83.   (or (and (= slot1 (+ 6 slot2))
  84.        (not (= (modulo slot1 5) 1)))
  85.       (= slot1 (+ 5 slot2))
  86.       (and (= slot1 (+ 4 slot2))
  87.        (not (= (modulo slot1 5) 0)))
  88.       (and (= slot1 (+ 1 slot2))
  89.        (not (= (modulo slot1 5) 1)))
  90.       (and (= slot1 (- slot2 1))
  91.        (not (= (modulo slot1 5) 0)))
  92.       (and (= slot1 (- slot2 4))
  93.        (not (= (modulo slot1 5) 1)))
  94.       (= slot1 (- slot2 5))
  95.       (and (= slot1 (- slot2 6))
  96.        (not (= (modulo slot1 5) 0)))))
  97.  
  98.  
  99.  
  100. (define (droppable? start-slot card-list end-slot)
  101.   (and (not (= start-slot end-slot))
  102.        (> end-slot 0)
  103.        (not (empty-slot? end-slot))
  104.        (adjacent? start-slot end-slot)
  105.        (= (get-value (car card-list))
  106.       (get-value (get-top-card end-slot)))))
  107.  
  108. (define (button-released start-slot card-list end-slot)
  109.   (and (droppable? start-slot card-list end-slot)
  110.        (add-to-score! 2)
  111.        (remove-card end-slot)))
  112.  
  113. (define (deal-the-empties slot)
  114.   (if (or (= slot 26)
  115.       (empty-slot? 0))
  116.       #t
  117.       (and (deal-cards-face-up 0 (list slot))
  118.        (deal-the-empties (+ 1 slot)))))
  119.  
  120. (define (moving-over slot blanks)
  121.   (cond ((= slot 26)
  122.      (deal-the-empties (- 26 blanks)))
  123.     ((empty-slot? slot)
  124.      (moving-over (+ 1 slot) (+ 1 blanks)))
  125.     ((> blanks 0)
  126.      (and (deal-cards slot (list (- slot blanks)))
  127.           (moving-over (+ 1 slot) blanks)))
  128.     (#t (moving-over (+ 1 slot) blanks))))
  129.  
  130. (define (move-cards-up)
  131.   (or (moving-over 1 0)
  132.       #t))
  133.  
  134. (define (button-clicked slot-id)
  135.   (and (= slot-id 0)
  136.        (move-cards-up)))
  137.  
  138. (define (button-double-clicked slot-id)
  139.   #f)
  140.  
  141. (define (game-continuable)
  142.   (give-status-message)
  143.   (and (not (game-won))
  144.       (get-hint)))
  145.  
  146.  
  147. (define (game-won)
  148.   (= 52 (get-score)))
  149.  
  150. (define (horizontal-check slot-id)
  151.   (cond ((and (not (= 0 (modulo slot-id 5)))
  152.           (not (empty-slot? (+ 1 slot-id)))
  153.           (not (empty-slot? slot-id))
  154.           (= (get-value (get-top-card slot-id))
  155.          (get-value (get-top-card (+ 1 slot-id)))))
  156.      (list 1 (get-name (get-top-card slot-id))
  157.            (get-name (get-top-card (+ 1 slot-id)))))
  158.     ((< slot-id 24)
  159.      (horizontal-check (+ 1 slot-id)))
  160.     (#t #f)))
  161.  
  162. (define (vertical-check slot-id)
  163.   (cond ((and (not (empty-slot? slot-id))
  164.           (not (empty-slot? (+ 5 slot-id)))
  165.           (= (get-value (get-top-card slot-id))
  166.          (get-value (get-top-card (+ 5 slot-id)))))
  167.      (list 1 (get-name (get-top-card slot-id))
  168.            (get-name (get-top-card (+ 5 slot-id)))))
  169.     ((< slot-id 20)
  170.      (vertical-check (+ 1 slot-id)))
  171.     (#t #f)))           
  172.  
  173. (define (backslash-check slot-id)
  174.   (cond ((and (not (= 0 (modulo slot-id 5)))
  175.           (not (empty-slot? (+ 6 slot-id)))
  176.           (not (empty-slot? slot-id))
  177.           (= (get-value (get-top-card slot-id))
  178.          (get-value (get-top-card (+ 6 slot-id)))))
  179.      (list 1 (get-name (get-top-card slot-id))
  180.            (get-name (get-top-card (+ 6 slot-id)))))
  181.     ((< slot-id 19)
  182.      (backslash-check (+ 1 slot-id)))
  183.     (#t #f)))
  184.  
  185. (define (slash-check slot-id)
  186.   (cond ((and (not (= 1 (modulo slot-id 5)))
  187.           (not (empty-slot? (+ 4 slot-id)))
  188.           (not (empty-slot? slot-id))
  189.           (= (get-value (get-top-card slot-id))
  190.          (get-value (get-top-card (+ 4 slot-id)))))
  191.      (list 1 (get-name (get-top-card slot-id))
  192.            (get-name (get-top-card (+ 4 slot-id)))))
  193.     ((< slot-id 20)
  194.      (slash-check (+ 1 slot-id)))
  195.     (#t #f)))
  196.  
  197. (define (empty? slot yesblank)
  198.   (cond ((= slot 26)
  199.      (if (and yesblank
  200.           (not (empty-slot? 0)))
  201.          (list 0 (_"Deal more cards"))
  202.          #f))
  203.     ((empty-slot? slot)
  204.      (empty? (+ 1 slot) #t))
  205.     (yesblank
  206.      (list 0 (_"Deal more cards")))
  207.     (#t (empty? (+ 1 slot) yesblank))))
  208.  
  209. (define (get-hint)
  210.   (or (horizontal-check 1)
  211.       (vertical-check 1)
  212.       (backslash-check 1)
  213.       (slash-check 2)
  214.       (empty? 1 #f)))
  215.  
  216. (define (get-options) 
  217.   #f)
  218.  
  219. (define (apply-options options) 
  220.   #f)
  221.  
  222. (define (timeout) 
  223.   #f)
  224.  
  225. (set-features droppable-feature)
  226.  
  227. (set-lambda new-game button-pressed button-released button-clicked
  228. button-double-clicked game-continuable game-won get-hint get-options
  229. apply-options timeout droppable?)
  230.