diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Main.hs | 341 |
1 files changed, 41 insertions, 300 deletions
diff --git a/src/Main.hs b/src/Main.hs index 5a66878..8a593f3 100644 --- a/src/Main.hs +++ b/src/Main.hs | |||
@@ -13,226 +13,80 @@ import qualified Data.Vector as V | |||
13 | import System.Random | 13 | import System.Random |
14 | import Foreign.Storable | 14 | import Foreign.Storable |
15 | import System.IO | 15 | import System.IO |
16 | import System.Environment | ||
16 | 17 | ||
17 | -- Open | Attacked | Queen | 18 | -- Open | Attacked | Queen |
18 | data Square = O | X | Qu deriving (Show, Eq) | 19 | data Square = O | X | Qu deriving (Show, Eq) |
19 | 20 | ||
20 | initBoard = matrix 8 8 $ const O | 21 | initBoard = matrix 8 8 $ const O |
21 | 22 | ||
22 | placeQueen' (r,c) b = placeQueen' $ markAttacked b | 23 | main :: IO () |
23 | where | 24 | main = do |
24 | placeQueen' b = setElem Qu (r,c) b | 25 | args <- getArgs |
25 | markAttacked b = rowAttacked $ colAttacked b -- $ diagAttacked b | 26 | let n = read $ head args :: Int |
26 | fX = (\_ x -> X) | 27 | in putStrLn $ show $ solve n |
27 | rowAttacked b = mapRow fX r b | ||
28 | colAttacked b = mapCol fX c b | ||
29 | -- diagAttacked b = let d = diag (r,c) b | ||
30 | -- attack ap ab = setElem X ap ab | ||
31 | -- attackall [x] = attack x b | ||
32 | -- attackall (x:xs) = attack x (attackall xs) | ||
33 | -- in attackall d | ||
34 | -- in last $ map (\p -> setElem X p b) d | ||
35 | -- in last $ scanr (\p -> setElem X p) b | ||
36 | |||
37 | --solve b = placeQueen (nextAvail b) b | ||
38 | |||
39 | queenAllowed p b = all (== O) $ map snd $ getRowColDiag p b | ||
40 | |||
41 | placeQueen p b = setElem Qu p $ mapQueensPath (\_ _ -> X) p b | ||
42 | |||
43 | mapRowColDiag :: ((Int,Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a | ||
44 | mapRowColDiag f (r,c) m = | ||
45 | matrix (nrows m) (ncols m) $ \(i,j) -> | ||
46 | let a = unsafeGet i j m | ||
47 | in if i == r || j == c || elem (i,j) ds | ||
48 | then f (i,j) a | ||
49 | else a | ||
50 | where ds = diag (r,c) m | ||
51 | |||
52 | getRowColDiag (r,c) m = map (\(i,j) -> ((i,j), getElem i j m)) $ p | ||
53 | where rows = [(r,j) | j <- [1..(ncols m)]] | ||
54 | cols = [(i,c) | i <- [1..(nrows m)]] | ||
55 | ds = diag (r,c) m | ||
56 | p = nub $ rows ++ cols ++ ds | ||
57 | |||
58 | mapQueensPath :: ((Int,Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a | ||
59 | mapQueensPath f p b = mapRowColDiag f p b | ||
60 | |||
61 | allPositions = [(i,j) | i <- [1..8], j <- [1..8]] | ||
62 | |||
63 | scanBoard s b = [(i,j) | (i,j) <- allPositions, (getElem i j b) == s] | ||
64 | |||
65 | openPositions b = scanBoard O b | ||
66 | --mapOpenPositions f b = map f $ openPositions b | ||
67 | |||
68 | nextAvail b = head $ takeWhile (\x -> queenAllowed x b) $ openPositions b | ||
69 | |||
70 | getRowL r b = map (\x -> b ! (r,x)) [1..8] | ||
71 | getColL c b = map (\x -> b ! (x,c)) [1..8] | ||
72 | getDiagL p b = map (\x -> b ! x) $ diag p b | ||
73 | |||
74 | |||
75 | isWinnable n b = n <= rowsAvail && n <= colsAvail | ||
76 | where availOn axisF = | ||
77 | maximum $ map (length) $ | ||
78 | map (filter (== O)) $ | ||
79 | map (\x -> axisF x b) [1..8] | ||
80 | rowsAvail = availOn getRowL | ||
81 | colsAvail = availOn getColL | ||
82 | |||
83 | isWinnable' n b = "rs: " ++ show rowsAvail ++ " | cs: " ++ show colsAvail | ||
84 | where availOn axisF = | ||
85 | maximum $ map (length) $ | ||
86 | map (filter (== O)) $ | ||
87 | map (\x -> axisF x b) [1..8] | ||
88 | rowsAvail = availOn getRowL | ||
89 | colsAvail = availOn getColL | ||
90 | -- calc free rows, free cols vs remaining queens | ||
91 | |||
92 | w = winners' 1 initBoard | ||
93 | |||
94 | |||
95 | |||
96 | |||
97 | -- solve n = tryAll n initBoard | ||
98 | -- where tryAll 1 b = safePos 0 b | ||
99 | -- tryall n b = safePos n $ tryAll (n-1) b | ||
100 | -- safePos n b = map (\x -> placeQueen x b) $ | ||
101 | -- filter (\x -> queenAllowed x b && isWinnable n b) $ openPositions b | ||
102 | |||
103 | -- WAS HERE | ||
104 | -- solve n = winners n [initBoard] | ||
105 | -- where | ||
106 | -- winners 1 b = concat $ map (winners' 1) b | ||
107 | -- winners n b = winners (n-1) $ concat $ map (winners' (n-1)) b | ||
108 | -- winners' n ab = map (\x -> placeQueen x ab) $ | ||
109 | -- filter (\x -> queenAllowed x ab && isWinnable n ab) $ | ||
110 | -- openPositions ab | ||
111 | |||
112 | 28 | ||
29 | solve :: Int -> [Matrix Square] | ||
113 | solve n | 30 | solve n |
114 | | n < 1 || n > 8 = [] | 31 | | n < 1 || n > 8 = [] |
115 | | otherwise = solveN n | 32 | | otherwise = solveN n |
116 | where | 33 | where |
117 | place :: [Matrix Square] -> [Matrix Square] | 34 | place :: [Matrix Square] -> [Matrix Square] |
118 | place bs = concat $ map (\b -> map (\p -> placeQueen p b) (openPositions b)) bs | 35 | place bs = concat $ map (\b -> map (\p -> placeQueen p b) (openPositions b)) bs |
119 | -- map (\b -> map (\p -> placeQueen p b) (openPositions b)) [initBoard] | 36 | solveN 0 = [] -- ghc thinks I need this; I'm not so sure |
120 | solveN 0 = [] | ||
121 | solveN 1 = place [initBoard] | 37 | solveN 1 = place [initBoard] |
122 | solveN n = place (solveN (n-1)) | 38 | solveN n = place (solveN (n-1)) |
123 | 39 | ||
124 | 40 | ||
125 | -- solveN n = place (solveN (n-1)) | 41 | queenAllowed p b = all (== O) $ map snd $ getRowColDiag p b |
126 | 42 | placeQueen p b = setElem Qu p $ mapQueensPath (\_ _ -> X) p b | |
127 | -- solveN n f = map place f | ||
128 | -- solveN n = place (solveN (n-1)) | ||
129 | -- applyN 1 f = f | ||
130 | -- applyN n f = f (applyN (n-1) f) | ||
131 | |||
132 | |||
133 | winners 1 b = concat $ map (winners' 1) b | ||
134 | winners n b = winners (n-1) $ concat $ map (winners' n) b | ||
135 | winners' n ab = map (\x -> placeQueen x ab) $ | ||
136 | filter (\x -> queenAllowed x ab) $ | ||
137 | openPositions ab | ||
138 | |||
139 | |||
140 | --s b = map (\y -> placeQueen y b) $ filter (\x -> queenAllowed x b) $ openPositions b | ||
141 | s b = map (\y -> placeQueen y b) $ filter (\x -> queenAllowed x b) $ openPositions b | ||
142 | |||
143 | |||
144 | -- solve n = times n tryAll n initBoard | ||
145 | -- where | ||
146 | -- times 0 b _ = print "Solution: \n" ++ show b | ||
147 | -- times 1 b p = b | ||
148 | -- times x b p = let nb = b | ||
149 | -- in times (x-1) $ tryAll x nb | ||
150 | -- allPositions b = map (\x -> placeQueen x b) $ openPositions b | ||
151 | -- tryAll n b = filter (\x -> queenAllowed x b && isWinnable n b) $ allPositions | ||
152 | |||
153 | |||
154 | -- solve n = times n $ exhaust n initBoard | ||
155 | -- where exhaust n b = filter lookAhead $ map (\x -> placeQueen x b) $ openPositions b | ||
156 | -- lookAhead b stillNeed = isWinnable stillNeeded b | ||
157 | -- times 1 b p = b | ||
158 | -- times x b p = let nb = b | ||
159 | -- in times (x-1) $ exhaust (x-1) b | ||
160 | |||
161 | |||
162 | -- solve n = times n $ placeQueen (nextAvail initBoard) initBoard | ||
163 | -- tryAll n b = let a = isWinnable placeQueen n b | ||
164 | -- in if a then a else tryAt (n+1) b | ||
165 | -- times 1 b p = b | ||
166 | -- times x b p = let nb = b | ||
167 | -- in times (x-1) $ placeQueen (nextAvail nb) nb | ||
168 | |||
169 | |||
170 | -- solve' n = times n $ placeQueen (nextAvail initBoard) initBoard | ||
171 | -- where | ||
172 | -- -- with x = | ||
173 | -- -- place' 0 b = b | ||
174 | -- -- place' n b = placeQueen (nextAvail b) $ place' (n-1) | ||
175 | -- -- place n b = placeQueen (nextAvail b) $ place | ||
176 | -- -- place' n b = place (n-1) $ placeQueen (nextAvail initBoard) initBoard | ||
177 | -- -- place n = place' (n-1) $ placeQueen (nextAvail initBoard) initBoard | ||
178 | -- nextFunc 1 = nextAvail | ||
179 | -- nextFunc x = nextAvail $ nextFunc (x-1) | ||
180 | -- times 1 b = b | ||
181 | -- times x b = let nb = b | ||
182 | -- na = nextAvail nb | ||
183 | -- in times (x-1) $ placeQueen (na) nb | ||
184 | |||
185 | |||
186 | -- times 0 f p b = undefined | ||
187 | -- times x f p b = times (x-1) $ f p b | ||
188 | |||
189 | -- place n r = place (n-1) $ place' n r | ||
190 | -- place 0 r = r | ||
191 | -- place' n r = placeQueen (nextAvail r) r | ||
192 | |||
193 | |||
194 | -- togglePosition :: (Int,Int) -> f -> t -> Matrix a -> Matrix a | ||
195 | -- togglePosition p b = | ||
196 | 43 | ||
197 | -- solve b = placeQueen n | 44 | allPositions = [(i,j) | i <- [1..8], j <- [1..8]] |
198 | -- where n = nextAvail b | 45 | scanBoard s b = [(i,j) | (i,j) <- allPositions, (getElem i j b) == s] |
199 | -- next = placeQueen n | ||
200 | -- solve' = | ||
201 | 46 | ||
202 | -- solve b = | 47 | openPositions b = scanBoard O b |
203 | -- where solve' b = (\n = placeQueen $ nextAvail b) | 48 | mapQueensPath :: ((Int,Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a |
49 | mapQueensPath f p b = mapRowColDiag f p b | ||
204 | 50 | ||
205 | -- solve b = second | 51 | markX p b = setElem X p b |
206 | -- where first = placeQueen (nextAvail b) b | ||
207 | -- second = placeQueen (nextAvail first) first | ||
208 | 52 | ||
209 | -- solve' b = s (nA b) b | ||
210 | -- where s n b = placeQueen n b | ||
211 | -- nA b = nextAvail b | ||
212 | diag :: (Int,Int) -> Matrix a -> [(Int,Int)] | 53 | diag :: (Int,Int) -> Matrix a -> [(Int,Int)] |
213 | diag c m = apply c | 54 | diag c m = apply c |
214 | where | 55 | where |
215 | ops = (\a b -> [(a,a),(a,b),(b,a),(b,b)]) (+1) (subtract 1) | 56 | ops = (\a b -> [(a,a),(a,b),(b,a),(b,b)]) (+1) (subtract 1) |
216 | -- applyop (x,y) (a,b) = (a x,b y) | ||
217 | applyopR (x,y) (fa,fb) = traverse' (\(i,j) -> (fa i, fb j)) (x,y) | 57 | applyopR (x,y) (fa,fb) = traverse' (\(i,j) -> (fa i, fb j)) (x,y) |
218 | traverse' dir p = takeWhile inBounds $ iterate dir p | 58 | traverse' dir p = takeWhile inBounds $ iterate dir p |
219 | inBounds (i,j) = i >= 1 && i <= nrows m && j >= 1 && j <= ncols m | 59 | inBounds (i,j) = i >= 1 && i <= nrows m && j >= 1 && j <= ncols m |
220 | -- applyops p = map ((`applyopR` p)) ops | ||
221 | -- apply x = concat $ map (applyopR x) $ applyops x | ||
222 | apply x = concat $ map (applyopR x) ops | 60 | apply x = concat $ map (applyopR x) ops |
223 | 61 | ||
224 | --diag r c = [(x,y) | x <- [1..8], y <- [1..8], (abs x-y) == 1 ] | 62 | -- did this 2 ways; not sure why I like above better; mostly cuz |
225 | diag'' r c = let rl = [1..r] | 63 | diag' r c = let rl = [1..r] |
226 | rr = [r..8] | 64 | rr = [r..8] |
227 | cu = [1..c] | 65 | cu = [1..c] |
228 | cd = [c..8] | 66 | cd = [c..8] |
229 | in zip rl cu ++ zip rr cd ++ | 67 | in zip rl cu ++ zip rr cd ++ |
230 | zip (reverse rl) cd ++ zip (reverse rr) cu | 68 | zip (reverse rl) cd ++ zip (reverse rr) cu |
231 | 69 | ||
232 | allops a b = [(a, a), (a, b), (b, a), (b, b)] | 70 | |
233 | ops = allops (+1) (subtract 1) | 71 | -- some of this next shit would've been nice to have already been Data.Matrix |
234 | applyop (x,y) (a,b) = (a x,b y) | 72 | mapRowColDiag :: ((Int,Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a |
235 | applyops p = map (applyop p) ops | 73 | mapRowColDiag f (r,c) m = |
74 | matrix (nrows m) (ncols m) $ \(i,j) -> | ||
75 | let a = unsafeGet i j m | ||
76 | in if i == r || j == c || elem (i,j) ds | ||
77 | then f (i,j) a | ||
78 | else a | ||
79 | where ds = diag (r,c) m | ||
80 | |||
81 | getRowColDiag (r,c) m = map (\(i,j) -> ((i,j), getElem i j m)) $ p | ||
82 | where rows = [(r,j) | j <- [1..(ncols m)]] | ||
83 | cols = [(i,c) | i <- [1..(nrows m)]] | ||
84 | ds = diag (r,c) m | ||
85 | p = nub $ rows ++ cols ++ ds | ||
86 | |||
87 | getRowL r b = map (\x -> b ! (r,x)) [1..8] | ||
88 | getColL c b = map (\x -> b ! (x,c)) [1..8] | ||
89 | getDiagL p b = map (\x -> b ! x) $ diag p b | ||
236 | 90 | ||
237 | mapDiag :: ((Int, Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a | 91 | mapDiag :: ((Int, Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a |
238 | mapDiag f p m = | 92 | mapDiag f p m = |
@@ -242,116 +96,3 @@ mapDiag f p m = | |||
242 | in if elem (i,j) diags | 96 | in if elem (i,j) diags |
243 | then f (i, j) a | 97 | then f (i, j) a |
244 | else a | 98 | else a |
245 | |||
246 | |||
247 | -- mapDiag f c b = map (\(x,y) -> setElem f (x,y) b) ds | ||
248 | -- where ds = diag'' c | ||
249 | |||
250 | -- mapDiag' f c b = map (on b f) ds where ds = diag'' c on b x p = let next bo = | ||
251 | -- set x p bo in map (next) b set x p b = setElem x p b | ||
252 | |||
253 | --mapDiag'' f c b = take 10 $ iterate (map (set f) ds) b | ||
254 | -- mapDiag'' f c b = take 10 $ iterate ( | ||
255 | -- where ds = diag'' c | ||
256 | -- eachD' p = setElem f p | ||
257 | -- eachD [p] = eachD' p | ||
258 | -- eachD (p:ps) = eachD' p : eachD ps | ||
259 | |||
260 | markX p b = setElem X p b | ||
261 | |||
262 | -- mapDiag'' f p b = applyfs fs b | ||
263 | -- where ds = diag'' p | ||
264 | -- fs = map (\x y -> markX x y) ds | ||
265 | -- applyfs [x] b = x b | ||
266 | -- applyfs (x:xs) b = applyfs x (applyfs xs) | ||
267 | |||
268 | |||
269 | onBoard b f = let next n = f n | ||
270 | in next b | ||
271 | |||
272 | --eB = mapDiag''' (\_ -> 1) (5,5) $ matrix 8 8 (\_ -> 0) | ||
273 | |||
274 | |||
275 | -- opfs ops = map (\(o1,o2) -> (\(x,y) -> (o1 x, o2 y))) ops | ||
276 | -- applyops x = map x opfs | ||
277 | -- ops = map ( | ||
278 | --applyops (x,y) = map (($ x), ($ y)) $ allops (+1) (-1) | ||
279 | -- fx a b = map \((oa,ob) -> ((cx,cy) -> (oa cx, ob cy))) $ allops (+1) (-1) | ||
280 | --applyops x = [(((fst f) (fst x)), ((snd f) (snd x))) | f <- allops (+1) (-1)] | ||
281 | -- applyops x = (fst x, snd x) | ||
282 | -- applyops x = map \((p,m) -> (p (fst x), m (snd x))) $ allops (+1) (-1) | ||
283 | -- apply c = map (\(p,m) -> (p (fst c), m (snd c))) $ allops (+1) (-1) | ||
284 | -- apply ops c = [( (fst o) (fst c), (snd o) (snd c) | o <- ops | ||
285 | |||
286 | |||
287 | |||
288 | -- diag (r,c) b = | ||
289 | -- where l = (r-1,c-1) | ||
290 | -- r = (r+1,c+1) | ||
291 | -- lowbound = 1 | ||
292 | -- highbound = 8 | ||
293 | |||
294 | |||
295 | --initBoard = (8><8) $ repeat O | ||
296 | |||
297 | --firstOpen b = take 1 [(r,c)| r <- [1..8], c <- [1..8], b ! (r,c) == O] | ||
298 | |||
299 | -- firstOpen b = let | ||
300 | -- elem x y = b ! (x, y) | ||
301 | -- in map | ||
302 | |||
303 | -- nextOpen b = | ||
304 | |||
305 | -- solve = let board = initBoard | ||
306 | |||
307 | --avail r c b = | ||
308 | |||
309 | --rowOccupied r b = any (== Q) $ getRow r b | ||
310 | |||
311 | |||
312 | |||
313 | -- diags p = let r = r p | ||
314 | -- l = l p | ||
315 | -- in p : inRange r | ||
316 | -- where inRange x = x >= 1 && x <= 8 | ||
317 | -- inRange' (x,y) = inRange (x) && inRange (y) | ||
318 | -- r x = (fst x + 1, snd x + 1) | ||
319 | -- l x = (fst x - 1, snd x - 1) | ||
320 | -- nexts x = diags' x | ||
321 | -- diags' x = [(fst x - 1, snd x -1), (fst x + 1, snd x + 1)] | ||
322 | -- -- down x = (fst x - 1, snd x - 1) | ||
323 | -- -- down (r,c) = let d = (r-1,c-1) in if inRange d then d : down d else | ||
324 | -- -- up (r,c) = let u = (r+1,c+1) in u : up u | ||
325 | |||
326 | |||
327 | --mapDiag r c = undefined | ||
328 | |||
329 | --placeAll = repeat 8 placeQueen | ||
330 | |||
331 | winnable = undefined | ||
332 | |||
333 | nextOpen board = undefined | ||
334 | |||
335 | -- placeQueen r c = | ||
336 | |||
337 | --b = getE | ||
338 | |||
339 | --placeQueen r c b = b ^. | ||
340 | |||
341 | -- rand = do | ||
342 | -- g <- newStdGen | ||
343 | -- print $ take 8 $ (randomRs (0, 8) g) | ||
344 | |||
345 | |||
346 | -- try r c = let next b = placeQueen r c b | ||
347 | -- in next initBoard | ||
348 | |||
349 | -- try' p = let next b = p b | ||
350 | -- in next initBoard | ||
351 | |||
352 | |||
353 | --res = [ try x y | x <- lo8, y <- lo8 ] | ||
354 | |||
355 | main :: IO () | ||
356 | main = | ||
357 | putStrLn "Hi" | ||