freecell.scm 34.6 KB
Newer Older
1
;;; freecell.scm -- Free Cell game for AisleRiot.
2

3
;; Copyright (C) 1998, 2003 Changwoo Ryu
4

5 6
;; Author: Changwoo Ryu <cwryu@adam.kaist.ac.kr>

7 8 9 10 11 12 13 14 15 16 17 18
; This program is free software: you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation, either version 3 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
;
; You should have received a copy of the GNU General Public License
; along with this program.  If not, see <http://www.gnu.org/licenses/>.
19

20 21
(use-modules (aisleriot interface) (aisleriot api) (ice-9 format))

22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62
;;; Commentary:

;; FREECELL
;;
;; * The 4 slots in the left-top are called "freecells". (F? in the below)
;; * The 4 slots in the right-top are called "homecells". (H? in the below)
;; * The 8 slots in the bottom are called "fields". (D? in the below)
;;
;;  -------------------------------------------
;;  |                                         |
;;  |(0)  (1)  (2)  (3)    (4)  (5)  (6)  (7) |
;;  | F1   F2   F3   F4     H1   H2   H3   H4 |
;;  |                                         |
;;  |                                         |
;;  | (8)  (9)  (10) (11) (12) (13) (14) (15) |
;;  |  D1   D2   D3   D4   D5   D6   D7   D8  |
;;  |                                         |
;;  -------------------------------------------

;;; Code:

;;
;; Constants
;;
(define freecell-1 0)
(define freecell-2 1)
(define freecell-3 2)
(define freecell-4 3)
(define homecell-1 4)
(define homecell-2 5)
(define homecell-3 6)
(define homecell-4 7)
(define field-1    8)
(define field-2    9)
(define field-3    10)
(define field-4    11)
(define field-5    12)
(define field-6    13)
(define field-7    14)
(define field-8    15)

63 64 65 66 67 68
(define freecells (list freecell-1 freecell-2 freecell-3 freecell-4))
(define homecells (list homecell-1 homecell-2 homecell-3 homecell-4))
(define fields (list field-1 field-2 field-3 field-4
                     field-5 field-6 field-7 field-8))
(define half-fields (list field-1 field-2 field-3 field-4))

69 70 71 72 73 74 75 76 77 78 79
;;
;; Initial cards
;;
(define (deal-initial-setup)
  (let ((fields (list field-1 field-2 field-3 field-4
			       field-5 field-6 field-7 field-8))
	(half-fields (list field-1 field-2 field-3 field-4)))
    (deal-cards-face-up-from-deck DECK
				  (append fields fields fields
					  fields fields fields
					  half-fields))))
80

81 82 83
;;
;; Utilities
;;
84

85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
(define (freecell? slot)
  (and (>= slot freecell-1) (<= slot freecell-4)))

(define (homecell? slot)
  (and (>= slot homecell-1) (<= slot homecell-4)))

(define (field? slot)
  (and (>= slot field-1) (<= slot field-8)))

