schedule-planner 0.1.0.1 → 0.1.0.2
raw patch · 7 files changed
+578/−1 lines, 7 files
Files
- schedule-planner.cabal +8/−1
- src/SchedulePlanner/App.hs +91/−0
- src/SchedulePlanner/Calculator.hs +27/−0
- src/SchedulePlanner/Calculator/Scale.hs +139/−0
- src/SchedulePlanner/Calculator/Solver.hs +129/−0
- src/SchedulePlanner/Serialize.hs +172/−0
- src/SchedulePlanner/Server.hs +12/−0
schedule-planner.cabal view
@@ -1,5 +1,5 @@ name: schedule-planner-version: 0.1.0.1+version: 0.1.0.2 cabal-version: >=1.10 build-type: Simple license: LGPL-3@@ -29,6 +29,13 @@ mtl > 1 main-is: Main.hs buildable: True+ other-modules:+ SchedulePlanner.App+ SchedulePlanner.Calculator+ SchedulePlanner.Serialize+ SchedulePlanner.Server+ SchedulePlanner.Calculator.Scale+ SchedulePlanner.Calculator.Solver default-language: Haskell2010 hs-source-dirs: src
+ src/SchedulePlanner/App.hs view
@@ -0,0 +1,91 @@+module SchedulePlanner.App (+ reportAndPrint,+ reportAndExecute+ ) where+++import Control.Applicative (pure, (<*>))+import Control.Monad.Writer+import qualified Data.List as List (take)+import qualified Data.Map as Map (keys)+import Data.Maybe (fromMaybe)+import SchedulePlanner.Calculator+import SchedulePlanner.Serialize+import System.IO (hPutStrLn, stderr)+import Text.JSON as JSON (Result (..))++++-- |Print a line to stdout+putErrorLine :: String -> IO()+putErrorLine = hPutStrLn stderr+++-- |Print a string if debug is enabled+printDebug :: Show a => Bool -> a -> Writer String ()+printDebug debugMode = when debugMode . tell . show+++{-|+ Evaluates the transformed json, compiles (useful) error messages, prints them+ and then runs the algorithm or, if the errors are too severe, aborts.+-}+reportAndExecute :: String -> Bool -> Result ([Result Rule], [Result (Lesson String)]) -> Writer String ()+reportAndExecute _ _ (Error s) =+ tell $ "Stopped execution due to a severe problem with the input data:" ++ show s+reportAndExecute outputFormat debugMode (Ok (r, l)) = do+ rules <- reportOrReturn r+ lessons <- reportOrReturn l++ let weighted = weigh rules lessons++ let mappedLessons = mapToSubject weighted++ let result = calcFromMap mappedLessons++ case result of+ Nothing ->+ tell "Calculation failed, no valid schedule possible"+ Just calculated ->++ case outputFormat of++ "print" -> do++ tell "\n"+ _ <- mapM (printDebug debugMode) rules+ tell "\n"++ tell "\n"+ _ <- mapM (printDebug debugMode) weighted+ tell "\n"++ tell "Legend:"+ _ <- mapM (tell . show . (pure (,) <*> shortSubject <*> id) ) (Map.keys mappedLessons)+++ tell "\n"+ _ <- pc calculated+ return ()++ "json" -> do+ tell $ serialize calculated+ return ()++ where+ pc = mapM (tell.("\n\n" ++).formatSchedule)++ reportOrReturn :: [Result a] -> Writer String [a]+ reportOrReturn [] = return []+ reportOrReturn (x:xs) =+ case x of+ Error s -> do+ tell "Some data was unusable:"+ tell s+ reportOrReturn xs+ Ok v -> liftM (v:) (reportOrReturn xs)+++reportAndPrint :: String -> Bool -> String -> IO()+reportAndPrint outputFormat debugMode rawInput =+ putStrLn $ snd $ runWriter $ reportAndExecute outputFormat debugMode (deSerialize rawInput)
+ src/SchedulePlanner/Calculator.hs view
@@ -0,0 +1,27 @@+{-|+Module : $Header$+Description : base module for the mathematical operations+Copyright : (c) Justus Adam, 2015+License : LGPL-3+Maintainer : development@justusadam.com+Stability : experimental+Portability : POSIX++Exports the most important functions neccessary for the actual work+of this software+-}+module SchedulePlanner.Calculator(+ calcFromMap,+ calcFromList,+ totalWeight,+ Lesson (..),+ Timeslot (..),+ Target(..),+ Rule(..),+ mapToSubject,+ MappedSchedule,+ weigh+) where++import SchedulePlanner.Calculator.Scale+import SchedulePlanner.Calculator.Solver
+ src/SchedulePlanner/Calculator/Scale.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-|+Module : $Header$+Description : Apply weighing rules to lessons+Copyright : (c) Justus Adam, 2015+License : LGPL-3+Maintainer : development@justusadam.com+Stability : experimental+Portability : POSIX++This module is used to weigh a list of lessons according to rules.+-}+module SchedulePlanner.Calculator.Scale (+ weigh,+ Rule(..),+ Target(..),+ calcMaps+) where++import Control.Applicative (pure, (<*>))+import Control.Monad.Trans.State (State, get, put, runState)+import Data.Data (Data)+import Data.List as List (mapAccumL)+import qualified Data.Map as Map (Map, empty,+ findWithDefault,+ insert, insertWith,+ lookup, update)+import Data.Tuple (swap)+import Data.Typeable (Typeable)+import SchedulePlanner.Calculator.Solver (Lesson (..), time, timeslot)+++-- |The scope and target a 'Rule' whishes to influence+data Target = Slot Int | Day Int | Cell Int Int deriving (Show, Typeable, Data, Ord, Eq)+-- |Weight increase by 'severity' for all 'Lesson's in target+data Rule = Rule {target :: Target, severity :: Int} deriving (Show, Typeable, Data)+-- |Dynamic rule with only one condition+data SimpleDynRule = SimpleDynRule {sDynTarget :: Target, sDynSeverity :: Int} deriving (Show)+++-- |Type alias for more expressive function signature+type WeightMap = Map.Map Target Int+-- |Type alias for structure holding the dynamic rules+type DynRuleMap = Map.Map Target [SimpleDynRule]+++-- |Scaffolding for a dynamic rule+class DynamicRule a where+ trigger :: Lesson s -> WeightMap -> a -> (WeightMap, a)+ getTriggerTarget :: a -> [Target]+++instance DynamicRule SimpleDynRule where+ trigger inserted wMap (SimpleDynRule target sev) =+ (Map.insertWith (+) target sev wMap, SimpleDynRule target sev)++ getTriggerTarget = return.sDynTarget+++-- |Recalculate the lesson weight tuple as a result of dynamic rules+reCalcMaps :: WeightMap -> Lesson s -> DynRuleMap -> (DynRuleMap, WeightMap)+reCalcMaps weightMap lesson rules = runState (++ reCalcHelper lesson (Slot (timeslot lesson)) rules >>=+ reCalcHelper lesson (Day (day lesson)) >>=+ reCalcHelper lesson (uncurry Cell (time lesson))++ ) weightMap+++reCalcHelper :: Ord k+ => Lesson s+ -> k+ -> Map.Map k [SimpleDynRule]+ -> State WeightMap (Map.Map k [SimpleDynRule])+reCalcHelper inserted key rMap =+ case Map.lookup key rMap of+ Nothing -> return rMap+ Just rules -> do+ s <- get+ let (newState, newRules) = mapAccumL (trigger inserted) s rules+ put newState+ return $ Map.insert key newRules rMap+++-- |Apply a function to only the first element of a 2-tuple+applyToFirst :: (a -> c) -> (a, b) -> (c, b)+applyToFirst f (x, y) = (f x, y)+++-- |Apply a function to only the second element of a 2-tuple+applyToSecond :: (b -> c) -> (a, b) -> (a, c)+applyToSecond f (x, y) = (x, f y)+++{-|+ Main function of the module.++ This funcion calculates weights the 'Lesson's provided applying the+ 'Rule's provided.++ Resulting 'Lesson's are exactly the same, except for the weight+ component which is the old weight + the weight calculated from the rules+-}+weigh :: [Rule] -> [Lesson s] -> [Lesson s]+weigh rs = map (weighOne (calcMaps rs))+++{-|+ Weighs a single 'Lesson', but instead of 'Rule's expects a+ weight increase map.+-}+weighOne :: WeightMap -> Lesson s -> Lesson s+weighOne wm l =+ l {weight = weight l + allTargeting l wm}+++allTargeting :: Lesson s -> WeightMap -> Int+allTargeting l = pure (\a b c -> a + b + c)+ <*> Map.findWithDefault 0 (Slot $ timeslot l)+ <*> Map.findWithDefault 0 (Day $ day l)+ <*> Map.findWithDefault 0 (uncurry Cell $ time l)++++{-|+ Contruct a /scope -> weight increase/ map for more efficient+ weighing afterwards+-}+calcMaps :: [Rule] -> WeightMap+calcMaps = (`calcMapsStep` Map.empty)+++{-|+ Recursive step for the actual calculation done by 'calcMaps'+-}+calcMapsStep :: [Rule] -> WeightMap -> WeightMap+calcMapsStep [] = id+calcMapsStep (Rule t sev :xs) = calcMapsStep xs . Map.insertWith (+) t sev
+ src/SchedulePlanner/Calculator/Solver.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-|+Module : $Header$+Description : Calculate schedules+Copyright : (c) Justus Adam, 2015+License : LGPL-3+Maintainer : development@justusadam.com+Stability : experimental+Portability : POSIX++This module provides functions for calculating possibilities for an ideal+schedule layout from weighted Lessons as well as providing functions for+converting them into readable/printable format.+-}+module SchedulePlanner.Calculator.Solver (+ calcFromMap,+ calcFromList,+ mapToSubject,+ totalWeight,+ time,+ Lesson (..),+ Timeslot (..),+ MappedSchedule,+ MappedLessons+ ) where++import Control.Applicative (pure, (<*>))+import Data.Data (Data)+import Data.List as List (sortBy, take)+import qualified Data.Map as Map (Map, empty, foldl, fromList,+ fromListWith, insert, keys, lookup,+ map, null, toList)+import Data.Maybe (fromMaybe)+import qualified Data.Ord as Ord (comparing)+import Data.Typeable (Typeable)+++-- |Base datastructure for representing lessons+data Lesson s = Lesson {+ timeslot :: Int,+ day :: Int,+ weight :: Int,+ subject :: s+} deriving (Show, Eq, Ord, Typeable, Data)+++-- |type Alias for readability+-- maps lessons to their respective subject+type MappedLessons s = Map.Map s [Lesson s]+-- |type Alias for readability+-- (Slot, Day)+type Timeslot = (Int, Int)+-- |type Alias for readability+-- represents a schedule+type MappedSchedule s = Map.Map Timeslot (Lesson s)+++-- |Convenience function extracing the (day, timeslot) 'Tuple' from a 'Lesson'+time :: Lesson a -> Timeslot+time = pure (,) <*> day <*> timeslot+++-- |Convenience function to obtain the total weight of a particular Schedule+totalWeight :: MappedSchedule a -> Int+totalWeight = Map.foldl (+) 0 . Map.map weight+++{-|+ Map a List of 'Lesson's to their respective subjects+-}+mapToSubject :: Ord s => [Lesson s] -> Map.Map s [Lesson s]+mapToSubject = Map.fromListWith (++) . map (\x -> (subject x, [x]))+++{-|+ Same as 'calcFromMap' but operates on a List of 'Lesson's+-}+calcFromList :: Ord s => [Lesson s] -> Maybe [MappedSchedule s]+calcFromList = calcFromMap.mapToSubject+++{-|+ Main evaluation function+ Transforms a map of weighted 'Lesson's of a particular subject into a list+ of lightest schedules by branching the evaluation at avery point+ where there is a timeslot collision+-}+calcFromMap :: Ord s => Map.Map s [Lesson s] -> Maybe [MappedSchedule s]+calcFromMap mappedLessons+ | Map.null mappedLessons = Nothing+ | otherwise = Map.lookup subjX sortedLessons >>=+ (\(x : xs) ->+ calc' x (Map.insert subjX xs sortedLessons) Map.empty minList+ )+ where+ sortedLessons = Map.map (List.sortBy (Ord.comparing weight)) mappedLessons+ (subjX : minList) = Map.keys sortedLessons+++{-|+ Helper function for 'calcFromMap'+ represents a recusively called and forking calculation step+-}+calc' :: Ord s => Lesson s -> MappedLessons s -> MappedSchedule s -> [s] -> Maybe [MappedSchedule s]+calc' x lists hourMap minList =+ case Map.lookup (time x) hourMap of++ Nothing ->+ case minList of+ [] -> return [newMap]+ (c : cs) -> Map.lookup c lists >>=+ (\(l : ls) -> calc' l (Map.insert c ls lists) newMap cs)++ Just old ->+ return $ r1 ++ r2+ where+ r1 = fromMaybe [] $ reduceLists (subject x) lists hourMap minList+ r2 = fromMaybe [] $ reduceLists (subject old) lists newMap minList++ where+ newMap = Map.insert (time x) x hourMap++ reduceLists :: Ord s => s -> MappedLessons s -> MappedSchedule s -> [s] -> Maybe [MappedSchedule s]+ reduceLists s lists schedules subjects = Map.lookup s lists >>=+ (\l ->+ case l of+ [] -> Nothing+ (c : cs) -> calc' c (Map.insert s cs lists) schedules subjects+ )
+ src/SchedulePlanner/Serialize.hs view
@@ -0,0 +1,172 @@+{-|+Module : $Header$+Description : (de)serializing in- and output+Copyright : (c) Justus Adam, 2015+License : LGPL-3+Maintainer : development@justusadam.com+Stability : experimental+Portability : POSIX++Hold the capeablilities to get and export in- and output data as well as (de)serialize it+-}+module SchedulePlanner.Serialize where++import Control.Applicative (pure, (<*>))+import Control.Monad (liftM)+import Data.List (intercalate)+import qualified Data.Map as Map (assocs, lookup)+import SchedulePlanner.Calculator+import Text.JSON as JSON (JSON, JSObject, JSValue (JSArray, JSObject),+ Result (..), decodeStrict,+ encode, showJSON,+ toJSObject, valFromObj)+import Text.Printf (printf)++++-- |Key for the rules data in the json input+ruleKey = "rules"+-- |Key for the lesson data in the json input+lessonKey = "lessons"+-- |Key for the scope property in Rule objects in the json input+scopeKey = "scope"+-- |Key for the severity property in Rule objects in the json input+severityKey = "severity"+-- |Key for the day property in Rule objects in the json input+ruleDayKey = "day"+-- |Key for the slot property in Rule objects in the json input+ruleSlotKey = "slot"+-- |Key for the subject property in Lesson objects in the json input+subjectKey = "subject"+-- |Key for the day property in Lesson objects in the json input+lessonDayKey = "day"+-- |Key for the slot property in Rule objects in the json input+lessonSlotKey = "slot"+++-- |How many days a week has+daysPerWeek = 7+-- |The amount of imeslots each day+slotsPerDay = 7+-- |The caracter width of a single slot in output+cellWidth = 20+++-- |Open a file and return the contents as parsed json+getFromFile :: JSON a => String -> IO(Result a)+getFromFile filename = liftM decodeStrict (readFile filename)+++-- |Open a file and write json to it+writeToFile :: String -> JSValue -> IO()+writeToFile filename = writeFile filename . JSON.encode+++-- | parses file as JSON and returns internally used data structures+-- | convenience function+deSerialize :: String -> Result ([Result Rule], [Result (Lesson String)])+deSerialize = transformTypes . decodeStrict+++-- |Turns parsed json values into the internally used datastructures.+transformTypes :: Result JSValue -> Result ([Result Rule], [Result (Lesson String)])+transformTypes (Ok (JSObject o)) = do+ rv <- valFromObj ruleKey o+ lv <- valFromObj lessonKey o++ rules <- extractRules rv+ lessons <- extractLessons lv++ return (rules, lessons)+transformTypes (Ok _) = Error "wrong value type"+transformTypes (Error e) = Error e+++serialize :: Show s => [MappedSchedule s] -> String+serialize = JSON.encode . nativeToJson+++-- |Transform Native the native schedules into JSON+nativeToJson :: Show s => [MappedSchedule s] -> JSValue+nativeToJson = JSArray . map convert+ where+ convert :: Show s => MappedSchedule s -> JSValue+ convert =+ pure (\a b -> JSObject (JSON.toJSObject [a,b]))+ <*> ((,) "weight" . showJSON . totalWeight)+ <*> ((,) "values" . JSArray .+ map+ (\((i, j), b) ->+ JSObject (JSON.toJSObject [+ ("day", showJSON i),+ ("slot", showJSON j),+ ("subject", (showJSON . show . subject) b)+ ]))+ . Map.assocs+ )+++-- |Turns a parsed json value into a 'List' of 'Rule's or return an 'Error'+extractRules :: JSValue -> Result [Result Rule]+extractRules (JSArray rv) = return $ map handleOne rv+ where+ handleOne :: JSValue -> Result Rule+ handleOne (JSObject o) = do+ scope <- valFromObj scopeKey o+ severity <- valFromObj severityKey o++ let rp = (`Rule` severity)++ case scope of+ "day" -> do+ day <- valFromObj ruleDayKey o+ return $ rp $ Day day+ "slot" -> do+ slot <- valFromObj ruleSlotKey o+ return $ rp $ Slot slot+ "cell" -> do+ slot <- valFromObj ruleSlotKey o+ day <- valFromObj ruleDayKey o+ return $ rp $ Cell day slot++ handleOne _ = Error "wrong value type"++extractRules _ = Error "key lessons does not contain array"+++-- |Turns a parsed json value into a 'List' of 'Lesson's or return an 'Error'+extractLessons :: JSValue -> Result [Result (Lesson String)]+extractLessons (JSArray a) = return $ map handleOne a+ where+ handleOne :: JSValue -> Result (Lesson String)+ handleOne (JSObject o) = do+ subject <- valFromObj subjectKey o+ day <- valFromObj lessonDayKey o+ slot <- valFromObj lessonSlotKey o+ return $ Lesson slot day 0 subject+ handleOne _ = Error "wrong type"++extractLessons _ = Error "wrong value type"+++shortSubject :: Show s => s -> String+shortSubject = reverse . take cellWidth . reverse . show+++{-|+ Transform a 'MappedSchedule' into a printable,+ and more importantly, readable String+-}+formatSchedule :: Show s => MappedSchedule s -> String+formatSchedule hours = intercalate "\n" $ header : map formatDay allHours+ where+ allHours = [(i, [1..slotsPerDay]) | i <- [1..daysPerWeek]]++ formatLesson :: Timeslot -> String+ formatLesson i =+ printf ("%" ++ show cellWidth ++ "v") $ maybe [] (shortSubject . subject) (Map.lookup i hours)++ formatDay :: (Int, [Int]) -> String+ formatDay (i, l) = intercalate " | " [formatLesson (j, i) | j <- l]++ header = printf "Total Weight: %10v" (totalWeight hours)
+ src/SchedulePlanner/Server.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+module SchedulePlanner.Server where++import Control.Applicative ((<$>), optional)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text.Lazy (unpack)+import Happstack.Lite+import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label)+import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value)+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A