scheduling (empty) → 0.1.0.0

raw patch · 15 files changed

+1816/−0 lines, 15 filesdep +aesondep +basedep +bimapsetup-changed

Dependencies added: aeson, base, bimap, bytestring, containers, gogol, gogol-sheets, lens, mime-mail, mtl, optparse-generic, random, sbv, scheduling, servant, text, time

Files

• LICENSE +30/−0
• README.md +59/−0
• Setup.hs +2/−0
• app/Main.hs +122/−0
• scheduling.cabal +82/−0
• src/Control/Scheduling.hs +64/−0
• src/Control/Scheduling/Event.hs +12/−0
• src/Control/Scheduling/Location.hs +14/−0
• src/Control/Scheduling/Mail.hs +214/−0
• src/Control/Scheduling/Person.hs +79/−0
• src/Control/Scheduling/Preference.hs +36/−0
• src/Control/Scheduling/Sheets.hs +481/−0
• src/Control/Scheduling/Solve.hs +482/−0
• src/Control/Scheduling/State.hs +96/−0
• src/Control/Scheduling/TimeSpan.hs +43/−0

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,59 @@+# scheduling - interview management utility for CLSP recruitment weekend++This code base produces a command-line utility for managing the interview+schedules of the CLSP recruitment weekend.  This involves manipulating+Google spreadsheets, and solving constraint-satisfaction problems based+on faculty preferences, availability, and other considerations.  Under+the hood it employs the Microsoft Z3 theorem prover to find optimal+solutions to problems formulated via the SBV library.  The interactions +with Google APIs are accomplished with the gogol-* libraries and heavy+use of lenses.++## Building and running the repository++After using `ghcup` to install and set a recent version (e.g. 9.X) of+GHC and Cabal, the code can be built with:++```+$ cabal build+```++and the tool invoked with:++```+$ cabal exec -- scheduler OPTIONS+```++## Preparing a spreadsheet and using the scheduler++The spreadsheet should allow "anyone with the link" to edit, and the+key (the long random path component in the URL) gets passed to the +scheduler tool with the `--access` switch.  The tool has two primary +modes, `init` and `solve`, that each rely on information being in +particular tabs, and create (or overwrite) a handful of others: outside+of these, it should not modify anything (though bugs are possible, and+interactions with e.g. formulae have not been considered).++The basic workflow is to manually create a "Prospects" and "Interviewers"+tab, each with "First", "Last", and "Email" columns, and interviewers with+a "Zoom" column (in any order, and additional columns will be ignored),+and invoke the tool with:++```+cabal exec -- scheduler init --access KEY+```++This generates the "Prospect Availability", "Interviewer Availability", and+"Interviewer Preferences" tabs, which can then be filled in by the relevant+parties.  *Note that running the command with the `--force` switch will +overwrite the tabs, so it may be wise to edit-protect them once information+has been entered.*  Then, invoke the tool with:++```+cabal exec -- scheduler solve --access KEY+```++The tool will attempt to satisfy the interviewer preferences using the +availability of both groups, and write it's best solution to the tabs+"Interviewer Schedule" and "Prospect Schedule".+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,122 @@+module Main where++import qualified Data.Map as Map+import Data.Map (Map)+import Data.Text (Text)+import Options.Generic (Generic, ParseRecord, Unwrapped, Wrapped, unwrapRecord, (:::), type (<?>)(..))+import Data.Text (Text)+import System.IO (stdout)+import Data.Maybe (fromMaybe, catMaybes, fromJust)+import Text.Printf (printf)+import Control.Monad+import Control.Scheduling+import Data.Time+import Data.Time.Format+import Control.Lens hiding (Wrapped, Unwrapped)+import qualified Data.ByteString.Lazy as BS+import Debug.Trace (traceShowId)+--import Control.Monad.Log+import qualified Network.Google.Sheets as S+import Network.Google.Resource.Sheets.Spreadsheets.Get+import Network.Google.Sheets hiding (Text, sheet)++sheetName :: Sheet -> Maybe Text+sheetName s = join $ s ^. sProperties <&> view sTitle++events = [ ("Welcome", ("Mon 08:00", "Mon 09:00"))+         , ("Shared lunch", ("Wed 12:00", "Wed 13:00"))+         ]++data Args w = Init { access :: w ::: Maybe Text <?> "Access code for Google Sheets endpoint"+                   , force :: w ::: Bool <?> "If set, existing tables will be overwritten"+                   , windows :: w ::: [String] <?> "Time windows (can specify multiple times): format is 'YYYY-MM-DD HH:MM-HH:MM'"+                   --, granularity :: w ::: Maybe Integer <?> "Time granularity, in minutes, for scheduling"+                   }+            | Show { access :: w ::: Maybe Text <?> "Access code for Google Sheets endpoint"+                   }+            | Solve { access :: w ::: Maybe Text <?> "Access code for Google Sheets endpoint"+                    , force :: w ::: Bool <?> "If set, existing tables will be overwritten"+                    }+            | Emails { access :: w ::: Maybe Text <?> "Access code for Google Sheets endpoint"+                     , jhuFacultyEmails :: w ::: String <?> "Path to write JHU faculty emails"+                     , nonJhuFacultyEmails :: w ::: String <?> "Path to write non-JHU-faculty emails"+                     --, nonFacultyEmails :: w ::: String <?> "Path to write non-faculty emails"+                     , prospectEmails :: w ::: String <?> "Path to write prospect emails"+                     }+  deriving (Generic)                             +                                                            +instance ParseRecord (Args Wrapped)+deriving instance Show (Args Unwrapped)++-- add resources!++generateSlots gran wins = do+  let dates = ["2022-01-" ++ (show d) | d <- [17..21]]+  toDrop <- sequence $ [] -- stringsToSlots "2021-03-08" "2021-03-08" "17:00" "17:00" gran+                       --, stringsToSlots "2021-03-10" "2021-03-10" "17:00" "19:00" gran+                       --, stringsToSlots "2021-03-12" "2021-03-12" "17:00" "19:00" gran+                       --]+  slots <- sequence $ [stringsToSlots d d "08:00" "22:00" gran | d <- dates]+  let toDrop' = concat toDrop+      slots' = [s | s <- concat slots, not $ s `elem` toDrop']+  return slots'++getCurrentCount :: State -> Map (Text, Text) Int+getCurrentCount state = Map.fromListWith (+) (pro ++ base)+  where+    fac = (Map.toList . fromMaybe Map.empty) $ state^.individualMeetings+    base = map (\p -> ((p^.firstName, p^.lastName), 0)) (state ^. prospects)+    mts = concat $ map (Map.toList . snd) fac+    pro = map ((,1) . fst) mts++getCurrentCount' :: State -> [((Text, Text), [(Text, Text)])]+getCurrentCount' state = fac --Map.fromListWith (+) (pro ++ base)+  where+    fac = (map (\(k, v) -> (k, Map.keys v)) . Map.toList . fromMaybe Map.empty) $ state^.individualMeetings+    --base = map (\p -> ((p^.firstName, p^.lastName), Map.size $ p^.)) (state ^. faculty)+    --mts = concat $ map (Map.toList . snd) fac+    --pro = map ((,1) . fst) mts+++main :: IO ()+main = do+  ps <- unwrapRecord "" :: IO (Args Unwrapped)+  let sid = fromMaybe "NULL" (access ps)+  ssheet <- readSpreadsheet sid+  let state = readState (generateSlots 60 []) ssheet+  case ps of Init{..} -> do+               let slu = ssheet^.sheetLookup+                   state' = state { _slots=generateSlots 60 [] }+               if ((slu Map.!? "Interviewer Preferences") == Nothing && (slu Map.!? "Interviewer Availability") == Nothing) || force == True+                 then writeForms sid (slu Map.!? "Interviewer Availability") (slu Map.!? "Interviewer Preferences") (slu Map.!? "Prospect Availability") state'                +                 else putStrLn "Refusing to overwrite existing forms (you may specify '--force' if you're sure)"+             Show{..} -> do+               --let mtg = (Map.toList . Map.map (\x -> length $ Map.keys x) . fromJust) $ state^.individualMeetings+               --putStrLn $ (show . sum . map snd) mtg+               --putStrLn $ unlines (map show mtg)+               putStrLn $ show $ (state^.individualMeetings)+               putStrLn $ unlines $ map show (getCurrentCount' state)+               --print $ getCurrentCount state+               return ()+               --putStrLn $ show $ (head $ state^.faculty) ^.availability+               --putStrLn $ show $ state^.faculty+               --putStrLn $ show $ state^.requestedMeetings+               --putStrLn $ show $ state^.individualMeetings+               --printSchedules (compressSlots state)+             Solve{..} -> do+               let slu = ssheet^.sheetLookup+                   state' = state { _slots=generateSlots 60 [] }+               --let state' = compressSlots $ state { _slots= Just $ [s | s <- (fromMaybe [] (defaultSlots 60))]}+               state'' <- solveSchedule state'+               if ((slu Map.!? "Interviewer Schedule") == Nothing && (slu Map.!? "Prospect Schedule" == Nothing)) || force == True+                 then writeSchedule sid (slu Map.!? "Interviewer Schedule") (slu Map.!? "Prospect Schedule") state'' (fromJust $ generateSlots 60 [])+                 else putStrLn "Refusing to overwrite existing schedule (you may specify '--force' if you're sure)"++               --print $ getCurrentCount state''+               --print $ map (\(x, y) -> (x, length y)) (getCurrentCount' state'')+               --putStrLn $ unlines $ map (show . +               return ()+             Emails{..} -> do+               emails <- generateEmails prospectEmails jhuFacultyEmails nonJhuFacultyEmails state+               sequence $ map (\(f, m) -> BS.writeFile f m) emails+               return ()

@@ -0,0 +1,82 @@+cabal-version: 1.12++name:           scheduling+version:        0.1.0.0+synopsis:       An interview scheduler using constraint satisfaction and Google Sheets+description:    Primarily a command-line tool for specifying people, their availabilities,+                and desired meetings, finding the best solution to this scheduling task,+                and a few other niceties, all directly in a Google Sheets spreadsheet+                so it's easy to edit collaboratively and view the results.+category:       Cloud, Time+homepage:       https://github.com/TomLippincott/scheduling#readme+author:         Tom Lippincott+maintainer:     tom.lippincott@jhu.edu+copyright:      2021 Tom Lippincott+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++library+  exposed-modules:+      Control.Scheduling+      Control.Scheduling.Event+      Control.Scheduling.Location+      Control.Scheduling.Mail+      Control.Scheduling.Person+      Control.Scheduling.Preference+      Control.Scheduling.Sheets+      Control.Scheduling.Solve+      Control.Scheduling.State+      Control.Scheduling.TimeSpan+  other-modules:+      Paths_scheduling+  hs-source-dirs:+      src+  default-extensions: Strict StrictData FlexibleContexts RecordWildCards MultiParamTypeClasses FlexibleInstances OverloadedStrings ScopedTypeVariables DataKinds DeriveGeneric StandaloneDeriving TypeOperators ExplicitNamespaces RankNTypes TemplateHaskell TupleSections+  build-depends:+      aeson >=1.2.4.0+    , base >=4.7 && <5+    , bimap >=0.3.3+    , bytestring >=0.10.10.1+    , containers >=0.5.10.2+    , gogol ==0.5.0+    , gogol-sheets ==0.5.0+    , lens >=4.16+    , mime-mail >=0.5.0+    , mtl ==2.2.2+    , optparse-generic >=1.3.0+    , random >=1.1+    , sbv >=8.3+    , servant+    , text >=1.2.2+    , time >=1.9.2+  default-language: Haskell2010++executable scheduler+  main-is: Main.hs+  other-modules:+      Paths_scheduling+  hs-source-dirs:+      app+  default-extensions: Strict StrictData FlexibleContexts RecordWildCards MultiParamTypeClasses FlexibleInstances OverloadedStrings ScopedTypeVariables TupleSections DataKinds DeriveGeneric OverloadedStrings StandaloneDeriving TypeOperators ExplicitNamespaces +  build-depends:+      aeson >=1.2.4.0+    , base >=4.7 && <5+    , bimap >=0.3.3+    , bytestring >=0.10.10.1+    , containers >=0.5.10.2+    , gogol ==0.5.0+    , gogol-sheets ==0.5.0+    , lens >=4.16+    , mime-mail >=0.5.0+    , mtl ==2.2.2+    , optparse-generic >=1.3.0+    , random >=1.1+    , sbv >=8.3+    , scheduling+    , servant+    , text >=1.2.2+    , time >=1.9.2+  default-language: Haskell2010

