1 ;; The first three lines of this file were inserted by DrScheme. They record metadata
2 ;; about the language level of this file in a form that our tools can easily process.
3 #reader(lib "htdp-advanced-reader.ss" "lang")((modname |32.3|) (read-case-sensitive #t) (teachpacks ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp") (lib "gui.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp") (lib "gui.ss" "teachpack" "htdp")))))
4 ;A solitaire board (board) is a (vectorof (vectorof booleans)), where true represents a filled square, false an empty square. In particular, for any given board, the n-th element is a vector containing n booleans. We call a triangular board with n-pegs to a side a size-n triangle. For example, the representation of a size-4 equilaterial triangular board:
6 ;(vector (vector false)
8 ; (vector true true true)
9 ; (vector true true true true))
13 ;where o,n are posns. o represents the original position of the peg and n represents the new position of the peg.
15 (define-struct state (board move))
17 ;A state is a structure
19 ;where b is a board and m is a move.
21 ;By default, we specify the coordinates of a peg with a posn (x,y), where x refers to horizontal distance (the column number) and y refers to the vertical distance (the row number). The top position of any given board has an index (make-posn 1 1). When referencing a given peg in the board by using vector indices, we will explicitly state that we are using vector indices 0,0 to reference the top position in the board. Otherwise, assume (make-posn 1 1) specifies the first position in the board.
23 ;enabled? : posn board -> boolean
24 ;Determines whether or not the peg specified by apeg is enabled in aboard (enabled means that the peg is capable of jumping).
26 (define (enabled? apeg aboard)
27 (local ((define peg-x (posn-x apeg))
28 (define peg-y (posn-y apeg))
29 (define right-peg-x (+ peg-x 2))
30 (define down-peg-y (+ peg-y 2))
31 (define left-peg-x (- peg-x 2))
32 (define up-peg-y (- peg-y 2))
33 (define down-peg (make-posn peg-x down-peg-y))
34 (define right-peg (make-posn right-peg-x peg-y))
35 (define up-peg (make-posn peg-x up-peg-y))
36 (define left-peg (make-posn left-peg-x peg-y))
37 (define diagonal-up-peg (make-posn left-peg-x up-peg-y))
38 (define diagonal-down-peg (make-posn right-peg-x down-peg-y)))
40 ;;first, is there even a peg?
41 ;;if so, test jump down, jump right, jump up, jump left, jump diagonal (up), jump diagonal (down), in that order
42 [(peg-exists? apeg aboard)
43 (or (jump? apeg down-peg aboard)
44 (jump? apeg right-peg aboard)
45 (jump? apeg up-peg aboard)
46 (jump? apeg left-peg aboard)
47 (jump? apeg diagonal-up-peg aboard)
48 (jump? apeg diagonal-down-peg aboard))]
51 ;peg-exists? : posn board -> boolean
52 ;Determines if a peg exists given apeg and aboard. apeg is reported using an index that starts at 1,1. peg-exists? converts the coordinates to vector indices (in vector indices, 0,0 is the first element in the board).
54 (define (peg-exists? apeg aboard)
55 (local ((define peg-x-v (sub1 (posn-x apeg)))
56 (define peg-y-v (sub1 (posn-y apeg))))
57 (vector-ref (vector-ref aboard peg-y-v) peg-x-v)))
59 ;jump? : posn posn board-> boolean
60 ;Given old-peg, new-peg, and aboard, determine if it is possible to make a jump. jump? converts these coordinates to vector indices, where 0,0 represents the first element in board. Conversions are denoted by -v.
62 (define (jump? old-peg new-peg aboard)
63 (local ((define old-peg-x-v (sub1 (posn-x old-peg)))
64 (define old-peg-y-v (sub1 (posn-y old-peg)))
65 (define new-peg-x-v (sub1 (posn-x new-peg)))
66 (define new-peg-y-v (sub1 (posn-y new-peg)))
67 (define remove-peg-x-v (+ (/ (- new-peg-x-v old-peg-x-v) 2) old-peg-x-v))
68 (define remove-peg-y-v (+ (/ (- new-peg-y-v old-peg-y-v) 2) old-peg-y-v))
69 (define need-length-x (add1 new-peg-x-v))
70 (define need-length-y (add1 new-peg-y-v)))
71 (and (not (negative? new-peg-x-v))
72 (not (negative? new-peg-y-v))
73 (>= (vector-length aboard) need-length-y)
74 (>= (vector-length (vector-ref aboard new-peg-y-v)) need-length-x)
75 (not (vector-ref (vector-ref aboard new-peg-y-v) new-peg-x-v))
76 (vector-ref (vector-ref aboard remove-peg-y-v) remove-peg-x-v))))
78 ;next-states : board posn -> (listof states)
79 ;Given aboard and apeg, create a (listof (make-state b moves)), ie, a (listof states), which return all possible board configurations with their corresponding moves. (since there may be more than one possible jump, we must list the results as a listof boards) 1,1 is the first position in the board, not 0,0.
81 (define (next-states aboard apeg)
82 (local ((define peg-x (posn-x apeg))
83 (define peg-y (posn-y apeg))
84 (define down-peg (make-posn peg-x (+ peg-y 2)))
85 (define right-peg (make-posn (+ peg-x 2) peg-y))
86 (define up-peg (make-posn peg-x (- peg-y 2)))
87 (define left-peg (make-posn (- peg-x 2) peg-y))
88 (define diagonal-up-peg (make-posn (- peg-x 2) (- peg-y 2)))
89 (define diagonal-down-peg (make-posn (+ peg-x 2) (+ peg-y 2))))
91 (filter (lambda (astate) (not (empty? (state-board astate))))
92 (list (make-state (jump aboard apeg down-peg) (list apeg down-peg))
93 (make-state (jump aboard apeg right-peg) (list apeg right-peg))
94 (make-state (jump aboard apeg up-peg) (list apeg up-peg))
95 (make-state (jump aboard apeg left-peg) (list apeg left-peg))
96 (make-state (jump aboard apeg diagonal-up-peg) (list apeg diagonal-up-peg))
97 (make-state (jump aboard apeg diagonal-down-peg) (list apeg diagonal-down-peg))))))
99 ;jump : board posn posn -> board or empty
100 ;Using aboard, return a new board with old-peg replaced with false and new-peg replaced with true. The intermediate peg is removed.
102 (define (jump aboard old-peg new-peg)
103 (local ((define old-peg-x (posn-x old-peg))
104 (define old-peg-y (posn-y old-peg))
105 (define new-peg-x (posn-x new-peg))
106 (define new-peg-y (posn-y new-peg))
107 (define remove-peg-x (+ (/ (- new-peg-x old-peg-x) 2) old-peg-x))
108 (define remove-peg-y (+ (/ (- new-peg-y old-peg-y) 2) old-peg-y)))
110 [(jump? old-peg new-peg aboard)
111 (build-board (vector-length aboard)
114 [(and (= x old-peg-x)
115 (= y old-peg-y)) false]
116 [(and (= x new-peg-x)
117 (= y new-peg-y)) true]
118 [(and (= x remove-peg-x)
119 (= y remove-peg-y)) false]
120 [else (vector-ref (vector-ref aboard (sub1 y)) (sub1 x))])))]
123 ;build-board : N (N N -> X) -> (vectorof (vectorof X))
124 ;Builds a size-n equilateral triangle according to f, where (f i j) specifies the value of the i,jth position of the board. The first value corresponds to (i,j)=(1,1). i represents the horizontal distance (the column number), j represents the vertical distance (the row number).
126 (define (build-board n f)
127 (build-vector n (lambda (i)
128 (build-vector (add1 i) (lambda (j) (f (add1 j) (add1 i)))))))
130 ;solitaire : board -> (listof moves), empty, or false
131 ;Given aboard0, solve the solitaire problem and return a (listof moves). If aboard0 is itself a solution, return empty. If the board cannot be solved, return false.
133 (define (solitaire aboard0)
134 ;;previous-moves is an accumulator that represents the necessary moves to go from
137 ((define (solitaire-accu aboard1 previous-moves pegs)
139 [(solved? aboard1) previous-moves]
140 [(empty? pegs) false]
143 ((define first-los (next-states aboard1 (first pegs)))
144 (define search-first-peg (solitaire/list-accu first-los previous-moves)))
146 [(boolean? search-first-peg)
147 (solitaire-accu aboard1 previous-moves (rest pegs))]
148 [else search-first-peg]))]))
149 (define (solitaire/list-accu alos previous-moves)
151 [(empty? alos) false]
154 ((define new-moves (append previous-moves
155 (list (state-move (first alos)))))
156 (define new-board (state-board (first alos)))
157 (define search-first-move
158 (solitaire-accu new-board new-moves (enabled-pegs new-board))))
160 [(boolean? search-first-move)
161 (solitaire/list-accu (rest alos) previous-moves)]
162 [else search-first-move]))])))
163 (solitaire-accu aboard0 empty (enabled-pegs aboard0))))
165 ;solitaire-accu : board (listof moves) (listof posns) -> (listof moves) or false
166 ;Solves aboard1 if possible and returns the listof moves necessary to reach the solution state. Otherwise, returns false. pegs "remembers" the enabled-pegs in aboard1 that have yet to be tested.
168 ;solitaire/list-accu : (listof states) (listof moves) -> (listof moves) or false
171 ;solved? : board -> boolean
172 ;Determines if aboard is solved
174 (define (solved? aboard)
176 [(equal? aboard SOLVED-BOARD) true]
180 (build-board 6 (lambda (x y)
185 (define INITIAL-BOARD
186 (build-board 6 (lambda (x y)
192 ;enabled-pegs : board -> (listof posns)
193 ;Determines all enabled pegs in a given board.
195 (define (enabled-pegs aboard)
196 (filter (lambda (peg) (enabled? peg aboard))
197 (build-peg-list (vector-length aboard) (lambda (x y) (make-posn x y)))))
199 ;build-peg-list : N (N N -> X) -> (listof X)
200 ;Builds a list that corresponds to positions of an n-sized equilaterial triangle.
202 (define (build-peg-list n f)
204 (build-list n (lambda (i)
205 (build-list (add1 i) (lambda (j) (f (add1 j) (add1 i))))))))
207 (solitaire INITIAL-BOARD)
