Added Haskell example for Dijkstras algorithm (egonSchiele#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

Author: bijoythomas

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

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)

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 []

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)

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