MapEnvironment.icl 31.9 KB
Newer Older
1 2 3 4 5 6
implementation module C2.Framework.MapEnvironment

import StdArray
import iTasks

import iTasks.UI.Definition
Bas Lijnse's avatar
Bas Lijnse committed
7 8 9
import iTasks.Internal.Tonic
import iTasks.Extensions.Admin.TonicAdmin
import iTasks.Extensions.DateTime
10
import qualified Data.Map as DM
Bas Lijnse's avatar
Bas Lijnse committed
11
from Data.Map import :: Map, instance Functor (Map k)
12
import Data.Map.GenJSON
13 14 15 16
import qualified Data.IntMap.Strict as DIS
from Data.IntMap.Strict import :: IntMap
import qualified Data.Heap as DH
from Data.Heap import :: Heap
17
import Data.GenLexOrd
18 19 20
from C2.Framework.Logging import addLog
import Data.List
import Data.Eq
Bas Lijnse's avatar
Bas Lijnse committed
21 22 23
import Data.Maybe
import Data.Functor
import Data.Either
24 25 26 27 28 29 30

import StdMisc

derive class iTask Map2D, Section, Borders, Border, Coord2D, Dir, MapAction

derive class iTask Actor, Object

31
// small utility functions
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73

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

74
maps2DShare :: SimpleSDSLens Maps2D
75 76
maps2DShare = sharedStore "maps2DShare" []

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
77 78
sharedGraph :: SDSLens () Graph ()
sharedGraph = sdsLens "sharedGraph" (const ()) (SDSRead read) (SDSWriteConst write) (SDSNotifyConst notify) Nothing maps2DShare
79 80 81 82 83
  where
  read _ m = Ok (maps2DToGraph m)

  write _ _ = Ok Nothing

Mart Lubbers's avatar
Mart Lubbers committed
84
  notify _ _  = const (const True)
85 86 87 88

sectionUsersShare :: SectionUsersShare
sectionUsersShare = sharedStore "sectionUsersShare" 'DM'.newMap

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
89
sectionForUserShare :: User -> SDSLens () (Maybe Coord3D) SectionUsersMap
90 91 92 93 94
sectionForUserShare user = mapRead (sectionForUser user) sectionUsersShare

focusedSectionUsersShare :: FocusedSectionUsersShare
focusedSectionUsersShare = mapLens "focusedSectionUsersShare" sectionUsersShare (Just [])

95
inventoryForUserSection :: !User !(FocusedSectionInventoryShare o) -> SimpleSDSSequence (IntMap (Object o)) | iTask o
Bas Lijnse's avatar
Bas Lijnse committed
96
inventoryForUserSection user inventoryForSectionShare = sdsSequence ("inventoryForUserSection" +++ toString user) id mkP2 (\_ _ -> Right mkr) (SDSWrite write1) (SDSWrite write2) (sectionForUserShare user) inventoryForSectionShare
97 98 99 100 101 102 103
  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)

104
lockedExitsShare :: SimpleSDSLens SectionExitLockMap
105 106
lockedExitsShare = sharedStore "lockedExitsShare" 'DM'.newMap

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
107
lockStatusForExit :: SDSLens Coord3D [Dir] [Dir]
108 109
lockStatusForExit = mapLens "lockStatusForExit" lockedExitsShare (Just [])

110
lockedHopsShare :: SimpleSDSLens SectionHopLockMap
111 112
lockedHopsShare = sharedStore "lockedHopsShare" 'DM'.newMap

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
113
lockStatusForHop :: SDSLens Coord3D [Coord3D] [Coord3D]
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
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]
248

249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332
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 ())

Bas Lijnse's avatar
Bas Lijnse committed
333
:: UITag :== [Int]
334 335 336 337 338 339 340 341 342 343 344

:: TaskUITree
  = Ed   UITag
  | Par  UITag [TaskUITree]
  | Step UITag [TaskUITree]

uiToRefs :: UI -> TaskUITree
uiToRefs (UI _ _ subs) = case recurse [] subs of
                           [x : _] -> x
                           _       -> Ed []
  where
