module CalLayout where
import Data.List
import Data.Tree
type TimeUnit = Int
class (Eq a) => CalEvent a where
start :: a -> TimeUnit
end :: a -> TimeUnit
data Dimension = Dimension {
top :: Double
, left :: Double
, width :: Double
, height :: Double
} deriving (Show)
insertEventTree :: (CalEvent a) => a -> Tree a -> Tree a
insertEventTree e n@(Node t t') = if e `intersects` t then Node t (insertEventForest e t') else n
intersects :: (CalEvent a) => a -> a -> Bool
intersects e e' = (start e >= start e' && start e < end e')
|| ((start e' == start e) || (end e' == end e))
treeContains :: (CalEvent a) => a -> Tree a -> Bool
treeContains e (Node e' []) = e == e'
treeContains e (Node e' trs) = e == e' || any (treeContains e) trs
insertEventForest :: (CalEvent a) => a -> Forest a -> Forest a
insertEventForest e [] = [Node e []]
insertEventForest e (t:ts) = let newTree = insertEventTree e t in
if treeContains e newTree
then newTree : ts
else t : insertEventForest e ts
mkIntersectionsForest :: (CalEvent a) => [a] -> Forest a
mkIntersectionsForest events = go (sortBy startSort events) []
where
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 [] forest = forest
go (e:es) forest = go es (insertEventForest 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 :: (CalEvent 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 :: (CalEvent a) => [a] -> [(a, Dimension)]
getDimensions events = calculateDimensions $ mkIntersectionsForest events