ADAA2 Week 1

Adda2Week1PrimMST.hs

{-# LANGUAGE UnicodeSyntax #-}
module Adda2.Week1.PrimMST where

import           Control.Applicative        (many, (<$>), (<*))
import           Control.Monad              (replicateM)
import           Data.List                  (nub, sort)

import           Data.Attoparsec.Text.Lazy
import           Data.Text.Lazy.IO          as T

import           Algo.PrimMST


exercise03 ∷ FilePath → IO Int
exercise03 φ = getMSTWeight <$> readGraph φ


readGraph ∷ FilePath → IO Graph
readGraph φ = toGraph . handle . parse parser <$> T.readFile φ
  where
    handle = either (error "jobs parser failed") id . eitherResult
    toGraph edges = fromList $ map (\v → (v, fromList $ findPairs edges v)) $ vertices edges
    vertices = nub . sort . map (\(b,_,_) → b)
    findPairs [] _ = []
    findPairs ((b,e,w):es) v | b == v = (e,w) : findPairs es v
                             | otherwise = findPairs es v

parser ∷ Parser [Edge]
parser = do
  _ ← decimal <* many space
  es ← decimal <* many space
  replicateM es parse_edge
    where
      parse_edge = do
        b ← decimal <* many space
        e ← decimal <* many space
        w ← signed decimal <* option '\n' (char '\n')
        return (b,e,w)

Adda2Week1Schedule.hs

{-# LANGUAGE UnicodeSyntax #-}
module Adda2.Week1.Schedule where

import           Control.Applicative        (many, (<$>), (<*), (<*>))
import           Control.Monad              (replicateM)

import           Data.Attoparsec.Text.Lazy
import           Data.Text.Lazy.IO          as T

import           Algo.Schedule


exercise01 ∷ FilePath → IO Int
exercise01 φ =
  calculateCompletionTime . sortJobsSubtract <$> readJobs φ

exercise02 ∷ FilePath → IO Int
exercise02 φ =
  calculateCompletionTime . sortJobsRatio <$> readJobs φ


readJobs ∷ FilePath → IO [Job]
readJobs φ = handle . parse parserJobs <$> T.readFile φ
  where
    handle = either (error "jobs parser failed") id . eitherResult

parserJobs ∷ Parser [Job]
parserJobs = do
  n ← decimal <* many space
  replicateM n parse_job
 where
  parse_job = Job <$>
    decimal <* many space <*>
    decimal <* option '\n' (char '\n')

AlgoPrimMST.hs

{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE UnicodeSyntax        #-}
module Algo.PrimMST
  ( fromList, Graph, Edge
  , getMSTWeight, Weight, Vertex
  ) where

import           Control.Monad        (when)
import           Control.Monad.Reader (Reader, ask, runReader)
import           Control.Monad.State  (StateT, execStateT, get, put)
import qualified Data.Heap            as DH
import           Data.IntMap          (fromList)
import qualified Data.IntMap          as IM hiding (fromList)
import           Data.List            (nub, sort, (\\))
import           Data.Maybe           (fromJust, isJust)


type Graph = IM.IntMap (IM.IntMap Weight)
type Vertex = Int
type Weight = Int
type Edge = (Vertex, Vertex, Weight)

instance Ord (Maybe Weight) where
  compare (Just x) (Just y) = compare x y
  compare Nothing   _       = GT
  compare _         Nothing = LT

type VerticesHeapElement = (Maybe Weight, Vertex)
type VerticesHeap = DH.Heap VerticesHeapElement

getMSTWeight ∷ Graph → Weight
getMSTWeight γ = fst' $ runReader (execStateT allSteps (0,[firstVertex],initialHeap)) γ
 where
  firstVertex = fst $ head $ IM.toList γ
  initialHeap = DH.fromList
    [ (w, v) |
      v ← allVertices,
      let w = if connected γ firstVertex v
                then Just $ δ γ firstVertex v
                else Nothing
    ]
  allVertices = (\\ [firstVertex]) . nub . sort . concatMap IM.keys . IM.elems $ γ
  fst' (a,_,_) = a

δ ∷ Graph → Vertex → Vertex → Weight
δ γ x y = (IM.!) ((IM.!) γ x') y'
  where x' = min x y
        y' = max x y

connected ∷ Graph → Vertex → Vertex → Bool
connected γ x y = isJust $ IM.lookup y' =<< IM.lookup x' γ
  where x' = min x y
        y' = max x y

allSteps ∷ StateT (Weight,[Vertex],VerticesHeap) (Reader Graph) ()
allSteps = do
  r ← step
  when r allSteps

step ∷ StateT (Weight,[Vertex],VerticesHeap) (Reader Graph) Bool
step = do
  γ ← ask
  (weight, vertices, heap) ← get
  if DH.null heap
    then return False
    else do
      put (weight + minWeight heap, minVertex heap : vertices, recalc γ heap)
      return True
        where
          minWeight = fromJust . fst . DH.minimum
          minVertex = snd . DH.minimum
          recalc γ heap = DH.map (recalcNeighb heap γ) $ DH.deleteMin heap
          recalcNeighb heap γ (w,v) =
            if connected γ v (minVertex heap)
               then (min w $ Just $ δ γ v $ minVertex heap, v)
               else (w, v)

AlgoSchedule.hs

{-# LANGUAGE UnicodeSyntax #-}
module Algo.Schedule where

import           Data.List  (sortBy)
import           Data.Ratio ((%))

type Weight = Int
type Length = Int
data Job = Job { weight ∷ Weight, level ∷ Length }
  deriving Show

compareSubstract ∷ Job → Job → Ordering
compareSubstract (Job w1 l1) (Job w2 l2)
  | w1 - l1 == w2 - l2 = compare w2 w1
  | otherwise = compare (w2 - l2) (w1 - l1)

compareRatio ∷ Job → Job → Ordering
compareRatio (Job w1 l1) (Job w2 l2) =
  compare (w2 % l2) (w1 % l1)

sortJobsSubtract ∷ [Job] → [Job]
sortJobsSubtract = sortBy compareSubstract

sortJobsRatio ∷ [Job] → [Job]
sortJobsRatio = sortBy compareRatio

calculateCompletionTime ∷ [Job] → Int
calculateCompletionTime = fst . foldl addNewJob (0,0)
  where
    addNewJob ∷ (Int,Int) → Job → (Int,Int)
    addNewJob (s,l') (Job w l) = let newLevel = l' + l in
      (s + w * newLevel, newLevel)

Main.hs

{-# LANGUAGE UnicodeSyntax #-}
import Adda2.Week1.Schedule
import Adda2.Week1.PrimMST

main ∷ IO ()
main = do
  putStr "Exercise 1: "
  print =<< exercise01 "jobs.txt"
  putStr "Exercise 2: "
  print =<< exercise02 "jobs.txt"
  putStr "Exercise 3: "
  print =<< exercise03 "edges.txt"

$> time ./Main 
Exercise 1: 69119377652
Exercise 2: 67311454237
Exercise 3: -3612829

real    0m0.244s
user    0m0.230s
sys 0m0.000s

👍

respect!