module Timetable ( ppTimetable, Entry
                 , monday, tuesday, wednesday, thursday, friday, saturday, sunday
                 , weekend, weekdays, sixdays, everyday
                 ) 
where

-- Import some nice stuff
import Data.List
import Data.Maybe

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Map (Map)
import qualified Data.Map as Map

-- Define a couple of handy datatypes
type Hour   = Int
type Minute = Int
type Time   = (Hour, Minute)
data Day    = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday deriving (Enum, Eq, Ord, Show)
type Entry  = (Time, Set Day)      -- for our DSL, easy specification
type EntryMap = Map Time (Set Day) -- hidden internal conversion
type Point  = (Int, Double)        -- x, y coordinate

-- Some shortcuts, for easy writing
monday    t = (t, Set.singleton Monday)
tuesday   t = (t, Set.singleton Tuesday)
wednesday t = (t, Set.singleton Wednesday)
thursday  t = (t, Set.singleton Thursday)
friday    t = (t, Set.singleton Friday)
saturday  t = (t, Set.singleton Saturday)
sunday    t = (t, Set.singleton Sunday)

weekend  t = (t, Set.fromList [Saturday, Sunday])
weekdays t = (t, Set.fromList [Monday, Tuesday, Wednesday, Thursday, Friday])
sixdays  t = (t, Set.fromList [Monday, Tuesday, Wednesday, Thursday, Friday, Saturday])
everyday t = (t, Set.fromList [Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday])

-- Ah, the core of our program
ppTimetable :: String -> [Entry] -> IO ()
ppTimetable title timetable = do
    putStrLn "\\documentclass{article}"
    putStrLn "\\usepackage{tikz}"
    putStrLn "\\usepackage{pdflscape}"
    putStrLn "\\usepackage{palatino}"
    putStrLn "\\usepackage[margin=1in]{geometry}"
    putStrLn "\\begin{document}"
    putStrLn "\\colorlet{color0}{black}"
    putStrLn "\\colorlet{color1}{darkgray}"
    putStrLn "\\colorlet{color2}{gray}"
    putStrLn "\\colorlet{color3}{lightgray}"
    putStrLn "\\colorlet{color4}{white}"
    putStrLn "\\pagestyle{empty}"
    putStrLn "\\begin{landscape}"
    putStrLn "\\begin{center}"
    makeTitle title
    putStrLn "\\begin{tikzpicture}"
    putStrLn "% Draw grid and axes with tick marks"
    putStrLn "\\draw [white] (0,-1.2) -- (0,12.2); % ugly trick to increase margins" 
    putStrLn $ "\\draw [gray] (-0.2,-0.9) grid (" ++ show h ++ ".2, 11.2);"
    minuteTicks
    hourTicks hs
    dataPoints tt hs ds
    putStrLn "\\end{tikzpicture}"
    legend ds
    putStrLn "\\end{center}"
    putStrLn "\\end{landscape}"
    putStrLn "\\end{document}"
    where hs = hours timetable
          h  = length hs - 1
          tt = timeMap timetable
          ds = limitSets $ daySets tt

-- Let's try to be terse
ppDaySet :: Set Day -> String
ppDaySet ds = ppDaySet' (Set.toList ds) False

ppDaySet' :: [Day] -> Bool -> String
ppDaySet' []  _ = ""
ppDaySet' [d] _ = show d
ppDaySet' [Saturday,Sunday] _ = "Weekends"
ppDaySet' [Monday,Tuesday,Wednesday,Thursday,Friday] _ = "Weekdays"
ppDaySet' [Monday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday] _ = "Every day"
ppDaySet' (prev:rest@(next:ds)) succMode 
    | next == succ prev && succMode        = ""                 ++ ppDaySet' rest True
    | next == succ prev && not (null ds)   = show prev ++ "---" ++ ppDaySet' rest True
    | otherwise                            = show prev ++ ", "  ++ ppDaySet' rest succMode

