diff --git a/schedule-planner.cabal b/schedule-planner.cabal --- a/schedule-planner.cabal +++ b/schedule-planner.cabal @@ -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 diff --git a/src/SchedulePlanner/App.hs b/src/SchedulePlanner/App.hs new file mode 100644 --- /dev/null +++ b/src/SchedulePlanner/App.hs @@ -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) diff --git a/src/SchedulePlanner/Calculator.hs b/src/SchedulePlanner/Calculator.hs new file mode 100644 --- /dev/null +++ b/src/SchedulePlanner/Calculator.hs @@ -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 diff --git a/src/SchedulePlanner/Calculator/Scale.hs b/src/SchedulePlanner/Calculator/Scale.hs new file mode 100644 --- /dev/null +++ b/src/SchedulePlanner/Calculator/Scale.hs @@ -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 diff --git a/src/SchedulePlanner/Calculator/Solver.hs b/src/SchedulePlanner/Calculator/Solver.hs new file mode 100644 --- /dev/null +++ b/src/SchedulePlanner/Calculator/Solver.hs @@ -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 + ) diff --git a/src/SchedulePlanner/Serialize.hs b/src/SchedulePlanner/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/SchedulePlanner/Serialize.hs @@ -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) diff --git a/src/SchedulePlanner/Server.hs b/src/SchedulePlanner/Server.hs new file mode 100644 --- /dev/null +++ b/src/SchedulePlanner/Server.hs @@ -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