home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / sol-games / camelot.scm < prev    next >
Encoding:
Text File  |  2006-08-22  |  6.8 KB  |  238 lines
  1. ; AisleRiot - camelot.scm
  2. ; Copyright (C) 1998, 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. (def-save-var add-stage #t)
  20. (def-save-var fill-count 0)
  21.  
  22. (define (new-game)
  23.   (initialize-playing-area)
  24.   (set-ace-low)
  25.   (make-standard-deck)
  26.   (shuffle-deck)
  27.  
  28.   (add-blank-slot)
  29.   (add-blank-slot)
  30.   (set! HORIZPOS (+ HORIZPOS 0.5))
  31.   (add-normal-slot '())           ; Slot 0
  32.   (add-normal-slot '())           ; Slot 1
  33.   (add-normal-slot '())           ; Slot 2
  34.   (add-normal-slot '())           ; Slot 3
  35.   (add-carriage-return-slot)
  36.   (add-blank-slot)
  37.   (add-blank-slot)
  38.   (set! HORIZPOS (+ HORIZPOS 0.5))
  39.   (add-normal-slot '())           ; Slot 4
  40.   (add-normal-slot '())           ; Slot 5
  41.   (add-normal-slot '())           ; Slot 6
  42.   (add-normal-slot '())           ; Slot 7
  43.   (add-carriage-return-slot)
  44.   (add-blank-slot)
  45.   (add-blank-slot)
  46.   (set! HORIZPOS (+ HORIZPOS 0.5))
  47.   (add-normal-slot '())           ; Slot 8
  48.   (add-normal-slot '())           ; Slot 9
  49.   (add-normal-slot '())           ; Slot 10
  50.   (add-normal-slot '())           ; Slot 11
  51.   (add-carriage-return-slot)
  52.   (add-blank-slot)
  53.   (add-blank-slot)
  54.   (set! HORIZPOS (+ HORIZPOS 0.5))
  55.   (add-normal-slot '())           ; Slot 12
  56.   (add-normal-slot '())           ; Slot 13
  57.   (add-normal-slot '())           ; Slot 14
  58.   (add-normal-slot '())           ; Slot 15
  59.  
  60.   (set! HORIZPOS 0)
  61.   (set! VERTPOS 0)
  62.  
  63.   (add-normal-slot DECK)          ; Slot 16
  64.   (add-normal-slot '())           ; Slot 17
  65.   (set! add-stage #t)
  66.   (set! fill-count 0)
  67.  
  68.   (give-status-message)
  69.  
  70.   (list 7 4)
  71. )
  72.  
  73. (define (give-status-message)
  74.   (set-statusbar-message (get-stock-no-string)))
  75.  
  76. (define (get-stock-no-string)
  77.   (string-append (_"Stock left:") " "
  78.          (number->string (length (get-cards 16)))))
  79.  
  80. (define (button-pressed slot-id card-list)
  81.   (and (not (empty-slot? slot-id))
  82.        (if (= slot-id 17)
  83.        (and (< fill-count 16)
  84.         (set! add-stage #t) 
  85.         #t)
  86.        (not (or add-stage
  87.             (= slot-id 16)
  88.             (= (get-value (car card-list)) king)
  89.             (= (get-value (car card-list)) queen)
  90.             (= (get-value (car card-list)) jack))))))
  91.  
  92. (define (droppable? start-slot card-list end-slot)
  93.   (if add-stage
  94.       (and (empty-slot? end-slot) 
  95.        (cond ((= (get-value (car card-list)) king)
  96.           (member end-slot '(0 3 12 15)))
  97.          ((= (get-value (car card-list)) queen)
  98.           (member end-slot '(1 2 13 14)))
  99.          ((= (get-value (car card-list)) jack)
  100.           (member end-slot '(4 7 8 11)))
  101.          (#t (not (= end-slot 16)))))
  102.       (if (= start-slot end-slot)
  103.       (= (get-value (car card-list)) 10)
  104.       (and (not (empty-slot? end-slot))
  105.            (not (= end-slot 17))
  106.            (= 10 (+ (get-value (car card-list))
  107.             (get-value (car (get-cards end-slot)))))))))
  108.  
  109. (define (button-released start-slot card-list end-slot)
  110.   (and (droppable? start-slot card-list end-slot)
  111.        (cond (add-stage
  112.               (move-n-cards! start-slot end-slot card-list)
  113.               (or (> end-slot 15)
  114.                   (set! fill-count (+ fill-count 1))))
  115.              ((= start-slot end-slot)
  116.               (set! fill-count (- fill-count 1)))
  117.              (#t
  118.           (remove-card end-slot)
  119.           (set! fill-count (- fill-count 2))))))
  120.  
  121. (define (button-clicked slot-id)  
  122.   (if (= slot-id 16)
  123.       (and (empty-slot? 17)
  124.        (or (empty-slot? 0)
  125.            (empty-slot? 1)
  126.            (empty-slot? 2)
  127.            (empty-slot? 3)
  128.            (empty-slot? 4)
  129.            (empty-slot? 5)
  130.            (empty-slot? 6)
  131.            (empty-slot? 7)
  132.            (empty-slot? 8)
  133.            (empty-slot? 9)
  134.            (empty-slot? 10)
  135.            (empty-slot? 11)
  136.            (empty-slot? 12)
  137.            (empty-slot? 13)
  138.            (empty-slot? 14)
  139.            (empty-slot? 15))
  140.        (set! add-stage #t)
  141.        (flip-stock 16 17 0))
  142.       (and (not add-stage)
  143.        (not (empty-slot? slot-id))
  144.        (is-visible? (get-top-card slot-id))
  145.        (= 10 (get-value (get-top-card slot-id)))
  146.        (set! fill-count (- fill-count 1))
  147.        (remove-card slot-id))))
  148.  
  149. (define (button-double-clicked slot)
  150.   #f)     
  151.  
  152. (define (game-won)
  153.   (and (empty-slot? 16)
  154.        (empty-slot? 17)
  155.        (empty-slot? 5)
  156.        (empty-slot? 6)
  157.        (empty-slot? 9)
  158.        (empty-slot? 10)))
  159.  
  160. (define (list-cards slot)
  161.   (if (= slot 16) 
  162.       '() 
  163.       (append (if (and (not (empty-slot? slot))
  164.                (< (get-value (get-top-card slot)) 11)) 
  165.           (get-cards slot) 
  166.           '()) 
  167.           (list-cards (+ 1 slot)))))
  168.  
  169. (define (find-card-val-in-list? cards value)
  170.   (and (not (null? cards))
  171.        (if (= value (get-value (car cards))) 
  172.        (car cards)
  173.        (find-card-val-in-list? (cdr cards) value))))
  174.  
  175. (define (find-match cards)
  176.   (and (not (null? cards))
  177.        (if (= 10 (get-value (car cards))) 
  178.        (list 2 (get-name (car cards)) (_"itself")) ; yuk..
  179.        (let ((match (find-card-val-in-list? 
  180.              (cdr cards)
  181.              (- 10 (get-value (car cards))))))
  182.          (if match
  183.          (list 1 (get-name (car cards)) (get-name match))
  184.          (find-match (cdr cards)))))))
  185.  
  186. (define (placeable? card)
  187.   (cond ((= (get-value card) king)
  188.      (and (or (empty-slot? 0)
  189.           (empty-slot? 3)
  190.           (empty-slot? 12)
  191.           (empty-slot? 15))
  192.           (_"an empty corner slot")))
  193.      ((= (get-value card) queen)
  194.       (or (and (or (empty-slot? 1)
  195.                (empty-slot? 2))
  196.            (_"an empty top slot"))
  197.           (and (or (empty-slot? 13)
  198.                (empty-slot? 14))
  199.            (_"an empty bottom slot"))))
  200.     ((= (get-value card) jack)
  201.       (or (and (or (empty-slot? 4)
  202.                (empty-slot? 8))
  203.            (_"an empty left slot"))
  204.           (and (or (empty-slot? 7)
  205.                (empty-slot? 11))
  206.            (_"an empty right slot"))))
  207.     (#t (_"an empty slot"))))
  208.  
  209. (define (game-over)
  210.   (give-status-message)
  211.   (if (or (= fill-count 16)
  212.       (and (empty-slot? 16) (empty-slot? 17)))
  213.       (begin 
  214.     (set! add-stage #f)
  215.     (find-match (list-cards 0)))
  216.       (or (empty-slot? 17)
  217.       (placeable? (get-top-card 17)))))
  218.  
  219. (define (get-hint)
  220.   (or (if add-stage
  221.       (and (not (empty-slot? 17))
  222.            (list 2 (get-name (get-top-card 17))
  223.              (placeable? (get-top-card 17))))
  224.       (find-match (list-cards 0)))
  225.       (list 0 (_"Deal a new card from the deck"))))
  226.  
  227. (define (get-options) #f)
  228.  
  229. (define (apply-options options) #f)
  230.  
  231. (define (timeout) #f)
  232.  
  233. (set-features droppable-feature)
  234.  
  235. (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?)
  236.  
  237.  
  238.