From 311b24e79ae8e3ab770405f4c2fa5c27f9e19d40 Mon Sep 17 00:00:00 2001 From: Steven Date: Wed, 29 May 2019 21:20:39 -0400 Subject: Cleaned up --- src/Main.hs | 341 ++++++++---------------------------------------------------- 1 file changed, 41 insertions(+), 300 deletions(-) (limited to 'src') 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 import System.Random import Foreign.Storable import System.IO +import System.Environment -- Open | Attacked | Queen data Square = O | X | Qu deriving (Show, Eq) initBoard = matrix 8 8 $ const O -placeQueen' (r,c) b = placeQueen' $ markAttacked b - where - placeQueen' b = setElem Qu (r,c) b - markAttacked b = rowAttacked $ colAttacked b -- $ diagAttacked b - fX = (\_ x -> X) - rowAttacked b = mapRow fX r b - colAttacked b = mapCol fX c b - -- diagAttacked b = let d = diag (r,c) b - -- attack ap ab = setElem X ap ab - -- attackall [x] = attack x b - -- attackall (x:xs) = attack x (attackall xs) - -- in attackall d --- in last $ map (\p -> setElem X p b) d --- in last $ scanr (\p -> setElem X p) b - ---solve b = placeQueen (nextAvail b) b - -queenAllowed p b = all (== O) $ map snd $ getRowColDiag p b - -placeQueen p b = setElem Qu p $ mapQueensPath (\_ _ -> X) p b - -mapRowColDiag :: ((Int,Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a -mapRowColDiag f (r,c) m = - matrix (nrows m) (ncols m) $ \(i,j) -> - let a = unsafeGet i j m - in if i == r || j == c || elem (i,j) ds - then f (i,j) a - else a - where ds = diag (r,c) m - -getRowColDiag (r,c) m = map (\(i,j) -> ((i,j), getElem i j m)) $ p - where rows = [(r,j) | j <- [1..(ncols m)]] - cols = [(i,c) | i <- [1..(nrows m)]] - ds = diag (r,c) m - p = nub $ rows ++ cols ++ ds - -mapQueensPath :: ((Int,Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a -mapQueensPath f p b = mapRowColDiag f p b - -allPositions = [(i,j) | i <- [1..8], j <- [1..8]] - -scanBoard s b = [(i,j) | (i,j) <- allPositions, (getElem i j b) == s] - -openPositions b = scanBoard O b ---mapOpenPositions f b = map f $ openPositions b - -nextAvail b = head $ takeWhile (\x -> queenAllowed x b) $ openPositions b - -getRowL r b = map (\x -> b ! (r,x)) [1..8] -getColL c b = map (\x -> b ! (x,c)) [1..8] -getDiagL p b = map (\x -> b ! x) $ diag p b - - -isWinnable n b = n <= rowsAvail && n <= colsAvail - where availOn axisF = - maximum $ map (length) $ - map (filter (== O)) $ - map (\x -> axisF x b) [1..8] - rowsAvail = availOn getRowL - colsAvail = availOn getColL - -isWinnable' n b = "rs: " ++ show rowsAvail ++ " | cs: " ++ show colsAvail - where availOn axisF = - maximum $ map (length) $ - map (filter (== O)) $ - map (\x -> axisF x b) [1..8] - rowsAvail = availOn getRowL - colsAvail = availOn getColL - -- calc free rows, free cols vs remaining queens - -w = winners' 1 initBoard - - - - --- solve n = tryAll n initBoard --- where tryAll 1 b = safePos 0 b --- tryall n b = safePos n $ tryAll (n-1) b --- safePos n b = map (\x -> placeQueen x b) $ --- filter (\x -> queenAllowed x b && isWinnable n b) $ openPositions b - --- WAS HERE --- solve n = winners n [initBoard] --- where --- winners 1 b = concat $ map (winners' 1) b --- winners n b = winners (n-1) $ concat $ map (winners' (n-1)) b --- winners' n ab = map (\x -> placeQueen x ab) $ --- filter (\x -> queenAllowed x ab && isWinnable n ab) $ --- openPositions ab - +main :: IO () +main = do + args <- getArgs + let n = read $ head args :: Int + in putStrLn $ show $ solve n +solve :: Int -> [Matrix Square] solve n | n < 1 || n > 8 = [] | otherwise = solveN n where place :: [Matrix Square] -> [Matrix Square] place bs = concat $ map (\b -> map (\p -> placeQueen p b) (openPositions b)) bs - -- map (\b -> map (\p -> placeQueen p b) (openPositions b)) [initBoard] - solveN 0 = [] + solveN 0 = [] -- ghc thinks I need this; I'm not so sure solveN 1 = place [initBoard] solveN n = place (solveN (n-1)) --- solveN n = place (solveN (n-1)) - --- solveN n f = map place f - -- solveN n = place (solveN (n-1)) - -- applyN 1 f = f - -- applyN n f = f (applyN (n-1) f) - - -winners 1 b = concat $ map (winners' 1) b -winners n b = winners (n-1) $ concat $ map (winners' n) b -winners' n ab = map (\x -> placeQueen x ab) $ - filter (\x -> queenAllowed x ab) $ - openPositions ab - - ---s b = map (\y -> placeQueen y b) $ filter (\x -> queenAllowed x b) $ openPositions b -s b = map (\y -> placeQueen y b) $ filter (\x -> queenAllowed x b) $ openPositions b - - --- solve n = times n tryAll n initBoard --- where --- times 0 b _ = print "Solution: \n" ++ show b --- times 1 b p = b --- times x b p = let nb = b --- in times (x-1) $ tryAll x nb --- allPositions b = map (\x -> placeQueen x b) $ openPositions b --- tryAll n b = filter (\x -> queenAllowed x b && isWinnable n b) $ allPositions - - --- solve n = times n $ exhaust n initBoard --- where exhaust n b = filter lookAhead $ map (\x -> placeQueen x b) $ openPositions b --- lookAhead b stillNeed = isWinnable stillNeeded b --- times 1 b p = b --- times x b p = let nb = b --- in times (x-1) $ exhaust (x-1) b - - --- solve n = times n $ placeQueen (nextAvail initBoard) initBoard --- tryAll n b = let a = isWinnable placeQueen n b --- in if a then a else tryAt (n+1) b --- times 1 b p = b --- times x b p = let nb = b --- in times (x-1) $ placeQueen (nextAvail nb) nb - - --- solve' n = times n $ placeQueen (nextAvail initBoard) initBoard --- where --- -- with x = --- -- place' 0 b = b --- -- place' n b = placeQueen (nextAvail b) $ place' (n-1) --- -- place n b = placeQueen (nextAvail b) $ place --- -- place' n b = place (n-1) $ placeQueen (nextAvail initBoard) initBoard --- -- place n = place' (n-1) $ placeQueen (nextAvail initBoard) initBoard --- nextFunc 1 = nextAvail --- nextFunc x = nextAvail $ nextFunc (x-1) --- times 1 b = b --- times x b = let nb = b --- na = nextAvail nb --- in times (x-1) $ placeQueen (na) nb - - - -- times 0 f p b = undefined - -- times x f p b = times (x-1) $ f p b - - -- place n r = place (n-1) $ place' n r - -- place 0 r = r - -- place' n r = placeQueen (nextAvail r) r - - --- togglePosition :: (Int,Int) -> f -> t -> Matrix a -> Matrix a --- togglePosition p b = +queenAllowed p b = all (== O) $ map snd $ getRowColDiag p b +placeQueen p b = setElem Qu p $ mapQueensPath (\_ _ -> X) p b --- solve b = placeQueen n --- where n = nextAvail b --- next = placeQueen n --- solve' = +allPositions = [(i,j) | i <- [1..8], j <- [1..8]] +scanBoard s b = [(i,j) | (i,j) <- allPositions, (getElem i j b) == s] --- solve b = --- where solve' b = (\n = placeQueen $ nextAvail b) +openPositions b = scanBoard O b +mapQueensPath :: ((Int,Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a +mapQueensPath f p b = mapRowColDiag f p b --- solve b = second --- where first = placeQueen (nextAvail b) b --- second = placeQueen (nextAvail first) first +markX p b = setElem X p b --- solve' b = s (nA b) b --- where s n b = placeQueen n b --- nA b = nextAvail b diag :: (Int,Int) -> Matrix a -> [(Int,Int)] diag c m = apply c where ops = (\a b -> [(a,a),(a,b),(b,a),(b,b)]) (+1) (subtract 1) - -- applyop (x,y) (a,b) = (a x,b y) applyopR (x,y) (fa,fb) = traverse' (\(i,j) -> (fa i, fb j)) (x,y) traverse' dir p = takeWhile inBounds $ iterate dir p inBounds (i,j) = i >= 1 && i <= nrows m && j >= 1 && j <= ncols m --- applyops p = map ((`applyopR` p)) ops --- apply x = concat $ map (applyopR x) $ applyops x apply x = concat $ map (applyopR x) ops ---diag r c = [(x,y) | x <- [1..8], y <- [1..8], (abs x-y) == 1 ] -diag'' r c = let rl = [1..r] - rr = [r..8] - cu = [1..c] - cd = [c..8] +-- did this 2 ways; not sure why I like above better; mostly cuz +diag' r c = let rl = [1..r] + rr = [r..8] + cu = [1..c] + cd = [c..8] in zip rl cu ++ zip rr cd ++ zip (reverse rl) cd ++ zip (reverse rr) cu -allops a b = [(a, a), (a, b), (b, a), (b, b)] -ops = allops (+1) (subtract 1) -applyop (x,y) (a,b) = (a x,b y) -applyops p = map (applyop p) ops + +-- some of this next shit would've been nice to have already been Data.Matrix +mapRowColDiag :: ((Int,Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a +mapRowColDiag f (r,c) m = + matrix (nrows m) (ncols m) $ \(i,j) -> + let a = unsafeGet i j m + in if i == r || j == c || elem (i,j) ds + then f (i,j) a + else a + where ds = diag (r,c) m + +getRowColDiag (r,c) m = map (\(i,j) -> ((i,j), getElem i j m)) $ p + where rows = [(r,j) | j <- [1..(ncols m)]] + cols = [(i,c) | i <- [1..(nrows m)]] + ds = diag (r,c) m + p = nub $ rows ++ cols ++ ds + +getRowL r b = map (\x -> b ! (r,x)) [1..8] +getColL c b = map (\x -> b ! (x,c)) [1..8] +getDiagL p b = map (\x -> b ! x) $ diag p b mapDiag :: ((Int, Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a mapDiag f p m = @@ -242,116 +96,3 @@ mapDiag f p m = in if elem (i,j) diags then f (i, j) a else a - - --- mapDiag f c b = map (\(x,y) -> setElem f (x,y) b) ds --- where ds = diag'' c - --- mapDiag' f c b = map (on b f) ds where ds = diag'' c on b x p = let next bo = --- set x p bo in map (next) b set x p b = setElem x p b - ---mapDiag'' f c b = take 10 $ iterate (map (set f) ds) b --- mapDiag'' f c b = take 10 $ iterate ( --- where ds = diag'' c --- eachD' p = setElem f p --- eachD [p] = eachD' p --- eachD (p:ps) = eachD' p : eachD ps - -markX p b = setElem X p b - --- mapDiag'' f p b = applyfs fs b --- where ds = diag'' p --- fs = map (\x y -> markX x y) ds --- applyfs [x] b = x b --- applyfs (x:xs) b = applyfs x (applyfs xs) - - -onBoard b f = let next n = f n - in next b - ---eB = mapDiag''' (\_ -> 1) (5,5) $ matrix 8 8 (\_ -> 0) - - --- opfs ops = map (\(o1,o2) -> (\(x,y) -> (o1 x, o2 y))) ops --- applyops x = map x opfs --- ops = map ( - --applyops (x,y) = map (($ x), ($ y)) $ allops (+1) (-1) --- fx a b = map \((oa,ob) -> ((cx,cy) -> (oa cx, ob cy))) $ allops (+1) (-1) - --applyops x = [(((fst f) (fst x)), ((snd f) (snd x))) | f <- allops (+1) (-1)] --- applyops x = (fst x, snd x) --- applyops x = map \((p,m) -> (p (fst x), m (snd x))) $ allops (+1) (-1) --- apply c = map (\(p,m) -> (p (fst c), m (snd c))) $ allops (+1) (-1) --- apply ops c = [( (fst o) (fst c), (snd o) (snd c) | o <- ops - - - --- diag (r,c) b = --- where l = (r-1,c-1) --- r = (r+1,c+1) --- lowbound = 1 --- highbound = 8 - - ---initBoard = (8><8) $ repeat O - ---firstOpen b = take 1 [(r,c)| r <- [1..8], c <- [1..8], b ! (r,c) == O] - --- firstOpen b = let --- elem x y = b ! (x, y) --- in map - --- nextOpen b = - --- solve = let board = initBoard - ---avail r c b = - ---rowOccupied r b = any (== Q) $ getRow r b - - - --- diags p = let r = r p --- l = l p --- in p : inRange r --- where inRange x = x >= 1 && x <= 8 --- inRange' (x,y) = inRange (x) && inRange (y) --- r x = (fst x + 1, snd x + 1) --- l x = (fst x - 1, snd x - 1) --- nexts x = diags' x --- diags' x = [(fst x - 1, snd x -1), (fst x + 1, snd x + 1)] --- -- down x = (fst x - 1, snd x - 1) --- -- down (r,c) = let d = (r-1,c-1) in if inRange d then d : down d else --- -- up (r,c) = let u = (r+1,c+1) in u : up u - - ---mapDiag r c = undefined - ---placeAll = repeat 8 placeQueen - -winnable = undefined - -nextOpen board = undefined - --- placeQueen r c = - ---b = getE - ---placeQueen r c b = b ^. - --- rand = do --- g <- newStdGen --- print $ take 8 $ (randomRs (0, 8) g) - - --- try r c = let next b = placeQueen r c b --- in next initBoard - --- try' p = let next b = p b --- in next initBoard - - ---res = [ try x y | x <- lo8, y <- lo8 ] - -main :: IO () -main = - putStrLn "Hi" -- cgit v1.2.3