From cbe440bb0adbfbccfdbbcedb29bf9408c0596866 Mon Sep 17 00:00:00 2001 From: Steven Date: Wed, 29 May 2019 20:06:05 -0400 Subject: Initial repository; needs clean up but it's working so let's not lose it --- src/8queens.hs | 18 +++ src/Main.hs | 357 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 375 insertions(+) create mode 100644 src/8queens.hs create mode 100644 src/Main.hs (limited to 'src') diff --git a/src/8queens.hs b/src/8queens.hs new file mode 100644 index 0000000..e8020ed --- /dev/null +++ b/src/8queens.hs @@ -0,0 +1,18 @@ +module EightQueens +( + main +) where + +--import Linear.Vector +import Linear.V2 +--import Linear.V3 +import Control.Lens + +data Square = X | Q + +board = V2 <$> [0..8] <*> [0..8] +--board = V3 <$> [0..8] <*> [0..8] <*> [X] +row p = undefined + +main = undefined +--main = repeat 8 placeQueen $ board diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..5a66878 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Main where + +import Control.Lens +import Control.Applicative +import Linear.V2 +import Linear.V3 +import Data.Matrix +import Data.List +import qualified Data.Vector as V +--import Numeric.LinearAlgebra +import System.Random +import Foreign.Storable +import System.IO + +-- 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 + + +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 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 = + +-- solve b = placeQueen n +-- where n = nextAvail b +-- next = placeQueen n +-- solve' = + +-- solve b = +-- where solve' b = (\n = placeQueen $ nextAvail b) + +-- solve b = second +-- where first = placeQueen (nextAvail b) b +-- second = placeQueen (nextAvail first) first + +-- 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] + 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 + +mapDiag :: ((Int, Int) -> a -> a) -> (Int,Int) -> Matrix a -> Matrix a +mapDiag f p m = + let diags = diag p m + in matrix (nrows m) (ncols m) $ \(i, j) -> + let a = unsafeGet i j 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