@@ -0,0 +1,64 @@+module Control.Scheduling ( TimeSpan(..)+                        , Event(..)+                        , State(..)+                        , simpleState+                        , requestedMeetings+                        , simplePreference+                        , faculty+                        , prospects+                        , slots+                        , individualMeetings+                        , groupMeetings+                        , granularity+                        , expand+                        , solveSchedule+                        , readState+                        , writeForms+                        , writeSchedule+                        , stringsToSlots+                        , readSpreadsheet+                        , sheetLookup+                        , Person(..)+                        , Gender(..)+                        , simplePerson+                        , firstName+                        , lastName+                        , email+                        --, school+                        --, office+                        , availability+                        , preferences+                        --, gender+                        --, urm+                        --, application+                        --, local+                        --, contact+                        --, ref+                        , zoom+                        --, biography+                        , printSchedules+                        , compressSlots+                        , generateEmails+                        , Preference(..)+                        , minutes+                        , priority+                        , intervieweeParticipants+                        , interviewerParticipants+                        , maxMeetings+                        , minMeetings+                        , requestedOnly+                        , maxMeetingSize+                        , required+                        , application+                        , group+                        ) where++import Control.Scheduling.Person+import Control.Scheduling.TimeSpan+import Control.Scheduling.Location+import Control.Scheduling.Event+import Control.Scheduling.State+import Control.Scheduling.Solve+import Control.Scheduling.Sheets+import Control.Scheduling.Mail+import Control.Scheduling.Preference

@@ -0,0 +1,12 @@+module Control.Scheduling.Event (Event(..)) where++import Text.Printf (printf, PrintfArg(..), fmtPrecision, fmtChar, errorBadFormat, formatString, vFmt, IsChar)+import Control.Lens ((^.), (.~), (<&>), set, view, makeLenses, makeFields)+import Data.Text (Text)+import Data.Map (Map)++data Event = Event { _title :: String+                   , _description :: String+                   }++makeLenses ''Event

@@ -0,0 +1,14 @@+module Control.Scheduling.Location (Location(..)) where++import Text.Printf (printf, PrintfArg(..), fmtPrecision, fmtChar, errorBadFormat, formatString, vFmt, IsChar)+import Control.Lens ((^.), (.~), (<&>), set, view, makeLenses, makeFields)+import Data.Text (Text)+import Data.Map (Map)++data Location = Location { _building :: String+                         , _room :: String+                         , _availability :: Maybe [Int] --[TimeSpan]+                         , _capacity :: Maybe Int+                         }++makeFields ''Location

@@ -0,0 +1,214 @@+module Control.Scheduling.Mail (generateEmails) where++import Prelude hiding (group)+import Text.Printf (printf, PrintfArg(..), fmtPrecision, fmtChar, errorBadFormat, formatString, vFmt, IsChar)+import Control.Lens ((^.), (.~), (<&>), set, view, makeLenses, makeFields)+import Control.Scheduling.State+import Control.Scheduling.Person+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, fromJust, catMaybes)+import Control.Monad (liftM)+import Control.Lens hiding (zoom)+import Data.ByteString.Lazy (ByteString)+import Debug.Trace (traceShowId)+import Network.Mail.Mime+import Control.Scheduling.TimeSpan+import Data.Time.Clock+import Data.Time.Format+import Data.List (sortOn, sort)++-- add prospect bios++formatTimeSpan range = Text.pack $ (formatTime defaultTimeLocale "%a, %b %e at %R (" s) ++ ("30-60") ++ " minutes)"+  where+    s = (head range)^.start+    e = utctDayTime $ (last range)^.end+    l = length range * 30+    +formatJhuFacMeeting (p, ms) = do+  let name = Text.unwords [p^.firstName, p^.lastName]+      filename = Text.unpack name ++ ".eml"+      to = Address (Just name) (fromJust $ p^.email)+      from = Address (Just "Tom Lippincott") "tom@cs.jhu.edu"+      grid' = map (\(time, (prosp, facs)) -> Text.unlines $ [Text.intercalate " " [prosp^.firstName, prosp^.lastName, Text.concat ["(", fromJust $ prosp^.email, ")"], formatTimeSpan time]] ++ (if length facs > 1 then [Text.unwords ["Along", "with", f^.firstName, f^.lastName, Text.concat ["(", fromJust (f^.email), ")"]] | f <- facs, f /= p] else []) ++ [Text.unwords ["Application link: ", fromJust $ prosp^.application]] ++ [Text.unwords ["Zoom link: ", fromJust $ (head facs)^.zoom]]) ((sortOn (\(ts, _) -> head ts) . Map.toList) (Map.filter (\x -> length x > 0) ms))+      grid = Text.unlines grid'+  email <- renderMail' $ simpleMail' to from "Your CLSP visit schedule" (+    LText.fromStrict $ Text.unlines [ Text.concat ["Hi ", p^.firstName, ","]        +                                    , ""+                                    , "Your schedule (in EST) is below, along with information about any shared meetings, contact emails, the Zoom link (probably yours) to use, and a link to the prospect's application on Slate.  There are also three events scheduled for the week:"+                                    , ""+                                    , "  Monday, 5PM-6PM: Introduction to the CLSP"+                                    , overview+                                    , ""+                                    , "  Wednesday, 5PM-8PM: Poster session and mixer"+                                    , poster+                                    , ""+                                    , "  Friday, 5PM-8PM: Shared meal and game night"+                                    , shared+                                    , ""+                                    , "If you plan to join us for the shared meal, please fill in this poll so we can handle reimbursement:"+                                    , ""+                                    , doordash+                                    , ""+                                    , "We have also set up a Slack workspace for the week, feel free to join and interact with prospects, help answer questions, etc:"+                                    , ""+                                    , slack+                                    , ""+                                    , "-Tom"+                                    , ""+                                    , ""+                                    , grid+                                    ]+    )+  return $ if length grid' > 0 then Just (filename, email) else Nothing++overview = "  https://jh.zoom.us/j/91487972275?pwd=V0V5Vy9zczloMlV5Umo3Q1lLc2xXZz09"+poster = "  https://gather.town/app/l8nJEc8iysj09hEC/CLSP (password: 'c15pvisit')"+doordash = "  https://forms.gle/4ZBRcic4awFi5zBi7"+games = "  https://forms.gle/AL6e8ENroDVqJHGp7"+slack = "  https://join.slack.com/t/jhu-mq46074/shared_invite/zt-niwde4sh-BqI1W7VcfFFXOS33V~9aWg"+shared = "  https://jh.zoom.us/j/99013636868?pwd=YllTdWRyUGJVOGpWTVl5M1J3bENhdz09"+neighborhoods = "  URL"+eisner = "  Eisner, TIME, URL"+vandurme = "  March 12, 10:45-11:45, https://jhubluejays.zoom.us/j/97190315377"++formatNonJhuFacMeeting (p, ms) = do+  let name = Text.unwords [p^.firstName, p^.lastName]+      filename = Text.unpack name ++ ".eml"+      to = Address (Just name) (fromJust $ p^.email)+      from = Address (Just "Tom Lippincott") "tom@cs.jhu.edu"+      grid' = map (\(time, (prosp, facs)) -> Text.unlines $ [Text.intercalate " " [prosp^.firstName, prosp^.lastName, Text.concat ["(", fromJust $ prosp^.email, ")"], formatTimeSpan time]] ++ (if length facs > 1 then [Text.unwords ["Along", "with", f^.firstName, f^.lastName, Text.concat ["(", fromJust (f^.email), ")"]] | f <- facs, f /= p] else []) ++ [Text.unwords ["Zoom link: ", fromJust $ (head facs)^.zoom]]) ((sortOn (\(ts, _) -> head ts) . Map.toList) (Map.filter (\x -> length x > 0) ms))+      grid = Text.unlines grid'+  email <- renderMail' $ simpleMail' to from "Your CLSP visit schedule" (+    LText.fromStrict $ Text.unlines [ Text.concat ["Hi ", p^.firstName, ","]        +                                    , ""+                                    , "Your schedule (in EST) is below, along with information about any shared meetings, contact emails, and the Zoom link to use.  There are also three events scheduled for the week:"+                                    , ""+                                    , "  Monday, 5PM-6PM: Introduction to the CLSP"+                                    , overview+                                    , ""+                                    , "  Wednesday, 5PM-8PM: Poster session and mixer"+                                    , poster+                                    , ""+                                    , "  Friday, 5PM-8PM: Shared meal and game night"+                                    , shared+                                    , ""+                                    , "If you plan to join us for the shared meal, please fill in this poll so we can handle reimbursement:"+                                    , ""+                                    , doordash+                                    , ""+                                    , "We have also set up a Slack workspace for the week, feel free to join and interact with prospects, help answer questions, etc:"+                                    , ""+                                    , slack+                                    , ""+                                    , "-Tom"+                                    , ""+                                    , ""+                                    , grid+                                    ]+    )+  return $ if length grid' > 0 then Just (filename, email) else Nothing    +--  return (filename, email)+++formatNonFacMeeting = formatNonJhuFacMeeting+++formatProspMeeting (p, ms) = do+  let name = Text.unwords [p^.firstName, p^.lastName]+      filename = Text.unpack name ++ ".eml"+      to = Address (Just name) (fromJust $ p^.email)+      from = Address (Just "Tom Lippincott") "tom@cs.jhu.edu"+      grid' = map (\(time, facs) -> Text.unlines [Text.unwords [Text.intercalate " and " [+                                                                                 Text.intercalate " " [fac^.firstName, fac^.lastName, Text.concat ["(", fromJust (fac^.email), ")"]] | fac <- facs], formatTimeSpan time], Text.unwords ["Zoom link: ", fromJust $ (head facs)^.zoom]]) ((sortOn (\(ts, _) -> head ts) . Map.toList) (Map.filter (\x -> length x > 0) ms))+      grid = Text.unlines grid'+  email <- renderMail' $ simpleMail' to from "Your CLSP visit schedule" (+    LText.fromStrict $ Text.unlines [ Text.concat ["Dear ", p^.firstName, ","]        +                                    , ""+                                    , "Your schedule (in EST) is below, along with the Zoom link to use and contact emails in case of difficulty connecting.  Each meeting may be with one or two students or faculty and last from 30 to 60 minutes.  Additionally, there are three events scheduled for the week that you're encouraged to attend:"+                                    , ""+                                    , "  Monday, 5PM-6PM: Introduction to the CLSP"+                                    , overview+                                    , ""+                                    , "  Wednesday, 5PM-8PM: Poster session and mixer"+                                    , poster+                                    , ""+                                    , "  Friday, 5PM-8PM: Shared meal and game night"+                                    , shared+                                    , ""+                                    , "If you plan to join us for the shared meal, please fill in this poll so we can handle reimbursement:"+                                    , ""+                                    , doordash+                                    , ""+                                    , "For the games following the meal, please fill in your preference so we can plan for the right numbers:"+                                    , ""+                                    , games+                                    , ""                                    +                                    -- , "Our current students have put together short video tours of popular Baltimore neighborhoods:"+                                    -- , ""+                                    -- , neighborhoods+                                    -- , ""+                                    , "A Slack workspace will be open for the entire week to ask questions asynchronously, chat informally with current students and faculty, etc:"+                                    , ""+                                    , slack+                                    , ""+                                    , "Finally, Professor Van Durme has kindly offered for you to sit in on his reading group for some representative immersion in CLSP activities, should your schedule allow:"+                                    , ""+                                    , vandurme+                                    , ""+                                    , "We look forward to seeing you over the coming days!"+                                    , ""+                                    , "-The CLSP"+                                    , ""+                                    , ""+                                    , grid+                                    ]+    )+  return $ if length grid' > 0 then Just (filename, email) else error "WHAT?"+  --return (filename, email)+++combineProspectMeetings :: (Ord a) => Map Person (Map Person a) -> Map Person (Map a [Person])+combineProspectMeetings ps = Map.map combine' ps+  where+    combine' p = Map.fromListWith (\a b -> sort $ a ++ b) $ (map (\(a, b) -> (b, [a])) . Map.toList) p+++combineInterviewerMeetings :: (Ord a) => Map Person (Map Person a) -> Map Person (Map a (Person, [Person]))+combineInterviewerMeetings facs = Map.mapWithKey combine' facs+  where+    combine' fac mtgs = Map.fromList $ map gather' (Map.toList mtgs)+      where+        gather' (prosp, ts) = (ts, (prosp, allFacs))+          where+            allFacs = sort $ [f | (f, m) <- Map.toList facs, (prosp `Map.lookup` m) == (Just ts)]++generateEmails :: String -> String -> String -> State -> IO [(String, ByteString)]+generateEmails prosp jhuFac nonJhuFac state = do+  let meetings = Map.map (Map.mapKeys (\(f, l) -> head [p & availability .~ Nothing | p <- state^.prospects, p^.firstName == f && p^.lastName == l])) (Map.mapKeys (\(f, l) -> head [p | p <- state^.faculty, p^.firstName == f && p^.lastName == l]) (fromJust $ (state^.individualMeetings)))+      --revMeetings = invertMap meetings+      prospMeetings = (combineProspectMeetings . invertMap) meetings+      (jhuFacMeetings, nonJhuFacMeetings) = Map.partitionWithKey (\k v -> k^.group == (Just "Faculty")) (combineInterviewerMeetings meetings)+      --(nonFacMeetings, nonJhuFacMeetings) = Map.partitionWithKey (\k v -> k^.group == (Just "Student")) rest+      --facMeetings = meetings+  --print meetings+  --print $ map (\x -> x^.group) (Map.keys jhuFacMeetings)+  prospMeetings' <- sequence $ map formatProspMeeting (Map.toList prospMeetings)+  jhuFacMeetings' <- sequence $ map formatJhuFacMeeting (Map.toList jhuFacMeetings)+  nonJhuFacMeetings' <- sequence $ map formatNonJhuFacMeeting (Map.toList nonJhuFacMeetings)+  --nonFacMeetings' <- sequence $ map formatNonFacMeeting (Map.toList nonFacMeetings)+  let prospMeetings'' = map (\(n, m) -> (prosp ++ n, m)) (catMaybes prospMeetings')+      jhuFacMeetings'' = map (\(n, m) -> (jhuFac ++ n, m)) (catMaybes jhuFacMeetings')+      nonJhuFacMeetings'' = map (\(n, m) -> (nonJhuFac ++ n, m)) (catMaybes nonJhuFacMeetings')+      --nonFacMeetings'' = map (\(n, m) -> (nonFac ++ n, m)) nonFacMeetings'+  return $ prospMeetings'' ++ jhuFacMeetings'' ++ nonJhuFacMeetings''+++invertMap m = Map.map (Map.fromList) unflat +  where+    flat = concat $ map (\(f, v) -> [(p, [(f, t)]) | (p, t) <- Map.toList v]) (Map.toList m)+    unflat = Map.fromListWith (++) flat

