1; AisleRiot - lady_jane.scm 2; Copyright (C) 1999, 2003 Rosanna Yuen <rwsy@mit.edu> 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 BASE-VAL 0) 20 21(define stock 0) 22(define waste 1) 23(define foundation '(2 3 4 5)) 24(define tableau '(6 7 8 9 10 11 12)) 25(define reserve '(13 14 15 16 17 18 19)) 26 27(define (new-game) 28 (initialize-playing-area) 29 (set-ace-low) 30 (make-standard-deck) 31 (shuffle-deck) 32 33 (add-normal-slot DECK 'stock) 34 (add-normal-slot '() 'waste) 35 36 (add-blank-slot) 37 38 (add-normal-slot '() 'foundation) 39 (add-normal-slot '() 'foundation) 40 (add-normal-slot '() 'foundation) 41 (add-normal-slot '() 'foundation) 42 43 (add-carriage-return-slot) 44 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 (set! HORIZPOS 0) 54 (set! VERTPOS 0) 55 56 (set! VERTPOS (+ VERTPOS 0.5)) 57 (set! HORIZPOS (+ HORIZPOS 7)) 58 (add-normal-slot '() 'reserve) 59 (add-carriage-return-slot) 60 (set! HORIZPOS (+ HORIZPOS 7)) 61 (add-normal-slot '() 'reserve) 62 (add-carriage-return-slot) 63 (set! HORIZPOS (+ HORIZPOS 7)) 64 (add-normal-slot '() 'reserve) 65 (add-carriage-return-slot) 66 (set! HORIZPOS (+ HORIZPOS 7)) 67 68 69 (set! HORIZPOS 0) 70 (set! VERTPOS 0) 71 72 (set! HORIZPOS (+ HORIZPOS 7)) 73 (add-blank-slot) 74 (add-normal-slot '() 'reserve) 75 (add-carriage-return-slot) 76 (set! HORIZPOS (+ HORIZPOS 7)) 77 (add-blank-slot) 78 (add-normal-slot '() 'reserve) 79 (add-carriage-return-slot) 80 (set! HORIZPOS (+ HORIZPOS 7)) 81 (add-blank-slot) 82 (add-normal-slot '() 'reserve) 83 (add-carriage-return-slot) 84 (set! HORIZPOS (+ HORIZPOS 7)) 85 (add-blank-slot) 86 (add-normal-slot '() 'reserve) 87 88 (deal-cards 0 '(7 8 9 10 11 12 8 9 10 11 12 9 10 11 12 10 11 12 89 11 12 12)) 90 (deal-cards-face-up 0 '(6 7 8 9 10 11 12 13 14 15 16 17 18 19 2)) 91 92 (add-to-score! 1) 93 94 (set! BASE-VAL (get-value (get-top-card 2))) 95 96 (give-status-message) 97 98 (list 9 4) 99) 100 101(define (give-status-message) 102 (set-statusbar-message (string-append (get-stock-no-string) 103 " " 104 (get-base-string)))) 105 106(define (get-base-string) 107 (cond ((and (> BASE-VAL 1) 108 (< BASE-VAL 11)) 109 (string-append (_"Base Card:") " " (number->string BASE-VAL))) 110 ((= BASE-VAL 1) 111 (_"Base Card: Ace")) 112 ((= BASE-VAL 11) 113 (_"Base Card: Jack")) 114 ((= BASE-VAL 12) 115 (_"Base Card: Queen")) 116 ((= BASE-VAL 13) 117 (_"Base Card: King")) 118 (#t ""))) 119 120(define (get-stock-no-string) 121 (if (> (length (get-cards 0)) 1) 122 (string-append (_"Stock left:") " " 123 (number->string (length (get-cards 0)))) 124 (string-append (_"Stock left: 0")))) 125 126(define (button-pressed slot-id card-list) 127 (and (not (empty-slot? slot-id)) 128 (is-visible? (car (reverse card-list))))) 129 130(define (to-foundation? card end-slot) 131 (if (empty-slot? end-slot) 132 (= (get-value card) BASE-VAL) 133 (and (eq? (get-suit card) 134 (get-suit (get-top-card end-slot))) 135 (or (= (+ 1 (get-value (get-top-card end-slot))) 136 (get-value card)) 137 (and (= (get-value (get-top-card end-slot)) king) 138 (= (get-value card) ace)))))) 139 140(define (to-tableau? card end-slot) 141 (if (empty-slot? end-slot) 142 (or (= (get-value card) (- BASE-VAL 1)) 143 (and (= BASE-VAL ace) 144 (= (get-value card) king))) 145 (and (not (eq? (is-red? card) 146 (is-red? (get-top-card end-slot)))) 147 (not (= (get-value (get-top-card end-slot)) BASE-VAL)) 148 (or (= (get-value (get-top-card end-slot)) 149 (+ 1 (get-value card))) 150 (and (= (get-value (get-top-card end-slot)) ace) 151 (= (get-value card) king)))))) 152 153(define (droppable? start-slot card-list end-slot) 154 (if (not (= start-slot end-slot)) 155 (cond ((and (> end-slot 1) 156 (< end-slot 6)) 157 (and (= (length card-list) 1) 158 (to-foundation? (car card-list) end-slot))) 159 ((and (> end-slot 5) 160 (< end-slot 13)) 161 (and (to-tableau? (car (reverse card-list)) end-slot))) 162 (#t #f)) 163 #f)) 164 165(define (button-released start-slot card-list end-slot) 166 (if (droppable? start-slot card-list end-slot) 167 (cond ((and (> end-slot 1) 168 (< end-slot 6)) 169 (and (or (and (> start-slot 5) 170 (< start-slot 13) 171 (not (empty-slot? start-slot)) 172 (make-visible-top-card start-slot)) 173 (and (> start-slot 1) 174 (< start-slot 6) 175 (add-to-score! -1)) 176 #t) 177 (add-to-score! 1) 178 (move-n-cards! start-slot end-slot card-list))) 179 ((and (> end-slot 5) 180 (< end-slot 13)) 181 (and (or (and (> start-slot 1) 182 (< start-slot 6) 183 (add-to-score! -1)) 184 (and (> start-slot 5) 185 (< start-slot 13) 186 (not (empty-slot? start-slot)) 187 (make-visible-top-card start-slot)) 188 #t) 189 (move-n-cards! start-slot end-slot card-list))) 190 (#t #f)) 191 #f)) 192 193(define (button-clicked slot-id) 194 (if (= slot-id 0) 195 (cond ((> (length (get-cards slot-id)) 7) 196 (and (deal-cards-face-up 0 '(13 14 15 16 17 18 19)) 197 (give-status-message))) 198 ((> (length (get-cards slot-id)) 1) 199 (and (deal-cards-face-up 0 '(1)) 200 (make-visible-top-card 0) 201 (give-status-message))) 202 (#t #f)) 203 #f)) 204 205(define (move-to-foundations? card slot-id) 206 (cond ((> slot-id 5) 207 #f) 208 ((to-foundation? card slot-id) 209 (add-card! slot-id card)) 210 (#t 211 (move-to-foundations? card (+ 1 slot-id))))) 212 213(define (button-double-clicked slot-id) 214 (if (or (empty-slot? slot-id) 215 (and (> slot-id 2) 216 (< slot-id 6)) 217 (not (is-visible? (get-top-card slot-id)))) 218 #f 219 (and (move-to-foundations? (get-top-card slot-id) 2) 220 (remove-card slot-id) 221 (add-to-score! 1) 222 (or (empty-slot? slot-id) 223 (> slot-id 12) 224 (< slot-id 2) 225 (make-visible-top-card slot-id))))) 226 227(define (game-continuable) 228 (and (not (game-won)) 229 (get-hint))) 230 231(define (game-won) 232 (and (= (length (get-cards 2)) 13) 233 (= (length (get-cards 3)) 13) 234 (= (length (get-cards 4)) 13) 235 (= (length (get-cards 5)) 13))) 236 237(define (dealable?) 238 (and (> (length (get-cards 0)) 1) 239 (list 0 (_"Deal another round")))) 240 241(define (check-a-foundation slot1 slot2) 242 (and (< slot2 6) 243 (if (to-foundation? (get-top-card slot1) slot2) 244 (hint-move slot1 1 slot2) 245 (check-a-foundation slot1 (+ 1 slot2))))) 246 247(define (check-to-foundations slot-id) 248 (cond ((> slot-id 19) 249 #f) 250 ((= slot-id 2) 251 (check-to-foundations 6)) 252 ((or (empty-slot? slot-id) 253 (not (is-visible? (get-top-card slot-id)))) 254 (check-to-foundations (+ 1 slot-id))) 255 (#t 256 (or (check-a-foundation slot-id 2) 257 (check-to-foundations (+ 1 slot-id)))))) 258 259(define (check-a-foundation2 card slot2) 260 (if (< slot2 6) 261 (or (to-foundation? card slot2) 262 (check-a-foundation2 card (+ 1 slot2))) 263 #f)) 264 265(define (stripped card-list card) 266 (if (<= (length card-list) 1) 267 '() 268 (if (eq? card (car card-list)) 269 (cdr card-list) 270 (if (= (length card-list) 2) 271 '() 272 (stripped (cdr card-list) card))))) 273 274(define (check-a-tableau-with-pile card slot1 card-list slot2 imbedded?) 275 (cond ((or (= (length card-list) 0) 276 (not (is-visible? (car card-list)))) 277 #f) 278 ((and (not (eq? (is-red? (car card-list)) 279 (is-red? card))) 280 (or (= (+ 1 (get-value (car card-list))) 281 (get-value card)) 282 (and (= (get-value (car card-list)) 283 king) 284 (= (get-value card) 285 ace)))) 286 (if (or (= (length card-list) 1) 287 (eq? (is-red? (car card-list)) 288 (is-red? (cadr card-list))) 289 imbedded? 290 (not (and (is-visible? (cadr card-list)) 291 (or (= (+ 1 (get-value (car card-list))) 292 (get-value (cadr card-list))) 293 (and (= (get-value (car card-list)) 294 king) 295 (= (get-value (cadr card-list)) 296 ace))))) 297 (check-a-foundation2 (cadr card-list) 2) 298 (check-a-tableau-with-pile (get-top-card slot2) 299 slot1 300 (cdr card-list) 301 slot2 302 #t) 303 (check-a-tableau-with-pile (cadr card-list) 304 slot2 305 (get-cards slot1) 306 slot1 307 #t) 308 (check-a-tableau-with-pile (cadr card-list) 309 slot2 310 (stripped (get-cards slot2) 311 (car card-list)) 312 slot2 313 #t)) 314 (if imbedded? 315 #t 316 (hint-move slot2 (- (+ 1 (length (get-cards slot2))) (length card-list)) slot1)) 317 (and (not imbedded?) 318 (check-a-tableau-with-pile card 319 slot1 320 (cdr card-list) 321 slot2 322 imbedded?)))) 323 (imbedded? #f) 324 (#t (check-a-tableau-with-pile card slot1 (cdr card-list) slot2 imbedded?)))) 325 326(define (check-a-tableau r-slot t-slot) 327 (if (and (eq? (is-red? (get-top-card r-slot)) 328 (is-black? (get-top-card t-slot))) 329 (or (= (+ 1 (get-value (get-top-card r-slot))) 330 (get-value (get-top-card t-slot))) 331 (and (= (get-value (get-top-card r-slot)) 332 king) 333 (= (get-value (get-top-card t-slot)) 334 ace)))) 335 (hint-move r-slot 1 t-slot) 336 #f)) 337 338(define (check-to-tableau? slot1 slot2) 339 (cond ((= slot1 20) 340 #f) 341 ((= slot1 2) 342 (check-to-tableau? 6 7)) 343 ((or (= slot2 13) 344 (empty-slot? slot1) 345 (not (is-visible? (get-top-card slot1)))) 346 (check-to-tableau? (+ 1 slot1) 6)) 347 ((and (not (= slot1 slot2)) 348 (> slot1 5) 349 (< slot1 13) 350 (check-a-tableau-with-pile (get-top-card slot1) 351 slot1 352 (get-cards slot2) 353 slot2 354 #f)) 355 (check-a-tableau-with-pile (get-top-card slot1) 356 slot1 357 (get-cards slot2) 358 slot2 359 #f)) 360 ((and (not (= slot1 slot2)) 361 (not (empty-slot? slot2)) 362 (or (> slot1 12) 363 (< slot1 2)) 364 (check-a-tableau slot1 slot2)) 365 (check-a-tableau slot1 slot2)) 366 (#t (check-to-tableau? slot1 (+ 1 slot2))))) 367 368(define (get-top-visible-card card-list) 369 (if (not (is-visible? (cadr card-list))) 370 (car card-list) 371 (get-top-visible-card (cdr card-list)))) 372 373(define (visible-card-count card-list acc) 374 (if (not (is-visible? (cadr card-list))) 375 acc 376 (visible-card-count (cdr card-list) (+ 1 acc)))) 377 378(define (find-high-value slot) 379 (cond ((= slot 20) 380 #f) 381 ((= slot 2) 382 (find-high-value 6)) 383 ((and (not (empty-slot? slot)) 384 (is-visible? (get-top-card slot)) 385 (< slot 13) 386 (> slot 5) 387 (not (is-visible? (car (reverse (get-cards slot))))) 388 (or (= (get-value (get-top-visible-card (get-cards slot))) 389 (- BASE-VAL 1)) 390 (and (= (get-value (get-top-visible-card (get-cards slot))) 391 king) 392 (= BASE-VAL ace)))) 393 (hint-move slot (visible-card-count (get-cards slot) 1) (find-empty-slot tableau))) 394 ((and (not (empty-slot? slot)) 395 (or (> slot 12) 396 (< slot 2)) 397 (is-visible? (get-top-card slot)) 398 (or (= (get-value (get-top-card slot)) 399 (- BASE-VAL 1)) 400 (and (= (get-value (get-top-card slot)) 401 king) 402 (= BASE-VAL ace)))) 403 (hint-move slot 1 (find-empty-slot tableau))) 404 (#t (find-high-value (+ 1 slot))))) 405 406(define (empty-tableau?) 407 (if (or (empty-slot? 6) 408 (empty-slot? 7) 409 (empty-slot? 8) 410 (empty-slot? 9) 411 (empty-slot? 10) 412 (empty-slot? 11) 413 (empty-slot? 12)) 414 (find-high-value 0) 415 #f)) 416 417(define (get-hint) 418 (or (check-to-foundations 0) 419 (check-to-tableau? 0 6) 420 (empty-tableau?) 421 (dealable?) 422 (list 0 (_"Try rearranging the cards")))) 423 424(define (get-options) 425 #f) 426 427(define (apply-options options) 428 #f) 429 430(define (timeout) 431 #f) 432 433(set-features droppable-feature) 434 435(set-lambda new-game button-pressed button-released button-clicked 436button-double-clicked game-continuable game-won get-hint get-options 437apply-options timeout droppable?) 438