1 12687dd9 2023-08-04 jrmu ;; The first three lines of this file were inserted by DrScheme. They record metadata
2 12687dd9 2023-08-04 jrmu ;; about the language level of this file in a form that our tools can easily process.
3 12687dd9 2023-08-04 jrmu #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 12687dd9 2023-08-04 jrmu ;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 12687dd9 2023-08-04 jrmu ;(vector (vector false)
7 12687dd9 2023-08-04 jrmu ; (vector true true)
8 12687dd9 2023-08-04 jrmu ; (vector true true true)
9 12687dd9 2023-08-04 jrmu ; (vector true true true true))
11 12687dd9 2023-08-04 jrmu ;A move is a list
13 12687dd9 2023-08-04 jrmu ;where o,n are posns. o represents the original position of the peg and n represents the new position of the peg.
15 12687dd9 2023-08-04 jrmu (define-struct state (board move))
17 12687dd9 2023-08-04 jrmu ;A state is a structure
18 12687dd9 2023-08-04 jrmu ;(make-state b m)
19 12687dd9 2023-08-04 jrmu ;where b is a board and m is a move.
21 12687dd9 2023-08-04 jrmu ;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 12687dd9 2023-08-04 jrmu ;enabled? : posn board -> boolean
24 12687dd9 2023-08-04 jrmu ;Determines whether or not the peg specified by apeg is enabled in aboard (enabled means that the peg is capable of jumping).
26 12687dd9 2023-08-04 jrmu (define (enabled? apeg aboard)
27 12687dd9 2023-08-04 jrmu (local ((define peg-x (posn-x apeg))
28 12687dd9 2023-08-04 jrmu (define peg-y (posn-y apeg))
29 12687dd9 2023-08-04 jrmu (define right-peg-x (+ peg-x 2))
30 12687dd9 2023-08-04 jrmu (define down-peg-y (+ peg-y 2))
31 12687dd9 2023-08-04 jrmu (define left-peg-x (- peg-x 2))
32 12687dd9 2023-08-04 jrmu (define up-peg-y (- peg-y 2))
33 12687dd9 2023-08-04 jrmu (define down-peg (make-posn peg-x down-peg-y))
34 12687dd9 2023-08-04 jrmu (define right-peg (make-posn right-peg-x peg-y))
35 12687dd9 2023-08-04 jrmu (define up-peg (make-posn peg-x up-peg-y))
36 12687dd9 2023-08-04 jrmu (define left-peg (make-posn left-peg-x peg-y))
37 12687dd9 2023-08-04 jrmu (define diagonal-up-peg (make-posn left-peg-x up-peg-y))
38 12687dd9 2023-08-04 jrmu (define diagonal-down-peg (make-posn right-peg-x down-peg-y)))
40 12687dd9 2023-08-04 jrmu ;;first, is there even a peg?
41 12687dd9 2023-08-04 jrmu ;;if so, test jump down, jump right, jump up, jump left, jump diagonal (up), jump diagonal (down), in that order
42 12687dd9 2023-08-04 jrmu [(peg-exists? apeg aboard)
43 12687dd9 2023-08-04 jrmu (or (jump? apeg down-peg aboard)
44 12687dd9 2023-08-04 jrmu (jump? apeg right-peg aboard)
45 12687dd9 2023-08-04 jrmu (jump? apeg up-peg aboard)
46 12687dd9 2023-08-04 jrmu (jump? apeg left-peg aboard)
47 12687dd9 2023-08-04 jrmu (jump? apeg diagonal-up-peg aboard)
48 12687dd9 2023-08-04 jrmu (jump? apeg diagonal-down-peg aboard))]
49 12687dd9 2023-08-04 jrmu [else false])))
51 12687dd9 2023-08-04 jrmu ;peg-exists? : posn board -> boolean
52 12687dd9 2023-08-04 jrmu ;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 12687dd9 2023-08-04 jrmu (define (peg-exists? apeg aboard)
55 12687dd9 2023-08-04 jrmu (local ((define peg-x-v (sub1 (posn-x apeg)))
56 12687dd9 2023-08-04 jrmu (define peg-y-v (sub1 (posn-y apeg))))
57 12687dd9 2023-08-04 jrmu (vector-ref (vector-ref aboard peg-y-v) peg-x-v)))
59 12687dd9 2023-08-04 jrmu ;jump? : posn posn board-> boolean
60 12687dd9 2023-08-04 jrmu ;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 12687dd9 2023-08-04 jrmu (define (jump? old-peg new-peg aboard)
63 12687dd9 2023-08-04 jrmu (local ((define old-peg-x-v (sub1 (posn-x old-peg)))
64 12687dd9 2023-08-04 jrmu (define old-peg-y-v (sub1 (posn-y old-peg)))
65 12687dd9 2023-08-04 jrmu (define new-peg-x-v (sub1 (posn-x new-peg)))
66 12687dd9 2023-08-04 jrmu (define new-peg-y-v (sub1 (posn-y new-peg)))
67 12687dd9 2023-08-04 jrmu (define remove-peg-x-v (+ (/ (- new-peg-x-v old-peg-x-v) 2) old-peg-x-v))
68 12687dd9 2023-08-04 jrmu (define remove-peg-y-v (+ (/ (- new-peg-y-v old-peg-y-v) 2) old-peg-y-v))
69 12687dd9 2023-08-04 jrmu (define need-length-x (add1 new-peg-x-v))
70 12687dd9 2023-08-04 jrmu (define need-length-y (add1 new-peg-y-v)))
71 12687dd9 2023-08-04 jrmu (and (not (negative? new-peg-x-v))
72 12687dd9 2023-08-04 jrmu (not (negative? new-peg-y-v))
73 12687dd9 2023-08-04 jrmu (>= (vector-length aboard) need-length-y)
74 12687dd9 2023-08-04 jrmu (>= (vector-length (vector-ref aboard new-peg-y-v)) need-length-x)
75 12687dd9 2023-08-04 jrmu (not (vector-ref (vector-ref aboard new-peg-y-v) new-peg-x-v))
76 12687dd9 2023-08-04 jrmu (vector-ref (vector-ref aboard remove-peg-y-v) remove-peg-x-v))))
78 12687dd9 2023-08-04 jrmu ;next-states : board posn -> (listof states)
79 12687dd9 2023-08-04 jrmu ;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 12687dd9 2023-08-04 jrmu (define (next-states aboard apeg)
82 12687dd9 2023-08-04 jrmu (local ((define peg-x (posn-x apeg))
83 12687dd9 2023-08-04 jrmu (define peg-y (posn-y apeg))
84 12687dd9 2023-08-04 jrmu (define down-peg (make-posn peg-x (+ peg-y 2)))
85 12687dd9 2023-08-04 jrmu (define right-peg (make-posn (+ peg-x 2) peg-y))
86 12687dd9 2023-08-04 jrmu (define up-peg (make-posn peg-x (- peg-y 2)))
87 12687dd9 2023-08-04 jrmu (define left-peg (make-posn (- peg-x 2) peg-y))
88 12687dd9 2023-08-04 jrmu (define diagonal-up-peg (make-posn (- peg-x 2) (- peg-y 2)))
89 12687dd9 2023-08-04 jrmu (define diagonal-down-peg (make-posn (+ peg-x 2) (+ peg-y 2))))
91 12687dd9 2023-08-04 jrmu (filter (lambda (astate) (not (empty? (state-board astate))))
92 12687dd9 2023-08-04 jrmu (list (make-state (jump aboard apeg down-peg) (list apeg down-peg))
93 12687dd9 2023-08-04 jrmu (make-state (jump aboard apeg right-peg) (list apeg right-peg))
94 12687dd9 2023-08-04 jrmu (make-state (jump aboard apeg up-peg) (list apeg up-peg))
95 12687dd9 2023-08-04 jrmu (make-state (jump aboard apeg left-peg) (list apeg left-peg))
96 12687dd9 2023-08-04 jrmu (make-state (jump aboard apeg diagonal-up-peg) (list apeg diagonal-up-peg))
97 12687dd9 2023-08-04 jrmu (make-state (jump aboard apeg diagonal-down-peg) (list apeg diagonal-down-peg))))))
99 12687dd9 2023-08-04 jrmu ;jump : board posn posn -> board or empty
100 12687dd9 2023-08-04 jrmu ;Using aboard, return a new board with old-peg replaced with false and new-peg replaced with true. The intermediate peg is removed.
102 12687dd9 2023-08-04 jrmu (define (jump aboard old-peg new-peg)
103 12687dd9 2023-08-04 jrmu (local ((define old-peg-x (posn-x old-peg))
104 12687dd9 2023-08-04 jrmu (define old-peg-y (posn-y old-peg))
105 12687dd9 2023-08-04 jrmu (define new-peg-x (posn-x new-peg))
106 12687dd9 2023-08-04 jrmu (define new-peg-y (posn-y new-peg))
107 12687dd9 2023-08-04 jrmu (define remove-peg-x (+ (/ (- new-peg-x old-peg-x) 2) old-peg-x))
108 12687dd9 2023-08-04 jrmu (define remove-peg-y (+ (/ (- new-peg-y old-peg-y) 2) old-peg-y)))
110 12687dd9 2023-08-04 jrmu [(jump? old-peg new-peg aboard)
111 12687dd9 2023-08-04 jrmu (build-board (vector-length aboard)
112 12687dd9 2023-08-04 jrmu (lambda (x y)
114 12687dd9 2023-08-04 jrmu [(and (= x old-peg-x)
115 12687dd9 2023-08-04 jrmu (= y old-peg-y)) false]
116 12687dd9 2023-08-04 jrmu [(and (= x new-peg-x)
117 12687dd9 2023-08-04 jrmu (= y new-peg-y)) true]
118 12687dd9 2023-08-04 jrmu [(and (= x remove-peg-x)
119 12687dd9 2023-08-04 jrmu (= y remove-peg-y)) false]
120 12687dd9 2023-08-04 jrmu [else (vector-ref (vector-ref aboard (sub1 y)) (sub1 x))])))]
121 12687dd9 2023-08-04 jrmu [else empty])))
123 12687dd9 2023-08-04 jrmu ;build-board : N (N N -> X) -> (vectorof (vectorof X))
124 12687dd9 2023-08-04 jrmu ;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 12687dd9 2023-08-04 jrmu (define (build-board n f)
127 12687dd9 2023-08-04 jrmu (build-vector n (lambda (i)
128 12687dd9 2023-08-04 jrmu (build-vector (add1 i) (lambda (j) (f (add1 j) (add1 i)))))))
130 12687dd9 2023-08-04 jrmu ;solitaire : board -> (listof moves), empty, or false
131 12687dd9 2023-08-04 jrmu ;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 12687dd9 2023-08-04 jrmu (define (solitaire aboard0)
134 12687dd9 2023-08-04 jrmu ;;previous-moves is an accumulator that represents the necessary moves to go from
135 12687dd9 2023-08-04 jrmu ;;aboard0 to aboard1
137 12687dd9 2023-08-04 jrmu ((define (solitaire-accu aboard1 previous-moves pegs)
139 12687dd9 2023-08-04 jrmu [(solved? aboard1) previous-moves]
140 12687dd9 2023-08-04 jrmu [(empty? pegs) false]
143 12687dd9 2023-08-04 jrmu ((define first-los (next-states aboard1 (first pegs)))
144 12687dd9 2023-08-04 jrmu (define search-first-peg (solitaire/list-accu first-los previous-moves)))
146 12687dd9 2023-08-04 jrmu [(boolean? search-first-peg)
147 12687dd9 2023-08-04 jrmu (solitaire-accu aboard1 previous-moves (rest pegs))]
148 12687dd9 2023-08-04 jrmu [else search-first-peg]))]))
149 12687dd9 2023-08-04 jrmu (define (solitaire/list-accu alos previous-moves)
151 12687dd9 2023-08-04 jrmu [(empty? alos) false]
154 12687dd9 2023-08-04 jrmu ((define new-moves (append previous-moves
155 12687dd9 2023-08-04 jrmu (list (state-move (first alos)))))
156 12687dd9 2023-08-04 jrmu (define new-board (state-board (first alos)))
157 12687dd9 2023-08-04 jrmu (define search-first-move
158 12687dd9 2023-08-04 jrmu (solitaire-accu new-board new-moves (enabled-pegs new-board))))
160 12687dd9 2023-08-04 jrmu [(boolean? search-first-move)
161 12687dd9 2023-08-04 jrmu (solitaire/list-accu (rest alos) previous-moves)]
162 12687dd9 2023-08-04 jrmu [else search-first-move]))])))
163 12687dd9 2023-08-04 jrmu (solitaire-accu aboard0 empty (enabled-pegs aboard0))))
165 12687dd9 2023-08-04 jrmu ;solitaire-accu : board (listof moves) (listof posns) -> (listof moves) or false
166 12687dd9 2023-08-04 jrmu ;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 12687dd9 2023-08-04 jrmu ;solitaire/list-accu : (listof states) (listof moves) -> (listof moves) or false
171 12687dd9 2023-08-04 jrmu ;solved? : board -> boolean
172 12687dd9 2023-08-04 jrmu ;Determines if aboard is solved
174 12687dd9 2023-08-04 jrmu (define (solved? aboard)
176 12687dd9 2023-08-04 jrmu [(equal? aboard SOLVED-BOARD) true]
177 12687dd9 2023-08-04 jrmu [else false]))
179 12687dd9 2023-08-04 jrmu (define SOLVED-BOARD
180 12687dd9 2023-08-04 jrmu (build-board 6 (lambda (x y)
182 12687dd9 2023-08-04 jrmu [(and (= x 1)
183 12687dd9 2023-08-04 jrmu (= y 1)) true]
184 12687dd9 2023-08-04 jrmu [else false]))))
185 12687dd9 2023-08-04 jrmu (define INITIAL-BOARD
186 12687dd9 2023-08-04 jrmu (build-board 6 (lambda (x y)
188 12687dd9 2023-08-04 jrmu [(and (= x 1)
189 12687dd9 2023-08-04 jrmu (= y 1)) false]
190 12687dd9 2023-08-04 jrmu [else true]))))
192 12687dd9 2023-08-04 jrmu ;enabled-pegs : board -> (listof posns)
193 12687dd9 2023-08-04 jrmu ;Determines all enabled pegs in a given board.
195 12687dd9 2023-08-04 jrmu (define (enabled-pegs aboard)
196 12687dd9 2023-08-04 jrmu (filter (lambda (peg) (enabled? peg aboard))
197 12687dd9 2023-08-04 jrmu (build-peg-list (vector-length aboard) (lambda (x y) (make-posn x y)))))
199 12687dd9 2023-08-04 jrmu ;build-peg-list : N (N N -> X) -> (listof X)
200 12687dd9 2023-08-04 jrmu ;Builds a list that corresponds to positions of an n-sized equilaterial triangle.
202 12687dd9 2023-08-04 jrmu (define (build-peg-list n f)
203 12687dd9 2023-08-04 jrmu (foldr append empty
204 12687dd9 2023-08-04 jrmu (build-list n (lambda (i)
205 12687dd9 2023-08-04 jrmu (build-list (add1 i) (lambda (j) (f (add1 j) (add1 i))))))))
207 12687dd9 2023-08-04 jrmu (solitaire INITIAL-BOARD)
209 12687dd9 2023-08-04 jrmu ;Wish-list:
211 12687dd9 2023-08-04 jrmu ;next-states,
213 12687dd9 2023-08-04 jrmu ;enabled-pegs,
