path: root/assignment-7/appointments.icl

module appointments

from StdFunc import flip, id, seq
import StdInt

import GenPrint

import Data.Bifunctor
from Data.Func import $
import Data.Functor
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,
	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, <+
import Text.HTML

import iTasks
import iTasks.UI.Editor.Common
import iTasks.Extensions.DateTime
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
	, duration     :: Time
	, owner        :: User
	, participants :: [User]
	}

derive class iTask Appointment
derive JSEncode Appointment, User, Time, DateTime, Maybe
instance == Appointment where == a b = a === b

appointments :: Shared [Appointment]
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]

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 >>|
	allTasks [assign (attrs u) finishTask \\ u <- app.participants] $>
	app
where
	finishTask :: Task ()
	finishTask =
		wait (Title "Wait for the start of this appointment") (\now -> now >= app.when) currentDateTime >>= \_ ->
		viewInformation (Title app.Appointment.title) [] "Click 'Done' to finish this task." >>*
		[OnAction (Action "Done") (always $ return ())]

	attrs :: User -> TaskAttributes
	attrs u = workerAttributes u
		[ ("title",          app.Appointment.title)
		, ("createdAt",      toString app.when)
		, ("createdBy",      toString app.owner)
		, ("createdFor",     toString u)
		, ("completeBefore", toString (addTime app.duration app.when))
		]

:: Availability
	= Maybe
	| Yes
	| No

derive gPrint Availability
instance toString Availability where toString a = printToString a

showAvailability :: (Maybe Availability) -> String
showAvailability Nothing  = "Unknown"
showAvailability (Just a) = toString a

:: ProposedAppointment =
	{ appointment  :: Appointment
	, startOptions :: [(DateTime, 'M'.Map User Availability)]
	}

derive class iTask Availability, ProposedAppointment

proposedAppointments :: Shared (Int, 'M'.Map Int ProposedAppointment)
proposedAppointments = sharedStore "proposedAppointments" (0, 'M'.newMap)

addProposedAppointment :: ProposedAppointment -> Task Int
addProposedAppointment papp=:{appointment={Appointment|title}} =
	get proposedAppointments >>= \(idx,_) ->
	upd (bifmap ((+) 1) ('M'.put idx papp)) proposedAppointments >>|
	allTasks [appendTopLevelTask (chooseAttrs u) False $ chooseTask idx u \\ u <- papp.appointment.participants] >>=
	appendTopLevelTask (manageAttrs papp.appointment.owner) False o manageTask idx >>|
	return idx
where
	chooseTask :: Int User -> Task (Int, 'M'.Map Int ProposedAppointment)
	chooseTask idx user =
		allTasks [updateInformation (toString w) [] Maybe \\ (w,_) <- papp.startOptions] >>= \avail ->
		upd (second $ 'M'.alter (fmap (setAvailability user avail)) idx) proposedAppointments
	where
		setAvailability :: User [Availability] ProposedAppointment -> ProposedAppointment
		setAvailability u as papp = {papp & startOptions=[(w, 'M'.put u a m) \\ (w,m) <- papp.startOptions & a <- as]}

	chooseAttrs :: User -> TaskAttributes
	chooseAttrs u = workerAttributes u
		[ ("title",      "Indicate availability for " +++ title)
		, ("createdBy",  toString papp.appointment.owner)
		, ("createdFor", toString u)
		]

	manageTask :: Int [TaskId] -> Task ()
	manageTask idx chooseTasks = ((
			viewSharedInformation
				(Title $ "Manage " +++ title)
				[ViewUsing (fromJust o 'M'.get idx o snd) proposalViewer]
				proposedAppointments
		||-
			enterChoice "Pick start time" [] (map fst papp.startOptions)
		) >>*
			[ OnAction (Action "Schedule appointment") $ hasValue schedule
			, OnAction (Action "Cancel appointment")   $ always cancel
			]
		) $> ()
	where
		proposalViewer :: Editor ProposedAppointment
		proposalViewer = comapEditorValue toTuple $ container4
			(withLabelAttr "Title"         gEditor{|*|})
			(withLabelAttr "Duration"      gEditor{|*|})
			(withLabelAttr "Participants"  usersViewer)
			(withLabelAttr "Start options" grid)

		toTuple :: ProposedAppointment -> (String, Time, [User], (ChoiceGrid, [Int]))
		toTuple papp =
			( papp.appointment.Appointment.title
			, papp.appointment.duration
			, papp.appointment.participants
			, ( { header = ["User":[toString u \\ u <- papp.appointment.participants]]
			    , rows   =
			      [ {id= i, cells=[Text $ toString d:
			          [Text $ showAvailability $ 'M'.get u o
			            \\ u <- papp.appointment.participants ]]}
			      \\ i <- [0..] & (d,o) <- papp.startOptions]
			    }
			  , []
			  )
			)

		schedule start = addAppointment {papp.appointment & when=start} >>| cancel

		cancel =
			allTasks (map (flip removeTask topLevelTasks) chooseTasks) >>|
			upd (second $ 'M'.del idx) proposedAppointments

	manageAttrs :: User -> TaskAttributes
	manageAttrs u = workerAttributes u
		[ ("title",      "Manage " +++ title)
		, ("createdBy",  toString papp.appointment.owner)
		, ("createdFor", toString papp.appointment.owner)
		]

