1; AisleRiot API 2; Copyright (C) 1998, 2003 Jonathan Blandford <jrb@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(define-module (aisleriot api)) 18 19(use-modules (aisleriot interface) (ice-9 format) (ice-9 i18n)) 20 21;; This is the encoding of strings returned from e.g. 'format', 22;; so we need to set this to "UTF-8" since that's what the C side 23;; of aisleriot expects. Otherwise as per docs, guile sets this 24;; from the locale encoding, which would be wrong if the locale is 25;; an not UTF-8 locale, and also it seems that even though we call 26;; setlocale(3), the guile side does not pick this up, for whatever 27;; reason. 28;; Bug #733881. 29(fluid-set! %default-port-encoding "UTF-8") 30 31;; Define the usual alias for gettext 32(define-public (_ msg) (gettext msg "aisleriot")) 33 34;; Feature masks: 35(define-public droppable-feature 1) 36(define-public scores-disabled 2) 37(define-public dealable-feature 4) 38 39(define-public (set-features . feature-list) 40 (set-feature-word! (+ (get-feature-word) 41 (apply + feature-list)))) 42 43(define-public jack 11) 44(define-public queen 12) 45(define-public king 13) 46(define-public ace 1) 47(define-public joker 0) 48 49(define-public club 0) 50(define-public diamond 1) 51(define-public heart 2) 52(define-public spade 3) 53 54(define-public black 0) 55(define-public red 1) 56 57(define-public down 0) 58(define-public right 1) 59 60;; Global variables: 61 62(define-public DECK '()) 63 64; The list of variables to save when saving the game state 65(define-public variable-list '()) 66 67;; NEW-GAME PROCEDURES 68; these may be used in game files during the new-game procedure. 69 70; This procedure MUST be called at the start of the new-game procedure. 71; 72; Note that variable-list is not cleared, this is because defines are normally 73; done before calling this and we would loose our variable list. At worst 74; case we end up saving and restoring variables that are not currently in use 75; (but will be defined) so it will work out OK. 76(define-public (initialize-playing-area) 77 (reset-surface) 78 (set! FLIP-COUNTER 0) 79 (set! SLOTS 0) 80 (set! HORIZPOS 0) 81 (set! VERTPOS 0) 82 (set! IN-GAME #f) 83 (set! MOVE '()) 84 (set-statusbar-message " ") 85 (set! HISTORY '()) 86 (set! FOUNDATION-SLOTS '()) 87 (set! TABLEAU-SLOTS '()) 88 (set! RESERVE-SLOTS '()) 89 (set! EDGE-SLOTS '()) 90 (set! CORNER-SLOTS '()) 91 (set! TOP-SLOTS '()) 92 (set! BOTTOM-SLOTS '()) 93 (set! LEFT-SLOTS '()) 94 (set! RIGHT-SLOTS '()) 95 (set-score! 0)) 96 97; Use this instead of define for variables which determine the state of 98; the game. i.e. anything that isn't a constant. This is so undo/redo 99; is transparent. It should behave otherwise identically to define. 100(defmacro-public def-save-var (nm value) 101 `(begin (define-public ,nm ,value) 102 (set! variable-list (cons ',nm variable-list)))) 103 104; create a 52 card deck (puts list of cards into DECK) 105(define-public (make-standard-deck) 106 (if (= ace 14) 107 (set! DECK (make-standard-deck-list-ace-high 2 club)) 108 (set! DECK (make-standard-deck-list-ace-low ace club)))) 109 110; create a 54 card deck with 2 jokers. 111(define-public (make-joker-deck) 112 (if (= ace 14) 113 (set! DECK (cons (make-card joker club) (cons (make-card joker diamond) 114 (make-standard-deck-list-ace-high 2 club)))) 115 (set! DECK (cons (make-card joker club) (cons (make-card joker diamond) 116 (make-standard-deck-list-ace-low ace club)))))) 117 118; create a double deck of 104 cards (puts list of cards into DECK) 119(define-public (make-standard-double-deck) 120 (if (= ace 14) 121 (set! DECK (append (make-standard-deck-list-ace-high 2 club) (make-standard-deck-list-ace-high 2 club))) 122 (set! DECK (append (make-standard-deck-list-ace-low ace club) (make-standard-deck-list-ace-low ace club))))) 123 124 ; makes a deck from init-value to kings 125(define-public (make-deck-list-ace-low init-value value suit) 126 (if (eq? king value) 127 (if (eq? spade suit) 128 (list (make-card king spade)) 129 (cons (make-card value suit) 130 (make-deck-list-ace-low 131 init-value init-value (+ 1 suit)))) 132 (cons (make-card value suit) 133 (make-deck-list-ace-low init-value (+ 1 value) suit)))) 134 135 ; makes a deck from init-value to aces 136(define-public (make-deck-list-ace-high init-value value suit) 137 (if (eq? 14 value) 138 (if (eq? spade suit) 139 (list (make-card ace spade)) 140 (cons (make-card value suit) 141 (make-deck-list-ace-high 142 init-value init-value (+ 1 suit)))) 143 (cons (make-card value suit) 144 (make-deck-list-ace-high init-value (+ 1 value) suit)))) 145 146; shuffle the card list 147(define (shuffle-card-list card-list) 148 (let* ((vec (list->vector card-list)) 149 (len (vector-length vec))) 150 (shuffle-deck-helper vec '() 0 len))) 151 152; shuffle the card list in DECK 153(define-public (shuffle-deck) 154 (set! DECK (shuffle-card-list DECK))) 155 156; shuffle the card list in slot 157(define-public (shuffle-slot slot-id) 158 (set-cards! slot-id (shuffle-card-list (get-cards slot-id)))) 159 160; The playing area is divided into slots, where cards can be placed. 161; Each slot can hold any amount of cards. The slots are identified 162; using numbers assigned in order of their creation. The deck of cards 163; held in DECK should be assigned to one of the slots on creation. 164; (You may then create another deck and place it in a later slot). 165; 166; The slots are added to the board from left to right until the 167; add-carriage-return-slot procedure is called, which starts a new line. 168; A space may be added using the add-blank-slot procedure. These false 169; slots are not assigned identifiers. 170 171(define-public (add-blank-slot) 172 (get-and-increment-position)) 173 174(define-public (add-carriage-return-slot) 175 (linefeed-position)) 176 177; The real slots come in three varieties: 178; A slot in which only the topmost card is visible: 179(define-public (add-normal-slot cards . type) 180 (add-slot (set-tag! (new-slot cards 181 (list 'normal (get-and-increment-position)) type)))) 182 183; A slot in which all the cards are visible, arranged as an overlapped pile: 184; (either proceeding to the right or down). 185(define-public (add-extended-slot cards direction . type) 186 (if (= right direction) 187 (add-slot (set-tag! (new-slot cards 188 (list 'expanded-right 189 (get-and-increment-position)) type))) 190 (add-slot (set-tag! (new-slot cards 191 (list 'expanded 192 (get-and-increment-position)) type))))) 193 194; A slot in only the n topmost cards are visible: 195(define-public (add-partially-extended-slot cards direction n . type) 196 (if (= right direction) 197 (add-slot (set-tag! (new-slot cards 198 (list 'partially-expanded-right 199 (get-and-increment-position) n) type))) 200 (add-slot (set-tag! (new-slot cards 201 (list 'partially-expanded 202 (get-and-increment-position) n) type))))) 203 204; Cards may be dealt off one slot (usually the one containing the deck) 205; and onto a list of other slots using these procedures: 206(define-public (deal-cards target-slot-id slot-list) 207 (if (not (null? slot-list)) 208 (begin 209 (add-card! (car slot-list) (remove-card target-slot-id)) 210 (deal-cards target-slot-id (cdr slot-list))))) 211 212(define-public (deal-cards-face-up target-slot-id slot-list) 213 (if (not (null? slot-list)) 214 (begin 215 (add-card! (car slot-list) (make-visible (remove-card target-slot-id))) 216 (deal-cards-face-up target-slot-id (cdr slot-list))))) 217 218;; GENERAL GAME PROCEDURES 219; these may be used in game files at any time. 220 221;; Procedures that change slot contents: 222 223; turn the top card of a slot over (face up to face down and vice versa) 224(define-public (flip-top-card slot-id) 225 (add-card! slot-id (flip-card (remove-card slot-id)))) 226 227; turn the top card of a slot face side up 228(define-public (make-visible-top-card slot-id) 229 (add-card! slot-id (make-visible (remove-card slot-id)))) 230 231; add a card onto the top of a slot 232(define-public (add-card! slot-id card) 233 (set-cards! slot-id (cons card (get-cards slot-id)))) 234 235; add a list of cards onto the top of a slot 236(define-public (add-cards! slot-id cards) 237 (set-cards! slot-id (append cards (get-cards slot-id)))) 238 239; remove (and return) the top card from a slot 240(define-public (remove-card slot-id) 241 (let ((cards (get-cards slot-id))) 242 (set-cards! slot-id (cdr cards)) 243 (car cards))) 244 245;; Utilities 246 247(define-public (flippable? stock-slot waste-slot flip-limit) 248 (or (not (empty-slot? stock-slot)) 249 (and (not (empty-slot? waste-slot)) 250 (or (< flip-limit 0) 251 (< FLIP-COUNTER flip-limit))))) 252 253; deal a card from the stock-slot to the waste-slot. 254; when the stock slot is empty than the waste slot will be flipped back 255; onto the stock unless the flip limit has been reached. 256; an optional forth argument indicates the number of cards to deal. 257; If the flip limit is negative, it is treated as infinite. 258(define-public (flip-stock stock-slot waste-slot flip-limit . rest) 259 (if (empty-slot? stock-slot) 260 (and (not (empty-slot? waste-slot)) 261 (or (< flip-limit 0) 262 (< FLIP-COUNTER flip-limit)) 263 (set! FLIP-COUNTER (+ 1 FLIP-COUNTER)) 264 (flip-deck stock-slot waste-slot)) 265 (or (let loop ((i (if (null? rest) 1 (car rest)))) 266 (and (> i 0) 267 (not (empty-slot? stock-slot)) 268 (add-card! waste-slot (flip-card (remove-card stock-slot))) 269 (loop (- i 1)))) 270 #t))) 271 272; turn the cards in the waste slot over and add them to the stock-slot. 273(define-public (flip-deck stock-slot waste-slot) 274 (and (not (empty-slot? waste-slot)) 275 (add-card! stock-slot (flip-card (remove-card waste-slot))) 276 (or (flip-deck stock-slot waste-slot) 277 #t))) 278 279;; Procedures for manipulating cards: 280 281; NB: In order to use these procedures you must remove the cards 282; from their slots and then replace them after applying the procedure 283; (as in the make-top-card-visible procedure above) 284(define-public (flip-card card) 285 (list (car card) (cadr card) (not (caddr card)))) 286 287(define-public (make-visible card) 288 (list (car card) (cadr card) #t)) 289 290;; Procedures that provide information only: 291 292; card procedures 293(define-public (is-visible? card) 294 (caddr card)) 295 296(define-public (get-suit card) 297 (cadr card)) 298 299(define-public (get-color card) 300 (cond ((eq? (get-suit card) club) black) 301 ((eq? (get-suit card) spade) black) 302 ((eq? (get-suit card) heart) red) 303 ((eq? (get-suit card) diamond) red) 304 (#t (_"Unknown color")))) 305 306(define-public (get-value card) 307 (car card)) 308 309;; WARNING: This generates a synthetic card that isn't part of the game. 310;; See gaps.scm for an example of its intended use. 311(define-public (add-to-value card n) 312 (cons (+ (car card) n) (cdr card))) 313 314; slot procedures 315(define-public (get-cards slot-id) 316 (cadr (get-slot slot-id))) 317 318(define-public (empty-slot? slot-id) 319 (null? (get-cards slot-id))) 320 321(define-public (any-slot-empty? slots) 322 (if (eq? slots '()) 323 #f 324 (or (empty-slot? (car slots)) 325 (any-slot-empty? (cdr slots))))) 326 327(define-public (find-empty-slot slots) 328 (cond ((null? slots) #f) 329 ((empty-slot? (car slots)) (car slots)) 330 (#t (find-empty-slot (cdr slots))))) 331 332(define-public (find-card-helper card cards n) 333 (if (null? cards) 334 #f 335 (if (equal? (car cards) card) 336 n 337 (find-card-helper card (cdr cards) (+ n 1))))) 338 339(define-public (find-card slot card) 340 (find-card-helper card (get-cards slot) 1)) 341 342(define (find-card-slot-helper slot card) 343 (if (equal? #f (find-card slot card)) 344 (find-card-slot-helper (+ 1 slot) card) 345 slot)) 346 347(define-public (find-card-slot card) 348 (find-card-slot-helper 0 card)) 349 350; Get the nth card from a slot. Returns #f if n is out of range. 351(define-public (get-nth-card slot-id n) 352 (let ((cards (get-cards slot-id))) 353 (cond ((< n 1) #f) 354 ((> n (length cards)) #f) 355 (#t (list-ref cards (- n 1)))))) 356 357(define-public (get-top-card slot-id) 358 (let ((cards (get-cards slot-id))) 359 (if (null? cards) 360 '() 361 (car cards)))) 362 363;; Utilities - need more of these: 364(define-public (suit-eq? card1 card2) 365 (eq? (get-suit card1) (get-suit card2))) 366 367(define-public (color-eq? card1 card2) 368 (eq? (get-color card1) (get-color card2))) 369 370(define-public (value-eq? card1 card2) 371 (eq? (get-value card1) (get-value card2))) 372 373(define-public (cards-eq? card1 card2) 374 (and (eq? (get-value card1) (get-value card2)) 375 (eq? (get-suit card1) (get-suit card2)))) 376 377(define-public (is-red? card) 378 (eq? red (get-color card))) 379 380(define-public (is-black? card) 381 (eq? black (get-color card))) 382 383(define-public (is-joker? card) 384 (= (get-value card) joker)) 385 386(define-public (set-ace-low) (set! ace 1)) 387 388(define-public (set-ace-high) (set! ace 14)) 389 390; use to compare two cards when aces are treated as high: 391(define-public (ace-high-order value) 392 (remainder (+ 11 value) 13)) 393 394(define-public (check-same-suit-list card-list) 395 (or (< (length card-list) 2) 396 (and (= (get-suit (car card-list)) (get-suit (cadr card-list))) 397 (check-same-suit-list (cdr card-list))))) 398 399(define-public (check-same-color-list card-list) 400 (or (< (length card-list) 2) 401 (and (eq? (is-red? (car card-list)) (is-red? (cadr card-list))) 402 (check-same-color-list (cdr card-list))))) 403 404(define-public (check-alternating-color-list card-list) 405 (or (< (length card-list) 2) 406 (and (eq? (is-black? (car card-list)) (is-red? (cadr card-list))) 407 (check-alternating-color-list (cdr card-list))))) 408 409(define-public (check-straight-descending-list card-list) 410 (or (< (length card-list) 2) 411 (and (= (get-value (car card-list)) (- (get-value (cadr card-list)) 1)) 412 (check-straight-descending-list (cdr card-list))))) 413 414; debugging aid: 415(define-public (display-list . objs) 416 (map display objs) (newline)) 417 418; hint procedures 419(define-public (get-joker-name card) 420 (if (is-black? card) (_"the black joker") (_"the red joker"))) 421 422(define (get-name card) 423 ; Do not use this function directly. To create a hint for moving a card or 424 ; stack of cards, use (hint-move). 425 (let ((value (get-value card)) (suit (get-suit card))) 426 (if (is-joker? card) 427 (get-joker-name card) 428 (cond ((eq? suit club) 429 (cond ((eq? value ace) (_"the ace of clubs")) 430 ((eq? value 2) (_"the two of clubs")) 431 ((eq? value 3) (_"the three of clubs")) 432 ((eq? value 4) (_"the four of clubs")) 433 ((eq? value 5) (_"the five of clubs")) 434 ((eq? value 6) (_"the six of clubs")) 435 ((eq? value 7) (_"the seven of clubs")) 436 ((eq? value 8) (_"the eight of clubs")) 437 ((eq? value 9) (_"the nine of clubs")) 438 ((eq? value 10) (_"the ten of clubs")) 439 ((eq? value jack) (_"the jack of clubs")) 440 ((eq? value queen) (_"the queen of clubs")) 441 ((eq? value king) (_"the king of clubs")) 442 (#t (_"the unknown card")))) 443 ((eq? suit spade) 444 (cond ((eq? value ace) (_"the ace of spades")) 445 ((eq? value 2) (_"the two of spades")) 446 ((eq? value 3) (_"the three of spades")) 447 ((eq? value 4) (_"the four of spades")) 448 ((eq? value 5) (_"the five of spades")) 449 ((eq? value 6) (_"the six of spades")) 450 ((eq? value 7) (_"the seven of spades")) 451 ((eq? value 8) (_"the eight of spades")) 452 ((eq? value 9) (_"the nine of spades")) 453 ((eq? value 10) (_"the ten of spades")) 454 ((eq? value jack) (_"the jack of spades")) 455 ((eq? value queen) (_"the queen of spades")) 456 ((eq? value king) (_"the king of spades")) 457 (#t (_"the unknown card")))) 458 ((eq? suit heart) 459 (cond ((eq? value ace) (_"the ace of hearts")) 460 ((eq? value 2) (_"the two of hearts")) 461 ((eq? value 3) (_"the three of hearts")) 462 ((eq? value 4) (_"the four of hearts")) 463 ((eq? value 5) (_"the five of hearts")) 464 ((eq? value 6) (_"the six of hearts")) 465 ((eq? value 7) (_"the seven of hearts")) 466 ((eq? value 8) (_"the eight of hearts")) 467 ((eq? value 9) (_"the nine of hearts")) 468 ((eq? value 10) (_"the ten of hearts")) 469 ((eq? value jack) (_"the jack of hearts")) 470 ((eq? value queen) (_"the queen of hearts")) 471 ((eq? value king) (_"the king of hearts")) 472 (#t (_"the unknown card")))) 473 ((eq? suit diamond) 474 (cond ((eq? value ace) (_"the ace of diamonds")) 475 ((eq? value 2) (_"the two of diamonds")) 476 ((eq? value 3) (_"the three of diamonds")) 477 ((eq? value 4) (_"the four of diamonds")) 478 ((eq? value 5) (_"the five of diamonds")) 479 ((eq? value 6) (_"the six of diamonds")) 480 ((eq? value 7) (_"the seven of diamonds")) 481 ((eq? value 8) (_"the eight of diamonds")) 482 ((eq? value 9) (_"the nine of diamonds")) 483 ((eq? value 10) (_"the ten of diamonds")) 484 ((eq? value jack) (_"the jack of diamonds")) 485 ((eq? value queen) (_"the queen of diamonds")) 486 ((eq? value king) (_"the king of diamonds")) 487 (#t (_"the unknown card")))) 488 (#t (_"the unknown card")))))) 489 490(define (hint-get-dest-format to-slot cards) 491 (if (null? cards) 492 (cond ((member to-slot FOUNDATION-SLOTS) (if (= (length FOUNDATION-SLOTS) 1) (_"Move ~a onto the foundation.") (_"Move ~a onto an empty foundation slot."))) 493 ((member to-slot TABLEAU-SLOTS) (if (= (length TABLEAU-SLOTS) 1) (_"Move ~a onto the tableau.") (_"Move ~a onto an empty tableau slot."))) 494 ((member to-slot RESERVE-SLOTS) (if (= (length RESERVE-SLOTS) 1) (_"Move ~a onto the reserve.") (_"Move ~a onto an empty reserve slot."))) 495 ((member to-slot EDGE-SLOTS) (_"Move ~a onto an empty edge slot.")) 496 ((member to-slot CORNER-SLOTS) (_"Move ~a onto an empty corner slot.")) 497 ((member to-slot TOP-SLOTS) (_"Move ~a onto an empty top slot.")) 498 ((member to-slot BOTTOM-SLOTS) (_"Move ~a onto an empty bottom slot.")) 499 ((member to-slot LEFT-SLOTS) (_"Move ~a onto an empty left slot.")) 500 ((member to-slot RIGHT-SLOTS) (_"Move ~a onto an empty right slot.")) 501 (else (_"Move ~a onto an empty slot."))) 502 (let* ((card (car cards)) (value (get-value card)) (suit (get-suit card))) 503 (cond ((is-joker? card) 504 (if (is-black? card) (_"Move ~a onto the black joker.") (_"Move ~a onto the red joker."))) 505 ((eq? suit club) 506 (cond ((eq? value ace) (_"Move ~a onto the ace of clubs.")) 507 ((eq? value 2) (_"Move ~a onto the two of clubs.")) 508 ((eq? value 3) (_"Move ~a onto the three of clubs.")) 509 ((eq? value 4) (_"Move ~a onto the four of clubs.")) 510 ((eq? value 5) (_"Move ~a onto the five of clubs.")) 511 ((eq? value 6) (_"Move ~a onto the six of clubs.")) 512 ((eq? value 7) (_"Move ~a onto the seven of clubs.")) 513 ((eq? value 8) (_"Move ~a onto the eight of clubs.")) 514 ((eq? value 9) (_"Move ~a onto the nine of clubs.")) 515 ((eq? value 10) (_"Move ~a onto the ten of clubs.")) 516 ((eq? value jack) (_"Move ~a onto the jack of clubs.")) 517 ((eq? value queen) (_"Move ~a onto the queen of clubs.")) 518 ((eq? value king) (_"Move ~a onto the king of clubs.")) 519 (#t (_"Move ~a onto the unknown card.")))) 520 ((eq? suit spade) 521 (cond ((eq? value ace) (_"Move ~a onto the ace of spades.")) 522 ((eq? value 2) (_"Move ~a onto the two of spades.")) 523 ((eq? value 3) (_"Move ~a onto the three of spades.")) 524 ((eq? value 4) (_"Move ~a onto the four of spades.")) 525 ((eq? value 5) (_"Move ~a onto the five of spades.")) 526 ((eq? value 6) (_"Move ~a onto the six of spades.")) 527 ((eq? value 7) (_"Move ~a onto the seven of spades.")) 528 ((eq? value 8) (_"Move ~a onto the eight of spades.")) 529 ((eq? value 9) (_"Move ~a onto the nine of spades.")) 530 ((eq? value 10) (_"Move ~a onto the ten of spades.")) 531 ((eq? value jack) (_"Move ~a onto the jack of spades.")) 532 ((eq? value queen) (_"Move ~a onto the queen of spades.")) 533 ((eq? value king) (_"Move ~a onto the king of spades.")) 534 (#t (_"Move ~a onto the unknown card.")))) 535 ((eq? suit heart) 536 (cond ((eq? value ace) (_"Move ~a onto the ace of hearts.")) 537 ((eq? value 2) (_"Move ~a onto the two of hearts.")) 538 ((eq? value 3) (_"Move ~a onto the three of hearts.")) 539 ((eq? value 4) (_"Move ~a onto the four of hearts.")) 540 ((eq? value 5) (_"Move ~a onto the five of hearts.")) 541 ((eq? value 6) (_"Move ~a onto the six of hearts.")) 542 ((eq? value 7) (_"Move ~a onto the seven of hearts.")) 543 ((eq? value 8) (_"Move ~a onto the eight of hearts.")) 544 ((eq? value 9) (_"Move ~a onto the nine of hearts.")) 545 ((eq? value 10) (_"Move ~a onto the ten of hearts.")) 546 ((eq? value jack) (_"Move ~a onto the jack of hearts.")) 547 ((eq? value queen) (_"Move ~a onto the queen of hearts.")) 548 ((eq? value king) (_"Move ~a onto the king of hearts.")) 549 (#t (_"Move ~a onto the unknown card.")))) 550 ((eq? suit diamond) 551 (cond ((eq? value ace) (_"Move ~a onto the ace of diamonds.")) 552 ((eq? value 2) (_"Move ~a onto the two of diamonds.")) 553 ((eq? value 3) (_"Move ~a onto the three of diamonds.")) 554 ((eq? value 4) (_"Move ~a onto the four of diamonds.")) 555 ((eq? value 5) (_"Move ~a onto the five of diamonds.")) 556 ((eq? value 6) (_"Move ~a onto the six of diamonds.")) 557 ((eq? value 7) (_"Move ~a onto the seven of diamonds.")) 558 ((eq? value 8) (_"Move ~a onto the eight of diamonds.")) 559 ((eq? value 9) (_"Move ~a onto the nine of diamonds.")) 560 ((eq? value 10) (_"Move ~a onto the ten of diamonds.")) 561 ((eq? value jack) (_"Move ~a onto the jack of diamonds.")) 562 ((eq? value queen) (_"Move ~a onto the queen of diamonds.")) 563 ((eq? value king) (_"Move ~a onto the king of diamonds.")) 564 (#t (_"Move ~a onto the unknown card.")))) 565 (#t (_"Move ~a onto the unknown card.")))))) 566 567(define-public (hint-move from-slot from-slot-count to-slot) 568 (if (= from-slot to-slot) 569 (list 0 (format #f (hint-get-dest-format to-slot (list-tail (get-cards to-slot) from-slot-count)) (get-name (get-nth-card from-slot from-slot-count)))) 570 (list 0 (format #f (hint-get-dest-format to-slot (get-cards to-slot)) (get-name (get-nth-card from-slot from-slot-count)))))) 571 572(define-public (hint-click slot-id hint-string) 573 (list 0 hint-string)) 574 575(define (get-remove-string card) 576 (let ((value (get-value card)) (suit (get-suit card))) 577 (cond ((is-joker? card) 578 (if (is-black? card) (_"Remove the black joker.") (_"Remove the red joker."))) 579 ((eq? suit club) 580 (cond ((eq? value ace) (_"Remove the ace of clubs.")) 581 ((eq? value 2) (_"Remove the two of clubs.")) 582 ((eq? value 3) (_"Remove the three of clubs.")) 583 ((eq? value 4) (_"Remove the four of clubs.")) 584 ((eq? value 5) (_"Remove the five of clubs.")) 585 ((eq? value 6) (_"Remove the six of clubs.")) 586 ((eq? value 7) (_"Remove the seven of clubs.")) 587 ((eq? value 8) (_"Remove the eight of clubs.")) 588 ((eq? value 9) (_"Remove the nine of clubs.")) 589 ((eq? value 10) (_"Remove the ten of clubs.")) 590 ((eq? value jack) (_"Remove the jack of clubs.")) 591 ((eq? value queen) (_"Remove the queen of clubs.")) 592 ((eq? value king) (_"Remove the king of clubs.")) 593 (#t (_"Remove the unknown card.")))) 594 ((eq? suit spade) 595 (cond ((eq? value ace) (_"Remove the ace of spades.")) 596 ((eq? value 2) (_"Remove the two of spades.")) 597 ((eq? value 3) (_"Remove the three of spades.")) 598 ((eq? value 4) (_"Remove the four of spades.")) 599 ((eq? value 5) (_"Remove the five of spades.")) 600 ((eq? value 6) (_"Remove the six of spades.")) 601 ((eq? value 7) (_"Remove the seven of spades.")) 602 ((eq? value 8) (_"Remove the eight of spades.")) 603 ((eq? value 9) (_"Remove the nine of spades.")) 604 ((eq? value 10) (_"Remove the ten of spades.")) 605 ((eq? value jack) (_"Remove the jack of spades.")) 606 ((eq? value queen) (_"Remove the queen of spades.")) 607 ((eq? value king) (_"Remove the king of spades.")) 608 (#t (_"Remove the unknown card.")))) 609 ((eq? suit heart) 610 (cond ((eq? value ace) (_"Remove the ace of hearts.")) 611 ((eq? value 2) (_"Remove the two of hearts.")) 612 ((eq? value 3) (_"Remove the three of hearts.")) 613 ((eq? value 4) (_"Remove the four of hearts.")) 614 ((eq? value 5) (_"Remove the five of hearts.")) 615 ((eq? value 6) (_"Remove the six of hearts.")) 616 ((eq? value 7) (_"Remove the seven of hearts.")) 617 ((eq? value 8) (_"Remove the eight of hearts.")) 618 ((eq? value 9) (_"Remove the nine of hearts.")) 619 ((eq? value 10) (_"Remove the ten of hearts.")) 620 ((eq? value jack) (_"Remove the jack of hearts.")) 621 ((eq? value queen) (_"Remove the queen of hearts.")) 622 ((eq? value king) (_"Remove the king of hearts.")) 623 (#t (_"Remove the unknown card.")))) 624 ((eq? suit diamond) 625 (cond ((eq? value ace) (_"Remove the ace of diamonds.")) 626 ((eq? value 2) (_"Remove the two of diamonds.")) 627 ((eq? value 3) (_"Remove the three of diamonds.")) 628 ((eq? value 4) (_"Remove the four of diamonds.")) 629 ((eq? value 5) (_"Remove the five of diamonds.")) 630 ((eq? value 6) (_"Remove the six of diamonds.")) 631 ((eq? value 7) (_"Remove the seven of diamonds.")) 632 ((eq? value 8) (_"Remove the eight of diamonds.")) 633 ((eq? value 9) (_"Remove the nine of diamonds.")) 634 ((eq? value 10) (_"Remove the ten of diamonds.")) 635 ((eq? value jack) (_"Remove the jack of diamonds.")) 636 ((eq? value queen) (_"Remove the queen of diamonds.")) 637 ((eq? value king) (_"Remove the king of diamonds.")) 638 (#t (_"Remove the unknown card.")))) 639 (#t (_"Remove the unknown card."))))) 640 641(define-public (hint-remove-top-card slot) 642 (hint-click slot (get-remove-string (get-top-card slot)))) 643 644(define-public (move-n-cards! start-slot end-slot cards) 645 (add-cards! end-slot cards)) 646 647(define-public (remove-n-cards slot-id n) 648 (set-cards! slot-id (list-tail (get-cards slot-id) n))) 649 650(define-public (deal-cards-from-deck deck slot-list) 651 (if (not (null? slot-list)) 652 (begin 653 (add-card! (car slot-list) (car deck)) 654 (deal-cards-from-deck (cdr deck) (cdr slot-list))))) 655 656(define-public (deal-cards-face-up-from-deck deck slot-list) 657 (if (not (null? slot-list)) 658 (begin 659 (add-card! (car slot-list) (make-visible (car deck))) 660 (deal-cards-face-up-from-deck (cdr deck) (cdr slot-list))))) 661 662 663(define-public (set-cards! slot-id new_cards) 664 (set-cards-c! slot-id new_cards)) 665 666(define-public (make-card value suit) 667 (list value suit #f)) 668 669(define-public (make-standard-deck-list-ace-high value suit) 670 (if (eq? ace value) 671 (if (eq? spade suit) 672 (list (make-card ace spade)) 673 (cons (make-card value suit) 674 (make-standard-deck-list-ace-high 2 (+ 1 suit)))) 675 (cons (make-card value suit) 676 (make-standard-deck-list-ace-high (+ 1 value) suit)))) 677 678(define-public (make-standard-deck-list-ace-low value suit) 679 (if (eq? king value) 680 (if (eq? spade suit) 681 (list (make-card king spade)) 682 (cons (make-card value suit) 683 (make-standard-deck-list-ace-low 1 (+ 1 suit)))) 684 (cons (make-card value suit) 685 (make-standard-deck-list-ace-low (+ 1 value) suit)))) 686 687(define-public (shuffle-deck-helper deck result ref1 len) 688 (if (zero? len) 689 result 690 (let* ((ref2 (+ ref1 (aisleriot-random len))) 691 (val-at-ref2 (vector-ref deck ref2))) 692 (vector-set! deck ref2 (vector-ref deck ref1)) 693 (shuffle-deck-helper deck (cons val-at-ref2 result) (+ ref1 1) (- len 1))))) 694 695(define-public (new-slot deck placement type) 696 (list #f deck placement (if (null? type) 'unknown (car type)))) 697 698(define-public (set-tag! slot) 699 (case (cadddr slot) 700 ((tableau) (set! TABLEAU-SLOTS (cons SLOTS TABLEAU-SLOTS))) 701 ((reserve) (set! RESERVE-SLOTS (cons SLOTS RESERVE-SLOTS))) 702 ((edge) (set! EDGE-SLOTS (cons SLOTS EDGE-SLOTS))) 703 ((corner) (set! CORNER-SLOTS (cons SLOTS CORNER-SLOTS))) 704 ((top) (set! TOP-SLOTS (cons SLOTS TOP-SLOTS))) 705 ((bottom) (set! BOTTOM-SLOTS (cons SLOTS BOTTOM-SLOTS))) 706 ((left) (set! LEFT-SLOTS (cons SLOTS LEFT-SLOTS))) 707 ((right) (set! RIGHT-SLOTS (cons SLOTS RIGHT-SLOTS))) 708 ((foundation) (set! FOUNDATION-SLOTS (cons SLOTS FOUNDATION-SLOTS)))) 709 (set! SLOTS (+ 1 SLOTS)) 710 (cons (- SLOTS 1) (cdr slot))) 711 712(define-public (get-and-increment-position) 713 (let ((retval (list HORIZPOS VERTPOS))) 714 (set! HORIZPOS (+ HORIZPOS 1)) 715 retval)) 716 717(define-public (linefeed-position) 718 (set! HORIZPOS 0) 719 (set! VERTPOS (+ VERTPOS 1))) 720 721(define-public (register-undo-function function data) 722 (set! MOVE (cons '(function data) (cdr MOVE)))) 723 724; set score 725(define-public (set-score! value) 726 (begin 727 (set! SCORE value) 728 (update-score (number->locale-string SCORE)) 729 SCORE)) 730 731(define-public (get-score) 732 SCORE) 733 734(define-public (add-to-score! delta) 735 (set-score! (+ (get-score) delta))) 736 737(define-public (set-statusbar-message message) 738 (set! STATUSBAR-MESSAGE message) 739 (set-statusbar-message-c message) 740) 741 742;; INTERNAL procedures 743 744; global variables 745(define-public FLIP-COUNTER 0) 746(define-public SLOTS 0) 747(define-public HORIZPOS 0) 748(define-public VERTPOS 0) 749(define-public MOVE '()) 750(define-public HISTORY '()) 751(define-public FUTURE '()) 752(define-public IN-GAME #f) 753(define-public FOUNDATION-SLOTS '()) 754(define-public TABLEAU-SLOTS '()) 755(define-public RESERVE-SLOTS '()) 756(define-public EDGE-SLOTS '()) 757(define-public CORNER-SLOTS '()) 758(define-public TOP-SLOTS '()) 759(define-public BOTTOM-SLOTS '()) 760(define-public LEFT-SLOTS '()) 761(define-public RIGHT-SLOTS '()) 762(define-public SCORE 0) 763(define-public STATUSBAR-MESSAGE "") 764 765; called from C: 766(define-public (start-game) 767 (set! IN-GAME #t)) 768 769; called from C: 770(define-public (end-move) 771 (if (not (= 0 (length MOVE))) 772 (begin 773 (set! HISTORY (cons MOVE HISTORY)) 774 (set! FUTURE '()) 775 (set! MOVE '()) 776 (if (null? HISTORY) 777 (undo-set-sensitive #f) 778 (undo-set-sensitive #t)) 779 (if (null? FUTURE) 780 (redo-set-sensitive #f) 781 (redo-set-sensitive #t))))) 782 783(define-public (return-cards card-positions slot-id) 784 (and (not (= 0 (length card-positions))) 785 (set-cards! slot-id (car card-positions)) 786 (return-cards (cdr card-positions) (+ 1 slot-id)))) 787 788(define-public (eval-move move) 789 (return-cards (caddr move) 0) 790 ((car move) (cadr move))) 791 792; called from C: 793(define-public (undo) 794 (and (not (null? HISTORY)) 795 (record-move -1 '()) 796 (eval-move (car HISTORY)) 797 (set! FUTURE (cons MOVE FUTURE)) 798 (set! HISTORY (cdr HISTORY)) 799 (set! MOVE '()) 800 (redo-set-sensitive #t) 801 (if (null? HISTORY) 802 (undo-set-sensitive #f)))) 803 804; called from C: 805(define-public (redo) 806 (and (not (null? FUTURE)) 807 (record-move -1 '()) 808 (eval-move (car FUTURE)) 809 (set! HISTORY (cons MOVE HISTORY)) 810 (set! FUTURE (cdr FUTURE)) 811 (set! MOVE '()) 812 (undo-set-sensitive #t) 813 (if (null? FUTURE) 814 (redo-set-sensitive #f)))) 815 816(define-public (undo-func data) 817 (set-score! (car data)) 818 (set! FLIP-COUNTER (cadr data)) 819 (set-statusbar-message (caddr data)) 820 (restore-variables variable-list (cadddr data))) 821;(register-undo-function undo-func '(score FLIP-COUNTER)) 822 823(define-public (snapshot-board slot-id moving-slot old-cards) 824 (cond ((>= slot-id SLOTS) 825 '()) 826 ((= slot-id moving-slot) 827 (cons old-cards 828 (snapshot-board (+ 1 slot-id) moving-slot old-cards))) 829 (#t 830 (cons (get-cards slot-id) 831 (snapshot-board (+ 1 slot-id) moving-slot old-cards))))) 832 833; called from C: 834(define-public (record-move slot-id old-cards) 835 (set! MOVE (list undo-func 836 (list (get-score) FLIP-COUNTER 837 STATUSBAR-MESSAGE 838 (save-variables variable-list)) 839 (snapshot-board 0 slot-id old-cards)))) 840 841; called from C: 842(define-public (discard-move) 843 (set! MOVE '())) 844 845;; Routines for saving/restoring generic variables 846 847; Get a list of values for the variables we wish to save. 848(define-public save-variables 849 (lambda (names) 850 (if (equal? '() names) 851 '() 852 (cons (eval (list 'copy-tree (car names)) (current-module)) 853 (save-variables (cdr names)))))) 854 855; Restore all the state variables for a game 856(define-public restore-variables 857 (lambda (names values) 858 (or (equal? '() names) 859 (begin 860 (eval (list 'set! (car names) (list 'quote (car values))) (current-module)) 861 (restore-variables (cdr names) (cdr values)) 862 )))) 863