(define (slot-type slot)
  (cond ((freecell? slot) 'freecell)
	((homecell? slot) 'homecell)
	((field? slot) 'field)))

(define (opposite-color color)
  (if (eq? color red) black red))
      

;;
;; Utilities for the homecells
;;

107
;; homecell id which holds the suit or an empty slot if there is no slot.
108 109 110 111 112 113 114 115
(define (homecell-by-suit suit)
  (define (p? slot)
    (and (not (empty-slot? slot))
	 (= (get-suit (get-top-card slot)) suit)))
  (cond ((p? homecell-1) homecell-1)
	((p? homecell-2) homecell-2)
	((p? homecell-3) homecell-3)
	((p? homecell-4) homecell-4)
116
	(#t (any-empty-homecell))))
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170

;; An empty homecell's id, if any
(define (any-empty-homecell)
  (cond ((empty-slot? homecell-1) homecell-1)
	((empty-slot? homecell-2) homecell-2)
	((empty-slot? homecell-3) homecell-3)
	((empty-slot? homecell-4) homecell-4)
	(else #f)))

(define (homecell-join? prev next)
  (and (eq? (get-suit prev) (get-suit next))
       (eq? (+ (get-value prev) 1) (get-value next))))

(define (get-color-homecells color)
  (define (iter n l)
    (if (< n homecell-1)
	l
	(if (eq? (get-top-card n) color)
	    (iter (- n 1) (cons n l))
	    (iter (- n 1) l))))
  (iter homecell-4 '()))

;;
;; Utilities for freecells
;;

;; The total number of empty freecells
(define (empty-freecell-number)
  (do ((i freecell-1 (+ i 1))
       (sum 0 (+ sum (if (empty-slot? i) 1 0))))
      ((> i freecell-4) sum)))

;; An empty freecell's id, if any
(define (any-empty-freecell)
  (cond ((empty-slot? freecell-1) freecell-1)
	((empty-slot? freecell-2) freecell-2)
	((empty-slot? freecell-3) freecell-3)
	((empty-slot? freecell-4) freecell-4)
	(else #f)))

;;
;; Utilities for fields
;;

(define (field-join? lower upper)
  (and (not (eq? (get-color lower) (get-color upper)))
       (eq? (+ (get-value lower) 1) (get-value upper))))

(define (field-sequence? card-list)
  (or (null? card-list)
      (null? (cdr card-list))
      (and (field-join? (car card-list) (cadr card-list))
	   (field-sequence? (cdr card-list)))))

171 172 173 174 175
(define (empty-field-number)
  (do ((i field-1 (+ i 1))
       (sum 0 (+ sum (if (empty-slot? i) 1 0))))
      ((> i field-8) sum)))

176 177 178 179
;;
;; How to move cards
;;

180 181 182 183 184 185
(define (movable-to-homecell? card-list homecell-id)
  (and (= (length card-list) 1)
       (if (empty-slot? homecell-id)
           (eq? (get-value (car card-list)) ace)
           (homecell-join? (car (get-cards homecell-id)) (car card-list)))))

186
(define (move-to-homecell card-list homecell-id)
187 188 189 190 191
	(and
		(= (length card-list) 1)
		(move-card-to-homecell (car card-list) homecell-id)
	)
)
192 193

(define (move-card-to-homecell card homecell-id)
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212
	(cond
		; if the homecell is empty, we can add an ace to it.
		((and
			(empty-slot? homecell-id)
			(eq? (get-value card) ace)
			(add-to-score! 1)
			(add-card! homecell-id card)
			(update-auto (get-suit card) (get-value card)))
		#t)
		; Put a +1 card into the homecell, whose suit is same.
		((and
			(not (empty-slot? homecell-id))
			(homecell-join? (car (get-cards homecell-id)) card)
			(add-to-score! 1)
			(add-card! homecell-id card)
			(update-auto (get-suit card) (get-value card)))
		#t)
		(#t #f)
	)
213
)
214

215 216
;; Version of move-to-field that only tests a move or supermove.
(define (movable-to-field? start-slot card-list field-id)
217
  (and (field-sequence? card-list)
218 219
       (<= (length card-list)
           (* (+ (empty-freecell-number) 1)
220
              (expt 2 (max (- (empty-field-number)
221 222 223 224 225 226 227 228 229 230 231
                               (if (empty-slot? field-id) 1 0)
                               (if (empty-slot? start-slot) 1 0))
                            0))))
       (or (empty-slot? field-id)
           (let ((dest-top (car (get-cards field-id))))
             (and (field-sequence? (append card-list (list dest-top))))))))


(define (move-to-field start-slot card-list field-id)
  (and (movable-to-field? start-slot card-list field-id)
       (add-cards! field-id card-list)))
232

233 234 235 236
(define (movable-to-freecell? card-list freecell-id)
  (and (= (length card-list) 1)
       (empty-slot? freecell-id)))

237
(define (move-to-freecell card-list freecell-id)
238 239 240 241 242 243 244 245 246 247 248 249 250
	(and
		(= (length card-list) 1)
		(move-card-to-freecell (car card-list) freecell-id)
	)
)

(define (move-card-to-freecell card freecell-id)
	(and
		(not (boolean? freecell-id))
		(empty-slot? freecell-id)
		(add-card! freecell-id card)
	)
)
251 252 253 254 255

;;
;; Auto move stuffs
;;

256 257 258 259
(def-save-var highest-club 0)
(def-save-var highest-diamond 0)
(def-save-var highest-heart 0)
(def-save-var highest-spade 0)
260 261

(define (update-auto suit value)
262 263 264 265 266 267 268
	(cond
		((eq? suit club) (set! highest-club value))
		((eq? suit diamond) (set! highest-diamond value))
		((eq? suit heart) (set! highest-heart value))
		((eq? suit spade) (set! highest-spade value))
	)
)
269 270

(define (max-auto-red)
271 272 273 274 275
	(min
		(+ 2 (min highest-club highest-spade))
		(+ 3 (min highest-diamond highest-heart))
	)
)
276 277

(define (max-auto-black)
278 279 280 281 282
	(min
		(+ 2 (min highest-diamond highest-heart))
		(+ 3 (min highest-club highest-spade))
	)
)
283 284

(define (move-low-cards slot)
285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312
  (or
   (and
    (not (homecell? slot))
    (not (empty-slot? slot))
    (let ((card (get-top-card slot)))
      (if (= (get-color card) red)
	  (and
	   (<= (get-value card) (max-auto-red))
	   (move-card-to-homecell card (homecell-by-suit (get-suit card)))
	   (remove-card slot)
	   (delayed-call ((lambda (x) (lambda () (move-low-cards x))) 0))
	   )
	  (and
	   (<= (get-value card) (max-auto-black))
	   (move-card-to-homecell card (homecell-by-suit (get-suit card)))
	   (remove-card slot)
	   (delayed-call ((lambda (x) (lambda () (move-low-cards x))) 0))
					;	(move-low-cards 0)
	   )
	  )
      )
    )
   (if (< slot field-8)
       (move-low-cards (+ 1 slot))
       #t
       )
   )
  )
313 314 315 316

;;
;; Callbacks & Initialize the game
;;
317

318
;; Set up a new game.
319 320
(define (new-game)
  (initialize-playing-area)
Rosanna Yuen's avatar
Rosanna Yuen committed
321
  (set-ace-low)
322 323 324
  (make-standard-deck)
  (shuffle-deck)
  
325 326 327
  ;; set up the board

  ; 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 349 350 351 352 353 354 355
  (add-extended-slot '() down 'tableau)		; 8
  (add-extended-slot '() down 'tableau)		; 9
  (add-extended-slot '() down 'tableau)		; 10
  (add-extended-slot '() down 'tableau)		; 11
  (add-extended-slot '() down 'tableau)		; 12
  (add-extended-slot '() down 'tableau)		; 13
  (add-extended-slot '() down 'tableau)		; 14
  (add-extended-slot '() down 'tableau)		; 15
356

357
  (add-blank-slot)
358
  (deal-initial-setup)
359 360 361 362
  (update-auto club 0)
  (update-auto diamond 0)
  (update-auto heart 0)
  (update-auto spade 0)
363 364

  (set! board-hash (make-hash-table hash-size))
365
  
366

367
  (list 8 3.5)
368
)
369

370 371 372 373
(define (button-pressed slot card-list)
  (cond ((homecell?   slot) #f)
	((field?      slot) (field-sequence? card-list))
	((freecell?   slot) #t)))
374

375 376 377 378 379
(define (droppable? start-slot card-list end-slot)
        (and (not (= start-slot end-slot))
             (cond
               ((homecell? end-slot) (movable-to-homecell? card-list end-slot))
               ((field?    end-slot) (movable-to-field? start-slot card-list end-slot))
380
	       ((freecell? end-slot) (movable-to-freecell? card-list end-slot))
381 382
               (else #f))))

383
(define (button-released start-slot card-list end-slot)
384 385 386 387
	(and
		(not (= start-slot end-slot))
		(cond
			((homecell? end-slot) (move-to-homecell card-list end-slot))
388
			((field?    end-slot) (move-to-field    start-slot card-list end-slot))
389 390 391 392 393
			((freecell? end-slot) (move-to-freecell card-list end-slot))
		)
		(move-low-cards 0)
	)
)
394
  
395 396
(define (button-clicked slot)
  ; (FIXME)
397 398
  #f)

399
(define (button-double-clicked slot)
400 401 402 403
	(and
		(not (empty-slot? slot))
		(let ((card (get-top-card slot)))
			(and
404 405 406
			        (move-card-to-freecell card (any-empty-freecell))
			        (remove-card slot)
			        (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 420 421 422
  (and (= 13 (length (get-cards homecell-1)))
       (= 13 (length (get-cards homecell-2)))
       (= 13 (length (get-cards homecell-3)))
       (= 13 (length (get-cards homecell-4)))))
423

424
(define (get-options) 
425
  #f)
426

427
(define (apply-options options) 
428
  #f)
429

430 431 432
(define (timeout) 
  ; (FIXME)
  #f)
433

434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542
;------------------------------------------------------------------------------
; Additions for hint feature
;
; Written by Matthew V. Ball <mball@siliconashes.net>
;
; The rest of this file is devoted to implementing an intelligent hint
; feature.  The general search algorithm creates a tree, with each unique
; board position representing a node.  These nodes are stored in a hash
; table so that the search does not repeat the work for a particular
; board position.  Furthermore, the move function sorts the cards within
; a given board so that different card orders are still treated as the 
; same board.
;
; Each searched board is given a qualitative value based first
; on "Mobility", then "Weight", then "Depth".  Here is a brief definition of
; these terms:
;
; Mobility - The maximum number of cards possible to move from one tableau
;   to another.  This equals (1 + (# of freecells)) * 2^(# of open tableaus))
; Weight - The number of cards in play that are not part of a sequence.
;   For example, placing a 5 on a 6 reduces the board weight by 1, unless the
;   5 was already on a different 6.
; Depth - The number of moves between the current node and the best node.
;
; In particular, the algorithm maximizes Mobility up until mobility-thresh,
; after which point additional mobility is not considered.  Both Weight and
; Depth are minimized.  By minimizing Depth, the algorithm will tend to
; optimize for the shortest path, eliminating unnecessary moves.  This
; becomes especially important when determining which of two winning moves
; to make (there are generally two winning moves: the last move made, if
; it is reversible, and the winning move that approaches the final solution).
;
; This algorithm will eventually find a solution, or determine that a
; solution is not possible.  However, in the interest of not searching for
; too long, the search algorithm will stop searching after a specified number
; of nodes, then return the best move found so far.  If the user presses
; help multiple times, then the search algorithm starts again where it left
; off and finds a better move.  If the search algorithm ever does find a
; solution, it will remember the entire solution in the hash table so that
; the hint feature can immediately return the next move when asked to do so.
;
; Here are definitions for some generic data structures used in this
; algorithm:
;
; Board vector - The board positions are stored in vectors (for no particular
;   reason -- I wanted to experiment with different data types).
;
; index	description
; ----- -----------
; 0-3	Freecell cards - Card list containing card, or '() if empty
; 4-7	Homecells - integer with highest card on homecell for each suit.
; 8-15	Field cards - Card list containing cards on each tableau.
;
; Board Attributes - This is a vector containg some working information
;   about an associated board.
;
; index description
; ----- -----------
; 0	Board mobility (size of largest group that can move to a field) (scalar)
; 1	Board weight (Number of groups in fields and freecells) (scalar)
; 2	Board outcome (win = 1, lose = 0, unknown = #f)
; 3	Depth to best board outcome
; 4	Inuse: Is this board currently being looked at? (#t or #f)
; 5	Best known value of sub-tree
; 6	List of possible moves, sorted from best to worst (#f if not generated)
;	Move definition: ((next-board . next-attributes) 
;                         start-slot card card-count end-slot)
;
; The hash table stores associated pairs of the board vector and board
; attributes.  This is often described as (board . info) in the following text.

;;-----------------------------------------------------------------------------
;; Constants

; Set debug to #t for verbose output 
(define debug #f)

; These constants refer to indices within a board attributes vector
(define index-mobility 0)
(define index-weight   1)
(define index-outcome  2)
(define index-depth    3)
(define index-inuse    4)
(define index-value    5)
(define index-moves    6)

; These constants are the possible values for a board outcome
(define outcome-win    1)
(define outcome-lose   0)
(define outcome-unknown #f)

; This is the highest mobility for which the algorithm strives.
; Any mobility larger than the threshhold is disregarded.
; 6 represents an open tableau and two cards in the reserve slots
; (generally, if the algorithm can create an open tableau, the game
; can be solved)
(define mobility-thresh 6)

; These constants indicate which board vector indices represent the state
; of the homecells.
(define board-foundation 4)
(define board-club    (+ board-foundation club))
(define board-diamond (+ board-foundation diamond))
(define board-heart   (+ board-foundation heart))
(define board-spade   (+ board-foundation spade))

; These constants affect the hash table and search algorithm
(define hash-size (- (expt 2 17) 1)) ; A Mersenne prime (2^17 - 1) ~128k
(define board-node-max  50) ; number of board positions to visit each time.
543
(define traverse-node-max 1000) ; prevents stack overflow
544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564

; These constants define values used in constructing the board value.
(define weight-factor   100) ; effect of weight on final score
(define mobility-factor (* 100 weight-factor)) ; effect of mobility
(define max-move-value  (* 1280 mobility-factor)) ; solution found
(define min-move-value  (- 0 max-move-value))     ; no solution found

; value-bias is the amount to bias the previously best move value when
; searching sub-trees.  A more negative number tends to favor a depth-first
; search instead of a breadth-first search.
(define value-bias      -50)

;;-----------------------------------------------------------------------------
;; Global variables

; This is a hash table that holds information about the board
; positions analyzed by the search function.
(define board-hash #()) ; This variable is initialized in new-game
(define visited-nodes 0) ; Number of board positions created for this search.
(define traversed-nodes 0) ; Number of board positions traversed through

565

566 567 568 569
;;-----------------------------------------------------------------------------
;; Functions

; Returns the best move found by the search algorithm
570
(define (get-hint)
571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624
  (if debug (display "get-hint\n"))
  (set! visited-nodes 0)
  (set! traversed-nodes 0)
  (let* ((board (copy-master-board))
	 (info  (get-board-info board)))
    (analyze-board board info 0)
    (let* ((moves (vector-ref info index-moves)))
      (if debug
	(begin
	  (display "visited nodes: ") (display visited-nodes) (newline)
	  (display "traversed nodes: ") (display traversed-nodes) (newline)
	  (display (list-head (vector->list info) 6))
	  (newline)
	  (display-moves board moves)
	  (newline)
	  (display-best-move-trace board moves)))
      (create-help-list board moves))))

; Displays the sequence of best moves found so far by the search. (Debug only)
; Note that the best sequence is occasionally not available depending on
; how the hint function terminates the search.  In these cases, this function
; displays "Non-decreasing" and shows the available moves at the point
; it got confused.
; move format: ((board . info) start-slot card card-count end-slot)
(define (display-best-move-trace board moves)
  (if (not (or (null? moves)
	       (eq? moves #f)))
    (let* ((best-move (car moves))
	   (next-moves (vector-ref (cdar best-move) index-moves)))
      (display-moves board (list best-move))
      (if (not (or (null? next-moves) (eq? next-moves #f)))
	(if (> (vector-ref (cdar best-move) index-depth)
	       (vector-ref (cdaar next-moves) index-depth))
	  (display-best-move-trace (caar best-move) next-moves)
	  (begin
	    (display "Non Decreasing:\n")
	    (display-moves board moves)
	    (display "Trace of best-move:\n")
	    (display-moves (caar best-move) next-moves)))))))

; Displays a list of moves, relative to a given board position (debug only)
; move format: ((board . info) start-slot card card-count end-slot)
(define (display-moves board moves)
  (if (not (null? moves))
    (begin
      (display (list-head (vector->list (cdaar moves)) 6))
      (display (create-help-list board moves))
      (newline)
      (display-moves board (cdr moves)))))

; Creates the move description returned by get-hint.
; move format: ((board . info) start-slot card card-count end-slot)
(define (create-help-list board moves)
  (if (null? moves)
625
    (list 0 (_"No moves are possible. Undo or start again."))
626 627 628 629 630
    (let* ((best-move (car moves))
	   (from-card (caddr best-move))
	   (to-slot   (list-ref best-move 4))
	   (to-stack  (vector-ref board to-slot)))
      (if (eq? (vector-ref (cdar best-move) index-outcome) outcome-lose)
631
	(list 0 (_"The game has no solution. Undo or start again."))
632 633 634 635 636 637 638 639
	(hint-move (find-card-slot from-card) (find-card (find-card-slot from-card) from-card)
	      (cond ((freecell? to-slot) (find-empty-slot freecells))
		    ((homecell? to-slot)
		     (if (equal? 0 to-stack)
		         (find-empty-slot homecells)
		         (find-card-slot (list to-stack (get-suit from-card) #t))))
		    ((null? to-stack) (find-empty-slot fields))
		    (else (find-card-slot (car to-stack)))))))))
640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690

; Returns a vector copy of the master board for use as the initial
; node in the search.
(define (copy-master-board)
  (let ((freecell-cards (map get-cards freecells))
	(homecell-cards (list highest-club
			      highest-diamond
			      highest-heart
			      highest-spade))
	(field-cards    (map get-cards fields)))
    (list->vector (append
		    (sort freecell-cards compare-cards)
		    homecell-cards
		    (sort field-cards compare-cards)))))

; Recursively analyzes board positions.  This function is the heart of
; the search algorithm.  It will continue to search sub-nodes as long as
; each newly searched board has a value that is greater than prev-best.
; Otherwise, this function saves the value of the best board position found
; in this sub-tree, and returns to the caller
;
; Parameters:
;   board - vector containing board position to analyze
;   info - vector describing board (board attributes)
;   prev-best - best board value seen in nodes above this node.
(define (analyze-board board info prev-best)
  ; increment the number of traversed nodes so that we can estimate the
  ; stack depth and ensure it doesn't get too deep.
  (set! traversed-nodes (+ 1 traversed-nodes))
  
  ; Check wether we have already generated moves for this board position.
  ; If not generate the moves now.
  (if (eq? (vector-ref info index-moves) #f)
    (vector-set! info index-moves (get-board-moves board)))
  (vector-set! info index-inuse (+ 1 (vector-ref info index-inuse)))

  ; set this node to outcome-lose so that we don't revisit the same node.
  ; This also becomes the default value if we return early
  (vector-set! info index-value min-move-value)
  (vector-set! info index-outcome outcome-lose)

  ; Sort the moves from best to worst based on value
  (let ((moves (sort (vector-ref info index-moves) move-compare)))
    (vector-set! info index-moves moves)

    ; Check whether there are any moves that don't lose.  (If not, exit
    ; with loss)
    (if (and (not (null? moves))
	     (not (eq? (vector-ref (cdaar moves) index-outcome) outcome-lose)))

      ; Determine whether to traverse deeper, or to go back up the tree
691
      (if (and (eq? (vector-ref (cdaar moves) index-outcome) #f)
692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012
	       (< visited-nodes board-node-max)
	       (< traversed-nodes traverse-node-max)
	       (>= (vector-ref (cdaar moves) index-value) prev-best))
	(begin
	  ; Traverse into the best available move
	  (analyze-board 
	    (caaar moves)
	    (cdaar moves)
	    (if (null? (cdr moves))
	      prev-best
	      (max prev-best (+ value-bias
				(vector-ref (cdaadr moves) index-value)))))
	  ; Repeat analysis of this node in case another move beats the
	  ; current best
	  (analyze-board board info prev-best))

	; Copy the best outcome and move to previous node
	(copy-outcome-info! info (cdaar moves)))
      ; else leave outcome set to 'outcome-lose' and go up to previous node
      ))
  (vector-set! info index-inuse (+ -1 (vector-ref info index-inuse))))

; copies the inportant board information from source to dest
(define (copy-outcome-info! dest source)
  (vector-set! dest index-outcome     (vector-ref source index-outcome))
  (vector-set! dest index-value (+ -1 (vector-ref source index-value)))
  (vector-set! dest index-depth (+  1 (vector-ref source index-depth))))

; Sort compare function -- compares two moves (see also get-move-value)
; Rules:
;  if a position is a winner, move it to the front.
;  else if a position is a loser, move it to the back.
;  else if the mobility of both positions is above a threshold, then
;       compare positions only using board weight
;  else compare using mobility first, then use board weight for a tie,
;       then use depth as a further tie-breaker.
;
; returns #t if left move is better than right move
; returns #f if both positions are equal or right move is better
; input format: ((board . info) start-slot card card-count end-slot)
(define (move-compare left right)
  (> (vector-ref (cdar left)  index-value)
     (vector-ref (cdar right) index-value)))

; Returns a list of possible board moves
(define (get-board-moves board)
  (get-board-moves-from-slots 
    board (append fields freecells)))

; Returns a list of board moves from a given list of slots
(define (get-board-moves-from-slots board slots)
  (if (null? slots)
    '()
    (append (get-board-moves-from-cards 
	      board 
	      (car slots)
	      1
	      (vector-ref board (car slots)))
	    (get-board-moves-from-slots board (cdr slots)))))

; Returns a list of board moves from a given slot with a given height of cards
(define (get-board-moves-from-cards board slot height cards)
  (if (null? cards) 
    '()
    (append (if (and (not (null? (cdr cards)))
		     (field-join? (car cards) (cadr cards)))
	      (get-board-moves-from-cards 
		board 
		slot 
		(+ height 1) 
		(cdr cards))
	      '() )
	    (get-moves-from-card-to-slots
	      board 
	      slot 
	      height 
	      (car cards)
	      (append 
		(remove-redundant-open-slots board fields)
		(get-leftmost-open-freecell board)
		homecells)))))

; returns a list containing the slot number for the left-most open freecell,
; or '() if none are open
(define (get-leftmost-open-freecell board)
  (cond ((null? (vector-ref board freecell-1)) (list freecell-1))
	((null? (vector-ref board freecell-2)) (list freecell-2))
	((null? (vector-ref board freecell-3)) (list freecell-3))
	((null? (vector-ref board freecell-4)) (list freecell-4))
	(else '())))

; Returns a list of field slot numbers with redundant open slots removed
(define (remove-redundant-open-slots board slots)
  (if (null? slots)
    '()
    (if (null? (vector-ref board (car slots)))
      (cons (car slots) (remove-all-open-fields board (cdr slots)))
      (cons (car slots) (remove-redundant-open-slots board (cdr slots))))))

; Returns a list of fields slot number with all open slots removed
(define (remove-all-open-fields board slots)
  (if (null? slots)
    '()
    (if (null? (vector-ref board (car slots)))
      (remove-all-open-fields board (cdr slots))
      (cons (car slots) (remove-all-open-fields board (cdr slots))))))

; determines the possible moves from a given card (at a particular source-slot
; and with a given height) to a set of destination slots.
(define (get-moves-from-card-to-slots board source-slot height card slots)
  (if (null? slots)
    '()
    (append 
      (let* ((dest-slot (car slots))
	     (dest-cards (vector-ref board dest-slot)))
	(if (or (and (homecell? dest-slot)
		     (= height 1)
		     (= (get-suit card) (- dest-slot homecell-1))
		     (= (get-value card) (+ dest-cards 1)))
	        (and (freecell? dest-slot)
		     (not (freecell? source-slot))
		     (= height 1)
		     (null? dest-cards))
	        (and (field? dest-slot)
		     (or (and (null? dest-cards)
			      (or (freecell? source-slot)
				  (not
				    (= height
				       (length
					 (vector-ref board source-slot))))))
			 (and (not (null? dest-cards))
			      (field-join? card (car dest-cards))))
		     (or (= height 1)
			 (<= height
			     (get-board-mobility
			       board
			       (if (null? dest-cards) 1 0))))))
	  (let* ((move-cdr (list source-slot card height (car slots)))
		 (move (cons (get-board-info-pair
			       (perform-move board move-cdr))
			     move-cdr)))
	    (if (= (vector-ref (cdar move) index-value) 0)
	      (vector-set! 
	        (cdar move) index-value
	        (quotient 
		  (get-move-value move)
		  (let ((source-cards (list-tail (vector-ref board source-slot)
					         height)))
		    (if (and (not (null? source-cards))
			     (not (freecell? (cadr move)))
			     (field-join?
			       (caddr move)
			       (car source-cards)))
		      2
		      1)))))
	    (list move))
	  '() ))
      (get-moves-from-card-to-slots 
	board 
	source-slot 
	height 
	card 
	(cdr slots)))))

; returns a new board with a given move applied and small cards moved up
;   board - a board vector
;   move - list in the form (source-slot card card-count dest-slot)
;          (This is more precisely a move-cdr)
(define (perform-move board move)
  (set! visited-nodes (+ 1 visited-nodes))
  (let ((new-board (list->vector (vector->list board)))
	(source-stack (vector-ref board (car move)))
	(dest-stack (vector-ref board (cadddr move))))
    (vector-set! new-board (cadddr move)
		 (if (homecell? (cadddr move))
		   (get-value (car source-stack))
		   (append (list-head source-stack (caddr move))
			   dest-stack)))
    (vector-set! new-board (car move) (list-tail source-stack (caddr move)))
    (move-board-low-cards new-board 0)
    (let* ((temp-board (vector->list new-board))
	   (freecell-cards (list-head temp-board 4))
	   (homecell-cards (list-head (list-tail temp-board 4) 4))
	   (field-cards (list-tail temp-board 8)))
      (set! new-board 
	(list->vector (append (sort freecell-cards compare-cards)
			      homecell-cards
			      (sort field-cards compare-cards)))))
    new-board))

; Compares two card stacks and returns #t if the top card from
; card1 is larger than that of card2.
(define (compare-cards card1 card2)
  (> (card-value card1) (card-value card2)))

; Returns 0 if there is no card, or between 1 and 52 for the absolute
; rank of the top card in a stack.  This equates to 4*rank+suit, where
; the suit order is club=0, diamond=1, heart=2, and spade=3.
; format of card: ((rank suit visible) ...) or '()
(define (card-value card)
  (if (null? card)
    0
    (+ (* 4 (caar card)) (cadar card))))

; This function is more or less a copy of move-low-cards, except it
; operates on a local board instead of a global board.
(define (move-board-low-cards board slot)
  (and (not (homecell? slot))
       (not (null? (vector-ref board slot)))
       (let* ((card (car (vector-ref board slot)))
	      (homecell-slot (+ board-foundation (get-suit card)))
	      (homecell-value (vector-ref board homecell-slot)))
	 (if (and (= (get-value card) (+ 1 homecell-value))
		  (or (and (= (get-color card) red)
			   (<= (get-value card) (max-board-auto-red board)))
		      (and (= (get-color card) black)
			   (<= (get-value card) (max-board-auto-black board)))))
	   (begin
	     (vector-set! board (+ board-foundation (get-suit card)) 
			  (get-value card))
	     (vector-set! board slot (cdr (vector-ref board slot)))
	     (move-board-low-cards board 0)))))
  (or (>= slot field-8)
      (move-board-low-cards board (+ 1 slot))))

; Copy of max-auto-red, except uses a local board.
; Returns the maximum rank of the red homecells that is automatically moved.
; This equates to the highest red suit rank that is not useful in play.  In
; other words, it is better to move the lower black suit cards to the
; homecells instead of stacking them on top of a red suit card that is at or
; below this rank.
(define (max-board-auto-red board)
  (min (+ 2 (min (vector-ref board board-club)
		 (vector-ref board board-spade)))
       (+ 3 (min (vector-ref board board-diamond)
		 (vector-ref board board-heart)))))

; see max-board-auto-red and exchange red for black
(define (max-board-auto-black board)
  (min (+ 2 (min (vector-ref board board-diamond) 
		 (vector-ref board board-heart)))
       (+ 3 (min (vector-ref board board-club) 
		 (vector-ref board board-spade)))))

; Returns the value of a move, based on the board information.
; The resulting format generally looks like this: MWWDD, where
;   M is Mobility, WW is 100 - board weight, and DD is 100 - depth.
; input format: ((board . info) start-slot card card-count end-slot)
(define (get-move-value move)
  (let ((info  (cdar move))
	(board (caar move)))
    (let ((mobility (vector-ref info index-mobility))
	  (weight   (vector-ref info index-weight))
	  (outcome  (vector-ref info index-outcome))
	  (inuse    (> (vector-ref info index-inuse) 0))
	  (depth    (vector-ref info index-depth)))
      (cond (inuse                      min-move-value)
	    ((eq? outcome outcome-win)  (- max-move-value depth))
	    ((= weight 0)		(- max-move-value depth))
	    ((eq? outcome outcome-lose) min-move-value)
	    (else (+ (* mobility-factor (min mobility-thresh mobility))
		     (- mobility-factor (* weight-factor weight))
		     (- weight-factor depth)))))))

; generates a board and info pair (board . pair) based on an input board
(define (get-board-info-pair board)
  (cons board (get-board-info board)))

; Returns the information for a particular board position by looking
; in hash table.  If not entry found, creates a new entry in the hash
; table with default information
(define (get-board-info board)
  (or (hash-ref board-hash board)
      (let ((info (vector (get-board-mobility board 0)
			  (get-board-weight board)
			  outcome-unknown ; Outcome not known
			  1     ; each new board has a depth of 1
			  0     ; board is not yet being looked at
			  0     ; position has no value yet
			  #f))) ; no moves generated yet
	; Add new board to hash table
	(hash-set! board-hash board info)
	(if (= (vector-ref info index-weight) 0)
	  (vector-set! info index-outcome outcome-win))
	info)))

; Determines a board's 'Weight' by determining the number of groups within
; the tableaus and the freecells (reserves).  A group is defined as a set
; of consecutive cards that alternate color.
(define (get-board-weight board)
  (define (get-slot-list-weight slots)
    (if (null? slots)
      0
      (+ (get-card-list-weight (vector-ref board (car slots)))
	 (get-slot-list-weight (cdr slots)))))
  (get-slot-list-weight (append freecells fields)))
	    
; returns the 'weight' of a card list, which is the number of distinct runs
(define (get-card-list-weight card-list)
  (cond ((null? card-list)       0)
        ((null? (cdr card-list)) 1)
        (else (+ (get-card-list-weight (cdr card-list))
		 (if (field-join? (car card-list) (cadr card-list)) 0 1)))))

; Returns the board 'Mobility', which is defined as the largest run of cards
; the user could move to another card.
; Parameters:
;   board: board vector
;   adjust: 0 - Compute mobility when moving a stack to another card
;           1 - Compute mobility when moving a stack to an open tableau
(define (get-board-mobility board adjust)
  (* (+ (get-board-free-count board freecells) 1)
     (expt 2 (- (get-board-free-count board fields) adjust))))

; returns the number of open cells available within a given set of cells
(define (get-board-free-count board cells)
  (if (null? cells)
    0
    (+ (get-board-free-count board (cdr cells))
       (if (null? (vector-ref board (car cells))) 1 0))))

1013 1014 1015
(set-features droppable-feature)

(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