home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / diamond_mine.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  9.5 KB  |  321 lines
  1. ; AisleRiot - diamond_mine.scm
  2. ; Copyright (C) 2001, 2003 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-blank-slot)
  26.   (add-blank-slot)
  27.   (add-blank-slot)
  28.   (add-blank-slot)
  29.   (add-blank-slot)
  30.   (add-blank-slot)
  31.  
  32.   (add-normal-slot DECK)
  33.   (add-carriage-return-slot)
  34.  
  35.   (add-extended-slot '() down)
  36.   (add-extended-slot '() down)
  37.   (add-extended-slot '() down)
  38.   (add-extended-slot '() down)
  39.   (add-extended-slot '() down)
  40.   (add-extended-slot '() down)
  41.   (add-extended-slot '() down)
  42.   (add-extended-slot '() down)
  43.   (add-extended-slot '() down)
  44.   (add-extended-slot '() down)
  45.   (add-extended-slot '() down)
  46.   (add-extended-slot '() down)
  47.   (add-extended-slot '() down)
  48.  
  49.   (deal-cards 0 '(1 2 3 4 5 6 7 8 9 10 11 12 13 1 2 3 4 5 6 7 8 9 10
  50.             11 12 13 1 2 3 4 5 6 7 8 9 10 11 12 13))
  51.  
  52.  
  53.   (deal-cards-face-up 0 '(1 2 3 4 5 6 7 8 9 10 11 12 13))
  54.  
  55.   
  56.   (list 13 4))
  57.  
  58. (define (button-pressed slot-id card-list)
  59.   (and (not (empty-slot? slot-id))
  60.        (> slot-id 0)
  61.        (is-visible? (car (reverse card-list)))))
  62.  
  63. (define (droppable? start-slot card-list end-slot)
  64.   (cond
  65.    ((= start-slot end-slot) #f)
  66.    ((= end-slot 0)
  67.     (and (= (length card-list) 1)
  68.      (= (get-suit (car card-list)) diamond)
  69.      (or (empty-slot? 0)
  70.          (= (modulo (get-value (car card-list)) 13)
  71.         (modulo (+ 1 (get-value (get-top-card 0))) 13)))))
  72.    (#t
  73.     (and (not (= (get-suit (car card-list)) diamond))
  74.      (or (empty-slot? end-slot)
  75.          (and (not (= (get-suit (get-top-card end-slot)) diamond))
  76.           (= (get-value (get-top-card end-slot))
  77.              (+ 1 (get-value (car (reverse card-list)))))))))))
  78.  
  79. (define (button-released start-slot card-list end-slot)
  80.   (and (droppable? start-slot card-list end-slot)
  81.        (begin
  82.      (move-n-cards! start-slot end-slot card-list)
  83.      (if (= (get-suit (car card-list)) diamond)
  84.          (add-to-score! (get-value (car card-list)))
  85.          (begin
  86.            (and (= (length (get-cards end-slot)) 13)
  87.             (check-same-suit-list (get-cards end-slot))
  88.             (add-to-score! 3))
  89.            (and (= 13 (+ (length (get-cards start-slot))
  90.                  (length card-list)))
  91.             (check-same-suit-list card-list)
  92.             (check-same-suit-list (get-cards start-slot))
  93.             (or (= (length (get-cards start-slot)) 0)
  94.             (= (get-suit (get-top-card start-slot))
  95.                (get-suit (car card-list))))
  96.             (add-to-score! -3))))
  97.      (or (empty-slot? start-slot)
  98.          (make-visible-top-card start-slot)))))
  99.  
  100. (define (button-clicked slot-id)
  101.   #f)
  102.  
  103. (define (button-double-clicked slot-id)
  104.   (and (not (empty-slot? slot-id))
  105.        (> slot-id 0)
  106.        (= (get-suit (get-top-card slot-id)) diamond)
  107.        (or (and (empty-slot? 0)
  108.         (deal-cards slot-id '(0))
  109.         (or (empty-slot? slot-id)
  110.             (make-visible-top-card slot-id))
  111.         (add-to-score! (get-value (get-top-card 0))))
  112.        (and (or (= (get-value (get-top-card slot-id))
  113.                (+ 1 (get-value (get-top-card 0))))
  114.             (and (= (get-value (get-top-card slot-id)) ace)
  115.              (= (get-value (get-top-card 0)) king)))
  116.         (deal-cards slot-id '(0))
  117.         (or (empty-slot? slot-id)
  118.             (make-visible-top-card slot-id))
  119.         (add-to-score! (get-value (get-top-card 0)))))))
  120.  
  121.  
  122. (define (game-continuable)
  123.   (and (not (game-won))
  124.        (get-hint)))
  125.  
  126. (define (check-slots-for-win slot)
  127.   (cond ((= slot 14)
  128.      #t)
  129.     ((or (empty-slot? slot)
  130.          (and (= (length (get-cards slot)) 13)
  131.           (check-same-suit-list (get-cards slot))
  132.           (is-visible? (car (reverse (get-cards slot))))))
  133.      (check-slots-for-win (+ 1 slot)))
  134.     (#t #f)))
  135.  
  136. (define (game-won)
  137.   (and (= (length (get-cards 0)) 13)
  138.        (check-slots-for-win 1)))
  139.  
  140. (define (check-to-foundation slot)
  141.   (cond ((or (empty-slot? 0)
  142.          (= slot 14))
  143.      #f)
  144.     ((and (not (empty-slot? slot))
  145.           (= (get-suit (get-top-card slot)) diamond)
  146.           (or (= (get-value (get-top-card slot))
  147.              (+ 1 (get-value (get-top-card 0))))
  148.           (and (= (get-value (get-top-card slot)) ace)
  149.                (= (get-value (get-top-card 0)) king))))
  150.      (list 1
  151.            (get-name (get-top-card slot))
  152.            (get-name (get-top-card 0))))
  153.     (#t (check-to-foundation (+ 1 slot)))))
  154.  
  155. (define (stripped card-list card)
  156.   (cond ((>= (get-value (car card-list))
  157.          (get-value card))
  158.      (car card-list))
  159.     ((< (length card-list) 2)
  160.      (car card-list))
  161.     ((= (+ 1 (get-value (car card-list)))
  162.         (get-value card))
  163.      (car card-list))
  164.     ((is-visible? (cadr card-list))
  165.      (stripped (cdr card-list) card))
  166.     (#t (car card-list))))
  167.           
  168.  
  169. (define (check-same-suit-build slot1 slot2)
  170.   (cond ((= slot1 14)
  171.      #f)
  172.     ((or (empty-slot? slot1)
  173.          (= (get-suit (get-top-card slot1)) diamond)
  174.          (= slot2 14))
  175.      (check-same-suit-build (+ 1 slot1) 1))
  176.     ((and (not (= slot1 slot2))
  177.           (not (empty-slot? slot2))
  178.           (not (= (get-suit (get-top-card slot2))
  179.               diamond))
  180.           (= (get-suit (stripped (get-cards slot1) 
  181.                      (get-top-card slot2)))
  182.          (get-suit (get-top-card slot2)))
  183.           (= (+ 1 (get-value (stripped (get-cards slot1) 
  184.                        (get-top-card slot2))))
  185.          (get-value (get-top-card slot2))))
  186.      (list 1 
  187.            (get-name (stripped (get-cards slot1) 
  188.                    (get-top-card slot2)))
  189.            (get-name (get-top-card slot2))))
  190.     (#t 
  191.      (check-same-suit-build slot1 (+ 1 slot2)))))
  192.  
  193. (define (uncover? card-list card)
  194.   (if (not (is-visible? (car (reverse card-list))))
  195.       (uncover? (reverse (cdr (reverse card-list))) card)
  196.       (and (= (get-value (car (reverse card-list)))
  197.           (get-value card))
  198.        (= (get-suit (car (reverse card-list)))
  199.           (get-suit card)))))
  200.  
  201. (define (check-diff-suit-build slot1 slot2)
  202.   (cond ((= slot1 14)
  203.      #f)
  204.     ((or (empty-slot? slot1)
  205.          (= (get-suit (get-top-card slot1)) diamond)
  206.          (= slot2 14))
  207.      (check-diff-suit-build (+ 1 slot1) 1))
  208.     ((and (not (= slot1 slot2))
  209.           (not (empty-slot? slot2))
  210.           (not (= (get-suit (get-top-card slot2))
  211.               diamond))
  212.           (= (+ 1 (get-value (stripped (get-cards slot1) 
  213.                        (get-top-card slot2))))
  214.          (get-value (get-top-card slot2)))
  215.           (uncover? (get-cards slot1) 
  216.             (stripped (get-cards slot1)
  217.                   (get-top-card slot2))))
  218.      (list 1 
  219.            (get-name (stripped (get-cards slot1) 
  220.                    (get-top-card slot2)))
  221.            (get-name (get-top-card slot2))))
  222.     (#t 
  223.      (check-diff-suit-build slot1 (+ 1 slot2)))))
  224.  
  225. (define (simple-strip card-list)
  226.   (if (not (is-visible? (car (reverse card-list))))
  227.       (simple-strip (reverse (cdr (reverse card-list))))
  228.       (car (reverse card-list))))
  229.  
  230. (define (possible-move-off? slot)
  231.   (cond ((= slot 14)
  232.      #f)
  233.     ((and (not (empty-slot? slot))
  234.           (not (is-visible? (car (reverse (get-cards slot)))))
  235.           (not (= (get-suit (get-top-card slot)) diamond)))
  236.      (simple-strip (get-cards slot)))
  237.     (#t (possible-move-off? (+ 1 slot)))))
  238.  
  239. (define (check-for-empties slot)
  240.   (cond ((= slot 14)
  241.      #f)
  242.     ((and (empty-slot? slot)
  243.           (possible-move-off? 0))
  244.      (list 2 (get-name (possible-move-off? 0)) (_"an empty slot")))
  245.     (#t (check-for-empties (+ 1 slot)))))
  246.  
  247. (define (start-foundation slot)
  248.   (cond ((or (not (empty-slot? 0))
  249.          (= slot 14))
  250.      #f)
  251.     ((and (not (empty-slot? slot))
  252.           (= (get-suit (get-top-card slot)) diamond))
  253.      (list 2 (get-name (get-top-card slot)) (_"the foundation pile")))
  254.     (#t (start-foundation (+ 1 slot)))))
  255.  
  256. (define (any-empty? slot)
  257.   (cond ((= slot 14)
  258.      #f)
  259.     ((empty-slot? slot)
  260.      #t)
  261.     (#t (any-empty? (+ 1 slot)))))
  262.  
  263. (define (search-a-slot card-suit card-rank card-list)
  264.   (cond ((and (= (get-suit (car card-list)) card-suit)
  265.           (= (get-value (car card-list)) card-rank))
  266.      (is-visible? (car card-list)))
  267.     ((> (length card-list) 1)
  268.      (search-a-slot card-suit card-rank (cdr card-list)))
  269.     (#t #f)))
  270.  
  271. (define (find-card card-suit card-rank slot)
  272.   (cond ((= slot 14)
  273.      #f)
  274.     ((and (not (empty-slot? slot))
  275.           (search-a-slot card-suit card-rank (get-cards slot)))
  276.      #t)
  277.     (#t (find-card card-suit card-rank (+ 1 slot)))))
  278.  
  279. (define (check-a-tab-slot card-list)
  280.   (cond ((or (< (length card-list) 2)
  281.          (not (is-visible? (cadr card-list))))
  282.      #f)
  283.     ((and (is-visible? (cadr card-list))
  284.           (not (= (get-suit (car card-list))
  285.               (get-suit (cadr card-list))))
  286.           (find-card (get-suit (car card-list)) (+ 1 (get-value (car card-list))) 1))
  287.      (car card-list))
  288.     (#t (check-a-tab-slot (cdr card-list)))))
  289.  
  290. (define (check-tableau-suit-changes slot)
  291.   (cond ((or (= slot 14)
  292.          (not (any-empty? 1)))
  293.      #f)
  294.     ((and (not (empty-slot? slot))
  295.           (check-a-tab-slot (get-cards slot)))
  296.      (list 2 (get-name (check-a-tab-slot (get-cards slot))) (_"an empty slot")))
  297.     (#t (check-tableau-suit-changes (+ 1 slot)))))
  298.  
  299. (define (get-hint)
  300.   (or (check-to-foundation 1)
  301.       (check-same-suit-build 1 2)
  302.       (check-diff-suit-build 1 2)
  303.       (check-for-empties 1)
  304.       (start-foundation 1)
  305.       (check-tableau-suit-changes 1)))
  306.  
  307. (define (get-options) 
  308.   #f)
  309.  
  310. (define (apply-options options) 
  311.   #f)
  312.  
  313. (define (timeout) 
  314.   #f)
  315.  
  316. (set-features droppable-feature)
  317.  
  318. (set-lambda new-game button-pressed button-released button-clicked
  319. button-double-clicked game-continuable game-won get-hint get-options
  320. apply-options timeout droppable?)
  321.