Fix calendar

1 files changed, 99 insertions, 23 deletions

diff --git a/assignment-7/appointments.icl b/assignment-7/appointments.icl
index 6f5a6d9..54b2d86 100644
--- a/assignment-7/appointments.icl
+++ b/assignment-7/appointments.icl
@@ -1,6 +1,7 @@
 module appointments
 
 from StdFunc import flip, id, seq
+import StdInt
 
 import GenPrint
 
@@ -11,9 +12,15 @@ import Data.List
 import qualified Data.Map as M
 import Data.Tuple
 import qualified Graphics.Scalable as G
-from Graphics.Scalable import class margin, instance margin Span
+from Graphics.Scalable import
+	class margin, instance margin Span,
+	class *.(..), instance *. Span,
+	:: FontDef{..}, :: FillAttr{..}, :: StrokeAttr{..}, :: StrokeWidthAttr{..},
+	<@<, class tuneImage, instance tuneImage FillAttr,
+	instance tuneImage StrokeAttr, instance tuneImage StrokeWidthAttr,
+	class toSVGColor(..), instance toSVGColor String
 import System.Time
-from Text import class Text(concat), instance Text String
+from Text import class Text(concat), instance Text String, <+
 import Text.HTML
 
 import iTasks
@@ -23,6 +30,9 @@ import iTasks.Extensions.SVG.SVGEditor
 
 import DateExtensions
 
