1
; AisleRiot - Bear River
2
; Copyright (C) 2009 Vincent Povirk
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/>.
19
(define tableau '(4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21))
20
(define foundation '(0 1 2 3))
21
(define hole '(9 15 21))
26
(initialize-playing-area)
33
(add-normal-slot DECK)
37
(add-carriage-return-slot)
39
(add-extended-slot '() right)
40
(add-extended-slot '() right)
41
(add-extended-slot '() right)
42
(add-extended-slot '() right)
43
(add-extended-slot '() right)
44
(set! HORIZPOS (+ HORIZPOS 0.18))
45
(add-extended-slot '() right)
46
(add-carriage-return-slot)
48
(add-extended-slot '() right)
49
(add-extended-slot '() right)
50
(add-extended-slot '() right)
51
(add-extended-slot '() right)
52
(add-extended-slot '() right)
53
(set! HORIZPOS (+ HORIZPOS 0.18))
54
(add-extended-slot '() right)
55
(add-carriage-return-slot)
57
(add-extended-slot '() right)
58
(add-extended-slot '() right)
59
(add-extended-slot '() right)
60
(add-extended-slot '() right)
61
(add-extended-slot '() right)
62
(set! HORIZPOS (+ HORIZPOS 0.18))
63
(add-extended-slot '() right)
64
(add-carriage-return-slot)
66
(deal-to-tableau 0 tableau)
69
(set! BASE-VAL (get-value (get-top-card 0)))
73
(define (deal-to-tableau deck piles)
77
(deal-cards-face-up deck (list (car piles) (car piles)))
78
(and (not (member (car piles) hole))
79
(deal-cards-face-up deck (list (car piles))))
80
(deal-to-tableau deck (cdr piles)))))
82
(define (give-status-message)
83
(set-statusbar-message (get-base-string)))
85
(define (get-base-string)
86
(cond ((and (> BASE-VAL 1)
88
(string-append (_"Base Card: ") (number->string BASE-VAL)))
94
(_"Base Card: Queen"))
99
(define (button-pressed slot-id card-list)
100
(and (member slot-id tableau)
101
(= (length card-list) 1)))
103
(define (value-offset? offset card1 card2)
105
(modulo (- (get-value card2) (get-value card1)) 13)))
107
(define (droppable? start-slot card-list end-slot)
108
(if (member end-slot foundation)
109
(if (empty-slot? end-slot)
110
(= (get-value (car card-list)) BASE-VAL)
111
(and (suit-eq? (car card-list) (get-top-card end-slot))
112
(value-offset? 1 (get-top-card end-slot) (car card-list))))
113
(and (not (= start-slot end-slot))
114
(if (empty-slot? end-slot)
115
(member end-slot hole)
116
(and (< (length (get-cards end-slot)) 3)
117
(suit-eq? (get-top-card end-slot) (car card-list))
118
(or (value-offset? 1 (get-top-card end-slot) (car card-list))
119
(value-offset? 1 (car card-list) (get-top-card end-slot))))))))
121
(define (button-released start-slot card-list end-slot)
122
(and (droppable? start-slot card-list end-slot)
123
(move-n-cards! start-slot end-slot card-list)))
125
(define (button-clicked slot-id)
128
(define (try-to-foundations from-slot to-slots)
131
(if (droppable? from-slot (list (get-top-card from-slot)) (car to-slots))
132
(deal-cards from-slot (list (car to-slots)))
133
(try-to-foundations from-slot (cdr to-slots)))))
135
(define (button-double-clicked slot-id)
136
(and (member slot-id tableau)
137
(not (empty-slot? slot-id))
138
(try-to-foundations slot-id foundation)))
140
(define (game-continuable)
141
(give-status-message)
142
(and (not (game-won))
145
(define (count-cards slots acc)
148
(count-cards (cdr slots) (+ acc (length (get-cards (car slots)))))))
150
(define (update-score)
151
(set-score! (count-cards foundation 0)))
154
(= (update-score) 52))
156
(define (hint-slot-to-foundation from-slot to-slots)
157
(cond ((null? to-slots) #f)
158
((droppable? from-slot (list (get-top-card from-slot)) (car to-slots))
159
(if (empty-slot? (car to-slots))
160
(list 2 (get-name (get-top-card from-slot)) (_"an empty foundation slot"))
161
(list 1 (get-name (get-top-card from-slot)) (get-name (get-top-card (car to-slots))))))
162
(else (hint-slot-to-foundation from-slot (cdr to-slots)))))
164
(define (hint-to-foundation from-slots to-slots)
165
(cond ((null? from-slots) #f)
166
((empty-slot? (car from-slots))
167
(hint-to-foundation (cdr from-slots) to-slots))
168
(else (or (hint-slot-to-foundation (car from-slots) to-slots)
169
(hint-to-foundation (cdr from-slots) to-slots)))))
171
(define (hint-slot-to-tableau from-slot to-slots)
172
(cond ((null? to-slots) #f)
173
((empty-slot? (car to-slots)) (hint-slot-to-tableau from-slot (cdr to-slots)))
174
((droppable? from-slot (list (get-top-card from-slot)) (car to-slots))
175
(list 1 (get-name (get-top-card from-slot)) (get-name (get-top-card (car to-slots)))))
176
(else (hint-slot-to-tableau from-slot (cdr to-slots)))))
178
(define (hint-within-tableau from-slots to-slots)
179
(cond ((null? from-slots) #f)
180
((or (< (length (get-cards (car from-slots))) 2)
181
(let ((card1 (get-top-card (car from-slots)))
182
(card2 (cadr (get-cards (car from-slots)))))
183
(and (suit-eq? card1 card2)
184
(value-offset? 1 card1 card2))))
185
(hint-within-tableau (cdr from-slots) to-slots))
186
(else (or (hint-slot-to-tableau (car from-slots) to-slots)
187
(hint-within-tableau (cdr from-slots) to-slots)))))
189
(define (hint-empty-hole from-slots to-slots)
190
(cond ((null? from-slots) #f)
191
((not (= (length (get-cards (car from-slots))) 1))
192
(hint-empty-hole (cdr from-slots) to-slots))
193
(else (or (hint-slot-to-tableau (car from-slots) to-slots)
194
(hint-empty-hole (cdr from-slots) to-slots)))))
196
; Last resort hint: Find any possible tableau move, even unpleasant ones that were skipped earlier.
197
(define (hint-last-resort from-slots to-slots)
198
(if (null? from-slots)
200
(or (and (not (empty-slot? (car from-slots)))
201
(hint-slot-to-tableau (car from-slots) to-slots))
202
(hint-last-resort (cdr from-slots) to-slots))))
205
(or (hint-to-foundation tableau foundation)
206
(hint-empty-hole hole tableau)
207
(hint-within-tableau tableau tableau)
208
(and (any-slot-empty? hole)
209
(list 0 (_"Move something onto an empty right-hand tableau slot")))
210
(hint-last-resort tableau tableau)))
212
(define (get-options)
215
(define (apply-options options)
221
(set-features droppable-feature)
223
(set-lambda new-game button-pressed button-released button-clicked
224
button-double-clicked game-continuable game-won get-hint get-options
225
apply-options timeout droppable?)
added
removed
games/bear_river.scm