@@ -0,0 +1,79 @@+module Control.Scheduling.Person ( Person(..)+                               , Gender(..)+                               , simplePerson+                               , firstName+                               , lastName+                               , email+                               --, school+                               --, office+                               , availability+                               , preferences+                               --, gender+                               --, urm+                               --, application+                               --, local+                               --, contact+                               --, ref+                               --, biography+                               , fullName+                               , zoom+                               , maxMeetings+                               , minMeetings+                               , maxMeetingSize+                               , requestedOnly+                               , application+                               , group+                               ) where++import Text.Printf (printf, PrintfArg(..), fmtPrecision, fmtChar, errorBadFormat, formatString, vFmt, IsChar)+import Control.Lens ((^.), (.~), (<&>), set, view, makeLenses, makeFields)+import Control.Scheduling.TimeSpan (TimeSpan(..))+import Data.Text (Text)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Control.Monad (liftM)+import Control.Lens hiding (zoom)+import Data.Text (pack, unpack, intercalate)++data Gender = Male | Female | Other+  deriving (Ord, Show, Eq)++data Person = Person { _firstName :: Text+                     , _lastName :: Text+                     , _email :: Maybe Text+                     --, _school :: Maybe Text+                     --, _office :: Maybe Text+                     , _availability :: Maybe [TimeSpan]+                     , _preferences :: Maybe (Map Person Int)+                     --, _gender :: Maybe Gender+                     --, _urm :: Maybe Bool+                     , _application :: Maybe Text+                     --, _local :: Maybe Bool+                     --, _contact :: Maybe Person+                     --, _ref :: Maybe Text+                     --, _biography :: Maybe Text+                     , _zoom :: Maybe Text+                     , _maxMeetings :: Int+                     , _minMeetings :: Int+                     , _maxMeetingSize :: Int+                     , _requestedOnly :: Bool+                     , _group :: Maybe Text+                     } deriving (Eq, Ord)++simplePerson :: Text -> Text -> Person+simplePerson first last = Person first last Nothing Nothing Nothing Nothing Nothing 3 1 2 True Nothing+--simplePerson first last = Person first last Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing 1 2 True++instance PrintfArg Person where+  formatArg Person{..} fmt = formatString (printf "%s %s" _firstName _lastName :: String) (fmt { fmtChar = 's', fmtPrecision = Nothing })+--  formatArg Person{..} fmt = formatString (printf "%s %s: Avail slots=%s, Req slots=%s" _firstName _lastName ((show . liftM length) _availability) ((show . liftM (sum . Map.elems)) _preferences) :: String) (fmt { fmtChar = 's', fmtPrecision = Nothing })  +++makeLenses ''Person++instance Show Person where+  show p = (unpack . intercalate " ") [p^.firstName, p^.lastName, (pack . show) (p^.minMeetings), (pack . show) (p^.maxMeetings)]++fullName :: Lens' Person (Text, Text)+fullName = lens (\p -> (p ^. firstName, p ^. lastName)) undefined

@@ -0,0 +1,36 @@+module Control.Scheduling.Preference (Preference(..), interviewerParticipants, intervieweeParticipants, minutes, priority, simplePreference, required) where++import Text.Printf (printf, PrintfArg(..), fmtPrecision, fmtChar, errorBadFormat, formatString, vFmt, IsChar)+import Control.Lens ((^.), (.~), (<&>), set, view, makeLenses, makeFields)+--import Control.Scheduling.TimeSpan (TimeSpan(..))+import Data.Text (Text)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Maybe (fromMaybe)+import Control.Monad (liftM)+import Control.Lens++--data Gender = Male | Female | Other+--  deriving (Ord, Show, Eq)++data Preference = Preference { _interviewerParticipants :: Set (Text, Text)+                             , _intervieweeParticipants :: Set (Text, Text)+                             , _minutes :: Int+                             , _priority :: Int+                             , _required :: Bool+                             } deriving (Show, Eq, Ord)++simplePreference :: Preference+simplePreference = Preference Set.empty Set.empty 60 0 False+-- first last = Person first last Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing 1 2 True++--instance PrintfArg Preference where+--  formatArg Preference{..} fmt = formatString (printf "%s %s" _firstName _lastName :: String) (fmt { fmtChar = 's', fmtPrecision = Nothing })+--  formatArg Person{..} fmt = formatString (printf "%s %s: Avail slots=%s, Req slots=%s" _firstName _lastName ((show . liftM length) _availability) ((show . liftM (sum . Map.elems)) _preferences) :: String) (fmt { fmtChar = 's', fmtPrecision = Nothing })  ++makeLenses ''Preference++--fullName :: Lens' Person (Text, Text)+--fullName = lens (\p -> (p ^. firstName, p ^. lastName)) undefined

