implementation module C2.Framework.MapEnvironment import StdArray import iTasks import iTasks.UI.Definition import iTasks.Internal.Tonic import iTasks.Extensions.Admin.TonicAdmin import iTasks.Extensions.DateTime import qualified Data.Map as DM from Data.Map import :: Map, instance Functor (Map k) import Data.Map.GenJSON import qualified Data.IntMap.Strict as DIS from Data.IntMap.Strict import :: IntMap import qualified Data.Heap as DH from Data.Heap import :: Heap import Data.GenLexOrd from C2.Framework.Logging import addLog import Data.List import Data.Eq import Data.Maybe import Data.Functor import Data.Either import StdMisc derive class iTask Map2D, Section, Borders, Border, Coord2D, Dir, MapAction derive class iTask Actor, Object // small utility functions instance == (Actor o a) where (==) a1 a2 = a1.userName == a2.userName derive gLexOrd Coord2D instance == (Object obj) | == obj where (==) o1 o2 = o1 == o2 instance toString (Object obj) | toString obj where toString {Object | objId, objType} = toString objType +++ " " +++ toString objId instance toString Coord2D where toString {col, row} = "(" +++ toString row +++ ", " +++ toString col +++ ")" instance toString Coord3D where toString (l, {col, row}) = "(" +++ toString l +++ ", " +++ toString row +++ ", " +++ toString col +++ ")" instance toString Dir where toString N = "N" toString E = "E" toString W = "W" toString S = "S" instance == Coord2D where (==) l r = l === r instance < Coord2D where (<) l r = case l =?= r of LT -> True _ -> False instance zero Coord2D where zero = {Coord2D | col=0, row=0} instance == Dir where (==) l r = l === r instance == Border where (==) l r = l === r infinity =: 67108864 maps2DShare :: SimpleSDSLens Maps2D maps2DShare = sharedStore "maps2DShare" [] sharedGraph :: SDSLens () Graph () sharedGraph = sdsLens "sharedGraph" (const ()) (SDSRead read) (SDSWriteConst write) (SDSNotifyConst notify) Nothing maps2DShare where read _ m = Ok (maps2DToGraph m) write _ _ = Ok Nothing notify _ _ = const (const True) sectionUsersShare :: SectionUsersShare sectionUsersShare = sharedStore "sectionUsersShare" 'DM'.newMap sectionForUserShare :: User -> SDSLens () (Maybe Coord3D) SectionUsersMap sectionForUserShare user = mapRead (sectionForUser user) sectionUsersShare focusedSectionUsersShare :: FocusedSectionUsersShare focusedSectionUsersShare = mapLens "focusedSectionUsersShare" sectionUsersShare (Just []) inventoryForUserSection :: !User !(FocusedSectionInventoryShare o) -> SimpleSDSSequence (IntMap (Object o)) | iTask o inventoryForUserSection user inventoryForSectionShare = sdsSequence ("inventoryForUserSection" +++ toString user) id mkP2 (\_ _ -> Right mkr) (SDSWrite write1) (SDSWrite write2) (sectionForUserShare user) inventoryForSectionShare where mkP2 p (Just c3d) = c3d mkP2 _ _ = (-1, {col = -1, row = -1}) mkr (_, inv) = inv write1 p r1 w = Ok Nothing write2 p r2 w = Ok (Just w) lockedExitsShare :: SimpleSDSLens SectionExitLockMap lockedExitsShare = sharedStore "lockedExitsShare" 'DM'.newMap lockStatusForExit :: SDSLens Coord3D [Dir] [Dir] lockStatusForExit = mapLens "lockStatusForExit" lockedExitsShare (Just []) lockedHopsShare :: SimpleSDSLens SectionHopLockMap lockedHopsShare = sharedStore "lockedHopsShare" 'DM'.newMap lockStatusForHop :: SDSLens Coord3D [Coord3D] [Coord3D] lockStatusForHop = mapLens "lockStatusForHop" lockedHopsShare (Just []) maps2DToGraph :: !Maps2D -> Graph maps2DToGraph maps2D = fst (foldl map2DToGraph ('DM'.newMap, 0) maps2D) map2DToGraph :: !(!Graph, !Int) !Map2D -> (!Graph, !Int) map2DToGraph (graph, floorIdx) map2D #! (graph, _) = foldl (rowToGraph floorIdx) (graph, 0) map2D.map2D = (graph, floorIdx + 1) rowToGraph :: !Int !(!Graph, !Int) ![Section] -> (!Graph, !Int) rowToGraph floorIdx (graph, rowIdx) sections #! (graph, _) = foldl (colToGraph floorIdx rowIdx) (graph, 0) sections = (graph, rowIdx + 1) colToGraph :: !Int !Int !(!Graph, !Int) !Section -> (!Graph, !Int) colToGraph floorIdx rowIdx (graph, colIdx) section #! currCoord2D = {col = colIdx, row = rowIdx} #! graph = 'DM'.put (floorIdx, currCoord2D) (getCoord3Ds section floorIdx currCoord2D section.borders) graph = (graph, colIdx + 1) getCoord3Ds :: !Section !Int !Coord2D !Borders -> [(!Maybe Dir, !Coord3D)] getCoord3Ds section floorIdx currCoord2D borders #! acc = [] #! acc = addOnOpening floorIdx borders.n N currCoord2D acc #! acc = addOnOpening floorIdx borders.e E currCoord2D acc #! acc = addOnOpening floorIdx borders.w W currCoord2D acc #! acc = addOnOpening floorIdx borders.s S currCoord2D acc #! acc = acc ++ map (\h -> (Nothing, h)) section.hops = acc where addOnOpening :: !Int !Border !Dir !Coord2D ![(!Maybe Dir, !Coord3D)] -> [(!Maybe Dir, !Coord3D)] addOnOpening _ Wall _ _ acc = acc addOnOpening floorIdx b dir coord2D acc = [(Just dir, (floorIdx, twin dir coord2D)) : acc] :: PathMap :== Map Coord3D Coord3D :: DistMap :== Map Coord3D Distance shortestPath :: !(r -> Weight) !Coord3D !Coord3D !(SectionStatusMap r) !SectionExitLockMap !SectionHopLockMap !Graph -> Maybe (![Coord3D], !Distance) shortestPath costFn startRoomCoord endRoomCoord statusMap locks hopLocks graph | startRoomCoord == endRoomCoord = Just ([], 0) | otherwise #! pathMap = 'DM'.newMap #! distMap = 'DM'.put startRoomCoord 0 (fmap (const infinity) graph) #! pqueue = 'DH'.singleton (startRoomCoord, 0) = reconstructSP (findSP costFn graph pqueue statusMap locks hopLocks pathMap distMap) where reconstructSP :: !(!PathMap, !DistMap) -> Maybe (![Coord3D], !Distance) reconstructSP (pathMap, distMap) = reconstructSP` pathMap endRoomCoord [] >>= \path -> 'DM'.get endRoomCoord distMap >>= \totalDist -> Just (path, totalDist) reconstructSP` :: !PathMap !Coord3D ![Coord3D] -> Maybe [Coord3D] reconstructSP` pathMap currIdx path | currIdx == startRoomCoord = Just path | otherwise = case 'DM'.get currIdx pathMap of Just prevIdx #! path` = [currIdx : path] | prevIdx == startRoomCoord = Just path` | otherwise = reconstructSP` pathMap prevIdx path` _ = Nothing findSP :: !(r -> Weight) !Graph !(Heap (!Coord3D, !Distance)) !(SectionStatusMap r) !SectionExitLockMap !SectionHopLockMap !PathMap !DistMap -> (!PathMap, !DistMap) findSP costFn graph pqueue statusMap locks hopLocks pathMap distMap | 'DH'.null pqueue = (pathMap, distMap) | otherwise = case 'DH'.uncons pqueue of Just ((minIdx, minDist), pqueue) = case 'DM'.get minIdx graph of Just exits #! (pathMap, distMap, pqueue) = foldr (foldExits costFn statusMap locks hopLocks minDist minIdx) (pathMap, distMap, pqueue) exits = findSP costFn graph pqueue statusMap locks hopLocks pathMap distMap _ = (pathMap, distMap) _ = (pathMap, distMap) where foldExits :: !(r -> Weight) !(SectionStatusMap r) !SectionExitLockMap !SectionHopLockMap !Distance !Coord3D !(!Maybe Dir, !Coord3D) !(!PathMap, !DistMap, !Heap (!Coord3D, !Distance)) -> (!PathMap, !DistMap, !Heap (!Coord3D, !Distance)) foldExits costFn statusMap locks hopLocks minDist minIdx (dir, nextRoom) (pathMap, distMap, pqueue) | isLocked dir = (pathMap, distMap, pqueue) | otherwise = case 'DM'.get nextRoom distMap of Just nDist #! roomCost = maybe 1 costFn ('DM'.get nextRoom statusMap) #! alt = minDist + roomCost | alt < nDist = ( 'DM'.put nextRoom minIdx pathMap , 'DM'.put nextRoom alt distMap , 'DH'.insert (nextRoom, alt) pqueue) | otherwise = (pathMap, distMap, pqueue) _ = (pathMap, distMap, pqueue) where isLocked :: !(Maybe Dir) -> Bool isLocked (Just d) = isMember d (fromMaybe [] ('DM'.get minIdx locks)) isLocked _ = isMember nextRoom (fromMaybe [] ('DM'.get minIdx hopLocks)) getSectionFromMap :: !Coord3D !Maps2D -> Maybe Section getSectionFromMap (lvl, c2d) ms2d | lvl < length ms2d = getSection c2d (ms2d !! lvl) | otherwise = Nothing getMap2D :: !Maps2DIndex !Maps2D -> Maybe Map2D getMap2D idx ms2d | 0 <= idx && idx < length ms2d = Just (ms2d !! idx) | otherwise = Nothing setMap2D :: !Maps2DIndex !Map2D !Maps2D -> Maps2D setMap2D idx m ms2d | 0 <= idx && idx < length ms2d = updateAt idx m ms2d | otherwise = ms2d updMap2D :: !Maps2DIndex !(Map2D -> Map2D) !Maps2D -> Maps2D updMap2D idx f ms2d | 0 <= idx && idx < length ms2d = updateAt idx (f (ms2d !! idx)) ms2d | otherwise = ms2d getMapID :: !Maps2DIndex !Maps2D -> Maybe MapID getMapID idx ms2d | 0 <= idx && idx < length ms2d = Just (ms2d !! idx).Map2D.mapId | otherwise = Nothing getMap2DIndex :: !MapID !Maps2D -> Maybe Maps2DIndex getMap2DIndex mapID ms2d = listToMaybe [idx \\ {Map2D | mapId} <- ms2d & idx <- [0..] | mapId == mapID] getSection :: !Coord2D !Map2D -> Maybe Section getSection {col, row} {Map2D | map2D} = map2D !!! row >>= \cols -> cols !!! col setSection :: !Coord2D !Section !Map2D -> Map2D setSection {col, row} s m=:{Map2D | map2D} #! map2D` = case map2D !!! row of Just cols = case cols !!! col of Just _ = updateAt row (updateAt col s cols) map2D _ = map2D _ = map2D = {Map2D | m & map2D=map2D`} updSection :: !Coord2D !(Section -> Section) !Map2D -> Map2D updSection c f m = case getSection c m of Just s = setSection c (f s) m _ = m updSections :: !(Section -> Section) !Map2D -> Map2D updSections f m=:{Map2D | map2D} = {Map2D | m & map2D = map (map f) map2D} twin :: !Dir !Coord2D -> Coord2D twin d c=:{Coord2D | col, row} = case d of S = {Coord2D | c & row = row + 1} E = {Coord2D | c & col = col + 1} N = {Coord2D | c & row = row - 1} W = {Coord2D | c & col = col - 1} validCoord :: !Coord2D !Map2D -> Bool validCoord c map #! (cols, rows) = dimension map = 0 <= c.Coord2D.col && c.Coord2D.col < cols && 0 <= c.Coord2D.row && c.Coord2D.row < rows dimension :: !Map2D -> (!Int,!Int) dimension {Map2D | map2D} = (length (hd map2D),length map2D) getBorder :: !Dir !Section -> Border getBorder d {Section | borders={n,e,w,s}} = case d of N = n E = e W = w S = s setBorder :: !Dir !Border !Section -> Section setBorder d b s=:{Section | borders=bs} #! bs` = case d of N = {Borders | bs & n=b} E = {Borders | bs & e=b} W = {Borders | bs & w=b} S = {Borders | bs & s=b} = {Section | s & borders=bs`} updBorder :: !Dir !(Border -> Border) !Section -> Section updBorder d f s = setBorder d (f (getBorder d s)) s opposite :: !Dir -> Dir opposite N = S opposite S = N opposite W = E opposite E = W (!!!) infixl 9 :: ![.a] !Int -> Maybe .a (!!!) xs i = listToMaybe [x \\ x <- xs & j <- [0..] | i==j] (??) infixl 9 :: ![a] !a -> Int | == a (??) xs x = hd ([i \\ i <- [0..] & x` <- xs | x==x`] ++ [-1]) // moving around in the map addActorToMap :: !(DrawMapForActor r o a) !(Actor o a) !Coord3D !(FocusedSectionInventoryShare o) !(SectionStatusShare r) !(UserActorShare o a) !(SectionInventoryShare o) -> Task () | iTask r & iTask o & iTask a addActorToMap roomViz actor location inventoryForSectionShare shipStatusShare userToActorShare inventoryForAllSectionsShare = get maps2DShare >>= \ms2d -> if (existsSection location ms2d) ( upd ('DM'.put actor.userName actor) userToActorShare >>| move (0, {col = 0, row = 0}) location actor.userName >>| moveAround roomViz actor.userName inventoryForSectionShare shipStatusShare userToActorShare inventoryForAllSectionsShare) (viewInformation ("Section with number: " <+++ location <+++ " does not exist") [] () >>| return ()) :: UITag :== [Int] :: TaskUITree = Ed UITag | Par UITag [TaskUITree] | Step UITag [TaskUITree] uiToRefs :: UI -> TaskUITree uiToRefs (UI _ _ subs) = case recurse [] subs of [x : _] -> x _ -> Ed [] where uiToRefs` :: [Int] (Int, UI) -> [TaskUITree] uiToRefs` path (i, UI UIParallel _ subs) # curPath = path ++ [i] = [Par curPath (recurse curPath subs)] uiToRefs` path (i, UI UIStep _ subs) # curPath = path ++ [i] = [Step curPath (recurse curPath subs)] uiToRefs` path (i, _) # curPath = path ++ [i] = [Ed curPath] recurse curPath subs = flatten (map (uiToRefs` curPath) (zip2 [0..] subs)) getSubTree :: UI [Int] -> Maybe UI getSubTree ui [] = Just ui getSubTree (UI _ _ uis) [i : is] | i < length uis = getSubTree (uis !! i) is | otherwise = Nothing :: TaskUILayout = UIBeside [TaskUILayout] | UIAbove [TaskUILayout] | UINode UITag uiOf :: TaskUITree -> TaskUILayout uiOf (Ed path) = UINode path uiOf (Par path _) = UINode path uiOf (Step path _) = UINode path uiBeside :: [TaskUILayout] -> TaskUILayout uiBeside refs = UIBeside refs uiAbove :: [TaskUILayout] -> TaskUILayout uiAbove refs = UIAbove refs //layoutSubs_ :: (NodePath UI -> Bool) Layout -> Layout //layoutSubs_ pred layout = layout` //where //layout` (change,s) //| change=:(ReplaceUI _) //# (change,eitherState) = layoutChange_ [] pred layout change (NL []) //= (change,toJSON eitherState) //| otherwise //# (change,eitherState) = case fromMaybe (Right (NL [])) (fromJSON s) of //(Left state) = appSnd Left (layout (change,state)) //(Right states) = layoutChange_ [] pred layout change states //= (change,toJSON eitherState) /* modifyUI :: (TaskUITree -> TaskUILayout) -> Layout modifyUI f = idLayout modifyUI f = \(uichange, json) -> case uichange of ReplaceUI ui -> (ReplaceUI (toLayout ui (f (uiToRefs ui))), json) _ -> (uichange, json) where toLayout :: UI TaskUILayout -> UI toLayout ui (UIBeside ls) = UI UIParallel ('DM'.singleton "direction" (JSONString "horizontal")) (map (toLayout ui) ls) toLayout ui (UIAbove ls) = UI UIParallel ('DM'.singleton "direction" (JSONString "vertical")) (map (toLayout ui) ls) toLayout ui (UINode path) = case getSubTree ui path of Just ui -> ui _ -> UI UIDebug 'DM'.newMap [] */ moveAround :: !(DrawMapForActor r o a) !User !(FocusedSectionInventoryShare o) !(SectionStatusShare r) !(UserActorShare o a) !(SectionInventoryShare o) -> Task () | iTask r & iTask o & iTask a moveAround viewDeck user inventoryForSectionShare shipStatusShare userToActorShare inventoryForAllSectionsShare = forever ( walkAround -||- changeDecks -||- pickUpItems -||- dropItems) //<<@ ApplyLayout (idLayout modifyUI moveAroundUI) where walkAround :: Task () walkAround = watch (lockedExitsShare |*| roomNoForCurrentUserShare |*| maps2DShare) -|| viewDeck user shipStatusShare userToActorShare inventoryForAllSectionsShare >>* [ OnAction (Action "Go west") (moveTo W) , OnAction (Action "Go north") (moveTo N) , OnAction (Action "Go south") (moveTo S) , OnAction (Action "Go east") (moveTo E) ] changeDecks :: Task () changeDecks = watch (lockedHopsShare |*| roomNoForCurrentUserShare) -&&- enterChoiceWithShared "Change deck" [prettyPrintHops] nearbyHops >>* [OnAction (Action "Change deck") changeDeck] pickUpItems :: Task () pickUpItems = watch roomNoForCurrentUserShare -&&- enterChoiceWithShared "Items nearby" [prettyPrintItems] (nearbyItemsShare inventoryForSectionShare) >>* [OnAction (Action "Grab selected item") (withSelectedObject userToActorShare inventoryForSectionShare pickupObject)] dropItems :: Task () dropItems = watch roomNoForCurrentUserShare -&&- enterChoiceWithShared "Items in inventory" [prettyPrintItems] (inventoryShare userToActorShare) >>* [OnAction (Action "Drop selected item") (withSelectedObject userToActorShare inventoryForSectionShare dropObject)] moveAroundUI :: TaskUITree -> TaskUILayout moveAroundUI (Par _ [ walkAroundUI , Par _ [ changeDecksUI , Par _ [ pickUpUI , dropUI ] ] ]) = uiAbove [ uiOf walkAroundUI , uiBeside [uiOf changeDecksUI, uiOf pickUpUI, uiOf dropUI]] moveAroundUI us = UINode [] prettyPrintHops = ChooseFromGrid prettyHop prettyPrintItems = ChooseFromGrid prettyItem nearbyHops :: SDSLens () [(Coord3D, Coord3D)] () nearbyHops = toReadOnly (mapRead getHops (roomNoForCurrentUserShare |*| maps2DShare)) roomNoForCurrentUserShare :: SDSLens () (Maybe Coord3D) () roomNoForCurrentUserShare = toReadOnly (sectionForUserShare user) inventoryShare :: (UserActorShare o a) -> SDSLens () [Object o] () | iTask o & iTask a inventoryShare userToActorShare = toReadOnly (mapRead carriedObjects (sdsFocus user (actorForUserShare userToActorShare))) nearbyItemsShare :: (FocusedSectionInventoryShare o) -> SDSLens () [Object o] () | iTask o nearbyItemsShare inventoryForSectionShare = toReadOnly (mapRead 'DIS'.elems (inventoryForUserSection user inventoryForSectionShare)) getHops :: (Maybe Coord3D, Maps2D) -> [(Coord3D, Coord3D)] getHops (Just c3d, ms2d) = case getSectionFromMap c3d ms2d of Just section -> map (\h -> (c3d, h)) section.hops _ -> [] getHops _ = [] withSelectedObject :: (UserActorShare o a) (FocusedSectionInventoryShare o) (Coord3D (Object o) User (UserActorShare o a) (FocusedSectionInventoryShare o) -> Task ()) (TaskValue (Maybe Coord3D, Object o)) -> Maybe (Task ()) | iTask o & iTask a withSelectedObject userToActorShare inventoryForSectionShare f (Value (Just roomNo, selectedObject) _) = Just (f roomNo selectedObject user userToActorShare inventoryForSectionShare) withSelectedObject _ _ _ _ = Nothing prettyHop :: !(!Coord3D, !Coord3D) -> String prettyHop ((floorIdx, _), hop=:(nextFloor, c2d)) = "Go " +++ (if (nextFloor < floorIdx) "up" "down") +++ " to floor " +++ toString nextFloor +++ ", room " +++ toString c2d carriedObjects mactor = maybe [] (\a -> a.carrying) mactor prettyItem obj = obj.objType moveTo :: Dir (TaskValue ((SectionExitLockMap, Maybe Coord3D), Maps2D)) -> Maybe (Task ()) moveTo dir (Value ((exitLocks, Just roomNo=:(floor, room2D)), ms2d) _) = case getSectionFromMap roomNo ms2d of Just section | isWall section dir || doorIsLocked roomNo dir exitLocks = Nothing | otherwise = Just (move roomNo (floor, twin dir room2D) user) _ = Nothing where isWall :: !Section !Dir -> Bool isWall section dir = getBorder dir section == Wall moveTo _ _ = Nothing changeDeck :: (TaskValue ((SectionHopLockMap, Maybe Coord3D), (Coord3D, Coord3D))) -> Maybe (Task ()) changeDeck (Value ((hopLocks, Just roomNo), (_, hop)) _) | hopIsLocked roomNo hop hopLocks = Nothing | otherwise = Just (move roomNo hop user) where hopIsLocked :: !Coord3D !Coord3D !SectionHopLockMap -> Bool hopIsLocked currC3d nextC3d hopLocks = case 'DM'.get currC3d hopLocks of Just locks = elem nextC3d locks _ = False changeDeck _ = Nothing sectionForSectionNumberShare :: SDSLens Coord3D (Maybe Section) Section sectionForSectionNumberShare = sdsLens "sectionForSectionNumberShare" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) Nothing maps2DShare where read :: Coord3D Maps2D -> MaybeError TaskException (Maybe Section) read c3d ms2d = Ok (getSectionFromMap c3d ms2d) write :: Coord3D Maps2D Section -> MaybeError TaskException (Maybe Maps2D) write (floorIdx, c2d) ms2d section = Ok (Just (updMap2D floorIdx (setSection c2d section) ms2d)) notify :: Coord3D Maps2D Section -> SDSNotifyPred Coord3D notify c3d _ _ = \_ c3d` -> c3d == c3d` pickupObject :: !Coord3D !(Object o) !User !(UserActorShare o a) !(FocusedSectionInventoryShare o) -> Task () | iTask o & iTask a pickupObject c3d object user userActorShare shFocusedSectionInventory = upd f userActorShare >>| upd (\inv -> 'DIS'.fromList [(obj.objId, obj) \\ obj <- 'DIS'.elems inv | obj.objId /= object.objId]) (sdsFocus c3d shFocusedSectionInventory) @! () where f userActorMap = case 'DM'.get user userActorMap of Just actor = 'DM'.put user {actor & carrying = [object:actor.carrying]} userActorMap _ = userActorMap dropObject :: !Coord3D !(Object o) !User !(UserActorShare o a) !(FocusedSectionInventoryShare o) -> Task () | iTask o & iTask a dropObject c3d object user userActorShare shFocusedSectionInventory = upd f userActorShare >>| upd (\inv -> 'DIS'.put object.objId object inv) (sdsFocus c3d shFocusedSectionInventory) @! () where f userActorMap = case 'DM'.get user userActorMap of Just actor = 'DM'.put user {actor & carrying = removeObject object actor.carrying} userActorMap _ = userActorMap useObject :: !Coord3D !(Object o) !User !(UserActorShare o a) !(FocusedSectionInventoryShare o) -> Task Bool | iTask o & iTask a useObject c3d object user userActorShare shFocusedSectionInventory = get userActorShare >>- \userActorMap -> case 'DM'.get user userActorMap of Just actor | hasObject object actor = set ('DM'.put user {actor & carrying = removeObject object actor.carrying} userActorMap) userActorShare @! True _ = return False hasObject :: !(Object o) !(Actor o a) -> Bool hasObject obj actor = length [0 \\ obj` <- actor.carrying | obj.objId == obj`.objId] > 0 removeObject :: !(Object o) ![Object o] -> [Object o] removeObject obj objs = [obj` \\ obj` <- objs | obj.objId /= obj`.objId ] move :: !Coord3D !Coord3D !User -> Task () move fromSection toSection user = upd (enterSection user toSection o leaveSection user fromSection) sectionUsersShare @! () where leaveSection :: !User !Coord3D !SectionUsersMap -> SectionUsersMap leaveSection user roomNo usersMap = 'DM'.alter (fmap (\actors -> [a \\ a <- actors | a /= user])) roomNo usersMap enterSection :: !User !Coord3D !SectionUsersMap -> SectionUsersMap enterSection user roomNo usersMap #! actors = 'DM'.findWithDefault [] roomNo usersMap = 'DM'.put roomNo (nub [user : actors]) usersMap getObjectOfType :: !(Actor o a) !o -> Object o | iTask o & iTask a getObjectOfType {Actor | carrying} objType` = case [obj \\ obj <- carrying | obj.objType === objType`] of [x : _] -> x // auto moves around the maze autoMove :: !Coord3D !Coord3D !(Coord3D Coord3D (SectionStatusMap r) SectionExitLockMap SectionHopLockMap Graph -> Maybe ([Coord3D], Distance)) !User !(Shared sds (SectionStatusMap r)) !(UserActorShare o a) -> Task Bool | iTask r & iTask o & iTask a & RWShared sds autoMove thisSection target pathFun user shipStatusShare userToActorShare | thisSection == target = return True | otherwise = get sectionUsersShare >>- \actorMap -> case sectionForUser user actorMap of Just roomCoord = get shipStatusShare >>- \statusMap -> get lockedExitsShare >>- \exitLocks -> get lockedHopsShare >>- \hopLocks -> get sharedGraph >>- \graph -> case pathFun thisSection target statusMap exitLocks hopLocks graph of Just (path=:[nextSection:_], _) = waitForTimer 1 >>| move roomCoord nextSection user >>| addLog user "" ("Has moved to Section " <+++ nextSection) >>| autoMove nextSection target pathFun user shipStatusShare userToActorShare _ = return False _ = return False // room updating // actor status opdating updActorStatus :: !User !(a -> a) !(UserActorShare o a) -> Task () | iTask a & iTask o updActorStatus user upd userToActorShare = get userToActorShare >>= \userActorMap -> case 'DM'.get user userActorMap of Just actor -> set ('DM'.put user {actor & actorStatus = upd actor.actorStatus} userActorMap) userToActorShare @! () Nothing -> return () sectionForUser :: !User !SectionUsersMap -> Maybe Coord3D sectionForUser u sectionUsersMap = listToMaybe [k \\ (k, us) <- 'DM'.toList sectionUsersMap, u` <- us | u` == u] actorsInSectionShare :: (UserActorShare o a) -> SDSLens Coord3D [Actor o a] [Actor o a] | iTask o & iTask a actorsInSectionShare userActorShare = sdsLens "actorsInSectionShare" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) Nothing (sectionUsersShare >*< userActorShare) where read :: Coord3D (SectionUsersMap, UserActorMap o a) -> MaybeError TaskException [Actor o a] read c3d (sectionUsersMap, userActorMap) = Ok [a \\ Just us <- ['DM'.get c3d sectionUsersMap], u <- us, Just a <- ['DM'.get u userActorMap]] write :: Coord3D (SectionUsersMap, UserActorMap o a) [Actor o a] -> MaybeError TaskException (Maybe (SectionUsersMap, UserActorMap o a)) write c3d (sectionUsersMap, userActorMap) actors = Ok (Just ('DM'.put c3d (map (\a -> a.userName) actors) sectionUsersMap, 'DM'.fromList [(a.userName, a) \\ a <- actors])) notify :: Coord3D (SectionUsersMap, UserActorMap o a) [Actor o a] -> SDSNotifyPred Coord3D notify c3d _ _ = \_ c3d` -> c3d == c3d` actorForUserShare :: (UserActorShare o a) -> FocusedUserActorShare o a | iTask o & iTask a actorForUserShare userActorShare = mapMaybeLens "actorForUserShare" userActorShare findUser :: !User !SectionUsersMap !(UserActorMap o a) -> Maybe (!Coord3D, !Actor o a) | iTask o & iTask a findUser usr sectionUsersMap userActorMap = 'DM'.get usr userActorMap >>= \a -> sectionForUser usr sectionUsersMap >>= \s -> return (s, a) // room status updating toggleDoor :: !Coord3D !Dir -> Task () toggleDoor roomNo=:(floorIdx, c2d) exit #! twinC2d = twin exit c2d #! focus1 = sdsFocus roomNo lockStatusForExit #! focus2 = sdsFocus (floorIdx, twinC2d) lockStatusForExit = get focus1 >>- \locks1 -> get focus2 >>- \locks2 -> set (newLocks exit locks1) focus1 >>| set (newLocks (opposite exit) locks2) focus2 @! () where newLocks :: !Dir ![Dir] -> [Dir] newLocks dir locks #! (lockedDirs, rest) = partition (\l -> l === dir) locks | isEmpty lockedDirs = [dir : rest] | otherwise = rest toggleHop :: !Coord3D !Coord3D -> Task () toggleHop fromRoom toRoom #! focus1 = sdsFocus fromRoom lockStatusForHop #! focus2 = sdsFocus toRoom lockStatusForHop = get focus1 >>- \locks1 -> get focus2 >>- \locks2 -> set (newLocks fromRoom locks1) focus1 >>| set (newLocks toRoom locks2) focus2 @! () where newLocks :: !Coord3D ![Coord3D] -> [Coord3D] newLocks c3d locks #! (lockedDirs, rest) = partition (\l -> l === c3d) locks | isEmpty lockedDirs = [c3d : rest] | otherwise = rest doorIsLocked :: !Coord3D !Dir !SectionExitLockMap -> Bool doorIsLocked roomNo exit lockMap = case 'DM'.get roomNo lockMap of Just locks -> isEmpty [l \\ l <- locks | l == exit] _ -> False // utility functions to find things located in the map findAllObjects :: !(SectionInventoryMap o) -> [(!Coord3D, !Object o)] | iTask o findAllObjects objectMap = [ (roomNo, object) \\ (roomNo, objects) <- 'DM'.toList objectMap , object <- 'DIS'.elems objects ] allSections :: !Maps2D -> [Section] allSections ms2d = [room \\ floor <- ms2d, layer <- floor.map2D, room <- layer] existsSection :: !Coord3D !Maps2D -> Bool existsSection (lvl, c2d) ms2d | lvl < length ms2d #! m2d = ms2d !! lvl | c2d.row < length m2d.map2D #! s = m2d.map2D !! c2d.row = c2d.col < length s | otherwise = False | otherwise = False pathToClosestObject :: !(Coord3D Coord3D (SectionStatusMap r) SectionExitLockMap Maps2D -> Maybe ([Coord3D], Distance)) !o !Coord3D !(SectionStatusMap r) !(SectionInventoryMap o) !SectionExitLockMap !Maps2D -> (!Int, !(!Coord3D, !Distance, !Maybe (![Coord3D], !Distance))) | iTask o & == o & iTask r pathToClosestObject sp kind actorLoc statusMap inventoryMap exitLocks ms2d #! spath = sortBy (\(_, i, _) (_, j, _) -> i < j) (filter (\((ol, _), _, _) -> ol >= 0) [case sp actorLoc objectLoc statusMap exitLocks ms2d of path=:(Just (_, dist)) -> (objectLoc, dist, path) _ -> ((-1, {col = -1, row = -1}), infinity, Nothing) \\ (objectLoc, found) <- findAllObjects inventoryMap | found.objType == kind ]) = case spath of [x=:(_, _, Just (path, _)) :_] -> (length spath, x) [] -> (-1, ((-1, {col = -1, row = -1}), -1, Nothing)) // returns: number of objects found, location of object, distance to object, shortest path to obejct smartPathToClosestObject :: !(Coord3D Coord3D (SectionStatusMap r) SectionExitLockMap SectionHopLockMap Graph -> Maybe ([Coord3D], Distance)) !o !Coord3D !Coord3D !(SectionStatusMap r) !(SectionInventoryMap o) !SectionExitLockMap !SectionHopLockMap !Graph -> (!Maybe (Object o), !Int, !Distance, !Int, !(!Coord3D, !Distance, !Maybe [Coord3D])) | iTask o & == o & iTask r smartPathToClosestObject spath objectKind actorLoc targetLoc statusMap inventoryMap exitLocks hopLocks graph #! foundObjects = [tpl \\ tpl=:(_, found) <- findAllObjects inventoryMap | found.objType == objectKind ] | isEmpty foundObjects = (Nothing, infinity, infinity, 0, ((-1, {col = -1, row = -1}), -1, Nothing)) #! pathsFound = sortBy (\(_, i, _, _) (_, j, _, _) -> i < j) (filter (\(_, d, _, (loc, dist, path)) -> isJust path) [ let (oPath, oDistance) = case spath actorLoc objectLoc statusMap exitLocks hopLocks graph of (Just (path, distance)) -> (Just path, distance) _ -> (Nothing, infinity) (tPath, tDistance) = case spath objectLoc targetLoc statusMap exitLocks hopLocks graph of (Just (path, distance)) -> (Just path, distance) _ -> (Nothing, infinity) totalPathDist = case (oPath, tPath) of (Just xs, Just ys) -> length xs + length ys _ -> infinity in (obj, oDistance + tDistance, totalPathDist, (objectLoc, oDistance, oPath)) \\ (objectLoc, obj) <- foundObjects | objectLoc /= targetLoc ]) = case pathsFound of [(obj, cost, totalDist, x=:(_, _, Just path)) :_] -> (Just obj, cost, totalDist, length pathsFound, x) [] -> (Nothing, infinity, infinity, -1, ((-1, {col = -1, row = -1}), -1, Nothing))