From 542f4ab0a0ab9e20d04ddd15aba6f80a251b8653 Mon Sep 17 00:00:00 2001 From: Bijoy Thomas Date: Mon, 13 Nov 2017 10:16:12 -0600 Subject: [PATCH] Added Haskell example for Dijkstras algorithm (#18) * Adding binary search example for Haskell * Adding selection sort example in Haskell * Adding Haskell examples for chapter 3 * Adding examples for chapter 4 * Adding examples for chapter 5 * Adding git ignore * Add Haskell example for BFS * resetting * Adding haskell example for dijkstras algorithm * Adding Haskell example for chapter 8 * Adding power set based solution for set covering problem * Adding Haskell examples for chap 9 --- .../Haskell/01_dijkstras_algorithm.hs | 94 +++++++++++++++++++ .../Haskell/01_powerset-covering.hs | 33 +++++++ .../Haskell/01_set_convering.hs | 32 +++++++ .../Haskell/01_knapsack-powerset.hs | 27 ++++++ .../Haskell/01_knapsack_dynamic_prog.hs | 62 ++++++++++++ 5 files changed, 248 insertions(+) create mode 100644 07_dijkstras_algorithm/Haskell/01_dijkstras_algorithm.hs create mode 100644 08_greedy_algorithms/Haskell/01_powerset-covering.hs create mode 100644 08_greedy_algorithms/Haskell/01_set_convering.hs create mode 100644 09_dynamic_programming/Haskell/01_knapsack-powerset.hs create mode 100644 09_dynamic_programming/Haskell/01_knapsack_dynamic_prog.hs diff --git a/07_dijkstras_algorithm/Haskell/01_dijkstras_algorithm.hs b/07_dijkstras_algorithm/Haskell/01_dijkstras_algorithm.hs new file mode 100644 index 0000000..a6ddd4b --- /dev/null +++ b/07_dijkstras_algorithm/Haskell/01_dijkstras_algorithm.hs @@ -0,0 +1,94 @@ +import Data.List +import Control.Applicative +import qualified Data.HashMap.Strict as Map + +type Costs = Map.HashMap String Double +type Parents = Map.HashMap String String +type WeightedEdge = (String, Double) + +inf = read "Infinity" :: Double + +graph = Map.fromList [ + ("book", [("rarelp", 5.0), ("poster", 0.0)]), + ("rarelp", [("guitar", 15.0), ("drumset", 20.0)]), + ("poster", [("drumset", 35.0), ("guitar", 30.0)]), + ("drumset", [("piano", 10.0)]), + ("guitar", [("piano", 20.0)]), + ("piano", []) + ] + +neighbors :: String -> Costs +neighbors node = Map.fromList (maybe [] id (Map.lookup node graph)) + +closest :: String -> WeightedEdge +closest node = head $ sortBy (\x y -> compare (snd x) (snd y)) $ Map.toList $ (neighbors node) + +buildmap graph def initmapfn node = foldl + (\accMap key -> Map.insert key def accMap) + startingMap + keystoadd + where startingMap = initmapfn node + startKeys = node : (Map.keys startingMap) + allKeys = Map.keys graph + keystoadd = filter (not . (`elem` startKeys)) allKeys + +initcosts node = buildmap graph inf neighbors node + +initparents node = buildmap graph "" ((Map.map (\x -> node)) . neighbors) node + +safeHead [] = Nothing +safeHead (x:xs) = Just x + +cheapest :: [String] -> Costs -> Maybe WeightedEdge +cheapest processed costs = safeHead $ + sortBy (\x y -> compare (snd x) (snd y)) $ + filter (\(a, b) -> (not . (`elem` processed)) a) $ + Map.toList $ + costs + +updatecosts :: Costs -> WeightedEdge -> Costs +updatecosts costs (node, cost) = foldl + (\acc (neighbor, neighborcost) -> + let (Just newcost) = min (neighborcost + cost) <$> (Map.lookup neighbor acc) + in Map.insert neighbor newcost acc) + costs + edges + where edges = Map.toList $ neighbors node + +updateparents :: Parents -> Costs -> WeightedEdge -> Parents +updateparents parents costs (node, cost) = foldl + (\acc (neighbor, neighborcost) -> case (((cost + neighborcost) <) <$> (Map.lookup neighbor costs)) of + Just True -> Map.insert neighbor node acc + _ -> acc) + parents + edges + where edges = Map.toList $ neighbors node + +shortestpath :: Costs -> Parents -> [String] -> (Costs, Parents) +shortestpath costs parents processed = case (cheapest processed costs) of + Just (node, cost) -> shortestpath newcosts newparents (node : processed) + where newcosts = updatecosts costs (node, cost) + newparents = updateparents parents costs (node, cost) + Nothing -> (costs, parents) + +costto :: String -> Costs -> Double +costto node costMap = case (Map.lookup node costMap) of + Just cost -> cost + _ -> inf + +pathto :: String -> Parents -> [String] +pathto node parentsMap = buildpath node parentsMap [node] + where buildpath node parentsMap acc = case (Map.lookup node parentsMap) of + Just "book" -> "book" : acc + Just parent -> buildpath parent parentsMap (parent : acc) + +costs = initcosts "book" + +parents = initparents "book" + +processed = ["book"] + +main = do + (putStrLn . show . (costto "piano")) costsolution + (putStrLn . show . (pathto "piano")) parentsolution + where (costsolution, parentsolution) = shortestpath costs parents processed \ No newline at end of file diff --git a/08_greedy_algorithms/Haskell/01_powerset-covering.hs b/08_greedy_algorithms/Haskell/01_powerset-covering.hs new file mode 100644 index 0000000..cdf7b5e --- /dev/null +++ b/08_greedy_algorithms/Haskell/01_powerset-covering.hs @@ -0,0 +1,33 @@ +import Control.Applicative +import Data.List +import qualified Data.Set as Set +import qualified Data.HashMap.Strict as Map + +stationsMap = Map.fromList [ + ("kone", Set.fromList(["id", "nv", "ut"])), + ("ktwo", Set.fromList(["wa", "id", "mt"])), + ("kthree", Set.fromList(["or", "nv", "ca"])), + ("kfour", Set.fromList(["nv", "ut"])), + ("kfive", Set.fromList(["ca", "az"])) + ] + +statesNeeded = Set.fromList ["mt", "wa", "or", "id", "nv", "ut", "ca", "az"] + +powerSet xs = foldl (\acc x -> acc ++ (map (\e -> x:e) acc)) [[]] xs + +allStationCombinations = powerSet $ Map.keys stationsMap + +coverage stationsMap stations = map (`Map.lookup` stationsMap) stations + +stationsCoverage stations = + fmap (Set.size . (Set.intersection statesNeeded)) $ + Just (foldl Set.union Set.empty ) <*> + (sequence (coverage stationsMap stations)) + +solution = foldl + (\x y -> if stationsCoverage x >= stationsCoverage y then x else y) + first + rest + where (first: rest) = + sortBy (\a b -> compare (length a) (length b)) $ + (filter (not . null) allStationCombinations) \ No newline at end of file diff --git a/08_greedy_algorithms/Haskell/01_set_convering.hs b/08_greedy_algorithms/Haskell/01_set_convering.hs new file mode 100644 index 0000000..c9488d0 --- /dev/null +++ b/08_greedy_algorithms/Haskell/01_set_convering.hs @@ -0,0 +1,32 @@ +import qualified Data.Set as Set +import qualified Data.HashMap.Strict as Map + +stations = Map.fromList [ + ("kone", Set.fromList(["id", "nv", "ut"])), + ("ktwo", Set.fromList(["wa", "id", "mt"])), + ("kthree", Set.fromList(["or", "nv", "ca"])), + ("kfour", Set.fromList(["nv", "ut"])), + ("kfive", Set.fromList(["ca", "az"])) + ] + +statesNeeded = Set.fromList ["mt", "wa", "or", "id", "nv", "ut", "ca", "az"] + +bestStation statesNeeded selectedStations stations = foldl + (\a@(station1, states1) b@(station2, states2) -> + let fn states = Set.size $ (Set.intersection statesNeeded states) + coverage1 = fn states1 + coverage2 = fn states2 + in if coverage1 > coverage2 then a else b + ) + x + xs + where (x: xs) = filter (\(station, states) -> not $ station `elem` selectedStations) $ Map.toList stations + + +stationSet statesNeeded finalStations = + let (station, coveredStations) = bestStation statesNeeded finalStations stations + neededStations = Set.difference statesNeeded coveredStations + newStations = station : finalStations + in if (Set.size statesNeeded > 0) then stationSet neededStations newStations else finalStations + +finalSet = stationSet statesNeeded [] \ No newline at end of file diff --git a/09_dynamic_programming/Haskell/01_knapsack-powerset.hs b/09_dynamic_programming/Haskell/01_knapsack-powerset.hs new file mode 100644 index 0000000..33fee6a --- /dev/null +++ b/09_dynamic_programming/Haskell/01_knapsack-powerset.hs @@ -0,0 +1,27 @@ +import Control.Applicative +import Data.List +import qualified Data.Set as Set +import qualified Data.HashMap.Strict as Map + +items = Map.fromList [ + ("stereo", (4, 3000)), + ("laptop", (3, 2000)), + ("guitar", (1, 1500)) + ] + +value set = (a, b) + where + weightandvalues = (sequence $ map (`Map.lookup` items) set) + Just (a,b) = Just (foldl (\(a,b) (c,d) -> (a+c, b+d)) (0,0)) <*> weightandvalues + +powerSet xs = foldl (\acc x -> acc ++ (map (\e -> x:e) acc)) [[]] xs + +solution = foldl + (\acc v -> let + (firstweight, firstvalue) = value acc + (secondweight, secondvalue) = value v + in if firstweight <= 4 && firstvalue >= secondvalue then acc else if secondweight <= 4 then v else acc) + first + rest + where + (first: rest) = filter (not . null) $ powerSet $ (Map.keys items) diff --git a/09_dynamic_programming/Haskell/01_knapsack_dynamic_prog.hs b/09_dynamic_programming/Haskell/01_knapsack_dynamic_prog.hs new file mode 100644 index 0000000..ce19608 --- /dev/null +++ b/09_dynamic_programming/Haskell/01_knapsack_dynamic_prog.hs @@ -0,0 +1,62 @@ +import qualified Data.HashMap.Strict as Map +import Data.Array + +type Grid = Array (Integer, Integer) (Integer, [Char]) + +itemsMap = Map.fromList [ + ("stereo", (4, 3000)), + ("laptop", (3, 2000)), + ("guitar", (1, 1500)), + ("iphone", (1, 2000)) + ] + +weightOf item = case Map.lookup item itemsMap of + Just (w, v) -> w + otherwise -> 0 + +valueOf item = case Map.lookup item itemsMap of + Just (w, v) -> v + otherwise -> 0 + +emptyGrid :: Grid +emptyGrid = array ((0,0), (3,4)) [((x,y), (0, "")) | x <- [0..3], y <- [0..4]] + +best :: Grid -> Integer -> Integer -> String -> (Integer, String) +best arr row col item = + let weight = weightOf item + value = valueOf item + (previousMax, previousItems) = if (row /= 0) then arr ! (row - 1, col) else (0, "") + (valueOfRemainingSpace, itemsInRemainingSpace) = + if (row /= 0 && (col - weight) >= 0) + then arr ! (row - 1, col - weight) + else (0, "") + in if (previousMax > (value + valueOfRemainingSpace)) + then arr ! (row - 1, col) + else (value + valueOfRemainingSpace, itemsInRemainingSpace ++ " " ++ item) + +fillPrevBest arr row col = + if row /= 0 then (//) arr [((row, col), arr ! (row - 1, col))] else arr + +fillGrid emptyGrid = foldl + (\acc pair -> + let row = fst pair + item = snd pair + (weight, value) = (weightOf item, valueOf item) + in foldl + (\arr col -> + case weight <= col of + True -> (//) arr [((row, col), best arr row col item)] + False -> fillPrevBest arr row col + ) + acc + [0..4] + ) + emptyGrid + items + where items = zip [0..3] $ Map.keys itemsMap + +solution = foldl + (\(x, a) (y, b) -> if x > y then (x, a) else (y, b)) + first + rest + where (first: rest) = elems $ fillGrid emptyGrid \ No newline at end of file