Permutations with constraints – magic square

Starting from my previous post, I add code to apply constraints as permutations are being generated.

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'' (xs,ys) = map (\(y,y')->((y:xs),y')) $ picks ys

-- generate all the ways to pick one item from a list
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 [] = []
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 _ [] = []
chop n xs = (take n xs):(chop n $ drop n xs)

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

This is still faster than Tsoder’s brute force method, but slower than my list comprehension methods.

I like the way permutations and constraints are separated

I dislike the way the constraints are based on the recursion depth, which keeps changing. Perhaps a helper method to generate constraints from a more intuitive description would help.

Abstracting Predicates out as a monoid does not simplify this program, but it is reusable. I think it could be better named, particularly as there could be similar monoids with the other boolean operators, by analogy with All and Any for simple booleans.

I called the method permute (a verb betraying my imperative background) which does not clash with Data.List.permutations, but perhaps the name should be closer.

Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out /  Change )

Google photo

You are commenting using your Google account. Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. Log Out /  Change )

Connecting to %s

%d bloggers like this: