1;;; freecell.scm -- Free Cell game for AisleRiot. 2 3;; Copyright (C) 1998, 2003 Changwoo Ryu 4 5;; Author: Changwoo Ryu <cwryu@adam.kaist.ac.kr> 6 7; This program is free software: you can redistribute it and/or modify 8; it under the terms of the GNU General Public License as published by 9; the Free Software Foundation, either version 3 of the License, or 10; (at your option) any later version. 11; 12; This program is distributed in the hope that it will be useful, 13; but WITHOUT ANY WARRANTY; without even the implied warranty of 14; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15; GNU General Public License for more details. 16; 17; You should have received a copy of the GNU General Public License 18; along with this program. If not, see <http://www.gnu.org/licenses/>. 19 20(use-modules (aisleriot interface) (aisleriot api) (ice-9 format)) 21 22;;; Commentary: 23 24;; FREECELL 25;; 26;; * The 4 slots in the left-top are called "freecells". (F? in the below) 27;; * The 4 slots in the right-top are called "homecells". (H? in the below) 28;; * The 8 slots in the bottom are called "fields". (D? in the below) 29;; 30;; ------------------------------------------- 31;; | | 32;; |(0) (1) (2) (3) (4) (5) (6) (7) | 33;; | F1 F2 F3 F4 H1 H2 H3 H4 | 34;; | | 35;; | | 36;; | (8) (9) (10) (11) (12) (13) (14) (15) | 37;; | D1 D2 D3 D4 D5 D6 D7 D8 | 38;; | | 39;; ------------------------------------------- 40 41;;; Code: 42 43;; 44;; Constants 45;; 46(define freecell-1 0) 47(define freecell-2 1) 48(define freecell-3 2) 49(define freecell-4 3) 50(define homecell-1 4) 51(define homecell-2 5) 52(define homecell-3 6) 53(define homecell-4 7) 54(define field-1 8) 55(define field-2 9) 56(define field-3 10) 57(define field-4 11) 58(define field-5 12) 59(define field-6 13) 60(define field-7 14) 61(define field-8 15) 62 63(define freecells (list freecell-1 freecell-2 freecell-3 freecell-4)) 64(define homecells (list homecell-1 homecell-2 homecell-3 homecell-4)) 65(define fields (list field-1 field-2 field-3 field-4 66 field-5 field-6 field-7 field-8)) 67(define half-fields (list field-1 field-2 field-3 field-4)) 68 69;; 70;; Initial cards 71;; 72(define (deal-initial-setup) 73 (let ((fields (list field-1 field-2 field-3 field-4 74 field-5 field-6 field-7 field-8)) 75 (half-fields (list field-1 field-2 field-3 field-4))) 76 (deal-cards-face-up-from-deck DECK 77 (append fields fields fields 78 fields fields fields 79 half-fields)))) 80 81;; 82;; Utilities 83;; 84 85(define (freecell? slot) 86 (and (>= slot freecell-1) (<= slot freecell-4))) 87 88(define (homecell? slot) 89 (and (>= slot homecell-1) (<= slot homecell-4))) 90 91(define (field? slot) 92 (and (>= slot field-1) (<= slot field-8))) 93 94(define (slot-type slot) 95 (cond ((freecell? slot) 'freecell) 96 ((homecell? slot) 'homecell) 97 ((field? slot) 'field))) 98 99(define (opposite-color color) 100 (if (eq? color red) black red)) 101 102 103;; 104;; Utilities for the homecells 105;; 106 107;; homecell id which holds the suit or an empty slot if there is no slot. 108(define (homecell-by-suit suit) 109 (define (p? slot) 110 (and (not (empty-slot? slot)) 111 (= (get-suit (get-top-card slot)) suit))) 112 (cond ((p? homecell-1) homecell-1) 113 ((p? homecell-2) homecell-2) 114 ((p? homecell-3) homecell-3) 115 ((p? homecell-4) homecell-4) 116 (#t (any-empty-homecell)))) 117 118;; An empty homecell's id, if any 119(define (any-empty-homecell) 120 (cond ((empty-slot? homecell-1) homecell-1) 121 ((empty-slot? homecell-2) homecell-2) 122 ((empty-slot? homecell-3) homecell-3) 123 ((empty-slot? homecell-4) homecell-4) 124 (else #f))) 125 126(define (homecell-join? prev next) 127 (and (eq? (get-suit prev) (get-suit next)) 128 (eq? (+ (get-value prev) 1) (get-value next)))) 129 130(define (get-color-homecells color) 131 (define (iter n l) 132 (if (< n homecell-1) 133 l 134 (if (eq? (get-top-card n) color) 135 (iter (- n 1) (cons n l)) 136 (iter (- n 1) l)))) 137 (iter homecell-4 '())) 138 139;; 140;; Utilities for freecells 141;; 142 143;; The total number of empty freecells 144(define (empty-freecell-number) 145 (do ((i freecell-1 (+ i 1)) 146 (sum 0 (+ sum (if (empty-slot? i) 1 0)))) 147 ((> i freecell-4) sum))) 148 149;; An empty freecell's id, if any 150(define (any-empty-freecell) 151 (cond ((empty-slot? freecell-1) freecell-1) 152 ((empty-slot? freecell-2) freecell-2) 153 ((empty-slot? freecell-3) freecell-3) 154 ((empty-slot? freecell-4) freecell-4) 155 (else #f))) 156 157;; 158;; Utilities for fields 159;; 160 161(define (field-join? lower upper) 162 (and (not (eq? (get-color lower) (get-color upper))) 163 (eq? (+ (get-value lower) 1) (get-value upper)))) 164 165(define (field-sequence? card-list) 166 (or (null? card-list) 167 (null? (cdr card-list)) 168 (and (field-join? (car card-list) (cadr card-list)) 169 (field-sequence? (cdr card-list))))) 170 171(define (empty-field-number) 172 (do ((i field-1 (+ i 1)) 173 (sum 0 (+ sum (if (empty-slot? i) 1 0)))) 174 ((> i field-8) sum))) 175 176;; 177;; How to move cards 178;; 179 180(define (movable-to-homecell? card-list homecell-id) 181 (and (= (length card-list) 1) 182 (if (empty-slot? homecell-id) 183 (eq? (get-value (car card-list)) ace) 184 (homecell-join? (car (get-cards homecell-id)) (car card-list))))) 185 186(define (move-to-homecell card-list homecell-id) 187 (and 188 (= (length card-list) 1) 189 (move-card-to-homecell (car card-list) homecell-id) 190 ) 191) 192 193(define (move-card-to-homecell card homecell-id) 194 (cond 195 ; if the homecell is empty, we can add an ace to it. 196 ((and 197 (empty-slot? homecell-id) 198 (eq? (get-value card) ace) 199 (add-to-score! 1) 200 (add-card! homecell-id card) 201 (update-auto (get-suit card) (get-value card))) 202 #t) 203 ; Put a +1 card into the homecell, whose suit is same. 204 ((and 205 (not (empty-slot? homecell-id)) 206 (homecell-join? (car (get-cards homecell-id)) card) 207 (add-to-score! 1) 208 (add-card! homecell-id card) 209 (update-auto (get-suit card) (get-value card))) 210 #t) 211 (#t #f) 212 ) 213) 214 215;; Version of move-to-field that only tests a move or supermove. 216(define (movable-to-field? start-slot card-list field-id) 217 (and (field-sequence? card-list) 218 (<= (length card-list) 219 (* (+ (empty-freecell-number) 1) 220 (expt 2 (max (- (empty-field-number) 221 (if (empty-slot? field-id) 1 0) 222 (if (empty-slot? start-slot) 1 0)) 223 0)))) 224 (or (empty-slot? field-id) 225 (let ((dest-top (car (get-cards field-id)))) 226 (and (field-sequence? (append card-list (list dest-top)))))))) 227 228 229(define (move-to-field start-slot card-list field-id) 230 (and (movable-to-field? start-slot card-list field-id) 231 (add-cards! field-id card-list))) 232 233(define (movable-to-freecell? card-list freecell-id) 234 (and (= (length card-list) 1) 235 (empty-slot? freecell-id))) 236 237(define (move-to-freecell card-list freecell-id) 238 (and 239 (= (length card-list) 1) 240 (move-card-to-freecell (car card-list) freecell-id) 241 ) 242) 243 244(define (move-card-to-freecell card freecell-id) 245 (and 246 (not (boolean? freecell-id)) 247 (empty-slot? freecell-id) 248 (add-card! freecell-id card) 249 ) 250) 251 252;; 253;; Auto move stuffs 254;; 255 256(def-save-var highest-club 0) 257(def-save-var highest-diamond 0) 258(def-save-var highest-heart 0) 259(def-save-var highest-spade 0) 260 261(define (update-auto suit value) 262 (cond 263 ((eq? suit club) (set! highest-club value)) 264 ((eq? suit diamond) (set! highest-diamond value)) 265 ((eq? suit heart) (set! highest-heart value)) 266 ((eq? suit spade) (set! highest-spade value)) 267 ) 268) 269 270(define (max-auto-red) 271 (min 272 (+ 2 (min highest-club highest-spade)) 273 (+ 3 (min highest-diamond highest-heart)) 274 ) 275) 276 277(define (max-auto-black) 278 (min 279 (+ 2 (min highest-diamond highest-heart)) 280 (+ 3 (min highest-club highest-spade)) 281 ) 282) 283 284(define (move-low-cards slot) 285 (or 286 (and 287 (not (homecell? slot)) 288 (not (empty-slot? slot)) 289 (let ((card (get-top-card slot))) 290 (if (= (get-color card) red) 291 (and 292 (<= (get-value card) (max-auto-red)) 293 (move-card-to-homecell card (homecell-by-suit (get-suit card))) 294 (remove-card slot) 295 (delayed-call ((lambda (x) (lambda () (move-low-cards x))) 0)) 296 ) 297 (and 298 (<= (get-value card) (max-auto-black)) 299 (move-card-to-homecell card (homecell-by-suit (get-suit card))) 300 (remove-card slot) 301 (delayed-call ((lambda (x) (lambda () (move-low-cards x))) 0)) 302 ; (move-low-cards 0) 303 ) 304 ) 305 ) 306 ) 307 (if (< slot field-8) 308 (move-low-cards (+ 1 slot)) 309 #t 310 ) 311 ) 312 ) 313 314;; 315;; Callbacks & Initialize the game 316;; 317 318;; Set up a new game. 319(define (new-game) 320 (initialize-playing-area) 321 (set-ace-low) 322 (make-standard-deck) 323 (shuffle-deck) 324 325 ;; set up the board 326 327 ; freecells 328 (add-normal-slot '() 'reserve) ; 0 329 (set! HORIZPOS (- HORIZPOS (/ 1 24))) 330 (add-normal-slot '() 'reserve) ; 1 331 (set! HORIZPOS (- HORIZPOS (/ 1 24))) 332 (add-normal-slot '() 'reserve) ; 2 333 (set! HORIZPOS (- HORIZPOS (/ 1 24))) 334 (add-normal-slot '() 'reserve) ; 3 335 (set! HORIZPOS (+ HORIZPOS 0.25)) 336 337 ; homecells 338 (add-normal-slot '() 'foundation) ; 4 339 (set! HORIZPOS (- HORIZPOS (/ 1 24))) 340 (add-normal-slot '() 'foundation) ; 5 341 (set! HORIZPOS (- HORIZPOS (/ 1 24))) 342 (add-normal-slot '() 'foundation) ; 6 343 (set! HORIZPOS (- HORIZPOS (/ 1 24))) 344 (add-normal-slot '() 'foundation) ; 7 345 (add-carriage-return-slot) 346 347 ; fields 348 (add-extended-slot '() down 'tableau) ; 8 349 (add-extended-slot '() down 'tableau) ; 9 350 (add-extended-slot '() down 'tableau) ; 10 351 (add-extended-slot '() down 'tableau) ; 11 352 (add-extended-slot '() down 'tableau) ; 12 353 (add-extended-slot '() down 'tableau) ; 13 354 (add-extended-slot '() down 'tableau) ; 14 355 (add-extended-slot '() down 'tableau) ; 15 356 357 (add-blank-slot) 358 (deal-initial-setup) 359 (update-auto club 0) 360 (update-auto diamond 0) 361 (update-auto heart 0) 362 (update-auto spade 0) 363 364 (set! board-hash (make-hash-table hash-size)) 365 366 367 (list 8 3.5) 368) 369 370(define (button-pressed slot card-list) 371 (cond ((homecell? slot) #f) 372 ((field? slot) (field-sequence? card-list)) 373 ((freecell? slot) #t))) 374 375(define (droppable? start-slot card-list end-slot) 376 (and (not (= start-slot end-slot)) 377 (cond 378 ((homecell? end-slot) (movable-to-homecell? card-list end-slot)) 379 ((field? end-slot) (movable-to-field? start-slot card-list end-slot)) 380 ((freecell? end-slot) (movable-to-freecell? card-list end-slot)) 381 (else #f)))) 382 383(define (button-released start-slot card-list end-slot) 384 (and 385 (not (= start-slot end-slot)) 386 (cond 387 ((homecell? end-slot) (move-to-homecell card-list end-slot)) 388 ((field? end-slot) (move-to-field start-slot card-list end-slot)) 389 ((freecell? end-slot) (move-to-freecell card-list end-slot)) 390 ) 391 (move-low-cards 0) 392 ) 393) 394 395(define (button-clicked slot) 396 ; (FIXME) 397 #f) 398 399(define (button-double-clicked slot) 400 (and 401 (not (empty-slot? slot)) 402 (let ((card (get-top-card slot))) 403 (and 404 (move-card-to-freecell card (any-empty-freecell)) 405 (remove-card slot) 406 (move-low-cards 0) 407 ) 408 ) 409 ) 410) 411 412;; Condition for fail -- no more cards to move 413(define (game-over) 414 ; (FIXME) 415 (not (game-won))) 416 417;; Condition for win -- all the cards in homecells 418(define (game-won) 419 (and (= 13 (length (get-cards homecell-1))) 420 (= 13 (length (get-cards homecell-2))) 421 (= 13 (length (get-cards homecell-3))) 422 (= 13 (length (get-cards homecell-4))))) 423 424(define (get-options) 425 #f) 426 427(define (apply-options options) 428 #f) 429 430(define (timeout) 431 ; (FIXME) 432 #f) 433 434;------------------------------------------------------------------------------ 435; Additions for hint feature 436; 437; Written by Matthew V. Ball <mball@siliconashes.net> 438; 439; The rest of this file is devoted to implementing an intelligent hint 440; feature. The general search algorithm creates a tree, with each unique 441; board position representing a node. These nodes are stored in a hash 442; table so that the search does not repeat the work for a particular 443; board position. Furthermore, the move function sorts the cards within 444; a given board so that different card orders are still treated as the 445; same board. 446; 447; Each searched board is given a qualitative value based first 448; on "Mobility", then "Weight", then "Depth". Here is a brief definition of 449; these terms: 450; 451; Mobility - The maximum number of cards possible to move from one tableau 452; to another. This equals (1 + (# of freecells)) * 2^(# of open tableaus)) 453; Weight - The number of cards in play that are not part of a sequence. 454; For example, placing a 5 on a 6 reduces the board weight by 1, unless the 455; 5 was already on a different 6. 456; Depth - The number of moves between the current node and the best node. 457; 458; In particular, the algorithm maximizes Mobility up until mobility-thresh, 459; after which point additional mobility is not considered. Both Weight and 460; Depth are minimized. By minimizing Depth, the algorithm will tend to 461; optimize for the shortest path, eliminating unnecessary moves. This 462; becomes especially important when determining which of two winning moves 463; to make (there are generally two winning moves: the last move made, if 464; it is reversible, and the winning move that approaches the final solution). 465; 466; This algorithm will eventually find a solution, or determine that a 467; solution is not possible. However, in the interest of not searching for 468; too long, the search algorithm will stop searching after a specified number 469; of nodes, then return the best move found so far. If the user presses 470; help multiple times, then the search algorithm starts again where it left 471; off and finds a better move. If the search algorithm ever does find a 472; solution, it will remember the entire solution in the hash table so that 473; the hint feature can immediately return the next move when asked to do so. 474; 475; Here are definitions for some generic data structures used in this 476; algorithm: 477; 478; Board vector - The board positions are stored in vectors (for no particular 479; reason -- I wanted to experiment with different data types). 480; 481; index description 482; ----- ----------- 483; 0-3 Freecell cards - Card list containing card, or '() if empty 484; 4-7 Homecells - integer with highest card on homecell for each suit. 485; 8-15 Field cards - Card list containing cards on each tableau. 486; 487; Board Attributes - This is a vector containg some working information 488; about an associated board. 489; 490; index description 491; ----- ----------- 492; 0 Board mobility (size of largest group that can move to a field) (scalar) 493; 1 Board weight (Number of groups in fields and freecells) (scalar) 494; 2 Board outcome (win = 1, lose = 0, unknown = #f) 495; 3 Depth to best board outcome 496; 4 Inuse: Is this board currently being looked at? (#t or #f) 497; 5 Best known value of sub-tree 498; 6 List of possible moves, sorted from best to worst (#f if not generated) 499; Move definition: ((next-board . next-attributes) 500; start-slot card card-count end-slot) 501; 502; The hash table stores associated pairs of the board vector and board 503; attributes. This is often described as (board . info) in the following text. 504 505;;----------------------------------------------------------------------------- 506;; Constants 507 508; Set debug to #t for verbose output 509(define debug #f) 510 511; These constants refer to indices within a board attributes vector 512(define index-mobility 0) 513(define index-weight 1) 514(define index-outcome 2) 515(define index-depth 3) 516(define index-inuse 4) 517(define index-value 5) 518(define index-moves 6) 519 520; These constants are the possible values for a board outcome 521(define outcome-win 1) 522(define outcome-lose 0) 523(define outcome-unknown #f) 524 525; This is the highest mobility for which the algorithm strives. 526; Any mobility larger than the threshhold is disregarded. 527; 6 represents an open tableau and two cards in the reserve slots 528; (generally, if the algorithm can create an open tableau, the game 529; can be solved) 530(define mobility-thresh 6) 531 532; These constants indicate which board vector indices represent the state 533; of the homecells. 534(define board-foundation 4) 535(define board-club (+ board-foundation club)) 536(define board-diamond (+ board-foundation diamond)) 537(define board-heart (+ board-foundation heart)) 538(define board-spade (+ board-foundation spade)) 539 540; These constants affect the hash table and search algorithm 541(define hash-size (- (expt 2 17) 1)) ; A Mersenne prime (2^17 - 1) ~128k 542(define board-node-max 50) ; number of board positions to visit each time. 543(define traverse-node-max 1000) ; prevents stack overflow 544 545; These constants define values used in constructing the board value. 546(define weight-factor 100) ; effect of weight on final score 547(define mobility-factor (* 100 weight-factor)) ; effect of mobility 548(define max-move-value (* 1280 mobility-factor)) ; solution found 549(define min-move-value (- 0 max-move-value)) ; no solution found 550 551; value-bias is the amount to bias the previously best move value when 552; searching sub-trees. A more negative number tends to favor a depth-first 553; search instead of a breadth-first search. 554(define value-bias -50) 555 556;;----------------------------------------------------------------------------- 557;; Global variables 558 559; This is a hash table that holds information about the board 560; positions analyzed by the search function. 561(define board-hash #()) ; This variable is initialized in new-game 562(define visited-nodes 0) ; Number of board positions created for this search. 563(define traversed-nodes 0) ; Number of board positions traversed through 564 565 566;;----------------------------------------------------------------------------- 567;; Functions 568 569; Returns the best move found by the search algorithm 570(define (get-hint) 571 (if debug (display "get-hint\n")) 572 (set! visited-nodes 0) 573 (set! traversed-nodes 0) 574 (let* ((board (copy-master-board)) 575 (info (get-board-info board))) 576 (analyze-board board info 0) 577 (let* ((moves (vector-ref info index-moves))) 578 (if debug 579 (begin 580 (display "visited nodes: ") (display visited-nodes) (newline) 581 (display "traversed nodes: ") (display traversed-nodes) (newline) 582 (display (list-head (vector->list info) 6)) 583 (newline) 584 (display-moves board moves) 585 (newline) 586 (display-best-move-trace board moves))) 587 (create-help-list board moves)))) 588 589; Displays the sequence of best moves found so far by the search. (Debug only) 590; Note that the best sequence is occasionally not available depending on 591; how the hint function terminates the search. In these cases, this function 592; displays "Non-decreasing" and shows the available moves at the point 593; it got confused. 594; move format: ((board . info) start-slot card card-count end-slot) 595(define (display-best-move-trace board moves) 596 (if (not (or (null? moves) 597 (eq? moves #f))) 598 (let* ((best-move (car moves)) 599 (next-moves (vector-ref (cdar best-move) index-moves))) 600 (display-moves board (list best-move)) 601 (if (not (or (null? next-moves) (eq? next-moves #f))) 602 (if (> (vector-ref (cdar best-move) index-depth) 603 (vector-ref (cdaar next-moves) index-depth)) 604 (display-best-move-trace (caar best-move) next-moves) 605 (begin 606 (display "Non Decreasing:\n") 607 (display-moves board moves) 608 (display "Trace of best-move:\n") 609 (display-moves (caar best-move) next-moves))))))) 610 611; Displays a list of moves, relative to a given board position (debug only) 612; move format: ((board . info) start-slot card card-count end-slot) 613(define (display-moves board moves) 614 (if (not (null? moves)) 615 (begin 616 (display (list-head (vector->list (cdaar moves)) 6)) 617 (display (create-help-list board moves)) 618 (newline) 619 (display-moves board (cdr moves))))) 620 621; Creates the move description returned by get-hint. 622; move format: ((board . info) start-slot card card-count end-slot) 623(define (create-help-list board moves) 624 (if (null? moves) 625 (list 0 (_"No moves are possible. Undo or start again.")) 626 (let* ((best-move (car moves)) 627 (from-card (caddr best-move)) 628 (to-slot (list-ref best-move 4)) 629 (to-stack (vector-ref board to-slot))) 630 (if (eq? (vector-ref (cdar best-move) index-outcome) outcome-lose) 631 (list 0 (_"The game has no solution. Undo or start again.")) 632 (hint-move (find-card-slot from-card) (find-card (find-card-slot from-card) from-card) 633 (cond ((freecell? to-slot) (find-empty-slot freecells)) 634 ((homecell? to-slot) 635 (if (equal? 0 to-stack) 636 (find-empty-slot homecells) 637 (find-card-slot (list to-stack (get-suit from-card) #t)))) 638 ((null? to-stack) (find-empty-slot fields)) 639 (else (find-card-slot (car to-stack))))))))) 640 641; Returns a vector copy of the master board for use as the initial 642; node in the search. 643(define (copy-master-board) 644 (let ((freecell-cards (map get-cards freecells)) 645 (homecell-cards (list highest-club 646 highest-diamond 647 highest-heart 648 highest-spade)) 649 (field-cards (map get-cards fields))) 650 (list->vector (append 651 (sort freecell-cards compare-cards) 652 homecell-cards 653 (sort field-cards compare-cards))))) 654 655; Recursively analyzes board positions. This function is the heart of 656; the search algorithm. It will continue to search sub-nodes as long as 657; each newly searched board has a value that is greater than prev-best. 658; Otherwise, this function saves the value of the best board position found 659; in this sub-tree, and returns to the caller 660; 661; Parameters: 662; board - vector containing board position to analyze 663; info - vector describing board (board attributes) 664; prev-best - best board value seen in nodes above this node. 665(define (analyze-board board info prev-best) 666 ; increment the number of traversed nodes so that we can estimate the 667 ; stack depth and ensure it doesn't get too deep. 668 (set! traversed-nodes (+ 1 traversed-nodes)) 669 670 ; Check wether we have already generated moves for this board position. 671 ; If not generate the moves now. 672 (if (eq? (vector-ref info index-moves) #f) 673 (vector-set! info index-moves (get-board-moves board))) 674 (vector-set! info index-inuse (+ 1 (vector-ref info index-inuse))) 675 676 ; set this node to outcome-lose so that we don't revisit the same node. 677 ; This also becomes the default value if we return early 678 (vector-set! info index-value min-move-value) 679 (vector-set! info index-outcome outcome-lose) 680 681 ; Sort the moves from best to worst based on value 682 (let ((moves (sort (vector-ref info index-moves) move-compare))) 683 (vector-set! info index-moves moves) 684 685 ; Check whether there are any moves that don't lose. (If not, exit 686 ; with loss) 687 (if (and (not (null? moves)) 688 (not (eq? (vector-ref (cdaar moves) index-outcome) outcome-lose))) 689 690 ; Determine whether to traverse deeper, or to go back up the tree 691 (if (and (eq? (vector-ref (cdaar moves) index-outcome) #f) 692 (< visited-nodes board-node-max) 693 (< traversed-nodes traverse-node-max) 694 (>= (vector-ref (cdaar moves) index-value) prev-best)) 695 (begin 696 ; Traverse into the best available move 697 (analyze-board 698 (caaar moves) 699 (cdaar moves) 700 (if (null? (cdr moves)) 701 prev-best 702 (max prev-best (+ value-bias 703 (vector-ref (cdaadr moves) index-value))))) 704 ; Repeat analysis of this node in case another move beats the 705 ; current best 706 (analyze-board board info prev-best)) 707 708 ; Copy the best outcome and move to previous node 709 (copy-outcome-info! info (cdaar moves))) 710 ; else leave outcome set to 'outcome-lose' and go up to previous node 711 )) 712 (vector-set! info index-inuse (+ -1 (vector-ref info index-inuse)))) 713 714; copies the inportant board information from source to dest 715(define (copy-outcome-info! dest source) 716 (vector-set! dest index-outcome (vector-ref source index-outcome)) 717 (vector-set! dest index-value (+ -1 (vector-ref source index-value))) 718 (vector-set! dest index-depth (+ 1 (vector-ref source index-depth)))) 719 720; Sort compare function -- compares two moves (see also get-move-value) 721; Rules: 722; if a position is a winner, move it to the front. 723; else if a position is a loser, move it to the back. 724; else if the mobility of both positions is above a threshold, then 725; compare positions only using board weight 726; else compare using mobility first, then use board weight for a tie, 727; then use depth as a further tie-breaker. 728; 729; returns #t if left move is better than right move 730; returns #f if both positions are equal or right move is better 731; input format: ((board . info) start-slot card card-count end-slot) 732(define (move-compare left right) 733 (> (vector-ref (cdar left) index-value) 734 (vector-ref (cdar right) index-value))) 735 736; Returns a list of possible board moves 737(define (get-board-moves board) 738 (get-board-moves-from-slots 739 board (append fields freecells))) 740 741; Returns a list of board moves from a given list of slots 742(define (get-board-moves-from-slots board slots) 743 (if (null? slots) 744 '() 745 (append (get-board-moves-from-cards 746 board 747 (car slots) 748 1 749 (vector-ref board (car slots))) 750 (get-board-moves-from-slots board (cdr slots))))) 751 752; Returns a list of board moves from a given slot with a given height of cards 753(define (get-board-moves-from-cards board slot height cards) 754 (if (null? cards) 755 '() 756 (append (if (and (not (null? (cdr cards))) 757 (field-join? (car cards) (cadr cards))) 758 (get-board-moves-from-cards 759 board 760 slot 761 (+ height 1) 762 (cdr cards)) 763 '() ) 764 (get-moves-from-card-to-slots 765 board 766 slot 767 height 768 (car cards) 769 (append 770 (remove-redundant-open-slots board fields) 771 (get-leftmost-open-freecell board) 772 homecells))))) 773 774; returns a list containing the slot number for the left-most open freecell, 775; or '() if none are open 776(define (get-leftmost-open-freecell board) 777 (cond ((null? (vector-ref board freecell-1)) (list freecell-1)) 778 ((null? (vector-ref board freecell-2)) (list freecell-2)) 779 ((null? (vector-ref board freecell-3)) (list freecell-3)) 780 ((null? (vector-ref board freecell-4)) (list freecell-4)) 781 (else '()))) 782 783; Returns a list of field slot numbers with redundant open slots removed 784(define (remove-redundant-open-slots board slots) 785 (if (null? slots) 786 '() 787 (if (null? (vector-ref board (car slots))) 788 (cons (car slots) (remove-all-open-fields board (cdr slots))) 789 (cons (car slots) (remove-redundant-open-slots board (cdr slots)))))) 790 791; Returns a list of fields slot number with all open slots removed 792(define (remove-all-open-fields board slots) 793 (if (null? slots) 794 '() 795 (if (null? (vector-ref board (car slots))) 796 (remove-all-open-fields board (cdr slots)) 797 (cons (car slots) (remove-all-open-fields board (cdr slots)))))) 798 799; determines the possible moves from a given card (at a particular source-slot 800; and with a given height) to a set of destination slots. 801(define (get-moves-from-card-to-slots board source-slot height card slots) 802 (if (null? slots) 803 '() 804 (append 805 (let* ((dest-slot (car slots)) 806 (dest-cards (vector-ref board dest-slot))) 807 (if (or (and (homecell? dest-slot) 808 (= height 1) 809 (= (get-suit card) (- dest-slot homecell-1)) 810 (= (get-value card) (+ dest-cards 1))) 811 (and (freecell? dest-slot) 812 (not (freecell? source-slot)) 813 (= height 1) 814 (null? dest-cards)) 815 (and (field? dest-slot) 816 (or (and (null? dest-cards) 817 (or (freecell? source-slot) 818 (not 819 (= height 820 (length 821 (vector-ref board source-slot)))))) 822 (and (not (null? dest-cards)) 823 (field-join? card (car dest-cards)))) 824 (or (= height 1) 825 (<= height 826 (get-board-mobility 827 board 828 (if (null? dest-cards) 1 0)))))) 829 (let* ((move-cdr (list source-slot card height (car slots))) 830 (move (cons (get-board-info-pair 831 (perform-move board move-cdr)) 832 move-cdr))) 833 (if (= (vector-ref (cdar move) index-value) 0) 834 (vector-set! 835 (cdar move) index-value 836 (quotient 837 (get-move-value move) 838 (let ((source-cards (list-tail (vector-ref board source-slot) 839 height))) 840 (if (and (not (null? source-cards)) 841 (not (freecell? (cadr move))) 842 (field-join? 843 (caddr move) 844 (car source-cards))) 845 2 846 1))))) 847 (list move)) 848 '() )) 849 (get-moves-from-card-to-slots 850 board 851 source-slot 852 height 853 card 854 (cdr slots))))) 855 856; returns a new board with a given move applied and small cards moved up 857; board - a board vector 858; move - list in the form (source-slot card card-count dest-slot) 859; (This is more precisely a move-cdr) 860(define (perform-move board move) 861 (set! visited-nodes (+ 1 visited-nodes)) 862 (let ((new-board (list->vector (vector->list board))) 863 (source-stack (vector-ref board (car move))) 864 (dest-stack (vector-ref board (cadddr move)))) 865 (vector-set! new-board (cadddr move) 866 (if (homecell? (cadddr move)) 867 (get-value (car source-stack)) 868 (append (list-head source-stack (caddr move)) 869 dest-stack))) 870 (vector-set! new-board (car move) (list-tail source-stack (caddr move))) 871 (move-board-low-cards new-board 0) 872 (let* ((temp-board (vector->list new-board)) 873 (freecell-cards (list-head temp-board 4)) 874 (homecell-cards (list-head (list-tail temp-board 4) 4)) 875 (field-cards (list-tail temp-board 8))) 876 (set! new-board 877 (list->vector (append (sort freecell-cards compare-cards) 878 homecell-cards 879 (sort field-cards compare-cards))))) 880 new-board)) 881 882; Compares two card stacks and returns #t if the top card from 883; card1 is larger than that of card2. 884(define (compare-cards card1 card2) 885 (> (card-value card1) (card-value card2))) 886 887; Returns 0 if there is no card, or between 1 and 52 for the absolute 888; rank of the top card in a stack. This equates to 4*rank+suit, where 889; the suit order is club=0, diamond=1, heart=2, and spade=3. 890; format of card: ((rank suit visible) ...) or '() 891(define (card-value card) 892 (if (null? card) 893 0 894 (+ (* 4 (caar card)) (cadar card)))) 895 896; This function is more or less a copy of move-low-cards, except it 897; operates on a local board instead of a global board. 898(define (move-board-low-cards board slot) 899 (and (not (homecell? slot)) 900 (not (null? (vector-ref board slot))) 901 (let* ((card (car (vector-ref board slot))) 902 (homecell-slot (+ board-foundation (get-suit card))) 903 (homecell-value (vector-ref board homecell-slot))) 904 (if (and (= (get-value card) (+ 1 homecell-value)) 905 (or (and (= (get-color card) red) 906 (<= (get-value card) (max-board-auto-red board))) 907 (and (= (get-color card) black) 908 (<= (get-value card) (max-board-auto-black board))))) 909 (begin 910 (vector-set! board (+ board-foundation (get-suit card)) 911 (get-value card)) 912 (vector-set! board slot (cdr (vector-ref board slot))) 913 (move-board-low-cards board 0))))) 914 (or (>= slot field-8) 915 (move-board-low-cards board (+ 1 slot)))) 916 917; Copy of max-auto-red, except uses a local board. 918; Returns the maximum rank of the red homecells that is automatically moved. 919; This equates to the highest red suit rank that is not useful in play. In 920; other words, it is better to move the lower black suit cards to the 921; homecells instead of stacking them on top of a red suit card that is at or 922; below this rank. 923(define (max-board-auto-red board) 924 (min (+ 2 (min (vector-ref board board-club) 925 (vector-ref board board-spade))) 926 (+ 3 (min (vector-ref board board-diamond) 927 (vector-ref board board-heart))))) 928 929; see max-board-auto-red and exchange red for black 930(define (max-board-auto-black board) 931 (min (+ 2 (min (vector-ref board board-diamond) 932 (vector-ref board board-heart))) 933 (+ 3 (min (vector-ref board board-club) 934 (vector-ref board board-spade))))) 935 936; Returns the value of a move, based on the board information. 937; The resulting format generally looks like this: MWWDD, where 938; M is Mobility, WW is 100 - board weight, and DD is 100 - depth. 939; input format: ((board . info) start-slot card card-count end-slot) 940(define (get-move-value move) 941 (let ((info (cdar move)) 942 (board (caar move))) 943 (let ((mobility (vector-ref info index-mobility)) 944 (weight (vector-ref info index-weight)) 945 (outcome (vector-ref info index-outcome)) 946 (inuse (> (vector-ref info index-inuse) 0)) 947 (depth (vector-ref info index-depth))) 948 (cond (inuse min-move-value) 949 ((eq? outcome outcome-win) (- max-move-value depth)) 950 ((= weight 0) (- max-move-value depth)) 951 ((eq? outcome outcome-lose) min-move-value) 952 (else (+ (* mobility-factor (min mobility-thresh mobility)) 953 (- mobility-factor (* weight-factor weight)) 954 (- weight-factor depth))))))) 955 956; generates a board and info pair (board . pair) based on an input board 957(define (get-board-info-pair board) 958 (cons board (get-board-info board))) 959 960; Returns the information for a particular board position by looking 961; in hash table. If not entry found, creates a new entry in the hash 962; table with default information 963(define (get-board-info board) 964 (or (hash-ref board-hash board) 965 (let ((info (vector (get-board-mobility board 0) 966 (get-board-weight board) 967 outcome-unknown ; Outcome not known 968 1 ; each new board has a depth of 1 969 0 ; board is not yet being looked at 970 0 ; position has no value yet 971 #f))) ; no moves generated yet 972 ; Add new board to hash table 973 (hash-set! board-hash board info) 974 (if (= (vector-ref info index-weight) 0) 975 (vector-set! info index-outcome outcome-win)) 976 info))) 977 978; Determines a board's 'Weight' by determining the number of groups within 979; the tableaus and the freecells (reserves). A group is defined as a set 980; of consecutive cards that alternate color. 981(define (get-board-weight board) 982 (define (get-slot-list-weight slots) 983 (if (null? slots) 984 0 985 (+ (get-card-list-weight (vector-ref board (car slots))) 986 (get-slot-list-weight (cdr slots))))) 987 (get-slot-list-weight (append freecells fields))) 988 989; returns the 'weight' of a card list, which is the number of distinct runs 990(define (get-card-list-weight card-list) 991 (cond ((null? card-list) 0) 992 ((null? (cdr card-list)) 1) 993 (else (+ (get-card-list-weight (cdr card-list)) 994 (if (field-join? (car card-list) (cadr card-list)) 0 1))))) 995 996; Returns the board 'Mobility', which is defined as the largest run of cards 997; the user could move to another card. 998; Parameters: 999; board: board vector 1000; adjust: 0 - Compute mobility when moving a stack to another card 1001; 1 - Compute mobility when moving a stack to an open tableau 1002(define (get-board-mobility board adjust) 1003 (* (+ (get-board-free-count board freecells) 1) 1004 (expt 2 (- (get-board-free-count board fields) adjust)))) 1005 1006; returns the number of open cells available within a given set of cells 1007(define (get-board-free-count board cells) 1008 (if (null? cells) 1009 0 1010 (+ (get-board-free-count board (cdr cells)) 1011 (if (null? (vector-ref board (car cells))) 1 0)))) 1012 1013(set-features droppable-feature) 1014 1015(set-lambda new-game button-pressed button-released button-clicked button-double-clicked game-over game-won get-hint get-options apply-options timeout droppable?) 1016 1017;;; freecell.scm ends here 1018 1019 1020