1; AisleRiot - gypsy.scm 2; Copyright (C) 2001 Rosanna Yuen <zana@webwynk.net> 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)) 18 19(define foundation '(1 2 3 4 5 6 7 8)) 20 21(define (new-game) 22 (initialize-playing-area) 23 (set-ace-low) 24 (make-standard-double-deck) 25 (shuffle-deck) 26 27 (add-normal-slot DECK 'stock) 28 29 (add-blank-slot) 30 31 (add-normal-slot '() 'foundation) 32 (add-normal-slot '() 'foundation) 33 (add-normal-slot '() 'foundation) 34 (add-normal-slot '() 'foundation) 35 (add-normal-slot '() 'foundation) 36 (add-normal-slot '() 'foundation) 37 (add-normal-slot '() 'foundation) 38 (add-normal-slot '() 'foundation) 39 40 (add-carriage-return-slot) 41 42 (add-blank-slot) 43 44 (add-extended-slot '() down 'tableau) 45 (add-extended-slot '() down 'tableau) 46 (add-extended-slot '() down 'tableau) 47 (add-extended-slot '() down 'tableau) 48 (add-extended-slot '() down 'tableau) 49 (add-extended-slot '() down 'tableau) 50 (add-extended-slot '() down 'tableau) 51 (add-extended-slot '() down 'tableau) 52 53 (deal-cards 0 '(9 10 11 12 13 14 15 16 9 10 11 12 13 14 15 16)) 54 (deal-cards-face-up 0 '(9 10 11 12 13 14 15 16)) 55 56 (give-status-message) 57 58 59 (list 10 5)) 60 61(define (give-status-message) 62 (set-statusbar-message (get-stock-no-string))) 63 64(define (get-stock-no-string) 65 (string-append (_"Stock left:") " " 66 (number->string (length (get-cards 0))))) 67 68(define (button-pressed slot-id card-list) 69 (and (not (empty-slot? slot-id)) 70 (> slot-id 0) 71 (not (eq? '() card-list)) 72 (is-visible? (car (reverse card-list))) 73 (check-alternating-color-list card-list) 74 (check-straight-descending-list card-list))) 75 76(define (check-visibility slot) 77 (or (empty-slot? slot) 78 (is-visible? (get-top-card slot)) 79 (make-visible-top-card slot))) 80 81(define (foundation-score slot-id prev-total) 82 (define (current-total) 83 (+ prev-total 84 (* (length (get-cards slot-id)) 5) 85 (if (= (length (get-cards slot-id)) 13) 86 60 87 0))) 88 (if (= slot-id 8) 89 (current-total) 90 (foundation-score (+ slot-id 1) (current-total)))) 91 92(define (tableau-score slot-id prev-total) 93 (define (cards-score cards prev-total) 94 (if (< (length cards) 2) 95 prev-total 96 (if (and (is-visible? (car cards)) 97 (is-visible? (cadr cards)) 98 (not (= (get-color (car cards)) 99 (get-color (cadr cards)))) 100 (= (get-value (car cards)) 101 (- (get-value (cadr cards)) 1))) 102 (cards-score (cdr cards) (+ prev-total 2)) 103 (cards-score (cdr cards) prev-total)))) 104 (define (current-total) 105 (cards-score (get-cards slot-id) prev-total)) 106 (if (= slot-id 16) 107 (current-total) 108 (tableau-score (+ slot-id 1) (current-total)))) 109 110(define (recalculate-score) 111 (set-score! (+ (foundation-score 1 0) 112 (tableau-score 9 0)))) 113 114(define (droppable? start-slot card-list end-slot) 115 (cond ((= end-slot start-slot) 116 #f) 117 ((and (> end-slot 0) 118 (< end-slot 9)) 119 (if (= (length card-list) 1) 120 (cond ((empty-slot? end-slot) 121 (= (get-value (car card-list)) ace)) 122 (#t 123 (and (= (get-suit (get-top-card end-slot)) 124 (get-suit (car card-list))) 125 (= (get-value (car card-list)) 126 (+ 1 (get-value (get-top-card end-slot))))))) 127 #f)) 128 ((and (> end-slot 8) 129 (empty-slot? end-slot)) 130 #t) 131 (#t (and (> end-slot 8) 132 (eq? (is-red? (get-top-card end-slot)) 133 (is-black? (car (reverse card-list)))) 134 (= (get-value (get-top-card end-slot)) 135 (+ 1 (get-value (car (reverse card-list))))))))) 136 137(define (button-released start-slot card-list end-slot) 138 (and (droppable? start-slot card-list end-slot) 139 (move-n-cards! start-slot end-slot card-list) 140 (recalculate-score) 141 (check-visibility start-slot))) 142 143(define (button-clicked slot-id) 144 (and (= slot-id 0) 145 (not (empty-slot? slot-id)) 146 (deal-cards-face-up 0 '(9 10 11 12 13 14 15 16)) 147 (recalculate-score))) 148 149(define (find-empty-foundation a-slot f-slot) 150 (cond ((> f-slot 8) 151 #f) 152 ((empty-slot? f-slot) 153 (deal-cards a-slot (list f-slot))) 154 (#t (find-empty-foundation a-slot (+ 1 f-slot))))) 155 156(define (find-foundation a-slot f-slot) 157 (cond ((> f-slot 8) 158 #f) 159 ((and (not (empty-slot? f-slot)) 160 (= (get-suit (get-top-card a-slot)) 161 (get-suit (get-top-card f-slot))) 162 (= (get-value (get-top-card a-slot)) 163 (+ 1 (get-value (get-top-card f-slot))))) 164 (deal-cards a-slot (list f-slot))) 165 (#t (find-foundation a-slot (+ 1 f-slot))))) 166 167(define (autoplay-foundations) 168 (define (autoplay-foundations-tail) 169 (if (or-map button-double-clicked '(9 10 11 12 13 14 15 16)) 170 (delayed-call autoplay-foundations-tail) 171 #t)) 172 (if (or-map button-double-clicked '(9 10 11 12 13 14 15 16)) 173 (autoplay-foundations-tail) 174 #f)) 175 176(define (button-double-clicked slot-id) 177 (cond ((> slot-id 8) 178 (and (not (empty-slot? slot-id)) 179 (or (and (= (get-value (get-top-card slot-id)) 180 ace) 181 (find-empty-foundation slot-id 1) 182 (check-visibility slot-id) 183 (recalculate-score)) 184 (and (find-foundation slot-id 1) 185 (check-visibility slot-id) 186 (recalculate-score))))) 187 ((> slot-id 0) 188 (autoplay-foundations)) 189 (else #f))) 190 191 192(define (game-continuable) 193 (give-status-message) 194 (and (not (game-won)) 195 (get-hint))) 196 197(define (game-won) 198 (and (= (length (get-cards 1)) 13) 199 (= (length (get-cards 2)) 13) 200 (= (length (get-cards 3)) 13) 201 (= (length (get-cards 4)) 13) 202 (= (length (get-cards 5)) 13) 203 (= (length (get-cards 6)) 13) 204 (= (length (get-cards 7)) 13) 205 (= (length (get-cards 8)) 13))) 206 207(define (check-for-empty) 208 (if (or (empty-slot? 9) 209 (empty-slot? 10) 210 (empty-slot? 11) 211 (empty-slot? 12) 212 (empty-slot? 13) 213 (empty-slot? 14) 214 (empty-slot? 15) 215 (empty-slot? 16)) 216 (list 0 (_"Move a card or build of cards on to the empty slot")) 217 #f)) 218 219 220(define (check-a-foundation card slot-id) 221 (cond ((= slot-id 9) 222 #f) 223 ((and (not (empty-slot? slot-id)) 224 (eq? (get-suit card) 225 (get-suit (get-top-card slot-id))) 226 (= (get-value card) 227 (+ 1 (get-value (get-top-card slot-id))))) 228 slot-id) 229 (#t (check-a-foundation card (+ 1 slot-id))))) 230 231(define (check-to-foundations? slot-id) 232 (cond ((= slot-id 17) 233 #f) 234 ((empty-slot? slot-id) 235 (check-to-foundations? (+ 1 slot-id))) 236 ((= (get-value (get-top-card slot-id)) ace) 237 (hint-move slot-id 1 (find-empty-slot foundation))) 238 ((check-a-foundation (get-top-card slot-id) 1) 239 (hint-move slot-id 1 (check-a-foundation (get-top-card slot-id) 1))) 240 (#t (check-to-foundations? (+ 1 slot-id))))) 241 242(define (stripped card-list card) 243 (if (<= (length card-list) 1) 244 '() 245 (if (eq? card (car card-list)) 246 (cdr card-list) 247 (if (= (length card-list) 2) 248 '() 249 (stripped (cdr card-list) card))))) 250 251(define (check-a-tableau card slot1 card-list slot2 imbedded?) 252 (cond ((or (= (length card-list) 0) 253 (not (is-visible? (car card-list)))) 254 #f) 255 ((and (not (eq? (is-red? (car card-list)) 256 (is-red? card))) 257 (= (+ 1 (get-value (car card-list))) 258 (get-value card))) 259 (if (or (= (length card-list) 1) 260 (eq? (is-red? (car card-list)) 261 (is-red? (cadr card-list))) 262 imbedded? 263 (not (= (+ 1 (get-value (car card-list))) 264 (get-value (cadr card-list)))) 265 (check-a-foundation (cadr card-list) 1) 266 (and (check-alternating-color-list (list (car card-list) (cadr card-list))) 267 (check-straight-descending-list (list (car card-list) (cadr card-list))) 268 (check-a-tableau (get-top-card slot2) 269 slot1 270 (cdr card-list) 271 slot2 272 #t)) 273 (and (> (length (get-cards slot1)) 1) 274 (check-alternating-color-list (list (get-top-card slot1) 275 (cadr (get-cards slot1)))) 276 (check-straight-descending-list (list (get-top-card slot1) 277 (cadr (get-cards slot1)))) 278 (check-a-tableau (cadr card-list) 279 slot2 280 (get-cards slot1) 281 slot1 282 #t))) 283 (hint-move slot2 (+ 1 (- (length (get-cards slot2)) (length card-list))) slot1) 284 (and (not imbedded?) 285 (> (length card-list) 1) 286 (check-alternating-color-list (list (car card-list) 287 (cadr card-list))) 288 (check-straight-descending-list (list (car card-list) 289 (cadr card-list))) 290 (check-a-tableau card 291 slot1 292 (cdr card-list) 293 slot2 294 imbedded?)))) 295 (imbedded? #f) 296 (#t (and (> (length card-list) 1) 297 (check-alternating-color-list (list (car card-list) 298 (cadr card-list))) 299 (check-straight-descending-list (list (car card-list) 300 (cadr card-list))) 301 (check-a-tableau card slot1 (cdr card-list) slot2 imbedded?))))) 302 303(define (check-to-tableau? slot1 slot2) 304 (cond ((= slot1 17) 305 #f) 306 ((or (= slot2 17) 307 (empty-slot? slot1)) 308 (check-to-tableau? (+ 1 slot1) 9)) 309 ((and (not (= slot1 slot2)) 310 (check-a-tableau (get-top-card slot1) 311 slot1 312 (get-cards slot2) 313 slot2 314 #f)) 315 (check-a-tableau (get-top-card slot1) 316 slot1 317 (get-cards slot2) 318 slot2 319 #f)) 320 (#t (check-to-tableau? slot1 (+ 1 slot2))))) 321 322(define (check-from-foundation? slot1 slot2) 323 (cond ((= slot1 9) 324 #f) 325 ((or (= slot2 17) 326 (empty-slot? slot1)) 327 (check-from-foundation? (+ 1 slot1) 9)) 328 (#t (or (and (not (empty-slot? slot2)) 329 (check-a-tableau (get-top-card slot2) 330 slot2 331 (get-cards slot1) 332 slot1 333 #f)) 334 (check-from-foundation? slot1 (+ 1 slot2)))))) 335 336 337(define (check-for-deal) 338 (if (not (empty-slot? 0)) 339 (list 0 (_"Deal another hand")) 340 #f)) 341 342(define (get-hint) 343 (or (check-to-foundations? 9) 344 (check-to-tableau? 9 10) 345 (check-for-empty) 346 (check-for-deal) 347 (check-from-foundation? 1 9))) 348 349(define (get-options) 350 #f) 351 352(define (apply-options options) 353 #f) 354 355(define (timeout) 356 #f) 357 358(set-features droppable-feature) 359 360(set-lambda new-game button-pressed button-released button-clicked 361button-double-clicked game-continuable game-won get-hint get-options 362apply-options timeout droppable?) 363