cal-layout-0.1.0.0: src/CalLayout.hs

module CalLayout (CalLayout(..), Dimension, getDimensions) where

import Data.List
import Data.Tree

type TimeUnit = Int

-- | Main interface for events.
class (Eq a) => CalLayout a where
    start :: a -> TimeUnit
    end :: a -> TimeUnit

-- | Dimension data type.
data Dimension = Dimension {
    top :: Double
    , left :: Double
    , width :: Double
    , height :: Double
} deriving (Show)

-- | Insert an event into a tree by calculating intersections.
insertEvent :: (CalLayout a) => a -> Tree a -> Tree a
insertEvent e n@(Node t t') = if e `intersects` t then Node t (insertEventForest e t') else n
    where
    -- | Given two events, check if they intersect.
    intersects :: (CalLayout a) => a -> a -> Bool
    intersects e e' = (start e >= start e' && start e < end e')
                           || ((start e' == start e) || (end e' == end e))
    -- | Given an event and a tree, check if the tree contains it.
    treeContains :: (CalLayout a) => a -> Tree a -> Bool
    treeContains e (Node e' [])  = e == e'
    treeContains e (Node e' trs) = e == e' || any (treeContains e) trs
    -- | Insert an event in a forest.
    insertEventForest :: (CalLayout a) => a -> Forest a -> Forest a
    insertEventForest e []       = [Node e []]
    insertEventForest e (x:xs)   = let newx = insertEvent e x in
                                 if treeContains e newx
                                 then newx : xs
                                 else x : insertEventForest e xs

-- | Make intersections forest by recursively using `insertEvent`.
-- we need to provide an initial member since a `Data.Tree` cannot be empty.
mkIntersectionsForest :: (CalLayout a) => [a] -> a -> Forest a
mkIntersectionsForest events initial = go (sortBy startSort events) initialTree
    where
    -- | The initial tree contains a root node with least and most start/end times
    -- for capturing all intersections.
    initialTree      = Node initial []
    -- | startSort first sorts by start time, then length of events
    startSort e1 e2  | start e1 == start e2 = lengthSort e1 e2
                     | start e1 < start e2  = LT
                     | otherwise            = GT
    -- | Sorts by length of events
    lengthSort e1 e2 | end e2 < end e1 = LT
                     | otherwise       = GT
    -- | Iterative function for constructing the forest
    go [] (Node r f) = f -- skip `initial` root
    go (e:es) forest = go es (insertEvent e forest)

-- | For a given forest, populate max depth and depth
-- we need those for calculating width/left respectively.
populateDepths :: Forest a -> [(a, Int, Int)]
populateDepths = concatMap populateDepth
    where
    calcDepth :: Tree a -> Int
    calcDepth (Node _ [])            = 0
    calcDepth (Node _ x)             = 1 + maximum (map calcDepth x)
    squish :: Int -> Tree a -> [(a, Int, Int)] -> [(a, Int, Int)]
    squish maxDepth n@(Node x ts) xs = (x, maxDepth, calcDepth n) : foldr (squish maxDepth) xs ts
    populateDepth :: Tree a -> [(a, Int, Int)]
    populateDepth t                  = squish (calcDepth t) t []

-- | Calculate dimensions for a forest.
calculateDimensions :: (CalLayout a) => Forest a -> [(a, Dimension)]
calculateDimensions forest = go (populateDepths forest)
    where
    go []                          = []
    go ((e, maxDepth, depth) : xs) = (e, Dimension top left width height) : go xs
        where
        -- top is straightforward.
        top    = fromIntegral $ start e
        -- left is a little more complex, since it relies on depth.
        left   = width * fromIntegral depth
        -- width is a little more complex, since it relies on max depth.
        width  = 100 / (1 + fromIntegral maxDepth)
        -- height is straightforward.
        height = fromIntegral $ end e - start e

-- | Helper wrapper for getting dimensions.
getDimensions :: (CalLayout a) => [a] -> a -> [(a, Dimension)]
getDimensions events initial = calculateDimensions $ mkIntersectionsForest events initial