Add showAppointments tryouts with SVG, nicer makeAppointment, proposeAppointment stub

3 files changed, 171 insertions, 19 deletions

diff --git a/assignment-7/DateExtensions.dcl b/assignment-7/DateExtensions.dcl
new file mode 100644
index 0000000..c7eacec
--- /dev/null
+++ b/assignment-7/DateExtensions.dcl
@@ -0,0 +1,15 @@
+definition module DateExtensions
+
+import iTasks.Extensions.DateTime
+
+:: Day = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday
+
+derive class iTask Day
+instance toString Day
+
+nextHour :: DateTime -> DateTime
+nextDay :: (Date -> Date)
+
+dayOfWeek :: Date -> Day
+
+previous :: Day Date -> Date
diff --git a/assignment-7/DateExtensions.icl b/assignment-7/DateExtensions.icl
new file mode 100644
index 0000000..fa9ebb0
--- /dev/null
+++ b/assignment-7/DateExtensions.icl
@@ -0,0 +1,62 @@
+implementation module DateExtensions
+
+import _SystemArray
+from StdFunc import flip
+
+from Data.Func import $
+import System.Time
+
+import iTasks
+import iTasks.Extensions.DateTime
+
+derive class iTask Day
+
+instance toString Day
+where
+	toString Sunday    = "Sunday"
+	toString Monday    = "Monday"
+	toString Tuesday   = "Tuesday"
+	toString Wednesday = "Wednesday"
+	toString Thursday  = "Thursday"
+	toString Friday    = "Friday"
+	toString Saturday  = "Saturday"
+
+(+~) infixl 6 :: Timestamp Int -> Timestamp
+(+~) (Timestamp t) i = Timestamp (t+i)
+
+(-~) infixl 6 :: Timestamp Int -> Timestamp
+(-~) (Timestamp t) i = Timestamp (t-i)
+
+timestampToGmDate :: (Timestamp -> Date)
+timestampToGmDate = toDate o timestampToGmDateTime
+
+nextHour :: DateTime -> DateTime
+nextHour t = timestampToGmDateTime (Timestamp ts`)
+where
+	(Timestamp ts) = utcDateTimeToTimestamp t
+	ts` = ts + 3600 - (ts rem 3600)
+
+nextDay :: (Date -> Date)
+nextDay = timestampToGmDate o (flip (+~) 86400) o utcDateToTimestamp
+
+// https://en.wikipedia.org/wiki/Determination_of_the_day_of_the_week#Schwerdtfeger.27s_method
+dayOfWeek :: Date -> Day
+dayOfWeek date = days.[(d + e + f + g + g / 4) rem 7]
+where
+	days :: {Day}
+	days = {Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday}
+	d = date.Date.day
+	e = {#0,3,2,5,0,3,5,1,4,6,2,4}.[date.Date.mon-1]
+	f = {#0,5,3,1}.[c rem 4]
+	(c,g) = if (date.Date.mon >= 3)
+		(y     / 100, y - 100 * c)
+		((y-1) / 100, y - 100 * c - 1)
+	y = date.Date.year
+
+previous :: Day Date -> Date
+previous day date
+| dayOfWeek date === day = date
+| otherwise = previous day $ timestampToGmDate $ minus 86400 $ utcDateToTimestamp date
+where
+	minus :: Int Timestamp -> Timestamp
+	minus i (Timestamp t) = Timestamp (t-i)
diff --git a/assignment-7/appointments.icl b/assignment-7/appointments.icl
index 9de3c26..ae23a6d 100644
--- a/assignment-7/appointments.icl
+++ b/assignment-7/appointments.icl
@@ -1,8 +1,18 @@
 module appointments
 
-from StdFunc import flip
+from StdFunc import flip, id, seq
+
 from Data.Func import $
+import Data.Functor
+import qualified Graphics.Scalable as G
+from Graphics.Scalable import class margin, instance margin Span
+import System.Time
+
 import iTasks
+import iTasks.Extensions.DateTime
+import iTasks.Extensions.SVG.SVGEditor
+
+import DateExtensions
 
 :: Appointment =
 	{ title        :: String
@@ -13,36 +23,101 @@ import iTasks
 	}
 
 derive class iTask Appointment
+derive JSEncode Appointment, User, Time, DateTime, Maybe
 
 appointments :: Shared [Appointment]
-appointments = sharedStore "appointments" []
+appointments = sharedStore "appointments"
+	[ {title="Sunday", when={DateTime | year=2017,mon=10,day=29,hour=10,min=0,sec=0}, duration={Time | hour=1,min=0,sec=0}, owner=SystemUser, participants=[]}
+	, {title="Monday", when={DateTime | year=2017,mon=10,day=30,hour=12,min=0,sec=0}, duration={Time | hour=1,min=0,sec=0}, owner=SystemUser, participants=[]}
+	]
 
-Start :: *World -> *World
-Start w = startEngine
-	(   addWorkFlows
-	>>| loginAndManageWorkList "Scheduler" worklist
-	) w
+belongsTo :: User Appointment -> Bool
+belongsTo u a = isMember u [a.owner:a.participants]
+
+inFuture :: DateTime Appointment -> Bool
+inFuture d a = d < timestampToGmDateTime tsend
 where
-	addWorkFlows :: Task [Workflow]
-	addWorkFlows = upd (flip (++) newwfs) workflows
-	where
-		newwfs =
-			[ transientWorkflow "Show appointments" "Show appointments" showAppointments
-			, transientWorkflow "Make appointment"  "Make appointment"  makeAppointment
-			]
+	(Timestamp tsapp) = utcDateTimeToTimestamp a.when
+	tsend = Timestamp $ tsapp + a.duration.Time.sec + 60 * (a.duration.Time.min + 60 * a.duration.Time.hour)
 
+:: ProposedAppointment =
+	{ appointment  :: Appointment
+	, startOptions :: [DateTime]
+	}
+
+derive class iTask ProposedAppointment
+
+proposedAppointments :: Shared [ProposedAppointment]
+proposedAppointments = sharedStore "proposedAppointments" []
+
+Start :: *World -> *World
+Start w = startEngine (loginAndManageWorkList "Scheduler" worklist) w
+where
 	worklist :: [Workflow]
-	worklist = [workflow "Manage users" "Manage users" manageUsers]
+	worklist =
+		[ workflow          "Manage users"        "Manage users"        manageUsers
+		, transientWorkflow "Show appointments"   "Show appointments"   showAppointments
+		, transientWorkflow "Make appointment"    "Make appointment"    makeAppointment
+		, transientWorkflow "Propose appointment" "Propose appointment" proposeAppointment
+		]
 
 showAppointments :: Task [Appointment]
 showAppointments =
 	get currentUser >>= \user ->
+	get currentDateTime >>= \now ->
 	viewSharedInformation
 		(Title "Future appointments")
-		[ViewAs $ filter (\a -> a.owner == user)]
+		[ViewAs (filter (\a -> belongsTo user a && inFuture now a))]
 		appointments
 
-makeAppointment :: Task [Appointment]
+/*showAppointments :: Task [Appointment]
+showAppointments =
+	get currentUser >>= \user ->
+	get currentDate >>= \date ->
+	viewSharedInformation
+		(Title "Future appointments")
+		[ViewUsing (filter (belongsTo user)) (fromSVGEditor (editor (previous Sunday date)))]
+		appointments
+where
+	editor :: Date -> SVGEditor [Appointment] [Appointment]
+	editor day =
+		{ initView    = id
+		, renderImage = const (draw day)
+		, updView     = flip const
+		, updModel    = const
+		}
+
+	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
+		]
+		'G'.NoHost
+	where
+		days = take 7 $ iterate nextDay date
+
+		appsOn :: Date -> [Appointment] -> [Appointment]
+		appsOn d = filter (\a -> toDate a.when == d)*/
+
+makeAppointment :: Task (Maybe Appointment)
 makeAppointment =
-	enterInformation (Title "Make appointment") [] >>= \app ->
-	upd (flip (++) [app]) appointments
+	get currentUser >>= \user ->
+	get currentDateTime >>= \now ->
+	allTasks
+		[ enterInformation  "Title"    []                @ \t a -> {Appointment | a & title=t}
+		, updateInformation "When"     [] (nextHour now) @ \w a -> {Appointment | a & when=w}
+		, updateInformation "Duration" [] onehour        @ \d a -> {Appointment | a & duration=d}
+		, enterMultipleChoiceWithShared "Participants" [ChooseFromCheckGroup id] users @ \ps a -> {a & participants=ps}
+		]
+	@ flip seq {gDefault{|*|} & owner=user} >>*
+		[ OnAction (Action "Make") (hasValue \app -> upd (flip (++) [app]) appointments $> Just app)
+		, OnAction ActionCancel    (always $ return Nothing)
+		]
+where onehour = {Time | hour=1,min=0,sec=0}
+
+proposeAppointment :: Task (Maybe ProposedAppointment)
+proposeAppointment = return Nothing