+indexOf :: a [a] -> Int | == a
+indexOf e [x:xs] = if (x == e) 0 (1 + indexOf e xs)
+
 :: Appointment =
 	{ title        :: String
 	, when         :: DateTime
@@ -33,9 +43,19 @@ import DateExtensions
 
 derive class iTask Appointment
 derive JSEncode Appointment, User, Time, DateTime, Maybe
+instance == Appointment where == a b = a === b
 
 appointments :: Shared [Appointment]
-appointments = sharedStore "appointments" []
+appointments = sharedStore "appointments"
+	[ {title="Advanced Programming",  when={DateTime|year=2017,mon=11,day= 6,hour=10,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]}
+	, {title="Information Retrieval", when={DateTime|year=2017,mon=11,day= 6,hour=15,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]}
+	, {title="Cultural Contacts",     when={DateTime|year=2017,mon=11,day= 7,hour=13,min= 0,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]}
+	, {title="Historical Grammar",    when={DateTime|year=2017,mon=11,day= 7,hour=15,min= 0,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]}
+	, {title="Text Mining",           when={DateTime|year=2017,mon=11,day= 8,hour= 8,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]}
+	, {title="Testing Techniques",    when={DateTime|year=2017,mon=11,day= 8,hour= 8,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]}
+	, {title="Testing Techniques",    when={DateTime|year=2017,mon=11,day=10,hour= 8,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]}
+	, {title="Advanced Programming",  when={DateTime|year=2017,mon=11,day=10,hour=10,min=30,sec=0}, duration={Time|hour=2,min=0,sec=0}, owner=AuthenticatedUser "root" ["admin","manager"] (Just "Root user"), participants=[]}
+	]
 
 belongsTo :: User Appointment -> Bool
 belongsTo u a = isMember u [a.owner:a.participants]
@@ -43,6 +63,19 @@ belongsTo u a = isMember u [a.owner:a.participants]
 inFuture :: DateTime Appointment -> Bool
 inFuture d a = d < addTime a.duration a.when
 
+overlap :: Appointment Appointment -> Bool
+overlap a b =
+	a.when.DateTime.year == b.when.DateTime.year &&
+	a.when.DateTime.mon  == b.when.DateTime.mon  &&
+	a.when.DateTime.day  == b.when.DateTime.day  &&
+	(starta <= startb && enda >= startb
+		|| startb <= starta && endb >= starta)
+where
+	starta = 3600 * a.when.DateTime.hour + 60 * a.when.DateTime.min + a.when.DateTime.sec
+	startb = 3600 * b.when.DateTime.hour + 60 * b.when.DateTime.min + b.when.DateTime.sec
+	enda = starta + 3600 * a.duration.Time.hour + 60 * a.duration.Time.min + a.duration.Time.sec
+	endb = startb + 3600 * b.duration.Time.hour + 60 * b.duration.Time.min + b.duration.Time.sec
+
 addAppointment :: Appointment -> Task Appointment
 addAppointment app =
 	upd (flip (++) [app]) appointments >>|
@@ -166,6 +199,7 @@ where
 	worklist =
 		[ restrictedTransientWorkflow "Manage users" "Manage users" ["admin"] manageUsers
 		, transientWorkflow "Show appointments"   "Show appointments"   showAppointments
+		, transientWorkflow "Show calendar"       "Show calendar"       showCalendar
 		, transientWorkflow "Make appointment"    "Make appointment"    makeAppointment
 		, transientWorkflow "Propose appointment" "Propose appointment" proposeAppointment
 		]
@@ -185,38 +219,80 @@ where
 	toTuple app = (app.Appointment.title, app.when, app.duration, app.owner, app.participants)
 	fromTuple (t,w,d,o,p) = {title=t, when=w, duration=d, owner=o, participants=p}
 
-/*showAppointments :: Task [Appointment]
-showAppointments =
+showCalendar :: Task [Appointment]
+showCalendar =
 	get currentUser >>= \user ->
 	get currentDate >>= \date ->
 	viewSharedInformation
 		(Title "Future appointments")
-		[ViewUsing (filter (belongsTo user)) (fromSVGEditor (editor (previous Sunday date)))]
+		[ViewUsing (filter (belongsTo user))
+			(fromSVGEditor (editor (take 7 $ iterate nextDay $ previous Sunday date)))]
 		appointments
 where
-	editor :: Date -> SVGEditor [Appointment] [Appointment]
-	editor day =
+	editor :: [Date] -> SVGEditor [Appointment] [Appointment]
+	editor days =
 		{ initView    = id
-		, renderImage = const (draw day)
-		, updView     = flip const
-		, updModel    = const
+		, renderImage = const (draw days)
+		, updView     = \m _ -> m
+		, updModel    = \_ v -> v
 		}
 
-	draw :: Date [Appointment] *'G'.TagSource -> 'G'.Image [Appointment]
-	draw date apps tags = 'G'.beside (repeat 'G'.AtMiddleY) []
-		['G'.margin ('G'.px 10.0) $ 'G'.above (repeat 'G'.AtLeft) []
-			['G'.text ('G'.normalFontDef "Arial" 20.0) "Appointments":
-			['G'.text ('G'.normalFontDef "Arial" 14.0) app.Appointment.title
-			\\ app <- appsOn day apps
-			]] 'G'.NoHost
-		\\ day <- days
+	draw :: [Date] [Appointment] *'G'.TagSource -> 'G'.Image [Appointment]
+	draw dates apps tags = 'G'.margin ('G'.px 10.0) $ 'G'.grid
+		('G'.Columns 8)
+		('G'.ColumnMajor, 'G'.LeftToRight, 'G'.TopToBottom)
+		(repeat ('G'.AtMiddleX, 'G'.AtTop))
+		[] (
+		[spacer,spacer,spacer,'G'.collage hourlocs
+			['G'.margin ('G'.px 9.0) $
+				'G'.text {font & fontysize=12.0} $
+				timeString {Time|hour=h,min=0,sec=0} \\ h <- [0..23]] 'G'.NoHost] ++ flatten
+		[['G'.empty daywidth ('G'.px 0.0)
+		, 'G'.text {font & fontweight="bold"} (toString $ dayOfWeek day)
+		, 'G'.text font (toString day)
+		, 'G'.collage
+			(hourlocs ++ [('G'.px $ toReal (overlapOffset app apps) * 40.0, timespan (toTime app.when))
+				\\ app <- apps | toDate app.when == day])
+			(hours ++ [appimage app \\ app <- apps | toDate app.when == day])
+			'G'.NoHost
 		]
+		\\ day <- dates
+		])
 		'G'.NoHost
 	where
-		days = take 7 $ iterate nextDay date
-
-		appsOn :: Date -> [Appointment] -> [Appointment]
-		appsOn d = filter (\a -> toDate a.when == d)*/
+		spacer = 'G'.empty ('G'.px 0.0) ('G'.px 0.0)
+		font = 'G'.normalFontDef "Arial" 14.0
+		daywidth = 'G'.px 200.0
+		hourheight = 'G'.px 30.0
+
+		timespan t = hourheight *. (toReal t.Time.hour + toReal t.Time.min / 60.0)
+
+		overlapOffset :: Appointment [Appointment] -> Int
+		overlapOffset app apps = indexOf app (filter (overlap app) apps)
+
+		hourlocs = [('G'.px 0.0, hourheight *. h) \\ h <- [0..23]]
+		hours = ['G'.rect daywidth hourheight
+			<@< {fill=toSVGColor "#eeeeee"}
+			<@< {stroke=toSVGColor "#cccccc"}
+			<@< {strokewidth='G'.px 1.0} \\ h <- [0..23]]
+
+		appimage app = 'G'.overlay
+			[('G'.AtLeft, 'G'.AtMiddleY)] []
+			['G'.above [] (repeat ('G'.px 5.0, 'G'.px 0.0))
+				['G'.text font app.Appointment.title
+				,'G'.text {font & fontysize=11.0} (timeString $ toTime app.Appointment.when)
+				] 'G'.NoHost]
+			('G'.Host ('G'.rect ('G'.px 200.0) (timespan app.duration)
+			<@< {fill=toSVGColor "#92E1C0"} <@< {stroke=toSVGColor "#33B694"}))
+
+		timeString :: Time -> String
+		timeString {Time|hour,min,sec} = h +++ ":" +++ m +++ s +++ " " +++ ampm
+		where
+			h = if (hour == 12) "12" (toString (hour rem 12))
+			m = pad min
+			s = if (sec == 0) "" (":" <+ pad sec)
+			ampm = if (hour < 12) "am" "pm"
+			pad v = if (v < 10) (0 <+ v) (toString v)
 
 makeAppointment :: Task (Maybe Appointment)
 makeAppointment =