Bas Lijnse's avatar
Bas Lijnse committed
345
  uiToRefs` :: [Int] (Int, UI) -> [TaskUITree]
346 347 348 349 350 351 352 353 354 355 356
  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))

Bas Lijnse's avatar
Bas Lijnse committed
357
getSubTree :: UI [Int] -> Maybe UI
358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394
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)



Mart Lubbers's avatar
Mart Lubbers committed
395
/*
396
modifyUI :: (TaskUITree -> TaskUILayout) -> Layout
Bas Lijnse's avatar
Bas Lijnse committed
397
modifyUI f = idLayout
398 399 400 401 402 403 404 405 406 407
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 []
Bas Lijnse's avatar
Bas Lijnse committed
408
*/
409 410 411 412 413 414 415 416

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
Mart Lubbers's avatar
Mart Lubbers committed
417
            -||- pickUpItems -||- dropItems) //<<@ ApplyLayout (idLayout modifyUI moveAroundUI)
418 419 420 421 422
  where
  walkAround :: Task ()
  walkAround
    =   watch (lockedExitsShare |*| roomNoForCurrentUserShare |*| maps2DShare)
    -|| viewDeck user shipStatusShare userToActorShare inventoryForAllSectionsShare
Bas Lijnse's avatar
Bas Lijnse committed
423 424 425 426
    >>* [ OnAction (Action "Go west") (moveTo W)
        , OnAction (Action "Go north") (moveTo N)
        , OnAction (Action "Go south") (moveTo S)
        , OnAction (Action "Go east") (moveTo E)
427 428 429 430 431 432
        ]

  changeDecks :: Task ()
  changeDecks
    =    watch (lockedHopsShare |*| roomNoForCurrentUserShare)
    -&&- enterChoiceWithShared "Change deck" [prettyPrintHops] nearbyHops
Bas Lijnse's avatar
Bas Lijnse committed
433
    >>*  [OnAction (Action "Change deck") changeDeck]
434 435 436 437 438

  pickUpItems :: Task ()
  pickUpItems
    =    watch roomNoForCurrentUserShare
    -&&- enterChoiceWithShared "Items nearby" [prettyPrintItems] (nearbyItemsShare inventoryForSectionShare)
Bas Lijnse's avatar
Bas Lijnse committed
439
    >>*  [OnAction (Action "Grab selected item") (withSelectedObject userToActorShare inventoryForSectionShare pickupObject)]
440 441 442 443 444

  dropItems :: Task ()
  dropItems
    =    watch roomNoForCurrentUserShare
    -&&- enterChoiceWithShared "Items in inventory" [prettyPrintItems] (inventoryShare userToActorShare)
Bas Lijnse's avatar
Bas Lijnse committed
445
    >>*  [OnAction (Action "Drop selected item") (withSelectedObject userToActorShare inventoryForSectionShare dropObject)]
446 447 448 449 450 451 452 453 454 455 456 457 458

  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

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
459
  nearbyHops :: SDSLens () [(Coord3D, Coord3D)] ()
460 461
  nearbyHops = toReadOnly (mapRead getHops (roomNoForCurrentUserShare |*| maps2DShare))

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
462
  roomNoForCurrentUserShare :: SDSLens () (Maybe Coord3D) ()
463 464
  roomNoForCurrentUserShare = toReadOnly (sectionForUserShare user)

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
465
  inventoryShare :: (UserActorShare o a) -> SDSLens () [Object o] () | iTask o & iTask a
466 467
  inventoryShare userToActorShare = toReadOnly (mapRead carriedObjects (sdsFocus user (actorForUserShare userToActorShare)))

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
468
  nearbyItemsShare :: (FocusedSectionInventoryShare o) -> SDSLens () [Object o] () | iTask o
469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
  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

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
517 518
sectionForSectionNumberShare :: SDSLens Coord3D (Maybe Section) Section
sectionForSectionNumberShare = sdsLens "sectionForSectionNumberShare" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) Nothing maps2DShare
519 520 521 522 523 524 525 526 527
  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
Mart Lubbers's avatar
Mart Lubbers committed
528
  notify c3d _ _ = \_ c3d` -> c3d == c3d`
529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588

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))
589
            !User !(Shared sds (SectionStatusMap r)) !(UserActorShare o a)
Haye Böhm's avatar
Fix CI  
Haye Böhm committed
590
         -> Task Bool | iTask r & iTask o & iTask a & RWShared sds
591 592 593 594 595 596 597 598 599 600 601 602
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:_], _)
Bas Lijnse's avatar
Bas Lijnse committed
603
                                                  =   waitForTimer 1
604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623
                                                  >>| 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]

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
624 625
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)
626 627 628 629 630 631 632 633 634
  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
Mart Lubbers's avatar
Mart Lubbers committed
635
  notify c3d _ _ = \_ c3d` -> c3d == c3d`
636

Bas Lijnse's avatar
Bas Lijnse committed
637
actorForUserShare :: (UserActorShare o a) -> FocusedUserActorShare o a | iTask o & iTask a
638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658
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
659
    #! (lockedDirs, rest) = partition (\l -> l === dir) locks
660 661 662 663 664 665 666 667 668 669 670 671 672 673
    | 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
674
    #! (lockedDirs, rest) = partition (\l -> l === c3d) locks
675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742
    | 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))