@@ -0,0 +1,481 @@+module Control.Scheduling.Sheets (readSpreadsheet, readState, writeForms, writeSchedule, sheetLookup) where++import Prelude hiding (group)+import qualified Network.Google.Sheets as S+import Network.Google.Resource.Sheets.Spreadsheets.Get+import Network.Google.Sheets hiding (Text, sheet)+import Network.Google+import Data.Aeson.Types+import Data.Text (Text, unpack, pack)+import qualified Data.Text as T+import Text.Printf (printf, PrintfArg(..), fmtPrecision, fmtChar, errorBadFormat, formatString, vFmt, IsChar)+import Control.Lens hiding (zoom)+import Control.Exception (try, tryJust)+import Control.Monad (join)+import Data.Maybe (catMaybes, fromJust, fromMaybe)+import Data.Time.Clock (UTCTime(..), secondsToNominalDiffTime)+import Data.Time.Format+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import System.Random+import Data.Int (Int32)+import Control.Scheduling.State+import Control.Scheduling.Person+import Control.Scheduling.TimeSpan+import Control.Scheduling.Preference+import Data.Time+import Text.Read (readMaybe)+import Data.List (intercalate, sort)+import Debug.Trace (traceShowId)+import qualified Data.Text as Text+++readState :: Maybe [TimeSpan] -> Spreadsheet -> State+readState allSlots ssheet = simpleState & faculty .~ faculty' & prospects .~ prospects' & slots .~ allSlots & individualMeetings .~ indiv & requestedMeetings .~ requestedMeetings'+  where+    prospects' = (getPeople "Prospects") ssheet --+    --prospects' = (getAvailability "Prospect Availability" ssheet . getPeople "Prospects") ssheet+    faculty' = (getPeople "Interviewers") ssheet --(getAvailability "Interviewer Availability" ssheet . getPeople "Interviewers") ssheet+    requestedMeetings' = Just $ (getIndividualPrefs "Individual Preferences" ssheet) ++ (getGroupPrefs "Group Preferences" ssheet)+    slu = ssheet^.sheetLookup    +    flu = Map.fromList $ [(T.unwords [T.take 1 (p ^. firstName), p ^. lastName], (p ^. firstName, p ^. lastName)) | p <- prospects']+    indiv = Just $ if "Interviewer Schedule" `Map.member` slu then Map.fromList $ [((f ^. firstName, f ^. lastName), getFacultySchedule "Interviewer Schedule" ssheet f flu) | f <- faculty'] else Map.empty+++writeForms :: Text -> Maybe Int32 -> Maybe Int32 -> Maybe Int32 -> State -> IO ()+writeForms sid aid pid ppid state = do+  case pid of+    Nothing -> return ()+    Just tid -> deleteTab sid tid+  case aid of+    Nothing -> return ()+    Just tid -> deleteTab sid tid    +  case ppid of+    Nothing -> return ()+    Just tid -> deleteTab sid tid+  createPreferenceForm sid (state ^. faculty) (state ^. prospects)+  createAvailabilityForm "Interviewer Availability" sid (state ^. faculty) (fromJust $ state ^. slots)+  createAvailabilityForm "Prospect Availability" sid (state ^. prospects) (fromJust $ state ^. slots)+  return ()+++tab :: Text -> Lens' Spreadsheet Sheet+tab name = lens (\ss -> fromJust $ ssheet ss name) undefined++addTab sid name nRows nCols index = do+  env <- newEnv <&> (envScopes .~ spreadsheetsScope)+  let gp = gridProperties & gpColumnCount ?~ nCols & gpRowCount ?~ nRows & gpFrozenRowCount ?~ 1 & gpFrozenColumnCount ?~ 2+      sp = sheetProperties & sTitle ?~ name & sGridProperties ?~ gp & sIndex ?~ (fromIntegral index)+      asr = asrProperties ?~ sp $ addSheetRequest+  rv' <- try . runResourceT . runGoogle env $ send (spreadsheetsBatchUpdate sid (busrRequests .~ [(reqAddSheet .~ Just asr $ request')] $ batchUpdateSpreadsheetRequest)) :: IO (Either Error BatchUpdateSpreadsheetResponse)+  let Right rv = rv'+  return $ fromJust $ (fromJust $ (fromJust $ (head $ rv ^. busrReplies) ^. rAddSheet) ^. aProperties) ^. sSheetId+++tabId :: Sheet -> Maybe Int32+tabId s = join $ s ^. sProperties <&> view sSheetId+++deleteTab :: Text -> Int32 -> IO ()+deleteTab sid tid = do+  env <- newEnv <&> (envScopes .~ spreadsheetsScope)+  let req = deleteSheetRequest & dsrSheetId .~ Just tid+  resp <- try . runResourceT . runGoogle env $ send (spreadsheetsBatchUpdate sid (busrRequests .~ [(reqDeleteSheet .~ Just req $ request')] $ batchUpdateSpreadsheetRequest)) :: IO (Either Error BatchUpdateSpreadsheetResponse)+  return ()+++preferenceEntryFormat :: Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int -> [ConditionalFormatRule]+preferenceEntryFormat tid sr sc er ec n = [neg]+  where+    cv = [conditionValue & cvUserEnteredValue ?~ (pack . show) i | i <- [0, n]]+    bc = booleanCondition & bcValues .~ cv & bcType ?~ NumberNotBetween+    cf = cellFormat & cfBackgRoundColor ?~ (color & cRed ?~ 0.9 & cAlpha ?~ 0.1)+    br = booleanRule & brFormat ?~ cf & brCondition ?~ bc+    range = gridRange & grSheetId ?~ tid & grStartRowIndex ?~ sr & grEndRowIndex ?~ (fromIntegral $ er + 1) & grStartColumnIndex ?~ sc & grEndColumnIndex ?~ (fromIntegral $ ec + 1)+    neg = conditionalFormatRule & cfrBooleanRule ?~ br & cfrRanges .~ [range]+++availabilityEntryFormat :: Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> [ConditionalFormatRule]+availabilityEntryFormat tid sr sc er ec = [neg]+  where+    bc = booleanCondition & bcType ?~ NotBlank+    cf = cellFormat & cfBackgRoundColor ?~ (color & cGreen ?~ 0.9 & cAlpha ?~ 0.1)+    br = booleanRule & brFormat ?~ cf & brCondition ?~ bc+    range = gridRange & grSheetId ?~ tid & grStartRowIndex ?~ sr & grEndRowIndex ?~ (fromIntegral $ er + 1) & grStartColumnIndex ?~ sc & grEndColumnIndex ?~ (fromIntegral $ ec + 1)+    neg = conditionalFormatRule & cfrBooleanRule ?~ br & cfrRanges .~ [range]+++headerFormat :: TextFormatRun+headerFormat = textFormatRun & tfrStartIndex .~ Just 0 & tfrFormat .~ Just (textFormat & tfBold .~ Just True)+++--prefHelp = extendedValue & evStringValue ?~ "Instructions: indicate how much time you would like with each prospect, from 0-4 15-minute increments.  0 indicates you *will not* meet with the student, while a blank indicates you are *willing* to do so, to help round out the schedule.  The form will highlight invalid entries in red."+prefHelp = extendedValue & evStringValue ?~ "Instructions: enter '1' if you consider the student a potential advisee (one-on-one, hour-long meeting), '0' if you won't meet with the student *at all* (use sparingly, if at all), blank indicates you will meet with the student as part of a group" -- , but don't consider them a match as an advisee."++schedHelp = extendedValue & evStringValue ?~ "Instructions: enter any value to indicate you are available at that time (the particular value doesn't matter)"++--"how much time you would like with each prospect, from 0-4 15-minute increments.  0 indicates you *will not* meet with the student, while a blank indicates you are *willing* to do so, to help round out the schedule.  The form will highlight invalid entries in red."+++createPreferenceForm sid facs prosps = do+  env <- newEnv <&> (envScopes .~ spreadsheetsScope)+  let nRows = fromIntegral $ length prosps + 2+      nCols = fromIntegral $ length facs + 2+  tid <- addTab sid "Interviewer Preferences" nRows nCols 3+  let range = gridRange & grStartRowIndex .~ Just 0 & grEndRowIndex .~ Just nRows & grStartColumnIndex .~ Just 0 & grEndColumnIndex .~ Just nCols & grSheetId .~ Just tid+      header = map (\x -> x & cdTextFormatRuns .~ [headerFormat]) ([cellData & cdUserEnteredValue ?~ (extendedValue & evStringValue ?~ "First"), cellData & cdUserEnteredValue ?~ (extendedValue & evStringValue ?~ "Last")] ++ [cellData & cdUserEnteredValue .~ Just (extendedValue & evStringValue .~ Just _lastName) | Person{..} <- facs])+      rows = [rowData & rdValues .~ header] ++ [preferenceRow i (fromIntegral nCols) p | (i, p) <- zip [1..] prosps]+      help = [rowData & rdValues .~ [cellData & cdUserEnteredValue ?~ prefHelp]]+      req = updateCellsRequest & updRange .~ Just range & updFields .~ (Just . GFieldMask) "*"  & updRows .~ rows+      req' = updateCellsRequest & updRange ?~ (gridRange & grStartRowIndex ?~ (nRows - 1) & grEndRowIndex ?~ nRows & grStartColumnIndex ?~ 0 & grEndColumnIndex ?~ 1 & grSheetId ?~ tid) & updRows .~ help & updFields ?~ GFieldMask "*"+      fmts = [addConditionalFormatRuleRequest & acfrrRule ?~ fmt | fmt <- preferenceEntryFormat tid 1 2 (nRows - 1) nCols 4]+      fmtReqs = [reqAddConditionalFormatRule ?~ fmtReq $ request' | fmtReq <- fmts]+      resize = autoResizeDimensionsRequest & ardrDimensions ?~ (dimensionRange & drDimension ?~ DRDColumns & drSheetId ?~ tid & drStartIndex ?~ 0 & drEndIndex ?~ nCols)+  try . runResourceT . runGoogle env $ send (spreadsheetsBatchUpdate sid (busrRequests .~ [(reqUpdateCells .~ Just req $ request')] ++ fmtReqs ++ [reqAutoResizeDimensions .~ Just resize $ request']$ batchUpdateSpreadsheetRequest)) :: IO (Either Error BatchUpdateSpreadsheetResponse)+  try . runResourceT . runGoogle env $ send (spreadsheetsBatchUpdate sid (busrRequests .~ [reqAutoResizeDimensions .~ Just resize $ request']$ batchUpdateSpreadsheetRequest)) :: IO (Either Error BatchUpdateSpreadsheetResponse)+  try . runResourceT . runGoogle env $ send (spreadsheetsBatchUpdate sid (busrRequests .~ [(reqUpdateCells .~ Just req' $ request')] $ batchUpdateSpreadsheetRequest)) :: IO (Either Error BatchUpdateSpreadsheetResponse)+  return ()+++preferenceRow :: Int -> Int -> Person -> RowData+preferenceRow row nCols prosp = rowData & rdValues .~ (filled ++ rest)+  where+    f = prosp ^. firstName+    l = prosp ^. lastName+    --b = prosp ^. biography+    u = fromMaybe "www.google.com" (prosp ^. application)+    f' = T.concat ["=HYPERLINK(\"", u, "\", \"", f, "\")"]+    l' = T.concat ["=HYPERLINK(\"", u, "\", \"", l, "\")"]+    fv = extendedValue & evFormulaValue .~ Just f'    +    lv = extendedValue & evFormulaValue .~ Just l'+    filled = [] -- [cellData & cdUserEnteredValue .~ Just fv & cdNote .~ b, cellData & cdUserEnteredValue .~ Just lv & cdNote .~ b]+    rest = replicate (nCols - (length filled)) (cellData & cdNote ?~ "")+++availabilityRow :: Int -> Int -> TimeSpan -> RowData+availabilityRow row nCols slot = rowData & rdValues .~ (filled ++ rest)+  where+    f = slot ^. start+    l = slot ^. end+    f' = (pack . formatTime defaultTimeLocale "%a %R") f+    l' = (pack . formatTime defaultTimeLocale "%a %R") l+    fv = extendedValue & evStringValue .~ Just f'    +    lv = extendedValue & evStringValue .~ Just l'+    filled = [cellData & cdUserEnteredValue .~ Just fv, cellData & cdUserEnteredValue .~ Just lv]+    rest = replicate (nCols - (length filled)) cellData+++writeGrid sid tid xs = do+  undefined+++createAvailabilityForm name sid facs slots = do+  env <- newEnv <&> (envScopes .~ spreadsheetsScope)+  let nRows = fromIntegral $ length slots + 2+      nCols = fromIntegral $ length facs + 2+  tid <- addTab sid name nRows nCols 3+  let range = gridRange & grStartRowIndex .~ Just 0 & grEndRowIndex .~ Just nRows & grStartColumnIndex .~ Just 0 & grEndColumnIndex .~ Just nCols & grSheetId .~ Just tid+      header = map (\x -> x & cdTextFormatRuns .~ [headerFormat]) ([cellData & cdUserEnteredValue ?~ (extendedValue & evStringValue ?~ "Start"), cellData & cdUserEnteredValue ?~ (extendedValue & evStringValue ?~ "End")] ++ [cellData & cdUserEnteredValue .~ Just (extendedValue & evStringValue .~ Just _lastName) | Person{..} <- facs])      +      rows = [rowData & rdValues .~ header] ++ [availabilityRow i (fromIntegral nCols) p | (i, p) <- zip [1..] slots]+      help = [rowData & rdValues .~ [cellData & cdUserEnteredValue ?~ schedHelp]]+      req = updateCellsRequest & updRange .~ Just range & updFields .~ (Just . GFieldMask) "*"  & updRows .~ rows+      req' = updateCellsRequest & updRange ?~ (gridRange & grStartRowIndex ?~ (nRows - 1) & grEndRowIndex ?~ nRows & grStartColumnIndex ?~ 0 & grEndColumnIndex ?~ 1 & grSheetId ?~ tid) & updRows .~ help & updFields ?~ GFieldMask "*"+      fmts = [addConditionalFormatRuleRequest & acfrrRule ?~ fmt | fmt <- availabilityEntryFormat tid 1 2 nRows nCols]+      fmtReqs = [reqAddConditionalFormatRule ?~ fmtReq $ request' | fmtReq <- fmts]+      resize = autoResizeDimensionsRequest & ardrDimensions ?~ (dimensionRange & drDimension ?~ DRDColumns & drSheetId ?~ tid & drStartIndex ?~ 0 & drEndIndex ?~ nCols)+  try . runResourceT . runGoogle env $ send (spreadsheetsBatchUpdate sid (busrRequests .~ [(reqUpdateCells .~ Just req $ request')] ++ fmtReqs ++ [reqAutoResizeDimensions .~ Just resize $ request']$ batchUpdateSpreadsheetRequest)) :: IO (Either Error BatchUpdateSpreadsheetResponse)+  try . runResourceT . runGoogle env $ send (spreadsheetsBatchUpdate sid (busrRequests .~ [(reqUpdateCells .~ Just req' $ request')] $ batchUpdateSpreadsheetRequest)) :: IO (Either Error BatchUpdateSpreadsheetResponse)+  return ()+++writeSchedule :: Text -> Maybe Int32 -> Maybe Int32 -> State -> [TimeSpan] -> IO ()+writeSchedule sid tidF tidP state ts = do++  let ims = fromMaybe Map.empty (state ^. individualMeetings)+      --gms = fromMaybe Map.empty (state ^. groupMeetings)+  case tidF of+    Nothing -> return ()+    Just tid -> deleteTab sid tid+  let nRows = fromIntegral $ 1 + (length $ state ^. faculty)+      nCols = fromIntegral $ 2 + (length ts)+  env <- newEnv <&> (envScopes .~ spreadsheetsScope)+  tidF' <- addTab sid "Interviewer Schedule" nRows nCols 3+  let range = gridRange & grStartRowIndex .~ Just 0 & grEndRowIndex .~ Just nRows & grStartColumnIndex .~ Just 0 & grEndColumnIndex .~ Just nCols & grSheetId .~ Just tidF'+      header = map (\x -> x & cdTextFormatRuns .~ [headerFormat]) ([cellData & cdUserEnteredValue ?~ (extendedValue & evStringValue ?~ "First"), cellData & cdUserEnteredValue ?~ (extendedValue & evStringValue ?~ "Last")] ++ [cellData & cdUserEnteredValue .~ Just (extendedValue & evStringValue .~ Just (pack . formatTime defaultTimeLocale "%a %R" $ t ^. start)) | t <- ts])+      rows = [rowData & rdValues .~ header] ++ [scheduleFacultyRow ts n v | (n, v) <- (Map.toList . fromJust) (state ^. individualMeetings)]+      fmtReqs = []+      req = updateCellsRequest & updRange .~ Just range & updFields .~ (Just . GFieldMask) "*"  & updRows .~ rows+  try . runResourceT . runGoogle env $ send (spreadsheetsBatchUpdate sid (busrRequests .~ [(reqUpdateCells .~ Just req $ request')] ++ fmtReqs $ batchUpdateSpreadsheetRequest)) :: IO (Either Error BatchUpdateSpreadsheetResponse)++  case tidP of+    Nothing -> return ()+    Just tid -> deleteTab sid tid    ++  let nRows = fromIntegral $ 1 + (length $ state ^. prospects)+      nCols = fromIntegral $ 2 + (length ts)+  env <- newEnv <&> (envScopes .~ spreadsheetsScope)+  tidP' <- addTab sid "Prospect Schedule" nRows nCols 2+  let range = gridRange & grStartRowIndex .~ Just 0 & grEndRowIndex .~ Just nRows & grStartColumnIndex .~ Just 0 & grEndColumnIndex .~ Just nCols & grSheetId .~ Just tidP'+      header = map (\x -> x & cdTextFormatRuns .~ [headerFormat]) ([cellData & cdUserEnteredValue ?~ (extendedValue & evStringValue ?~ "First"), cellData & cdUserEnteredValue ?~ (extendedValue & evStringValue ?~ "Last")] ++ [cellData & cdUserEnteredValue .~ Just (extendedValue & evStringValue .~ Just (pack . formatTime defaultTimeLocale "%a %R" $ t ^. start)) | t <- ts])+      rows = [rowData & rdValues .~ header] ++ [scheduleProspectRow ts (p ^. fullName) (fromMaybe Map.empty $ state ^. individualMeetings)| p <- (state ^. prospects)]+      fmtReqs = []+      req = updateCellsRequest & updRange .~ Just range & updFields .~ (Just . GFieldMask) "*"  & updRows .~ rows+  x <- try . runResourceT . runGoogle env $ send (spreadsheetsBatchUpdate sid (busrRequests .~ [(reqUpdateCells .~ Just req $ request')] ++ fmtReqs $ batchUpdateSpreadsheetRequest)) :: IO (Either Error BatchUpdateSpreadsheetResponse)+  --print x+  return ()+++scheduleFacultyRow :: [TimeSpan] -> (Text, Text) -> Map (Text, Text) [TimeSpan] -> RowData+scheduleFacultyRow ts (first, last) vs = rowData & rdValues .~ ([first', last'] ++ rest')+  where+    fv = extendedValue & evStringValue .~ Just first+    lv = extendedValue & evStringValue .~ Just last+    first' = cellData & cdUserEnteredValue .~ Just fv+    last' = cellData & cdUserEnteredValue .~ Just lv+    restMap = Map.fromList $ concat [[(x, pack $ [head $ unpack f] ++ " " ++ (unpack l)) | x <- xs] | ((f, l), xs) <- Map.toList vs]+    --gRestMap = Map.fromList $ concat [[(x, T.intercalate "/" (map (id . snd) ns)) | x <- xs] | (ns, xs) <- Map.toList gvs]+    --rest = [extendedValue & evStringValue ?~ (Map.findWithDefault (if elem t knownEvents then "EVENT" else (Map.findWithDefault "" t gRestMap)) t restMap) | t <- ts]+    rest = [extendedValue & evStringValue ?~ (Map.findWithDefault "" t restMap) | t <- ts]+    rest' = [cellData & cdUserEnteredValue ?~ v | v <- rest]+++scheduleProspectRow :: [TimeSpan] -> (Text, Text) -> Map (Text, Text) (Map (Text, Text) [TimeSpan]) -> RowData+scheduleProspectRow ts (first, last) vs = rowData & rdValues .~ ([first', last'] ++ rest')+  where+    fv = extendedValue & evStringValue .~ Just first+    lv = extendedValue & evStringValue .~ Just last+    first' = cellData & cdUserEnteredValue .~ Just fv+    last' = cellData & cdUserEnteredValue .~ Just lv++    rel = concat [[(ss, Text.intercalate " " [Text.take 1 $ fst f, snd f]) | (p, ss) <- Map.toList ps, p == (first, last)] | (f, ps) <- Map.toList vs]+    --rel' = (Map.fromList . map (\(a, b) -> (b, a)) . Map.toList) $+    rel' = Map.fromListWith (\a b -> Text.intercalate ", " [a, b]) rel+    restMap = Map.fromList $ concat [[(t, s) | t <- ts] | (ts, s) <- Map.toList rel']+    --vs''' = Map.fromListWith (\a b -> a) [(v, k) | (k, v) <- Map.toList $ Map.mapKeys (\(a, b) -> Text.intercalate " " [a,b]) vs]+    --restMap = Map.fromList $ concat [ concat [[(t, fs) | t <- vs''] | ((pf, pl), vs'') <- Map.toList vs', (pf, pl) == (first, last)] | (fs, vs') <- Map.toList vs''']+    --restMap = Map.fromList $ concat [ concat [[(t, pack $ [head $ unpack ff] ++ " " ++ (unpack fl)) | t <- vs''] | ((pf, pl), vs'') <- Map.toList vs', (pf, pl) == (first, last)] | ((ff, fl), vs') <- Map.toList vs]+    --gRestMap = Map.fromList $ concat [ concat [[(t, pack $ [head $ unpack ff] ++ " " ++ (unpack fl)) | t <- vs''] | (pns, vs'') <- Map.toList vs', (first, last) `elem` pns] | ((ff, fl), vs') <- Map.toList gvs]+    --gRestMap = Map.fromList []+  --   restMap = Map.fromList $ concat [[(x, pack $ [head $ unpack f] ++ " " ++ (unpack l)) | x <- xs] | ((f, l), xs) <- Map.toList vs]+    rest = [extendedValue & evStringValue ?~ (Map.findWithDefault "" t restMap) | t <- ts]+    rest' = [cellData & cdUserEnteredValue ?~ v | v <- rest]+++  +-- createSchedule sid facs prosps slots = do+--   env <- newEnv <&> (envScopes .~ spreadsheetsScope)  +--   addTab sid "Schedule" (fromIntegral $ length prosps + 1) (fromIntegral $ length facs + 2)+--   let cols = ['A'..'Z']+--       facRange = pack $ printf "'Schedule'!A1:%v1" (cols !! (length facs + 2))+--       slotRange = pack $ printf "'Schedule'!A2:B%d" (length slots + 1)+--       facVals = ( vrMajorDimension .~ Just VRMDRows $ vrValues .~ [[String "Start", String "End"] ++ [String _lastName | Person{..} <- facs]] $ vrRange .~ Just facRange $ valueRange)+--       slotVals = ( vrMajorDimension .~ Just VRMDRows $ vrValues .~ [[String $ (pack . formatTime defaultTimeLocale "%a %R") (_start s), String $ (pack . formatTime defaultTimeLocale "%a %R") (_end s)] | s <- slots] $ vrRange .~ Just slotRange $ valueRange)      +--   runResourceT . runGoogle env $ send (svuValueInputOption .~ Just "USER_ENTERED" $ spreadsheetsValuesUpdate sid facVals facRange)+--   runResourceT . runGoogle env $ send (svuValueInputOption .~ Just "USER_ENTERED" $ spreadsheetsValuesUpdate sid slotVals slotRange)  +++readSpreadsheet sid = do+  env <- newEnv <&> (envScopes .~ spreadsheetsScope)+  runResourceT . runGoogle env $ send (sgIncludeGridData .~ Just True $ spreadsheetsGet sid)+++--readValues sid spec = do+--  env <- newEnv <&> (envScopes .~ spreadsheetsScope)+--  runResourceT . runGoogle env $ send (spreadsheetsValuesGet sid spec)+++-- writeValues sid sheet startRow startColumn endRow endColumn values = do+--   env <- newEnv <&> (envScopes .~ spreadsheetsScope)+--   let cols = ['A'..'Z']  +--   return ()+++++sheetName :: Sheet -> Maybe Text+sheetName s = join $ s ^. sProperties <&> view sTitle+++sheetId :: Sheet -> Maybe Int32+sheetId s = join $ s ^. sProperties <&> view sSheetId++  ++rowToPerson :: [Text] -> RowData -> Maybe Person+rowToPerson cols rd = do+  let cells = rd ^. rdValues  +      cells' = map (\x -> (x ^. cdFormattedValue, x^.cdHyperlink)) cells+      feats = Map.fromList $ zip cols cells'+      first = (fromJust . fst) $ feats Map.! "First"+      last = (fromJust .fst) $ feats Map.! "Last"+      minMtg = 1 -- (read . unpack) $ fromMaybe "3" (fst $ feats Map.! "Minimum meetings") :: Int+      maxMtg = 2 -- (read . unpack) $ fromMaybe "3" (fst $ feats Map.! "Maximum meetings") :: Int+      maxSz = 2 -- (read . unpack) $ fromMaybe "2" (fst $ feats Map.! "Maximum size") :: Int+      reqOnly = True -- (fromMaybe "FALSE" (fst $ feats Map.! "Requested only")) == "TRUE"+      e = (fst . fromMaybe (Nothing, undefined)) $ "Email" `Map.lookup` feats+      z = (fst . fromMaybe (Nothing, undefined)) $ "Zoom" `Map.lookup` feats+      g = Just "3" -- (fst . fromJust) $ "Group" `Map.lookup` feats+      a = Just "4" -- (snd . fromMaybe (Nothing, Just "")) $ "App" `Map.lookup` feats+  return $ simplePerson first last & email .~ e & zoom .~ z & minMeetings .~ minMtg & maxMeetings .~ maxMtg & requestedOnly .~ reqOnly & maxMeetingSize .~ maxSz & group .~ g & application .~ a+++rowToSlot :: RowData -> Maybe TimeSpan+rowToSlot rd = do+  let time:_ = rd ^. rdValues+  time' <- time ^. cdFormattedValue+  let startTime = parseTimeOrError True defaultTimeLocale "" (unpack time')      +  return $ TimeSpan startTime startTime++++++ssheet :: Spreadsheet -> Text -> Maybe Sheet+ssheet ssheet name = case ss of+                      [] -> Nothing+                      s:_ -> Just s+  where+    ss = [s | s <- ssheet ^. sprSheets, sheetName s == Just name]+++sheetLookup :: Lens' Spreadsheet (Map Text Int32)+sheetLookup = lens getter (\x y -> undefined)+  where+    getter ss = Map.fromList $ map (\s -> ((fromJust . sheetName) s, (fromJust . sheetId) s)) (ss ^. sprSheets)+++rowToGroupPreference row = simplePreference & intervieweeParticipants .~ (Set.fromList [prosp]) & interviewerParticipants .~ (Set.fromList ints) & priority .~ 2+  where+    first:last:interviewers = rowToStrings row+    prosp = (first, last)+    ints = map ((\(a, b) -> (a, Text.strip b)) . Text.breakOn " ") (filter (\x -> x /= "") interviewers)+    ++getGroupPrefs :: Text -> Spreadsheet -> [Preference]+getGroupPrefs sn ss = map rowToGroupPreference rows+  where+    (sheet:_) = [s | s <- ss ^. sprSheets, sheetName s == Just sn]+    (ds:_) = sheet ^. sData+    rows = ds ^. gdRowData . _tail+++rowToIndividualPreferences cols row = catMaybes $ map (cellToIndividualPreference (first, last)) (zip cols entries)+  where+    _:_:first:last:entries = rowToStrings row++    +cellToIndividualPreference interviewee (interviewer, value) = case value of "" -> Nothing+                                                                            "x" -> Just $ simplePreference & intervieweeParticipants .~ (Set.fromList [interviewee]) & interviewerParticipants .~ (Set.fromList [interviewer]) & priority .~ 1 & required .~ True+                                                                            _ -> Just $ simplePreference & intervieweeParticipants .~ (Set.fromList [interviewee]) & interviewerParticipants .~ (Set.fromList [interviewer]) & priority .~ 0 & required .~ False+++getIndividualPrefs :: Text -> Spreadsheet -> [Preference]+getIndividualPrefs sn ss = concat (map (rowToIndividualPreferences cols) rows)+  where+    (sheet:_) = [s | s <- ss ^. sprSheets, sheetName s == Just sn]+    (ds:_) = sheet ^. sData+    firsts = (drop 4 . rowToStrings . head) $ ds ^. gdRowData+    lasts = (drop 4 . rowToStrings . head . drop 1) $ ds ^. gdRowData+    cols = zip firsts lasts+    rows = (drop 2) $ ds ^. gdRowData+++getPeople :: Text -> Spreadsheet -> [Person]+getPeople sn ss = catMaybes $ map (rowToPerson cols) rows+  where+    (sheet:_) = [s | s <- ss ^. sprSheets, sheetName s == Just sn]+    (ds:_) = sheet ^. sData+    cols = rowToStrings $ head $ ds ^. gdRowData+    rows = ds ^. gdRowData . _tail+++rowToStrings :: RowData -> [Text]+rowToStrings r = map (\x -> fromMaybe "" (x ^. cdFormattedValue)) (r ^. rdValues)+++mon = parseTimeOrError True defaultTimeLocale "%Y-%-m-%-d" "2021-03-08" :: Day+tue = parseTimeOrError True defaultTimeLocale "%Y-%-m-%-d" "2021-03-09" :: Day+wed = parseTimeOrError True defaultTimeLocale "%Y-%-m-%-d" "2021-03-10" :: Day+thu = parseTimeOrError True defaultTimeLocale "%Y-%-m-%-d" "2021-03-11" :: Day+fri = parseTimeOrError True defaultTimeLocale "%Y-%-m-%-d" "2021-03-12" :: Day+--sat = parseTimeOrError True defaultTimeLocale "%Y-%-m-%-d" "2021-02-06" :: Day+++stringsToSlot :: Text -> Text -> TimeSpan+stringsToSlot s e = TimeSpan start end+  where+    sd:st:[] = map T.unpack (T.splitOn " " s)+    ed:et:[] = map T.unpack (T.splitOn " " e)+    d = case sd of "Mon" -> mon+                   "Tue" -> tue+                   "Wed" -> wed+                   "Thu" -> thu+                   "Fri" -> fri+                   --"Sat" -> sat+    start = UTCTime d (timeOfDayToTime (parseTimeOrError True defaultTimeLocale "%R" st :: TimeOfDay))+    end = UTCTime d (timeOfDayToTime (parseTimeOrError True defaultTimeLocale "%R" et :: TimeOfDay))+++getFacultySchedule :: Text -> Spreadsheet -> Person -> Map Text (Text, Text) -> Map (Text, Text) [TimeSpan]+getFacultySchedule tabName ss fac plu = Map.map fixTimes scheds+  where+    rows = [r | r <- map rowToStrings $ (head  $ ss ^. tab tabName . sData) ^. gdRowData]+    (_:_:slots) = head rows+    row = drop 2 $ head [r | r@(f:l:_) <- rows, (f, l) == (fac^.firstName, fac^.lastName)]+    scheds = Map.fromListWith (++) [(plu Map.! n, [ts]) | (n, ts) <- zip row slots, n /= ""]+++fixTimes times = times'+  where+    times' = sort $ map fixTime times+    --s = minimum times'+    --e = maximum times'++fixTime time = TimeSpan s e+  where+    sd = Text.take 3 time+    d = case sd of "Mon" -> mon+                   "Tue" -> tue+                   "Wed" -> wed+                   "Thu" -> thu+                   "Fri" -> fri+                   --"Sat" -> sat+    t = timeOfDayToTime (parseTimeOrError True defaultTimeLocale "%R" (Text.unpack $ Text.drop 4 time) :: TimeOfDay)+    s = UTCTime d t+    e = addUTCTime (secondsToNominalDiffTime (60*60)) s++-- getAvailability :: Text -> Spreadsheet -> [Person] -> [Person]+-- getAvailability tabName ss fac = fac'+--   where+--     (_:_:names):xs = map rowToStrings $ (head  $ ss ^. tab tabName . sData) ^. gdRowData+--     avails = concat $ map (\(s:e:xs') -> [(stringsToSlot s e, n, v) | (n, v) <- zip names xs', v /= ""]) (init xs)+--     fac' = map (\f -> f & availability ?~ [t | (t, n, v) <- avails, f ^. lastName == n]) fac+++getAvailability :: Text -> Spreadsheet -> [Person] -> [Person]+getAvailability tabName ss fac = fac --fac'+  where+    (_:_:firsts):(_:_:lasts):xs = map rowToStrings $ (head  $ ss ^. tab tabName . sData) ^. gdRowData+    names = zip firsts lasts+    +    avails = concat $ map (\(s:e:xs') -> [(stringsToSlot s e, n, v) | (n, v) <- zip names xs', v /= ""]) (init xs)+    fac' = map (\f -> f & availability ?~ [t | (t, (first, last), v) <- avails, first==f ^. firstName && last==f ^. lastName]) fac+++defaultSlots gran = do+  let dates = ["2021-03-" ++ (show d) | d <- [8,9,10,11,12]]+  slots <- sequence $ [stringsToSlots d d "08:00" "19:00" gran | d <- dates]+  return $ concat slots++++getPreferences :: Spreadsheet -> [Person] -> [Person] -> [Person]+getPreferences ss prosps fac = fac'+  where+    (_:_:_:names):xs = map rowToStrings $ (head  $ ss ^. tab "Individual Preferences" . sData) ^. gdRowData+    prefs = concat $ map (\(_:_:l:xs'') -> [(l, n, 1 :: Int) | (n, v) <- zip names xs'', v == "x"]) (init xs)+    plu = Map.fromList [(p ^. lastName, p) | p <- prosps]+    --fac' = map (\f -> f & preferences ?~ Map.fromList [((pf, pl), v) | (pf, pl, n, v) <- prefs, f ^. lastName == n]) fac+    fac' = map (\f -> f & preferences ?~ Map.fromList [(plu Map.! pl, v) | (pl, n, v) <- prefs, f ^. lastName == n]) fac

@@ -0,0 +1,482 @@+module Control.Scheduling.Solve (solveSchedule, printSchedules) where++import Data.SBV+import Data.SBV.Trans.Control+import Control.Scheduling.State (State(..), individualMeetings, groupMeetings, faculty, prospects, requestedMeetings)+import Control.Scheduling.Preference+import Control.Scheduling.Person+import Data.Maybe (Maybe, fromJust, catMaybes, fromMaybe)+import qualified Data.Map as Map+import Data.Map (Map)+import Control.Scheduling.Person (Person(..), availability, firstName, lastName, fullName, preferences)+import Control.Scheduling.TimeSpan (TimeSpan(..), stringsToSlots, start, end)+import Text.Printf (printf)+import Data.Bimap (Bimap)+import qualified Data.Set as Set+import qualified Data.Bimap as Bimap+import Control.Monad.IO.Class (liftIO)+import qualified Data.SBV.List as L+import Text.Read+import Control.Lens+import Control.Monad+import Data.Text (Text)+import Debug.Trace (traceShowId)++type Vars = Map (Int, Int, Int) SBool+type GVars = Map ((Int, [Int]), Int) SBool+type SVars = Map (Int, Int) (SList Bool) -- [SBool]+type Maxes = (Int, Int, Int)+type Ctx = (Maxes, Bimap (Text, Text) Int, Bimap (Text, Text) Int, Bimap TimeSpan Int)+type GMR = [((Text, Text), [[(Text, Text)]])]++frequency :: (Ord a) => [a] -> [(a, Int)]+frequency xs = Map.toList (Map.fromListWith (+) [(x, 1) | x <- xs])++getCurrentCount :: State -> Map (Text, Text) Int+getCurrentCount state = Map.fromListWith (+) (pro ++ base)+  where+    fac = (Map.toList . fromMaybe Map.empty) $ state^.individualMeetings+    base = map (\p -> ((p^.firstName, p^.lastName), 0)) (state ^. prospects)+    mts = concat $ map (Map.toList . snd) fac+    pro = map ((,1) . fst) mts++validate state oldstate = if all (\(f,p,t) -> t `elem` f && t `elem` p) mtgs then "valid" else "invalid"+  where+    flu = Map.fromList $ map (\p -> ((p^.firstName, p^.lastName), fromJust $ p^.availability)) (oldstate^.faculty)+    plu = Map.fromList $ map (\p -> ((p^.firstName, p^.lastName), fromJust $ p^.availability)) (oldstate^.prospects)+    mtgs = concat $ (map (\(k, v) -> concat $ [[(flu Map.! k, plu Map.! p, t) | t <- ts] | (p, ts) <- Map.toList v]) . Map.toList . fromJust) $ state^.individualMeetings+    people = []+  +    +--+--+--+solveSchedule :: State -> IO State+solveSchedule state = do+  let state''' = state & individualMeetings .~ (Just Map.empty)+  --state' <- solveGroupMeetings state'''+  --state' <- solveScheduleTier state''' 1 Map.empty False+  state' <- solveSchedule' state'''+  -- let mtgs' = concat ((map Map.keys . Map.elems . fromMaybe Map.empty) $ state'' ^. individualMeetings)+  --     cts' = Map.fromListWith (+) (map (, 1) mtgs')+  --     pmaxes = Map.fromListWith (+) $ (map (,1) . map (\p -> (p^.firstName, p^.lastName)) . concat . map Map.keys . map (\f -> fromJust $ f^.preferences)) (state^.faculty)+      +  -- print cts'+  -- print $ (sum . map snd . Map.toList) cts'+  -- let target = 3+  --     cur = getCurrentCount state''+  --     needed = Map.mapWithKey (\k v -> max 0 ((max target (pmaxes Map.! k))- v)) cur+  -- print needed+  -- print $ (sum . map snd . Map.toList) needed+  -- print $ state'' ^. individualMeetings+  -- print $ validate state'' state+++  -- state' <- solveScheduleTier state'' 1 needed True+  -- let bmtgs' = concat ((map Map.keys . Map.elems . fromMaybe Map.empty) $ state' ^. individualMeetings)+  --     bcts' = Map.fromListWith (+) (map (, 1) bmtgs')+  -- print bcts'+  -- print $ (sum . map snd . Map.toList) bcts'+  -- let target = 3+  --     bcur = getCurrentCount state'+  --     bneeded = Map.map (\v -> max 0 (target - v)) bcur+  -- print bneeded+  -- print $ (sum . map snd . Map.toList) bneeded+  -- print $ validate state' state++  -- print $ getCurrentCount state'+++  -- --print $ [(p ^. firstName, p ^. lastName, (length . fromJust) (p ^. availability)) | p <- state' ^. prospects]+  -- --print $ [(p ^. firstName, p ^. lastName, (length . fromJust) (p ^. availability)) | p <- state' ^. faculty]+  -- let mtgs'' = concat ((map Map.keys . Map.elems . fromMaybe Map.empty) $ state' ^. individualMeetings)+  --     cts'' = Map.fromListWith (+) (map (, 1) mtgs'')+  -- print cts''+  +  --    state' = state''+  --state' <- solveScheduleTier state'' 1 Map.empty -- needed+  +  --let fac = state' ^. faculty+  --    n = 2+  --    state'' = state' & faculty .~ (map (unasked n (state' ^. prospects)) fac)+  --    sched = (map (Map.keys . snd) . Map.toList . fromJust) $ state' ^. individualMeetings+  --    counts = frequency $ concat sched+  --print $ state' ^. schedule+  --state''' <- solveScheduleTier state'' n++  --let state''''' = state'''+  -- let fac = state''' ^. faculty+  --     n = 1+  --     state'''' = state''' & faculty .~ (map (unasked n (state''' ^. prospects)) fac)+  --     sched = (map (Map.keys . snd) . Map.toList . fromJust) $ state''' ^. schedule+  --     counts = frequency $ concat sched+  -- print counts  +  -- state''''' <- solveScheduleTier state'' n++  +  --let sched = (map (Map.keys . snd) . Map.toList . fromJust) $ state''''' ^. schedule+  --    counts = frequency $ concat sched+  --print counts++++  --printSchedules state'''''+  return state'++unasked :: Int -> [Person] -> Person -> Person+unasked n ps f = f & preferences ?~ prefs''+  where+    prefs' = [p ^. fullName | p <- (Map.keys . fromJust) $ f ^. preferences]+    prefs'' = Map.fromList [(p, n) | p <- ps, not $ elem (p ^. fullName) prefs'] +                            --(k, v) <- Map.toList prefs', v == (-1)]++contiguous :: [TimeSpan] -> Bool+contiguous [] = True+contiguous (a:[]) = True+contiguous (a:b:rest) = (a ^. end) == (b ^. start) && (contiguous (b:rest))++collapseSlots :: Int -> [TimeSpan] -> Map TimeSpan [TimeSpan]+collapseSlots n ss = Map.fromList $ go ss []+  where+    go [] acc = acc+    go ss' acc = if contiguous s && length s == n then go e (tpl:acc) else go (tail ss') acc+      where+        (s, e) = splitAt n ss'+        s' = head s+        e' = last s+        tpl = (TimeSpan (s' ^. start) (e' ^. end), s)+        -- (s, e) = splitAt n ss'+        -- tpl = (TimeSpan ((head s) ^. start) ((last s) ^. end), s)+  +solveScheduleTier :: State -> Int -> Map (Text, Text) Int -> Bool -> IO State+solveScheduleTier state tier rem strict = do+  let sts = collapseSlots tier ((fromJust . _slots) state)+      facs = enblocken (_faculty state) sts+      prosps = enblocken (_prospects state) sts+      ctx@(_, _, plu, _) = makeContext facs prosps (Map.keys sts)+      rem' = Map.mapKeys (\k -> plu Bimap.! k) rem+  sol <- satWith z3 $ problem ctx facs prosps sts tier rem' strict state+  let sol' = getModelDictionary sol+  let iVars = Map.fromList $ map (\(k, v) -> (read k :: (Int, Int, Int), fromCV v :: Bool)) [(k, v) | (k, v) <- Map.toList sol', k /= "goal" && (not $ '[' `elem` k)]+  case sol of u@(SatResult (Unsatisfiable cfg cores)) -> print (u, cfg, cores)+              _ -> print $ "solved tier " ++ (show tier)+  return $ updateState state iVars ctx sts+++solveSchedule' :: State -> IO State+solveSchedule' state = do+  let tier = 1+      sts = collapseSlots tier ((fromJust . _slots) state)+      facs = enblocken (_faculty state) sts+      prosps = enblocken (_prospects state) sts+      ctx@(_, _, plu, _) = makeContext facs prosps (Map.keys sts)+      rem' = Map.empty --Map.mapKeys (\k -> plu Bimap.! k) rem+      strict = True+  sol <- satWith z3 $ problem ctx facs prosps sts tier rem' strict state+  let sol' = getModelDictionary sol+  let iVars = Map.fromList $ map (\(k, v) -> (read k :: (Int, Int, Int), fromCV v :: Bool)) [(k, v) | (k, v) <- Map.toList sol', k /= "goal" && (not $ '[' `elem` k)]+  case sol of u@(SatResult (Unsatisfiable cfg cores)) -> print (u, cfg, cores)+              _ -> print $ "solved!"+  return $ updateState state iVars ctx sts+++solveGroupMeetings :: State -> IO State+solveGroupMeetings state = do+  let tier = 1+      sts = collapseSlots tier ((fromJust . _slots) state)+      facs = enblocken (_faculty state) sts+      prosps = enblocken (_prospects state) sts+      ctx@(_, _, plu, _) = makeContext facs prosps (Map.keys sts)+      --rem' = Map.mapKeys (\k -> plu Bimap.! k) rem+  sol <- satWith z3 $ groupProblem ctx facs prosps sts tier state+  let sol' = getModelDictionary sol+  let iVars = Map.fromList $ map (\(k, v) -> (read k :: (Int, Int, Int), fromCV v :: Bool)) [(k, v) | (k, v) <- Map.toList sol', k /= "goal" && (not $ '[' `elem` k)]+  case sol of u@(SatResult (Unsatisfiable cfg cores)) -> print (u, cfg, cores)+              _ -> print $ "solved groups"+  return $ updateGroupMeetings state iVars ctx sts++updateGroupMeetings :: State -> Map (Int, Int, Int) Bool -> Ctx -> Map TimeSpan [TimeSpan] -> State+updateGroupMeetings state vars ctx sts = state++enblocken :: [Person] -> Map TimeSpan [TimeSpan] -> [Person]+enblocken facs lu = map go facs+  where+    go f = f & availability ?~ [k | (k, vs) <- Map.toList lu, all (\v -> elem v (fromJust $ f ^. availability)) vs]+++updateState :: State -> Map (Int, Int, Int) Bool -> Ctx -> Map TimeSpan [TimeSpan] -> State+updateState state vars ctx timeLookup = state & faculty .~ fac' & prospects .~ prosp' & individualMeetings ?~ newSched+  where+    ((nFac, nProsp, nSlot), fLU, pLU, sLU) = ctx+    fac' = [updateAvailability f (concat [timeLookup Map.! (sLU Bimap.!> sid) | ((fid, pid, sid), b) <- Map.toList vars, b == True, fid == fLU Bimap.! (f ^. fullName)]) | f <- state ^. faculty]+    prosp' = [updateAvailability p (concat [timeLookup Map.! (sLU Bimap.!> sid) | ((fid, pid, sid), b) <- Map.toList vars, b == True, pid == pLU Bimap.! (p ^. fullName)]) | p <- state ^. prospects]+    oldSched = fromMaybe Map.empty (state ^. individualMeetings)+    newSched = Map.fromList [(f ^. fullName, updateFacultySchedule (Map.findWithDefault Map.empty (f ^. fullName) oldSched) [(pLU Bimap.!> pid, timeLookup Map.! (sLU Bimap.!> sid)) | ((fid, pid, sid), b) <- Map.toList vars, b == True, fid == fLU Bimap.! (f ^. fullName)] ) | f <- state ^. faculty]+++-- Remove assigned time slots from faculty availability+updateAvailability :: Person -> [TimeSpan] -> Person+updateAvailability p ts = p & availability ?~ [a | a <- oldAvail, not $ elem a ts]+  where+    oldAvail = fromJust $ p ^. availability++updateFacultySchedule :: Map (Text, Text) [TimeSpan] -> [((Text, Text), [TimeSpan])] -> Map (Text, Text) [TimeSpan]+updateFacultySchedule sched assign = Map.fromList $ Map.toList sched ++ assign++updateFacultyGroupSchedule :: Map [(Text, Text)] [TimeSpan] -> [([(Text, Text)], [TimeSpan])] -> Map [(Text, Text)] [TimeSpan]+updateFacultyGroupSchedule sched assign = Map.fromList $ Map.toList sched ++ assign+++makeContext :: [Person] -> [Person] -> [TimeSpan] -> Ctx+makeContext faculty prospects slots = (maxes, facLU, prospLU, slotLU)+  where+    nFac = length faculty+    nProsp = length prospects+    nSlot = length slots+    maxes = (nFac, nProsp, nSlot)+    facLU = Bimap.fromList (zip [f ^. fullName | f <- faculty] [1..])+    prospLU = Bimap.fromList (zip [p ^. fullName | p <- prospects] [1..])+    slotLU = Bimap.fromList (zip slots [1..])++testVars flu plu slu pst fst (f, p, s) = sl `elem` pls && sl `elem` fls+  where+    sl = slu Bimap.!> s+    pls = pst Map.! (plu Bimap.!> p)+    fls = fst Map.! (flu Bimap.!> f)++groupProblem :: Ctx -> [Person] -> [Person] -> Map TimeSpan [TimeSpan] -> Int -> State -> Goal+groupProblem ctx interviewers interviewees slots tier state = undefined+--  let mtgs = +--  return ()+++gms = [ (("Neha", "Verma"), [("Kenton", "Murray"), ("Kevin", "Duh")])+      , (("Orion", "Weller"), [("Paul", "Mcnamee"), ("Kevin", "Duh")])+      , (("Tucker", "Berckmann"), [("Kenton", "Murray"), ("Kevin", "Duh")])+      ]++++-- faculty exact+-- faculty loose+-- cogsci students+-- non-cogsci students+-- groups+problem :: Ctx -> [Person] -> [Person] -> Map TimeSpan [TimeSpan] -> Int -> Map Int Int -> Bool -> State -> Goal+problem ctx faculty prospects slots tier rem strict state = do+  +  let ((nFac, nProsp, nSlot), flu, plu, slu) = ctx+      pst = Map.fromList $ [((p^.firstName, p^.lastName), fromJust $ p^.availability) | p <- prospects]+      fst = Map.fromList $ [((p^.firstName, p^.lastName), fromJust $ p^.availability) | p <- faculty]+      gms' = map (\(p, fs) -> (plu Bimap.! p, map (flu Bimap.!) fs)) gms+      ignore = concat $ map (\(p, fs) -> [(f, p) | f <- fs]) gms'+      +  -- individual meeting variables+  iVars' <- sequence $ [sBool $ show (i, j, k) | i <- [1..nFac], j <- [1..nProsp], k <- [1..nSlot], testVars flu plu slu pst fst (i, j, k)]++  -- variable lookups+  let iNames = [(i, j, k) | i <- [1..nFac], j <- [1..nProsp], k <- [1..nSlot], testVars flu plu slu pst fst (i, j, k)]++  let iVars = Map.fromList $ zip iNames iVars'+      maxes = (nFac, nProsp, nSlot)+      v = Map.size iVars+++  -- fulfill individual meeting preferences+  sequence $ map (ensureIndividualMeeting ctx iVars state) [m | m <- fromMaybe [] (state^.requestedMeetings), (Set.size $ m^.interviewerParticipants) == 1]++  -- never double-book faculty (same slot, multiple prospects)+  sequence $ [constrain $ pbAtMost [iVars Map.! (f, p, s) | p <- [1..nProsp], (f,p,s) `Map.member` iVars] 1 | f <- [1..nFac], s <- [1..nSlot]]+  +  -- never double-book prospects (same slot, multiple faculty)+  let oneFac = [flu Bimap.! (traceShowId $ fac^.fullName) | fac <- faculty, (fac^.maxMeetingSize) == 1]+      twoFac = [flu Bimap.! (fac^.fullName) | fac <- faculty, (fac^.maxMeetingSize) == 2]++  -- never mix one and two meeting folks+  --sequence $ [constrain $ pbAtMost [iVars Map.! (f, p, s) |   +  --sequence $ [constrain $ pbAtMost [iVars Map.! (f, p, s) | f <- oneFac, (f,p,s) `Map.member` iVars] 1 | p <- [1..nProsp], s <- [1..nSlot]]+  --sequence $ [constrain $ pbAtMost [iVars Map.! (f, p, s) | f <- twoFac, (f,p,s) `Map.member` iVars] 2 | p <- [1..nProsp], s <- [1..nSlot]]+  -- keep faculty and others separate+  --sequence $ [constrain $ pbLe [(if f `elem` oneFac then 2 else 1, v) | ((f, p, s), v) <- Map.toList iVars, s == s', p == p'] 2| s' <- [1..nSlot], p' <- [1..nProsp]]++  -- at least one group must have zero attendance for each possible meeting+  --sequence $ [constrain $ pbAtLeast [ pbExactly [iVars Map.! (f, p, s) | f <- oneFac, (f, p, s) `Map.member` iVars] 0+  --                                  , pbExactly [iVars Map.! (f, p, s) | f <- twoFac, (f, p, s) `Map.member` iVars] 0+  --                                  ] 1 | s <- [1..nSlot], p <- [1..nProsp]]+  sequence $ [constrain $ pbExactly [pbExactly [iVars Map.! (f, p, s) | f <- fs, (f, p, s) `Map.member` iVars] (length fs) | s <- [1..nSlot]] 1 | (p, fs) <- gms']+  +  sequence $ [constrain $ pbExactly [ pbExactly [ pbExactly [iVars Map.! (f, p, s) | f <- oneFac, (f, p, s) `Map.member` iVars && (not $ (f, p) `elem` ignore)] 1+                                                , pbExactly [iVars Map.! (f, p, s) | f <- twoFac, (f, p, s) `Map.member` iVars && (not $ (f, p) `elem` ignore)] 0+                                                ] 2+                                    , pbExactly [ pbExactly [iVars Map.! (f, p, s) | f <- twoFac, (f, p, s) `Map.member` iVars && (not $ (f, p) `elem` ignore)] 2+                                                , pbExactly [iVars Map.! (f, p, s) | f <- oneFac, (f, p, s) `Map.member` iVars && (not $ (f, p) `elem` ignore)] 0+                                                ] 2+                                    , pbExactly [iVars Map.! (f, p, s) | f <- [1..nFac], (f, p, s) `Map.member` iVars && (not $ (f, p) `elem` ignore)] 0+                                    ] 1 | s <- [1..nSlot], p <- [1..nProsp]]    ++  -- make sure no faculty-prospect pair meets more than once+  sequence $ [constrain $ pbAtMost ([v | ((f', p', _), v) <- Map.toList iVars, f' == f && p' == p]) 1 | f <- [1..nFac], p <- [1..nProsp]]++  -- don't reschedule if they already meet+  --sequence $ [constrain $ pbExactly ([v | ((f', p', _), v) <- Map.toList iVars, f' == f && p' == p]) 0 | f <- [1..nFac], p <- [1..nProsp],+  --            (plu Bimap.!> p) `Map.member` fromMaybe Map.empty ((flu Bimap.!> f) `Map.lookup` (fromJust $ state^.individualMeetings))+  --            ]++  -- require minimum number of meetings per faculty+  sequence $ [constrain $ pbAtLeast [b | ((f, p, s), b) <- Map.toList iVars, (flu Bimap.! (fac^.fullName)) == f] (fac^.minMeetings) | fac <- faculty]++  -- limit maximum number of meetings per faculty+  sequence $ [constrain $ pbAtMost [b | ((f, p, s), b) <- Map.toList iVars, (flu Bimap.! (fac^.fullName)) == f] (fac^.maxMeetings) | fac <- faculty]++  -- require minimum number of meetings per prospect+  sequence $ [constrain $ pbAtLeast [b | ((f, p, s), b) <- Map.toList iVars, (plu Bimap.! (pr^.fullName)) == p] (pr^.minMeetings) | pr <- prospects]++  -- limit maximum number of meetings per prospect+  sequence $ [constrain $ pbAtMost [b | ((f, p, s), b) <- Map.toList iVars, (plu Bimap.! (pr^.fullName)) == p] (pr^.maxMeetings) | pr <- prospects]+  +  --sequence $ [softConstrain $ pbAtLeast [v | ((_, p', _), v) <- Map.toList iVars, p' == p] n | (p, n) <- Map.toList rem]+  --sequence $ [constrain $ pbExactly [v | ((_, p', _), v) <- Map.toList iVars, p' == p] n | (p, n) <- Map.toList rem]++  -- limit the maximal number of meetings per prospect+  --sequence $ [constrain $ pbAtMost [v | ((_, p', _), v) <- Map.toList iVars, p' == p] (max n 2) | (p, n) <- Map.toList pmaxes]++++  -- if tier == 1 then+  --   do+  --     sequence $ [constrain $ pbAtMost [v | ((f', _, _), v) <- Map.toList iVars, f' == f] 19 | f <- [1..nFac]] --(p, n) <- Map.toList (traceShowId rem)]+  --     sequence $ [constrain $ pbAtMost [v | ((f', _, _), v) <- Map.toList iVars, f' == (flu Bimap.! f)] n | (f, n) <- [+  --                    (("Jason", "Eisner"), 8),+  --                    --(("Ben", "Van Durme"), 19),+  --                    (("David", "Yarowsky"), 9),+  --                    (("Mark", "Dredze"), 9),+  --                    (("Tom", "Lippincott"), 10),+  --                    (("Philipp", "Koehn"), 12),+  --                    (("Ayah", "Zirikly"), 10),+  --                    (("Kevin", "Duh"), 11),+  --                    (("Dawn", "Lawrie"), 11),+  --                    (("Alan", "Yuille"), 1)+  --                    ]]+  --     sequence $ [constrain $ pbAtMost [v | ((f', _, _), v) <- Map.toList iVars, f' == (flu Bimap.! f)] n | (f, n) <- [        +  --                    (("Kenton", "Murray"), 6),+  --                    (("Patrick", "Xia"), 6),+  --                    (("Nils", "Holzenberger"), 6)+  --                    ]]  +  --     -- sequence $ [constrain $ pbAtMost [v | ((f', _, _), v) <- Map.toList iVars, f' == (flu Bimap.! f)] n | (f, n) <- [+  --     --                (("Jason", "Eisner"), 6),+  --     --                --(("Ben", "Van Durme"), 19),+  --     --                (("David", "Yarowsky"), 11),+  --     --                (("Mark", "Dredze"), 10),+  --     --                (("Tom", "Lippincott"), 11),+  --     --                (("Philipp", "Koehn"), 12),+  --     --                (("Ayah", "Zirikly"), 8),+  --     --                (("Kevin", "Duh"), 11),+  --     --                (("Dawn", "Lawrie"), 11)+  --     --                ]]+  --     -- sequence $ [constrain $ pbExactly [v | ((f', _, _), v) <- Map.toList iVars, f' == (flu Bimap.! f)] n | (f, n) <- [        +  --     --                (("Kenton", "Murray"), 6),+  --     --                (("Patrick", "Xia"), 6)+  --     --                ]]  +  --     --sequence $ [constrain $ pbAtMost [v | ((f', _, _), v) <- Map.toList iVars, f' == (flu Bimap.! f)] 10 | f <- [("Jason", "Eisner"), ("Patrick", "Xia")]]+  --   else return []+    +  return ()++-- preferenceConstraint :: Ctx -> Vars -> Int -> Map Int Int -> [Person] -> Bool -> State -> Person -> Goal+-- preferenceConstraint ctx@(maxes, flu, _, _) vars tier rem prosps strict state f = do+--   let (_, fname) = f ^. fullName+--       fid = flu Bimap.! (f ^. fullName)+--       mtgs = [m | m <- fromMaybe [] (state^.requestedMeetings), (f^.firstName, f^.lastName) `Set.member` (m^.interviewerParticipants)]+--       --mtgs = [head [x | x <- prosps, x ^. fullName == (p ^. fullName)] | (p, n) <- ((Map.toList . fromJust . _preferences) f), n == tier]+--       --pb = if Map.size rem == 0 || f^.lastName == "Yuille" then pbExactly else pbAtLeast+--       --pb = pbExactly+--   sequence $ map (ensureMeeting ctx vars f strict) mtgs+--   if tier == 2 then constrain $ pbExactly [v | ((f', _, _), v) <- Map.toList vars, f' == fid] (length mtgs) else return ()+--   return ()+++ensureMeeting :: Ctx -> Vars -> Person -> Bool -> Person -> Goal+ensureMeeting (maxes, flu, plu, slu) vars fac strict prosp = do+  let fid = flu Bimap.! (fac ^. fullName)+      pid = plu Bimap.! (prosp ^. fullName)+      availF = (Set.fromList . fromJust) $ _availability fac+      availP = (Set.fromList . fromJust) $ _availability prosp+      avail = Set.toList $ Set.intersection availF availP+      sids = catMaybes $ map (\x -> Bimap.lookup x slu) avail+      prefs = ((fromJust . _preferences) fac)+      num = Map.findWithDefault (0) prosp prefs+  (if strict then constrain else softConstrain) $ pbExactly [vars Map.! (fid, pid, sid) | sid <- sids] 1 --(traceShowId num)+  constrain $ pbAtMost [vars Map.! (fid, pid, sid) | sid <- sids] 1+++ensureIndividualMeeting :: Ctx -> Vars -> State -> Preference -> Goal+ensureIndividualMeeting (maxes, flu, plu, slu) vars state mtg = do+  let fac = (head . Set.toList) $ mtg^.interviewerParticipants+      prosp = (head . Set.toList) $ mtg^.intervieweeParticipants+      fid = flu Bimap.! fac --(fac ^. fullName)+      pid = plu Bimap.! prosp -- (prosp ^. fullName)+      fac' = head $ [x | x <- state^.faculty, (x^.firstName == (fst fac)) && (x ^.lastName == (snd fac))]+      prosp' = head $ [x | x <- state^.prospects, (x^.firstName == (fst prosp)) && (x ^.lastName == (snd prosp))]+      availF = (Set.fromList . fromJust) $ _availability fac'+      availP = (Set.fromList . fromJust) $ _availability prosp'+      avail = Set.toList $ Set.intersection availF availP+      sids = catMaybes $ map (\x -> Bimap.lookup x slu) avail+      strict = mtg^.required+  (if strict then constrain else softConstrain) $ pbExactly [vars Map.! (fid, pid, sid) | sid <- sids] 1 --(traceShowId num)+  constrain $ pbAtMost [vars Map.! (fid, pid, sid) | sid <- sids] 1  +  return ()++ensureGroupMeeting :: Ctx -> Vars -> State -> Preference -> Goal+ensureGroupMeeting (maxes, flu, plu, slu) vars state mtg = do+  let facs = Set.toList $ mtg^.interviewerParticipants+      prosp = (head . Set.toList) $ mtg^.intervieweeParticipants+      fids = map (flu Bimap.!) facs --(fac ^. fullName)+      pid = plu Bimap.! prosp -- (prosp ^. fullName)+      facs' = map (\(f, l) -> head $ [x | x <- state^.faculty, (x^.firstName == f) && (x ^.lastName == l)]) facs+      prosp' = head $ [x | x <- state^.prospects, (x^.firstName == (fst prosp)) && (x ^.lastName == (snd prosp))]+      --availF = (Set.fromList . fromJust) $ _availability fac+      --availP = (Set.fromList . fromJust) $ _availability prosp+      --avail = Set.toList $ Set.intersection availF availP+  --     sids = catMaybes $ map (\x -> Bimap.lookup x slu) avail+  --     prefs = ((fromJust . _preferences) fac)+  --     num = Map.findWithDefault (0) prosp prefs+  -- (if strict then constrain else softConstrain) $ pbExactly [vars Map.! (fid, pid, sid) | sid <- sids] 1 --(traceShowId num)+  -- constrain $ pbAtMost [vars Map.! (fid, pid, sid) | sid <- sids] 1+  return ()+-- preferenceConstraint' :: Ctx -> Vars -> Int -> [Person] -> Person -> Goal+-- preferenceConstraint' ctx@(maxes, _, _, _) vars tier prosps f = do+--   sequence $ map (ensureMeeting' ctx vars f tier) [head [x | x <- prosps, x ^. fullName == (p ^. fullName)] | (p, n) <- ((Map.toList . fromJust . _preferences) f), n == tier]+--   return ()+++-- ensureMeeting' :: Ctx -> Vars -> Person -> Int -> Person -> Goal+-- ensureMeeting' (maxes, flu, plu, slu) vars fac tier prosp = do+--   let fid = flu Bimap.! (fac ^. fullName)+--       pid = plu Bimap.! (prosp ^. fullName)+--       availF = (Set.fromList . fromJust) $ _availability fac+--       availP = (Set.fromList . fromJust) $ _availability prosp+--       avail = Set.toList $ Set.intersection availF availP+--       sids = catMaybes $ map (\x -> Bimap.lookup x slu) avail+--       prefs = ((fromJust . _preferences) fac)+--       num = Map.findWithDefault (-1) prosp prefs+--   -- liftIO $ print (fid, pid, availF)+--   -- liftIO $ print (fid, pid, availP)+--   -- liftIO $ print (fid, pid, avail)+--   -- liftIO $ print "\n"+--   softConstrain $ pbExactly [vars Map.! (fid, pid, sid) | sid <- sids] 1+--   constrain $ pbAtMost [vars Map.! (fid, pid, sid) | sid <- sids] 1+++printSchedules :: State -> IO ()+printSchedules state = do+  let facs = _faculty state+      prosps = _prospects state+      sts = ((fromJust . _slots) state)+      ctx = makeContext facs prosps sts+      ((nFac, nProsp, nSlot), fLU, pLU, sLU) = ctx+      sched = fromMaybe Map.empty (state ^. individualMeetings)+      vars = Map.fromList [((f, p, s), elem (sLU Bimap.!> s) (fromMaybe [] $ (fromMaybe Map.empty $ sched Map.!? ((fLU Bimap.!> f))) Map.!? (pLU Bimap.!> p))) | f <- [1..nFac], p <- [1..nProsp], s <- [1..nSlot]]+  let facGrid = [[printf "%2d-%14v" i (snd $ fLU Bimap.!> f)] ++ [case (head $ [p | p <- [1..nProsp], vars Map.! (f, p, s) == True] ++ [0] :: Int) of 0 -> "  "; v -> printf "%2d" v | s <- [1..nSlot]] | (i, f) <- zip [1 :: Int ..] [1..nFac]] :: [[String]]+      prospGrid = [[printf "%2d-%14v" i (snd $ pLU Bimap.!> p)] ++ [case (head $ [f | f <- [1..nFac], vars Map.! (f, p, s) == True] ++ [0] :: Int) of 0 -> "  "; v -> printf "%2d" v | s <- [1..nSlot]] | (i, p) <- zip [1 :: Int ..] [1..nProsp]] :: [[String]]      +  putStrLn $ unlines (map unwords facGrid)+  putStrLn $ unlines (map unwords prospGrid)

@@ -0,0 +1,96 @@+module Control.Scheduling.State ( State(..)+                                , individualMeetings+                                , groupMeetings+                                , faculty+                                , prospects+                                , slots+                                , granularity+                                , compressSlots+                                , simpleState+                                , requestedMeetings+                                ) where++import Text.Printf ( printf+                   , PrintfArg(..)+                   , fmtPrecision+                   , fmtChar+                   , errorBadFormat+                   , formatString+                   , vFmt+                   , IsChar+                   )+import Control.Lens ((^.), (.~), (&), (<&>), set, view, makeLenses, makeFields, (%~))+import Control.Scheduling.Person (Person(..), availability)+import Control.Scheduling.TimeSpan (TimeSpan(..))+import Control.Scheduling.Preference (Preference(..))+import Data.Text (Text)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.List (intercalate)+import Data.Maybe (fromMaybe, fromJust)+import System.Random+import qualified Control.Monad.State as S++data State = State { _faculty :: [Person]+                   , _prospects :: [Person]+                   , _requestedMeetings :: Maybe [Preference]+                   , _slots :: Maybe [TimeSpan]+                   , _individualMeetings :: Maybe (Map (Text, Text) (Map (Text, Text) [TimeSpan])) -- faculty to student+                   , _groupMeetings :: Maybe (Map (Text, Text) (Map [(Text, Text)] [TimeSpan]))+                   , _granularity :: Maybe Int+                   , _interviewerSheet :: Text+                   , _prospectSheet :: Text+                   , _interviewerAvailabilitySheet :: Text+                   , _prospectAvailabilitySheet :: Text+                   , _individualPreferenceSheet :: Text+                   , _groupPreferenceSheet :: Text+                   , _interviewerScheduleSheet :: Text+                   , _prospectScheduleSheet :: Text+                   } deriving (Show)++instance PrintfArg State where+  formatArg State{..} fmt | fmtChar (vFmt 'P' fmt) == 'P' = formatString (printf "State:\n\n  Interviewers:\n%s\n\n  Prospects:\n%s\n\n  Slots:\n%s\n " facs prosps slots :: String) (fmt { fmtChar = 's', fmtPrecision = Nothing })+    where+      facs = intercalate "\n" (map (printf "    %s") _faculty :: [String])+      prosps = intercalate "\n" (map (printf "    %s") _prospects :: [String])+      slots = printf "    %d" ((length . fromMaybe []) _slots :: Int) :: String++makeLenses ''State++simpleState = State [] [] Nothing Nothing Nothing Nothing Nothing "Interviewers" "Prospects" "Interviewer Availability" "Prospect Availability" "Individual Preferences" "Group Preferences" "Interviewer Schedule" "Prospect Schedule"++filtAvail :: (Ord a) => Set a -> Maybe [a] -> Maybe [a]+filtAvail keep others = Just $ Set.toList toKeep+  where+    others' = (Set.fromList . fromJust) others+    toKeep = Set.intersection others' keep++compressSlots :: State -> State+compressSlots state@(State{..}) = state & faculty .~ faculty' & prospects .~ prospects' & slots .~ slots'+  where+    allFacAvail = Set.fromList $ concat [fromJust $ f ^. availability | f <- _faculty]+    allProspAvail = Set.fromList $ concat [fromJust $ f ^. availability | f <- _prospects]+    allSlots = Set.fromList $ fromJust _slots+    overlap' = Set.intersection allFacAvail allProspAvail+    overlap = Set.intersection overlap' allSlots+    faculty' = [p & availability %~ filtAvail overlap | p <- _faculty]+    prospects' = [p & availability %~ filtAvail overlap | p <- _prospects]+    slots' = Just $ Set.toList overlap+-- randomizeEntries :: State -> IO State+-- randomizeEntries s = do+--   faculty' <- randomizeAvailability (_faculty s) (_slots s)+--   faculty'' <- sequence $ map (randomizePreferences (_prospects s)) faculty'+--   return $ s { _faculty=faculty'' } ++-- randomizePreferences :: [Person] -> Person -> IO Person+-- randomizePreferences prosp fac = do+--   r <- newStdGen+--   let rs = randomRs (0.0, 1.0) r :: [Double]+--       bs = map (\v -> if v < 0.5 then 0 else if v < 0.85 then 1 else 1) rs+--   return $ fac { _preferences=Just $ Map.fromList $ zip prosp bs }+  +-- randomizeAvailability :: [Person] -> Maybe [TimeSpan] -> IO [Person]+-- randomizeAvailability fac slots = do+--   return $ [p { _availability=slots }| p <- fac]

@@ -0,0 +1,43 @@+module Control.Scheduling.TimeSpan (expand, TimeSpan(..), start, end, stringsToSlots, timesFromStrings) where++import Data.Time+import Control.Lens ((^.), (.~), (<&>), set, view, makeLenses, makeFields)+import Data.List (unfoldr)++data TimeSpan = TimeSpan { _start :: UTCTime+                         , _end :: UTCTime+                         } deriving (Show, Eq, Ord)++makeLenses ''TimeSpan++stringsToSlots :: String -> String -> String -> String -> Integer -> Maybe [TimeSpan]+stringsToSlots sd ed st et sl = Just slots+  where+    days = daysFromStrings sd ed+    (st', et') = timesFromStrings st et+    ranges = [TimeSpan (UTCTime d st') (UTCTime d et') | d <- days]+    increment' = secondsToDiffTime $ 60 * sl :: DiffTime+    slots = concat $ map (expand increment') ranges++expand :: DiffTime -> TimeSpan -> [TimeSpan]+expand slotLength block = if s' > e then [n] else n:(expand slotLength block')+  where+    s = block ^. start+    e = block ^. end+    s' = s { utctDayTime=utctDayTime s + slotLength }+    n = TimeSpan s s'+    block' = TimeSpan s' e+  +daysFromStrings :: String -> String -> [Day]+daysFromStrings s e = ds+  where+    s' = parseTimeOrError True defaultTimeLocale "%Y-%-m-%-d" s :: Day+    e' = parseTimeOrError True defaultTimeLocale "%Y-%-m-%-d" e :: Day+    ds = unfoldr (\d -> if d > e' then Nothing else Just (d, (addDays 1 d))) s'++timesFromStrings :: String -> String -> (DiffTime, DiffTime)+timesFromStrings s e = (timeOfDayToTime s', timeOfDayToTime e')+  where+    s' = parseTimeOrError True defaultTimeLocale "%R" s :: TimeOfDay+    e' = parseTimeOrError True defaultTimeLocale "%R" e :: TimeOfDay+