-- A title (optional)
makeTitle :: String -> IO ()
makeTitle [] = return ()
makeTitle s  = putStrLn $ "{\\huge " ++ s ++ "}\n"

-- Make a nice map (could be rewritten using an accumulator for better behaviour)
timeMap :: [Entry] -> Map Time (Set Day)
timeMap [] = Map.empty
timeMap ((t,ds):e) = Map.insertWith Set.union t ds (timeMap e)

-- (Ordering could be improved, taking into account the order of the days?)
daySets :: Map Time (Set Day) -> [Set Day]
daySets = sortBy (\x y -> compare (Set.size y) (Set.size x)) . nub . Map.elems -- note: reversed x y

limitSets :: [Set Day] -> [Set Day]
limitSets s | length s > 5 = error "Too many different combinations of days, I can't draw a clear table for this"
            | otherwise    = s

-- Calculate a nice stretch of hours, leaving the biggest hole out
hours :: [Entry] -> [Hour]
hours ps = bestSplit . sort . nub . hours' $ ps
    where
        hours' :: [Entry] -> [Hour]
        hours' []     = []
        hours' (((h,_),_):ps') = h : hours' ps'

bestSplit hs'@(h':_) | end == split = [h'..end] -- this one is easy, we can keep the list, but have to fill in the missing numbers
                     | otherwise    = [head (dropWhile (<= split) hs')..23] ++ [0..split] -- fill in the part around midnight
    where end   = last hs'
          split = bestSplit' h' hs' 0 0

          bestSplit' :: Hour -> [Hour] -> Hour -> Hour -> Hour
          bestSplit' _ [] _ split = error "This should never happen"
          bestSplit' start [end] max split | 24 - end + start >= max = end -- if it doesn't matter, we prefer to split at midnight
                                           | otherwise               = split
          bestSplit' start (prev:rest@(next:_)) max split | next - prev > max = bestSplit' start rest (next - prev) prev
                                                          | otherwise         = bestSplit' start rest max split

-- Coordinate calculation for drawing
coordinate :: Time -> [Hour] -> Point
coordinate (h, m) hs = (fromJust $ elemIndex h hs, 11.0 - ((fromIntegral m) / 5.0))

color :: Set Day -> [Set Day] -> Int
color ds dss = fromJust $ elemIndex ds dss

dataPoints :: EntryMap -> [Hour] -> [Set Day] -> IO () 
dataPoints tt hs dss = sequence_ $ map (\(t,ds) -> drawPoint (coordinate t hs) (color ds dss)) $ Map.assocs tt

drawPoint :: Point -> Int -> IO ()
drawPoint p c = putStrLn $ tikzDot p c

-- Place the minutes along the y-axis
minuteTicks :: IO ()
minuteTicks = sequence_ $ 
    map (\(m,x) -> putStrLn $ "\\draw (-0.3," ++ show x ++ ") node[anchor=east] {:" ++ pad 2 m ++ "};")
        (zip [55,50..0] [0..11])

-- And place the hours along the x-axis
hourTicks :: [Hour] -> IO ()
hourTicks hours = sequence_ $
    map (\(h,x) -> putStrLn $ "\\draw (" ++ show x ++ ",11.2) node[above] {" ++ show h ++ "};")
        (zip hours [0..])

-- Padded numbers look nice(r)
pad :: Int -> Int -> String
pad length number = (reverse . take length . reverse) $ replicate length '0' ++ show number 

-- Legend
legend :: [Set Day] -> IO ()
legend ds = do
    putStr "\n"
    sequence_ $ 
        map (\(x,d) -> putStrLn $ "\\tikz " ++ tikzDot (0,0) x ++ " " ++ ppDaySet d ++ "\\qquad") 
            (zip [0..] ds)

tikzDot :: Point -> Int -> String
tikzDot (x,y) c = "\\filldraw [fill=color" ++ show c ++ "] (" ++ show x ++ "," ++ show y ++ ") ellipse (5pt and 3pt);"