sinelaw / test-search.hs

Last active February 06, 2013


    
    View test-search.hs 
  
  
      test-search.hs
    
    
        Raw
      
    
    File suppressed. Click to show.
  
  
            1
            2
            3
            4
            5
            6
            7
            8
            9
            10
            11
            12
            13
            14
            15
            16
            17
            18
            19
            20
            21
            22
            23
            24
            25
            26
            27
            28
            29
            30
            31
            32
            33
            34
            35
            36
            37
            38
            39
            40
            41
            42
            43
            44
            45
            46
            47
            48
            49
            50
            51
            52
            53
            54
            55
            56
            57
            58
            59
            60
            61
            62
            63
            64
            65
            66
            67
            68
            69
            70
            71
            72
            73
            74
            75
            76
            77
            78
            79
            80
            81
            82
            83
            84
            85
            86
            87
            88
            89
            90
            91
            92
            93
            94
            95
            96
            97
            98
            99
            100
            101
            102
            103
            104
            105
            106
            107
            108
            109
            110
            111
            112
            113
            114
            115
            116
            117
            118
            119
            120
            121
            122
          
          
            {-# 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