Permutations with constraints – magic square

type Constraints a = [(Int->Bool, [[a]->Bool])]

permute::Constraints a->[a]->[[a]]
permute cs xs = map fst $ permute' cs (length xs) [([],xs)]

-- The elements of the tuples are partial permutation and unallocated elements
permute'::Constraints a->Int->[([a],[a])] -> [([a],[a])] 
permute' _ 0 xs = xs
permute' cs level xs = 
   permute' cs (level - 1) $ 
   filter ((constraints cs level).fst) $ 
   concat $ map permute'' xs

-- generate the next level of permutation of a single item
permute''::([a],[a])->[([a],[a])]
permute'' (xs,ys) = map (\(y,y')->((y:xs),y')) $ picks ys

-- generate all the ways to pick one item from a list
picks::[a]->[(a,[a])] 
picks xs = map picks' $ splits xs

picks'::([a],[a]) -> (a,[a])
picks' (xs, ys) = ((head ys),(xs ++ tail ys))

-- generate all the ways to split a list
splits::[a]->[([a],[a])]
splits [] = []
splits (x:xs) = ([],x:xs):[(x:ls,rs) | (ls,rs)<-splits xs]



newtype Predicate a = Predicate {getPredicate::(a->Bool)} -- works as data or newtype

{- Before GHC 8.4, mappend (<>) was declared in Monoid. Semigroup is now a superclass of Monoid and the instances have to be declared separately. -}
instance Semigroup (Predicate a) where
  (Predicate f) <> (Predicate g) = Predicate (\x->((f x) && (g x)))
  
instance Monoid (Predicate a) where
  mempty = Predicate (\_->True)
  
-- combine all the constraints for this level
constraints :: Constraints a -> Int -> ([a]->Bool)
constraints cs level = 
    getPredicate $ 
    foldMap Predicate $
    concat $ map snd $
    filter (\x -> (fst x) level) cs  


-- constraints for magic square
-- note that permutations are built in reverse order, so most recently added element is first (x!!0)
-- and levels are built in descending order
msconstraints :: Constraints Int
msconstraints = [ 
  ((\x->elem x [7,4,1]),[\x->x!!0 == 15 - x!!1 - x!!2]),  -- rows
  ((\x->elem x [3,2,1]),[\x->x!!0 == 15 - x!!3 - x!!6]),  -- columns
  ((== 3),              [\x->x!!0 == 15 - x!!2 - x!!4]),  -- diagonal 1
  ((== 1),              [\x->x!!0 == 15 - x!!4 - x!!8]),  -- diagonal 2
  
  -- redundant constraints included for efficiency 
  ((== 5),             [(\x->(5 == x!!0))]),
  ((== 9),             [(\x->(even (x!!0)))]),
  ((\x->elem x [6,8]), [\x->(odd (x!!0)),
                        \x->(x!!0 /= 5)])
  ]

magicsquares = map (chop 3) $ permute msconstraints [1..9]
-- with redundant constraints    (0.01 secs, 1,175,040 bytes)
-- without redundant constraints (0.08 secs, 16,050,864 bytes)
  
chop::Int->[a]->[[a]]
chop _ [] = []
chop n xs = (take n xs):(chop n $ drop n xs)

main :: IO ()           
main = mapM_ (putStrLn . show) $ magicsquares