1
; AisleRiot - sir_tommy.scm
2
; Copyright (C) 2001 Rosanna Yuen <zana@webwynk.net>
4
; This program 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 3 of the License, or
7
; (at your option) any later version.
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.
14
; You should have received a copy of the GNU General Public License
15
; along with this program. If not, see <http://www.gnu.org/licenses/>.
18
(initialize-playing-area)
23
(add-normal-slot DECK)
31
(add-carriage-return-slot)
35
(add-extended-slot '() down)
36
(add-extended-slot '() down)
37
(add-extended-slot '() down)
38
(add-extended-slot '() down)
43
(define (give-status-message)
44
(set-statusbar-message (get-stock-no-string)))
46
(define (get-stock-no-string)
47
(string-append (_"Stock left:") " "
48
(number->string (length (get-cards 0)))))
50
(define (button-pressed slot-id card-list)
51
(and (not (empty-slot? slot-id))
52
(= (length card-list) 1)
56
(define (droppable? start-slot card-list end-slot)
60
(or (and (= (get-value (car card-list)) ace)
61
(empty-slot? end-slot))
62
(and (not (empty-slot? end-slot))
63
(= (get-value (car card-list))
64
(+ 1 (get-value (get-top-card end-slot)))))))
67
(define (button-released start-slot card-list end-slot)
68
(and (droppable? start-slot card-list end-slot)
70
(move-n-cards! start-slot end-slot card-list))
73
(move-n-cards! start-slot end-slot card-list)
77
(define (button-clicked slot-id)
81
(deal-cards-face-up 0 '(1))))
83
(define (check-top-card slot f-slot)
86
((and (not (empty-slot? f-slot))
87
(= (get-value (get-top-card slot))
88
(+ 1 (get-value (get-top-card f-slot)))))
90
((and (= (get-value (get-top-card slot))
94
(#t (check-top-card slot (+ 1 f-slot)))))
96
(define (button-double-clicked slot-id)
97
(and (not (empty-slot? slot-id))
100
(check-top-card slot-id 2)
101
(deal-cards slot-id (check-top-card slot-id 2))
104
(define (game-continuable)
105
(give-status-message)
106
(and (not (game-won))
110
(and (= (length (get-cards 2)) 13)
111
(= (length (get-cards 3)) 13)
112
(= (length (get-cards 4)) 13)
113
(= (length (get-cards 5)) 13)))
115
(define (check-to-foundation slot)
119
(check-to-foundation 6))
120
((and (not (empty-slot? slot))
121
(check-top-card slot 2))
122
(or (and (= (get-value (get-top-card slot)) ace)
123
(list 2 (get-name (get-top-card slot)) (_"empty foundation")))
125
(get-name (get-top-card slot))
126
(get-name (get-top-card (car (check-top-card slot 2)))))))
127
(#t (check-to-foundation (+ 1 slot)))))
130
(and (not (empty-slot? 1))
131
(not (empty-slot? 0))
132
(list 0 (_"Move waste on to a reserve slot"))))
135
(and (not (empty-slot? 0))
136
(list 0 (_"Deal another card"))))
139
(or (check-to-foundation 1)
143
(define (get-options)
146
(define (apply-options options)
152
(set-features droppable-feature)
154
(set-lambda new-game button-pressed button-released button-clicked
155
button-double-clicked game-continuable game-won get-hint get-options
156
apply-options timeout droppable?)