Skip to content

Instantly share code, notes, and snippets.

@timjb

timjb/ImbalanceSolver.hs

Last active Dec 16, 2015
Embed
What would you like to do?
-- A solver for imbalance problems. Inspired by
-- http://lostinrecursion.wordpress.com/2013/03/21/imbalance-problems/
-- http://lostinrecursion.wordpress.com/2013/03/23/more-imbalance-problems-3/
-- http://lostinrecursion.wordpress.com/2013/03/30/imbalance-abundance/
-- This file uses linear programming to search for solutions for the weights of
-- the object. Since it uses a library for LP, you have to
-- `cabal install hmatrix-glpk`.
module Main where
import Data.List (nub, sortBy)
import Data.Function (on)
import Numeric.LinearProgramming
-- A mobile with objects of type a
data Imbalance a = Node (Imbalance a) (Imbalance a) -- lopsided to the left
| Single a (Imbalance a)
| End
deriving (Eq, Show, Read)
fromList :: [a] -> Imbalance a
fromList = foldr Single End
(/:), (\:) :: Imbalance a -> Imbalance a -> Imbalance a
(/:) = Node
(\:) = flip Node
-- Lists all objects in an imbalance.
objects :: Imbalance a -> [a]
objects End = []
objects (Single a r) = a : objects r
objects (Node l r) = objects l ++ objects r
-- Given an imbalance and an ordering of the objects in the imbalance, produce
-- a list of linear inequalities that the objects must satisfy.
constraints :: Eq a => [a] -> Imbalance a -> [Bound [Double]]
constraints _ End = []
constraints labels (Single _ i) = constraints labels i
constraints labels (Node l r) = [bound] ++ constraints labels l ++ constraints labels r
where
bound = balance :=>: 1
balance = map fromIntegral (zipWith (-) (aggregate l) (aggregate r))
aggregate imb = map (length . flip filter (objects imb) . (==)) labels
-- Solve an imbalance using linear programming
solve :: Eq a => Imbalance a -> Maybe [(a, Double)]
solve imb = case simplex opt constr [] of
Feasible (_, s) -> Just $ zip labels s
Optimal (_, s) -> Just $ zip labels s
where
labels = nub $ objects imb
opt = Minimize $ map (const 1) labels
constr = Dense $ constraints labels imb
data Shape = Square | Triangle | Circle | Diamond deriving (Eq, Read)
instance Show Shape where
show Square = ""
show Triangle = ""
show Circle = ""
show Diamond = ""
-- The problems from the website above
problems :: [Imbalance Shape]
problems =
[ (triangleE \: squareE) /: (circleE \: squareE)
, (circle triangleE \: square triangleE) /: (triangle circleE \: triangle triangleE)
, (circle (triangle squareE) /: square (circle squareE)) \: (circle (square circleE) /: square (square circleE))
, (squareE /: circle circleE) \: (triangleE /: circleE)
, circle (triangle squareE) /: (3 `n` Circle \: square squareE)
, triangle (3 `n` Circle /: square circleE) \: square (triangle squareE /: square (circle circleE))
, (2 `n` Square /: circle (circle squareE)) \: (circle (triangle squareE) /: circle (triangle triangleE))
, triangle (circleE \: square triangleE) /: circle (circle triangleE \: squareE)
, circle (triangle triangleE) \: (circleE /: triangle squareE)
, circle (circleE \: triangleE) /: triangle (square triangleE)
, (square squareE \: circle triangleE) /: (triangle triangleE \: square circleE)
, (circle circleE /: squareE) \: square (squareE /: triangleE)
, squareE -- can't encode problem 13 because it uses a balance
, triangle (square (3 `n` Circle) \: (3 `n` Triangle)) /: circle (circle (circle (triangle triangleE)) \: (3 `n` Square))
, (square (triangle (square triangleE)) \: (3 `n` Circle)) /: (circle (triangle (circle triangleE)) \: (3 `n` Square))
]
where
square = Single Square
triangle = Single Triangle
circle = Single Circle
squareE = square End
triangleE = triangle End
circleE = circle End
c `n` w = fromList (replicate c w)
main :: IO ()
main = do
putStrLn "The objects from lightest to heaviest:\n"
sequence_ $ zipWith solveProblem [1..] problems
where
solveProblem i imb = putStrLn $ show i ++ ". " ++ maybe errMsg showSolution (solve imb)
errMsg = "Problem couldn't be solved!"
showSolution = show . map fst . sortBy (compare `on` snd)
The objects from lightest to heaviest:
1. [●,▲,■]
2. [●,▲,■]
3. [■,▲,●]
4. [●,■,▲]
5. [●,■,▲]
6. [●,■,▲]
7. [●,▲,■]
8. [●,▲,■]
9. [▲,■,●]
10. [■,●,▲]
11. [▲,■,●]
12. [▲,●,■]
13. [■]
14. [●,■,▲]
15. [▲,■,●]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.