Start :: *World -> *World
Start w = startEngine (loginAndManageWorkList "Scheduler" worklist) w
where
	worklist :: [Workflow]
	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
		]

showAppointments :: Task [Appointment]
showAppointments =
	get currentUser >>= \user ->
	get currentDateTime >>= \now ->
	viewSharedInformation
		(Title "Future appointments")
		[ViewUsing (filter (\a -> belongsTo user a && inFuture now a)) editor]
		appointments
where
	editor = listEditor Nothing False False Nothing (bijectEditorValue toTuple fromTuple tupEdit)
	tupEdit = toolbar5 gEditor{|*|} gEditor{|*|} gEditor{|*|} userViewer usersViewer
	userViewer = comapEditorValue toString gEditor{|*|}
	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}

showCalendar :: Task [Appointment]
showCalendar =
	get currentUser >>= \user ->
	get currentDate >>= \date ->
	viewSharedInformation
		(Title "Future appointments")
		[ViewUsing (filter (belongsTo user))
			(fromSVGEditor (editor (take 7 $ iterate nextDay $ previous Sunday date)))]
		appointments
where
	editor :: [Date] -> SVGEditor [Appointment] [Appointment]
	editor days =
		{ initView    = id
		, renderImage = const (draw days)
		, updView     = \m _ -> m
		, updModel    = \_ v -> v
		}

	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
		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 =
	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 $ fmap Just o addAppointment)
		, OnAction ActionCancel    (always   $ makeAppointment)
		]
where onehour = {Time | hour=1,min=0,sec=0}

proposeAppointment :: Task (Maybe ProposedAppointment)
proposeAppointment =
	get currentUser >>= \user ->
	get currentDateTime >>= \now ->
	allTasks
		[ enterInformation  "Title"         []         @ \t pa -> {pa & appointment.Appointment.title=t}
		, updateInformation "Duration"      [] onehour @ \d pa -> {pa & appointment.duration=d}
		, enterInformation  "Start options" []         @ \w pa -> {pa & startOptions=map (flip tuple 'M'.newMap) w}
		, enterMultipleChoiceWithShared "Participants" [ChooseFromCheckGroup id] users @ \ps pa -> {pa & appointment.participants=ps}
		]
	@ flip seq {gDefault{|*|} & appointment.owner=user} >>*
		[ OnAction (Action "Propose") (ifValue (\papp -> not $ isEmpty papp.startOptions) addProposedAppointment`)
		, OnAction ActionCancel       (always  $ proposeAppointment)
		]
where
	addProposedAppointment` :: ProposedAppointment -> Task (Maybe ProposedAppointment)
	addProposedAppointment` papp = addProposedAppointment papp $> Just papp

	onehour = {Time | hour=1,min=0,sec=0}

usersViewer :: Editor [User]
usersViewer = comapEditorValue (concat o intersperse "; " o map toString) textView