module CalLayout (CalLayout(..), Dimension, getDimensions) where
import Data.List
import Data.Tree
type TimeUnit = Int
class (Eq a) => CalLayout a where
start :: a -> TimeUnit
end :: a -> TimeUnit
data Dimension = Dimension {
top :: Double
, left :: Double
, width :: Double
, height :: Double
} deriving (Show)
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
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))
treeContains :: (CalLayout a) => a -> Tree a -> Bool
treeContains e (Node e' []) = e == e'
treeContains e (Node e' trs) = e == e' || any (treeContains e) trs
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
mkIntersectionsForest :: (CalLayout a) => [a] -> a -> Forest a
mkIntersectionsForest events initial = go (sortBy startSort events) initialTree
where
initialTree = Node initial []
startSort e1 e2 | start e1 == start e2 = lengthSort e1 e2
| start e1 < start e2 = LT
| otherwise = GT
lengthSort e1 e2 | end e2 < end e1 = LT
| otherwise = GT
go [] (Node r f) = f
go (e:es) forest = go es (insertEvent e forest)
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 []
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 = fromIntegral $ start e
left = width * fromIntegral depth
width = 100 / (1 + fromIntegral maxDepth)
height = fromIntegral $ end e - start e
getDimensions :: (CalLayout a) => [a] -> a -> [(a, Dimension)]
getDimensions events initial = calculateDimensions $ mkIntersectionsForest events initial