Last active
December 12, 2015 03:09
-
-
Save sinelaw/4704827 to your computer and use it in GitHub Desktop.
Added dynamic programming with parallelization
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE NoMonomorphismRestriction #-} | |
module Main where | |
import Debug.Trace (traceShow) | |
import Data.List (minimumBy, sortBy, genericLength) | |
import Control.Monad ((=<<), liftM, liftM2) | |
import Data.Maybe (fromJust, isJust) | |
import System.IO (hPutStrLn, stderr) | |
import Control.Parallel (par, pseq) | |
import Control.DeepSeq (NFData, rnf) | |
import Control.Parallel.Strategies (parMap, rdeepseq) | |
a0 = 0 :: Double | |
b0 = 16 :: Double | |
costConstant = 1000 | |
constantCost = const costConstant | |
linearCost x = (x + 1) * costConstant | |
quadraticCost x = (linearCost x) * (linearCost x) | |
cost = linearCost | |
test1 = makeTrees constantCost a0 b0 | |
test2 = makeTrees linearCost a0 b0 | |
test3 = makeTrees quadraticCost a0 b0 | |
printGraph x label = do | |
let rangeStr = "[" ++ show a0 ++ ", " ++ show b0 ++ "]" | |
hPutStrLn stderr $ "solving: " ++ label ++ " - " ++ rangeStr | |
putStr "digraph G {\n" | |
putStr $ tree2dot x | |
putStr $ "labelloc=\"t\";label=\"" ++ label ++ " - " ++ rangeStr ++ "\";" | |
putStr "}\n" | |
main = do | |
printGraph test1 "Constant cost" | |
printGraph test2 "Linear cost" | |
printGraph test3 "Quadratic cost" | |
allPairs :: Monad m => m a -> m b -> m (a,b) | |
allPairs = (=<<) . flip (liftM . flip (,)) | |
data Tree a = Leaf { getValue :: a } | Node { getRange :: (a,a,a), | |
getLeft :: Tree a, | |
getRight :: Tree a } | |
deriving (Show) | |
instance NFData a => NFData (Tree a) where | |
rnf (Leaf x) = rnf x | |
rnf (Node rng l r) = rnf rng `seq` rnf l `seq` rnf r | |
makeTrees :: (NFData t, Ord t, Enum t, Eq t, Fractional a, Num t, Ord a) => (t -> a) -> t -> t -> Tree t | |
makeTrees cost a b = if a == b | |
then Leaf a | |
else head . (sortByAverageCost cost) $ map' makeTree' [a..(b-1)] | |
where makeTree' x = uncurry (Node (a,x,b)) | |
$ if (x == a) | |
then (Leaf a, rightTree) | |
else (rightTree, leftTree) | |
where leftTree = makeTrees cost a x | |
rightTree = makeTrees cost (x+1) b | |
map' = if (b - a) > 5 -- use parallel map only for larger trees | |
then parMap rdeepseq | |
else map | |
averageCost :: Fractional b => (t -> b) -> Tree t -> b | |
averageCost f tree = sum d / genericLength d | |
where d = costs f tree | |
sortWith :: Ord a1 => (a -> a1) -> [a] -> [a] | |
sortWith f = sortBy $ \a b -> compare (f a) (f b) | |
sortByAverageCost :: (Fractional a, Ord a) => (t -> a) -> [Tree t] -> [Tree t] | |
sortByAverageCost f = sortWith $ averageCost f | |
depth :: (Num b, Ord b) => Tree t -> b | |
depth (Leaf _) = 1 | |
depth (Node _ l r) = 1 + max (depth l) (depth r) | |
--depths :: (Num b, Ord b, Fractional b) => Tree t -> b | |
depths (Leaf _) = [1] | |
depths (Node _ l r) = addDepth l ++ addDepth r | |
where addDepth x = map (+1) (depths x) | |
costs f t@(Leaf x) = [f x] | |
costs f t@(Node (_,x,_) l r) = addCost l ++ addCost r | |
where addCost y = map (+(f x)) ((costs f) y) | |
averageDepth tree = sum d / genericLength d | |
where d = depths tree | |
sortByAverageDepth = sortWith averageDepth | |
quote s = "\"" ++ s ++ "\"" | |
nodeLabel (Leaf x) = quote . show $ x | |
nodeLabel (Node (a,b,c) _ _) = quote $ show (floor b) ++ " ?" | |
nodeLabel' :: (Show a, RealFrac a) => Maybe (Tree a) -> String | |
nodeLabel' Nothing = "bad" | |
nodeLabel' (Just x) = nodeLabel x | |
tree2dot t@(Leaf _) = nodeLabel t ++ ";\n" | |
tree2dot t@(Node _ l r) = nodeLabel t ++ " -> " ++ nodeLabel l' ++ ";\n" ++ nodeLabel t ++ " -> " ++ nodeLabel r' ++ ";\n" ++ tree2dot l' ++ tree2dot r' | |
where orderNodes a'@(Leaf a) b'@(Leaf b) = orderByLabels a b a' b' | |
orderNodes a'@(Leaf a) b'@(Node (_, b, _) _ _) = orderByLabels a b a' b' | |
orderNodes a'@(Node (_, a, _) _ _) b'@(Node (_, b, _) _ _) = orderByLabels a b a' b' | |
orderNodes a'@(Node (_, a, _) _ _) b'@(Leaf b) = orderByLabels a b a' b' | |
orderByLabels a b a' b' = if a <= b then (a', b') else (b', a') | |
l' = fst $ orderNodes l r | |
r' = snd $ orderNodes l r | |
tree2dot' :: (Show a, RealFrac a) => Maybe (Tree a) -> String | |
tree2dot' t@Nothing = nodeLabel' t | |
tree2dot' (Just x) = tree2dot x |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment