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