1  -- N Queens: A genetic approach. --
   2  --         by Frank W.           --
   3  
   4  {-# OPTIONS_GHC -XPatternSignatures #-}
   5  
   6  module Main where
   7  
   8  -- Modules
   9  import Array(Array,listArray,elems)
  10  import Control.Monad(replicateM,liftM)
  11  import Data.List(minimumBy,group,sort,sortBy)
  12  import Data.Ord(comparing)
  13  import System(getArgs)
  14  import System.Random(getStdRandom,randomR)
  15  
  16  -- A board has one int per row, and each int is the column of
  17  -- the queen. So a 2x2 board might be [1, 0] if the queen in
  18  -- the first row is in column 1 and the second row is in column 0.
  19  type Board = [Int]
  20  
  21  -- Make a random board with n rows.
  22  mkBoardR :: Int -> IO Board
  23  mkBoardR n = replicateM n $ getStdRandom $ randomR (0, n-1)
  24  
  25  -- Create a random population with s boards, each with n rows.
  26  initPopR :: Int -> Int -> IO [Board]
  27  initPopR n s = replicateM s $ mkBoardR n
  28  
  29  -- Score a board. Lower is better. The score is the number of
  30  -- attacks happening. Row attacks are impossible by design.
  31  score :: Board -> Int
  32  score b = (countAtt b) + (countAtt $ leftDiags 0 b) + (countAtt $ rightDiags 0 b)
  33            where numAtt n = n * (n - 1)
  34                  countAtt = sum . map (numAtt . length) . group . sort
  35                  leftDiags n []     = []
  36                  leftDiags n (x:xs) = (x+n) : leftDiags (n+1) xs
  37                  rightDiags n = reverse . leftDiags n . reverse
  38  
  39  -- Randomly slide elements down the list.
  40  slideR :: [a] -> IO [a]
  41  slideR []       = return []
  42  slideR [x]      = return [x]
  43  slideR (x:y:xs) = do (c::Float) <- getStdRandom $ randomR (0.0, 1.0)
  44                       if c < 0.33 then do rest <- slideR (y:xs)
  45                                           return (x:rest)
  46                                   else do rest <- slideR (x:xs)
  47                                           return (y:rest)
  48  
  49  -- Make pairs from adjacent list items.
  50  pairs :: [a] -> [(a, a)]
  51  pairs []       = []
  52  pairs [x]      = [(x, x)]
  53  pairs (x:y:xs) = (x, y) : pairs xs
  54  
  55  -- Randomly pair up items in the list.
  56  mkPairsR :: [a] -> IO [(a, a)]
  57  mkPairsR = liftM pairs . slideR
  58  
  59  -- Merge two lists, selecting each element from x or y randomly.
  60  crossR :: [a] -> [a] -> IO [a]
  61  crossR [] _          = return []
  62  crossR _ []          = return []
  63  crossR (x:xs) (y:ys) = do (c::Int) <- getStdRandom $ randomR (0, 1)
  64                            rest <- crossR xs ys
  65                            if c == 0 then return (x:rest) else return (y:rest)
  66  
  67  -- Change a list element to a new value
  68  change :: Int -> a -> [a] -> [a]
  69  change _ _ []     = []
  70  change 0 e (x:xs) = e:xs
  71  change n e (x:xs) = x : (change (n-1) e xs)
  72  
  73  -- Randomly mutate the board.
  74  mutateR :: Board -> IO Board
  75  mutateR b = do let len = length b
  76                 (r::Int) <- getStdRandom $ randomR (0, len - 1)
  77                 (n::Int) <- getStdRandom $ randomR (0, len - 1)
  78                 return $ change r n b               
  79  
  80  -- Combine two boards, with random crossover and mutation.
  81  breedR :: (Board, Board) -> IO Board
  82  breedR (x, y) = do b <- crossR x y
  83                     (c::Int) <- getStdRandom $ randomR (0, 2)
  84                     if c == 0 then mutateR b else return b
  85  
  86  -- Produce a new population from the given population.
  87  reproR :: [Board] -> IO [Board]
  88  reproR pop = do let len = length pop
  89                  let survivors = take (len `div` 2) $ sortBy (comparing score) pop
  90                  parents <- mkPairsR survivors
  91                  sequence $ take len $ map breedR $ cycle parents
  92  
  93  -- Keep producing new generations of the population until a solution is reached.
  94  solve :: [Board] -> IO Board
  95  solve pop = do children <- reproR pop
  96                 let best = minimumBy (comparing score) children
  97                 putStrLn ("Best so far: " ++ (show $ score best))
  98                 if (score best) == 0 then return best else solve children
  99  
 100  -- Takes one argument: The size of the board
 101  main = do [n] <- getArgs
 102            pop <- initPopR (read n) 1000
 103            soln <- solve pop
 104            putStrLn $ "Solution: " ++ (show soln)