;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Framework for the Yukon solitaire project. ;; Version 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; #t if you want a graphic representation of the board, #f otherwise (define *TK-GRAPHICS* #t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Game playing procedures ;; A good way to call this procedure is (yukon (new-deck)) (define (yukon deck) (play (new-board deck) ) ) ;; this is a good starting point for testing (define (play board) (show-the-board board) (let ((moves (possible-moves board))) (cond ((we-win? board) (game-over #t)) ((null? moves) (game-over #f)) ((play (updated board (choice-from moves board)))) ) ) ) (define (show-the-board board) (if *TK-GRAPHICS* (draw-board board) (print-board board))) (define (game-over win?) (if win? (display "yeah!") (display "awwww"))) ;;; ************************************************************************** ;;; 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) (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)))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Board printing procedures (printing to the console) (define (print-board board) (display "---------------------------------------------------------------") (newline) (print-foundations (foundations board)) (newline) (display "- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -") (newline) (print-tableau (tableau board) #f) (newline) ) ;; 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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Board graphics procedures (showing graphics in Tk graphics window) (define *CARD-HEIGHT* 100) ;; Height of the cards in pixels (define *CARD-WIDTH* 70) ;; Width of the cards (define *CARD-CENTER-INSET* 15) ;; The distance from the edge of the card ;; to the inset box on the front of the card (define *CARD-SPACING* 5) ;; The spacing between cards (define *CARD-OFFSET* 17) ;; The vertical distance between cards ;; stacked on one another (define *CARD-BACK-COLOR* 'forestgreen) ;; The color of the backs of the cards (define *CARD-FRONT-COLOR* 'white) ;; The color of the card front background (define *HIDDEN-CARD-FRONT-COLOR* 'grey50) ;; The color for the fronts ;; of face down cards (define *CARD-CENTER-COLOR* 'gray50) ;; The color of the card front inset (define *NO-CARD-COLOR* 'grey20) ;; The color of an empty stack (define *DEBUGGING* #f) ;; #f if playing normally. Set to #t if you ;; want the face down cards to show. ;; We need to redefine canvas-width and canvas-height ;; becaue the default size is too small for the tableau. (define (canvas-width) (+ (* (+ *CARD-WIDTH* *CARD-SPACING*) 7) *CARD-SPACING*)) (define (canvas-height) (+ (* (+ *CARD-HEIGHT* *CARD-SPACING*) 2) (* *CARD-OFFSET* 20))) ;; The main entry point for the tk board drawing routine. ;; Takes a board and draws it in the turtle graphics window. ;; The four foundation stacks are placed in a row at the top of the canvas. ;; The tableau is placed immediately below across the canvas. ;; Every stack is separated by *CARD-SPACING* pixels. Each card ;; of each stack in the tableau is staggered downward by *CARD-OFFSET* pixels. ;; As an added benefit, if *DEBUGGING* is true, then all the face-down cards ;; are drawn face-up (in a different color, as to be distinguishable). ;; This procedure does no error checking, and dies miserably ;; if an invalid board is passed in. (define (draw-board board) (clearscreen) (hideturtle) (draw-foundation-stacks (foundations board) 0) ;; Draw the foundations ;; starting at the left edge (draw-tableau-stacks (tableau board) 0)) ;; Draw the tableau starting ;; at the left edge ;; Draws the foundations (the four stacks at the top of the board). ;; Takes in the foundation stacks. ;; position needs to start at the left edge of where you want the stacks. ;; This is adjusted to the right by *CARD-SPACING* pixels. (define (draw-foundation-stacks foundation-stacks position) (if (not (null? foundation-stacks)) (begin (draw-foundation-stack (car foundation-stacks) (+ position *CARD-SPACING*)) (draw-foundation-stacks (cdr foundation-stacks) (+ position *CARD-SPACING* *CARD-WIDTH*))))) ;; Draws a single given foundation stack. ;; The position is the real left edge of the stack. ;; The top edge of the stack is placed *CARD-SPACING* pixels ;; from the top of the window. (define (draw-foundation-stack foundation-stack position) (if (null? foundation-stack) (draw-no-card position *CARD-SPACING*) (draw-card-front (car foundation-stack) position *CARD-SPACING*))) ;; Draws the tableau (the seven stacks across the board). ;; Takes in the tableau stacks. ;; position needs to start at the left edge of where you want the stacks. ;; This is adjusted to the right by *CARD-SPACING* pixels. (define (draw-tableau-stacks tableau-stacks position) (if (not (null? tableau-stacks)) (begin (maybe-draw-tableau-stack (car tableau-stacks) (+ position *CARD-SPACING*) (+ (* *CARD-SPACING* 2) *CARD-HEIGHT*)) (draw-tableau-stacks (cdr tableau-stacks) (+ position *CARD-SPACING* *CARD-WIDTH*))))) ;; Given a single tableau stack, either draws the stack, ;; or places a blank place if the stack is empty. (define (maybe-draw-tableau-stack tableau-stack x-position y-position) (if (and (null? (cadr tableau-stack)) (null? (car tableau-stack))) (draw-no-card x-position y-position) (draw-tableau-stack (map reverse tableau-stack) x-position y-position))) ;; Draws a single given tableau stack. ;; The positions are the real left and top edges of the stack. ;; This code assumes that the lists of cards have been reversed, ;; as it makes it much easier to draw the stack. (define (draw-tableau-stack tableau-stack x-position y-position) (cond ((not (null? (cadr tableau-stack))) ;; We have a face down card (if *DEBUGGING* ;; We may want to see the face down cards to debug (draw-hidden-card-front (caadr tableau-stack) x-position y-position) (draw-card-back x-position y-position)) ;; We strip out the face down card and recurse (draw-tableau-stack (list (car tableau-stack) (cdadr tableau-stack)) x-position (+ y-position *CARD-OFFSET*))) ((not (null? (car tableau-stack))) ;; We have a face up card (draw-card-front (caar tableau-stack) x-position y-position) ;; We strip out the face up card and recurse (draw-tableau-stack (list (cdar tableau-stack) (cadr tableau-stack)) x-position (+ y-position *CARD-OFFSET*))) (else))) ;; We do nothing with an empty stack. If it was empty in the ;; first place, it was handled in maybe-draw-tableau-stack. ;; Draws a blank space for a card. (define (draw-no-card x y) (canvas-widget 'create 'rect x y (+ x *CARD-WIDTH*) (+ y *CARD-HEIGHT*) :fill *NO-CARD-COLOR*)) ;; Draws the back of a card (define (draw-card-back x y) (canvas-widget 'create 'rect x y (+ x *CARD-WIDTH*) (+ y *CARD-HEIGHT*) :fill *CARD-BACK-COLOR*)) ;; Draws the front of a card that is face down (define (draw-hidden-card-front card x y) (canvas-widget 'create 'rect x y (+ x *CARD-WIDTH*) (+ y *CARD-HEIGHT*) :fill *HIDDEN-CARD-FRONT-COLOR*) ;; The background (canvas-widget 'create 'rect (+ x *CARD-CENTER-INSET*) (+ y *CARD-CENTER-INSET*) (- (+ x *CARD-WIDTH*) *CARD-CENTER-INSET*) (- (+ y *CARD-HEIGHT*) *CARD-CENTER-INSET*) :fill *CARD-CENTER-COLOR*) ;; The inset (canvas-widget 'create 'text (+ x 2) (+ y 2) :text (card-to-string card) :fill 'black ;; See note below :anchor 'nw) ;; The rank (draw-suit card (+ x 17) (+ y 2))) ;; The suit ;; Draws the front of a card that is face up (define (draw-card-front card x y) (canvas-widget 'create 'rect x y (+ x *CARD-WIDTH*) (+ y *CARD-HEIGHT*) :fill *CARD-FRONT-COLOR*) ;; The background (canvas-widget 'create 'rect (+ x *CARD-CENTER-INSET*) (+ y *CARD-CENTER-INSET*) (- (+ x *CARD-WIDTH*) *CARD-CENTER-INSET*) (- (+ y *CARD-HEIGHT*) *CARD-CENTER-INSET*) :fill *CARD-CENTER-COLOR*) ;; The inset (canvas-widget 'create 'text (+ x 2) (+ y 2) :text (card-to-string card) :fill 'black ;; I considered using (suit-color card) here, ;; but thought black was more readable. ;; Feel free to change it if you would like. :anchor 'nw) ;; The rank (draw-suit card (+ x 17) (+ y 2))) ;; The suit ;; Takes a card and returns the card's rank as a string. (define (card-to-string card) (cond ((numeric-card? card) (number->string (rank card))) ((equal? (rank card) 'jack) "J") ((equal? (rank card) 'queen) "Q") ((equal? (rank card) 'king) "K") ((equal? (rank card) 'ace) "A") (else "??"))) ;; Given a card and a position, draw the suit of the card at that position. (define (draw-suit card x y) ((cadr (assoc (suit card) `((hearts ,draw-heart) (clubs ,draw-club) (spades ,draw-spade) (diamonds ,draw-diamond)))) x y)) ;; Returns the color of the suit of a card (define (suit-color card) (cadr (assoc (suit card) `((hearts red) (clubs black) (spades black) (diamonds red))))) ;; Draws a heart at the given position (define (draw-heart x y) (canvas-widget 'create 'polygon (+ x 6) (+ y 4) (+ x 3) (+ y 1) (+ x 1) (+ y 2) (+ x 0) (+ y 4) (+ x 1) (+ y 6) (+ x 6) (+ y 12) (+ x 11) (+ y 6) (+ x 12) (+ y 4) (+ x 11) (+ y 2) (+ x 9) (+ y 1) (+ x 6) (+ y 4) :fill 'red)) ;; Draws a diamond at the given position (define (draw-diamond x y) (canvas-widget 'create 'polygon (+ x 6) (+ y 0) (+ x 0) (+ y 6) (+ x 6) (+ y 12) (+ x 12) (+ y 6) (+ x 6) (+ y 0) :fill 'red)) ;; Draws a spade at the given position (define (draw-spade x y) (canvas-widget 'create 'polygon (+ x 5) (+ y 12) (+ x 5) (+ y 9) (+ x 3) (+ y 11) (+ x 1) (+ y 10) (+ x 0) (+ y 8) (+ x 1) (+ y 6) (+ x 6) (+ y 0) (+ x 11) (+ y 6) (+ x 12) (+ y 8) (+ x 11) (+ y 10) (+ x 9) (+ y 11) (+ x 7) (+ y 9) (+ x 7) (+ y 12) :fill 'black)) ;; Draws a club at the given position. ;; The club is kind of ugly; does someone want to fix it? (define (draw-club x y) (canvas-widget 'create 'polygon (+ x 5) (+ y 11) (+ x 5) (+ y 9) (+ x 0) (+ y 9) (+ x 0) (+ y 5) (+ x 4) (+ y 5) (+ x 4) (+ y 1) (+ x 8) (+ y 1) (+ x 8) (+ y 5) (+ x 12) (+ y 5) (+ x 12) (+ y 9) (+ x 7) (+ y 9) (+ x 7) (+ y 11) :fill 'black)) ;;; ************************************************************************** ;;; ************************************************************************** ;; Add your code here.