1; AisleRiot - giant.scm
2; Copyright (C) 2009 Ed Sirett <ed@makewrite.demon.co.uk>
3;
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.
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, see <http://www.gnu.org/licenses/>.
16
17(use-modules (aisleriot interface) (aisleriot api) (ice-9 format))
18
19
20;set up the deck
21(set-ace-low)
22
23(define stock-slot 0)
24(define foundation '(1 2 3 4 5 6 7 8))
25(define tableau '(9 10 11 12 13 14 15 16 ))
26(define reserve-slot 17)
27(define (make-deck)
28  (make-standard-double-deck)
29)
30
31(define winning-score 104)
32
33(define allow-empty-slots #t)
34(define same-suit #f)
35
36(define (new-game)
37  (initialize-playing-area)
38  (make-deck)
39  (shuffle-deck)
40
41  ;set up the board
42  (add-normal-slot DECK 'stock)
43  (add-blank-slot)
44  (add-normal-slot '() 'foundation)
45  (add-normal-slot '() 'foundation)
46  (add-normal-slot '() 'foundation)
47  (add-normal-slot '() 'foundation)
48  (add-normal-slot '() 'foundation)
49  (add-normal-slot '() 'foundation)
50  (add-normal-slot '() 'foundation)
51  (add-normal-slot '() 'foundation)
52  (add-carriage-return-slot)
53  (add-extended-slot '() down 'tableau)
54  (add-extended-slot '() down 'tableau)
55  (add-extended-slot '() down 'tableau)
56  (add-extended-slot '() down 'tableau)
57  (add-extended-slot '() down 'tableau)
58  (add-extended-slot '() down 'tableau)
59  (add-extended-slot '() down 'tableau)
60  (add-extended-slot '() down 'tableau)
61  (add-blank-slot)
62  (add-normal-slot '() 'reserve)
63
64  (deal-cards-face-up stock-slot tableau)
65
66
67  (give-status-message)
68  (list 10 4.5))
69
70(define (give-status-message)
71  (set-statusbar-message (get-stock-no-string))
72)
73
74(define (get-stock-no-string)
75  (format #f
76          (_"Deals left: ~a")
77          (number->string (/ (length (get-cards stock-slot)) 8 ))
78  )
79)
80
81;additional functions.
82
83(define (complete-transaction start-slot card-list end-slot)
84  (if (member end-slot foundation)
85      (move-n-cards! start-slot end-slot (reverse card-list))
86      (move-n-cards! start-slot end-slot card-list)
87  )
88)
89
90(define (button-pressed slot card-list)
91  (if (or (empty-slot? slot) (= slot stock-slot))
92        #f   ; can't pick from stock or empty piles
93        (and (or (and (not same-suit) (check-alternating-color-list card-list))
94                 (and same-suit  (check-same-suit-list card-list)))
95             (check-straight-descending-list card-list))))
96
97
98
99(define (droppable? start-slot card-list end-slot)
100  (and (not (= start-slot end-slot))
101       ( or (and  (member end-slot foundation)
102                  (check-straight-descending-list card-list)
103                  (check-same-suit-list card-list)
104                  (if (empty-slot? end-slot)
105                      (= (get-value (car card-list)) ace)
106                      (and (= (get-suit (car card-list)) (get-suit (get-top-card end-slot)))
107                           (= (- (get-value (car card-list)) 1 ) (get-value (get-top-card end-slot)))
108                      )
109                  )
110            )
111            (and  (member end-slot tableau)
112                  (check-straight-descending-list card-list)
113                  (or (and (not same-suit) (check-alternating-color-list card-list))
114                      (and  same-suit (check-same-suit-list card-list)))
115                  (if (not (empty-slot? end-slot))
116                      (and (= (+ (get-value (car (reverse card-list))) 1 ) (get-value (get-top-card end-slot)))
117                           (or (and (not same-suit)
118                                    (not ( eq? ( is-red? ( car (reverse card-list))) (is-red? (get-top-card end-slot)))))
119                               (and same-suit
120                                    (= (get-suit (car (reverse card-list))) (get-suit (get-top-card end-slot))))))
121                      #t
122                  )
123            )
124            (and  (=  end-slot reserve-slot)
125                  (empty-slot? reserve-slot)
126                  (= (length card-list) 1)
127            )
128       )
129  )
130)
131
132(define (button-released start-slot card-list end-slot)
133  (and (droppable? start-slot card-list end-slot)
134       (complete-transaction start-slot card-list end-slot))
135)
136
137(define (do-deal-next-cards)
138  (deal-cards-face-up stock-slot tableau))
139
140(define (button-clicked slot)
141  (if (= stock-slot slot)
142      (if (dealable?) (do-deal-next-cards) #f)
143      #f))
144
145
146(define (find-any-to-foundation from-slots)
147  (if (eq? from-slots '() )
148      #f
149      (let ((find-to-result (find-to foundation (car from-slots))))
150        (if find-to-result
151            (list (car from-slots) find-to-result)
152            (find-any-to-foundation (cdr from-slots))))))
153
154; remake a list of slots with/without empty members
155(define (without-gaps slots with-empties)
156    (cond ((eq? slots '()) '())
157          (with-empties slots)
158          ((empty-slot? (car slots)) (without-gaps (cdr slots) with-empties))
159          ( else (cons (car slots) (without-gaps (cdr slots) with-empties)))))
160
161
162(define (find-any-to-tableau from-slots with-empties)
163  (if (eq? from-slots '() )
164      #f
165      (let ((find-to-result (find-to (without-gaps tableau with-empties) (car from-slots)))
166            (cfs (car from-slots)))
167        (if (and find-to-result
168                  ; check we are not breaking an existing run
169                 (or (= (length (get-cards cfs )) 1)
170                     (not (check-straight-descending-list (list (get-top-card cfs) (cadr (get-cards cfs))))))
171                  ; if suggesting a move to a gap make sure it is worthwhile
172                 (or (not (empty-slot? find-to-result))
173                     (> (length (get-cards cfs )) 1)))  ;can move a top card to a gap if it does not make a gap
174            (list cfs find-to-result)
175            (find-any-to-tableau (cdr from-slots) with-empties)))))
176
177(define (move-any-to-foundation slots)
178  (let (( find-any-result (find-any-to-foundation slots)))
179    (if find-any-result
180        (move-a-card (car find-any-result) (cadr find-any-result))
181        #f)))
182
183
184(define (auto-play)
185    (if (move-any-to-foundation (append tableau (list reserve-slot)))
186        (delayed-call auto-play)
187        #f
188    )
189)
190
191
192(define (find-to slots from-slot)
193  (if (or (empty-slot? from-slot) (eq? slots '()))
194        #f
195       (if (droppable? from-slot (list (get-top-card from-slot)) (car slots) )
196           (car slots)
197           (find-to (cdr slots) from-slot)
198       )
199  )
200)
201
202(define (move-a-card from-slot to-slot)
203   (if ( or (not to-slot) (empty-slot? from-slot))
204        #f
205       (add-card! to-slot (remove-card from-slot))
206   )
207)
208
209(define (move-to-foundation from-slot)
210   (move-a-card from-slot (find-to foundation from-slot ))
211)
212
213
214(define (button-double-clicked slot)
215   (if (member slot foundation)
216           (auto-play)
217           (if (or (member slot tableau) (= slot reserve-slot) )
218               (move-to-foundation slot)
219               #f
220           )
221   )
222)
223
224
225(define (game-over)
226  (give-status-message)
227  (and (not (game-won))
228       (get-hint)))
229
230
231
232; score the game - 1 pt for every card in the foundations 104 to win.
233(define (game-score slot-list)
234  (if (and (null? slot-list))
235      0
236      (+ (length (get-cards (car slot-list))) (game-score (cdr slot-list)))
237  )
238)
239
240; game is won when all cards are moved to foundations.
241(define (game-won)
242   (= (set-score! (game-score foundation)) winning-score)
243)
244
245
246
247(define (dealable?)
248  (if (and
249        (not (empty-slot? stock-slot ))
250        (or allow-empty-slots
251            (not (any-slot-empty? tableau))))
252      (list 0 (_"Deal a row"))
253      #f))
254
255
256
257; This is the hint function
258; 1) Suggest a move to a foundation.
259; 2) Suggest moving a card from the (reserve  + tableau) to the tableau.
260; 3) Suggest moviing a card to an empty tableau-slot
261; 4) Suggest moving to the reserve if unoccupied
262; 5) Suggest dealing a row if there are cards still in the stock.
263; 6) Suggest moving cards around.
264
265(define (get-hint)
266  (let ((find-result (find-any-to-foundation (append tableau (list reserve-slot))))
267        (t-result1   (find-any-to-tableau  (append tableau (list reserve-slot)) #f  ))
268        (t-result2   (find-any-to-tableau  (append tableau (list reserve-slot)) #t )))
269     (cond
270           ( find-result
271            (hint-move (car find-result) 1 (cadr find-result)))
272           ( t-result1
273            (hint-move (car t-result1) 1 (cadr t-result1)))
274           ( t-result2
275            (hint-move (car t-result2) 1 (cadr t-result2)))
276           ( (empty-slot? reserve-slot) (list 0 (_"Try moving a card to the reserve")))
277           ( (dealable?) (list 0 (_"Try dealing a row of cards")))
278; this isn't great, but it will get around the premature end-of-game call
279           (else (list 0 (_"Try moving card piles around")))
280     )))
281
282(define (get-options)
283  (list 'begin-exclusive
284        (list (_"Same suit") same-suit)
285        (list (_"Alternating colors") (not same-suit))
286        'end-exclusive))
287
288(define (apply-options options)
289  (set! same-suit (cadr (list-ref options 1))))
290
291(define (timeout) #f)
292
293(set-features droppable-feature dealable-feature)
294
295(set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint
296get-options apply-options timeout droppable? dealable?)
297