;; Framework for the Yukon solitaire project. ;; A good way to call this procedure is ;; (yukon (new-deck)) (define (yukon deck) (play (new-board deck) ) ) ;;; Game-playing procedures. (define (play board) (let ((moves (possible-moves board))) (cond ((we-win? board)) ((null? moves) #f) ((play (updated board (choice-from moves board)))) ) ) ) ;;; ************************************************************************** ;;; Procedures that you supply. ;;; ;; Return a list of the possible moves. (define (possible-moves board) ; You supply this procedure. This version always returns the empty list. '( ) ) ;; Return one of the moves in move-list (which must be nonempty). ;; This version asks the user which move to make. (define (choice-from move-list board) (print-board board) (newline) (display (append '(moves: ) move-list)) (newline) (display "Which move? ") (flush) (list-ref move-list (read)) ) ;; Return the board that result from making the given move with the given board. (define (updated board move) ; You supply this procedure. This version never makes a move. board ) ;;; ************************************************************************** ;; Return true when we've won, #f if we haven't won yet. (define (we-win? board) (true-for-all? (lambda (stack) (= (length stack) 13)) (foundations board) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Board access procedures. ;;; A board is a two-element list containing the tableau and the foundations. ;;; A tableau is a seven-element list, each element containing the face-up ;;; and the face-down stacks. ;;; The foundations are a four-element list of stacks, each containing cards ;;; of the same suit built up from the ace. (define (tableau board) (car board)) (define (foundations board) (cadr board)) (define (face-up stack) (car stack)) (define (face-down stack) (cadr stack)) ;; Return an initialized board. It has empty foundation stacks and a tableau ;; as described in the problem information. (define (new-board deck) (list (new-tableau deck) '(( ) ( ) ( ) ( ))) ) ;; Return an initialized tableau. ;; The first stack contains only a single face-up card, and is therefore ;; handled specially. The kth subsequent stack (k starting at 1) contains ;; five face-up cards atop k face-down cards. (define (new-tableau deck) (cons (list (list (car deck)) '( )) (new-tableau-helper (cdr deck) 1)) ) (define (new-tableau-helper deck stack#) (if (> stack# 6) (if (null? deck) '( ) (error (append '(reached stack 7 with deck = ) deck))) (cons (list (first-n deck 5) (first-n (list-tail deck 5) stack#)) (new-tableau-helper (list-tail deck (+ 5 stack#)) (+ 1 stack#)) ) ) ) ;; Return the first n elements of the given list. (define (first-n L n) (if (= n 0) '( ) (cons (car L) (first-n (cdr L) (- n 1)))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Printing procedures (define (print-board board) (display "---------------------------------------------------------------") (newline) (print-foundations (foundations board)) (newline) (display "- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -") (newline) (print-tableau (tableau board) #f) ) ;; Print foundation by printing each foundation stack, in order given (define (print-foundations foundations) (if (not (null? foundations)) (begin (print-foundation-stack (car foundations)) (print-foundations (cdr foundations))))) ;; print a foundation stack -- only print the top (first) card (define (print-foundation-stack foundation-stack) (cond ((empty? foundation-stack) (print-foundation-stack-spacer) (print-no-card #t)) (else (print-foundation-stack-spacer) (print-card (car foundation-stack))))) (define (print-foundation-stack-spacer) (display " ")) ;; print a card - the printed representation of a card will always ;; take up 9 spaces. (define (print-card card) (print-card-spacer) (let ((two-char-representation (cond ((numeric-card? card) (align (rank card) 2)) ((equal? (rank card) 'jack) "JA") ((equal? (rank card) 'queen) "QU") ((equal? (rank card) 'king) "KI") ((equal? (rank card) 'ace) "AC") (else (display "??"))))) (display two-char-representation)) (display "-") ;; this is harder if we don't use the "first" command! (display (string-ref (symbol->string (suit card)) 0)) ) ;; printa blank card, with dashes if so specified (define (print-no-card dashes?) (print-card-spacer) (if dashes? (display "----") (display " "))) (define (print-card-spacer) (display " ")) ;; Print the given tableau. Depending on the value of print-face-down?, ;; either print the actual values of the face-down cards in each stack ;; or print a dash for each face-down card. ;; AHA. In this version we never print the face-down cards! (define (print-tableau tableau print-face-down?) (print-face-down (map face-down tableau) print-face-down?) (newline) (print-face-up (map (lambda (stack) (reverse (face-up stack))) tableau))) ;; Represent the face down cards. Sadly, we ignore print-face-down?. (define (print-face-down stack-list print-face-down?) (cond ((not (null? stack-list)) (print-a-face-down-stack (car stack-list)) (print-face-down (cdr stack-list) print-face-down?)))) (define (print-a-face-down-stack stack) (cond ((null? stack) (print-no-card #f)) (else (print-card-spacer) (display "[-") (display (length stack)) ;; less than 10, right? (display "]")))) ;; Print the face up cards (define (print-face-up stack-list) (cond ((not (all-null? stack-list)) (print-first-row stack-list) (newline) (print-face-up (map remove-car-if-not-null stack-list)) ))) (define (print-first-row stack-list) (cond ((not (null? stack-list)) (if (null? (car stack-list)) (print-no-card #f) (print-card (caar stack-list))) (print-first-row (cdr stack-list))))) ;;; Some printing utilities ;; returns true if each list in the list of lists is null (define (all-null? LofL) (cond ((null? LofL) #t) ((not (null? (car LofL))) #f) (else (all-null? (cdr LofL))))) ;; removes the first element if the list isn't empty (define (remove-car-if-not-null L) (if (null? L) L (cdr L))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Card procedures ;; Return the card corresponding to a given integer. (define (new-card n) (list (rank-equiv (remainder (- n 1) 13)) (suit-equiv (remainder (- n 1) 4) ) ) ) ;; Return the rank and suit corresponding to a given integer. (define (rank-equiv k) (list-ref ALL-RANKS k)) (define (suit-equiv k) (list-ref ALL-SUITS k)) ;; Access procedures to the rank and suit of a card. (define (rank card) (car card)) (define (suit card) (cadr card)) (define ALL-RANKS '(ace 2 3 4 5 6 7 8 9 10 jack queen king)) (define ALL-SUITS '(clubs diamonds hearts spades)) ;; utility procs (define (numeric-card? card) (number? (rank card))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Deck procedures (define brand-new-deck (apply append (map (lambda (rank) (map (lambda (suit) (list rank suit)) ALL-SUITS) ) ALL-RANKS) ) ) (define (new-deck) (shuffled brand-new-deck)) (define DECKSIZE (length brand-new-deck)) ;; Return a random permutation of the given deck. (define (shuffled deck) (random-permutation (length deck) (map new-card (countdown (length deck))) ) ) ;; Return the list (n n-1 n-2 ... 1). (define (countdown n) (if (= n 0) '() (cons n (countdown (- n 1)))) ) ;; Return a random permutation of k elements of L. ;; Note: this doesn't work if L contains duplicate elements. (define (random-permutation k L) (if (= k 0) '() (let ((selection (random-pick L))) (cons selection (random-permutation (- k 1) (keep-if (lambda (x) (not (equal? selection x))) L) ) ) ) ) ) ;; Return a randomly selected item from L. (define (random-pick L) (list-ref L (random (length L))) ) ;;; ************************************************************************** ;;; ************************************************************************** ;; Add your code here.