Commit 7395794f authored by Bas Lijnse's avatar Bas Lijnse

Fixed compile errors in C2 demo

parent 22edddb9
implementation module C2.Apps.ShipAdventure.Core
import iTasks.API.Extensions.SVG.SVGEditor
import Graphics.Scalable
import iTasks.Extensions.DateTime
import iTasks.Extensions.SVG.SVGEditor
//import Graphics.Scalable
import qualified Data.List as DL
import qualified Data.Map as DM
import qualified Data.IntMap.Strict as DIS
......@@ -16,13 +17,20 @@ import C2.Apps.ShipAdventure.Images
import C2.Apps.ShipAdventure.Types, C2.Framework.Logging, C2.Apps.ShipAdventure.Scripting
import C2.Apps.ShipAdventure.PathFinding, C2.Apps.ShipAdventure.Util
// the next function should be placed in the library somewhere
derive class iTask ChoiceGrid, ChoiceRow
mkTable :: [String] ![a] -> Table | gText{|*|} a
mkTable headers a = Table headers (map row a) Nothing
where
row :: !a -> [HtmlTag] | gText{|*|} a
row x = [Text cell \\ cell <- gText{|*|} AsRow (Just x)]
derive JSEncode Map2D, Network, Coord2D, Cable, CableType, Section, Borders, Border
derive JSEncode Device, SectionStatus, DeviceType, DeviceKind, User, Dir, Availability
derive JSEncode Actor, ActorStatus, ActorEnergy, ActorHealth, Object, ObjectType
derive JSEncode MapAction
derive JSEncode Maybe, Map, IntMap
// the next function should be placed in the library somewhere
mkTable :: [String] ![a] -> (ChoiceGrid,[Int]) | gText{|*|} a
mkTable header a = ({ChoiceGrid|header=header,rows=[{ChoiceRow|id=i,cells = row r} \\ r <- a & i <- [0..]]},[])
where
row :: !a -> [HtmlTag] | gText{|*|} a
row x = [Text cell \\ cell <- gText{|*|} AsRow (Just x)]
myTasks :: [Workflow]
myTasks = [ workflow "Walk around" "Enter map, walk around, follow instructions of commander" currentUserWalkAround
......@@ -106,9 +114,9 @@ giveInstructions =
) <<@ ArrangeVertical
)
where
ActionByHand = Action "By Hand" []
ActionSimulated = Action "Simulate" []
ActionScript = Action "Simulate with Script" []
ActionByHand = Action "By Hand"
ActionSimulated = Action "Simulate"
ActionScript = Action "Simulate with Script"
showAlarm :: !(!Coord3D, !SectionStatus) -> String
showAlarm (alarmLoc, detector) = "Section " <+++ alarmLoc <+++ " : " <+++ toString detector <+++ "!"
......@@ -126,9 +134,8 @@ giveInstructions =
(\_ -> mkTable ["Status"] ["Everything in order"])
)
)
= viewSharedInformation () [ViewAs view] (sharedGraph |*| myStatusMap |*| myInventoryMap |*| lockedExitsShare |*| lockedHopsShare) @! ()
= viewSharedInformation () [ViewUsing view grid] (sharedGraph |*| myStatusMap |*| myInventoryMap |*| lockedExitsShare |*| lockedHopsShare) @! ()
where
mkFireView :: !(!(!(!(!Graph, !MySectionStatusMap), !MySectionInventoryMap), !SectionExitLockMap), !SectionHopLockMap) -> Table
mkFireView ((((graph, statusMap), inventoryMap), exitLocks), hopLocks)
#! (_,_,eCost,nrExt, (extLoc, distExt, _)) = smartShipPathToClosestObject FireExtinguisher inventoryMap actorLoc alarmLoc statusMap exitLocks hopLocks graph
#! (_,_,bCost,nrFireBlankets, (blanketLoc, distFireBlankets, _)) = smartShipPathToClosestObject FireBlanket inventoryMap actorLoc alarmLoc statusMap exitLocks hopLocks graph
......@@ -138,13 +145,11 @@ giveInstructions =
, ("Closest Extinquisher (" <+++ nrExt <+++ " in reach)", roomToString extLoc, toString distExt, toString eCost)
, ("Closest FireBlanket (" <+++ nrFireBlankets <+++ " in reach)", roomToString blanketLoc, toString distFireBlankets, toString bCost)
]
mkSmokeView :: !(!(!(!(!Graph, !MySectionStatusMap), !MySectionInventoryMap), !SectionExitLockMap), !SectionHopLockMap) -> Table
mkSmokeView ((((graph, statusMap), inventoryMap), exitLocks), hopLocks)
#! distance = shipShortestPath actorLoc alarmLoc statusMap exitLocks hopLocks graph
= mkTable [ "Object Description", "Located in Section", "Distance from " <+++ actor.userName, "Route Length"]
[ ("Smoke Alarm", roomToString alarmLoc, spToDistString2 distance, spToDistString2 distance )
]
mkWaterView :: !(!(!(!(!Graph, !MySectionStatusMap), !MySectionInventoryMap), !SectionExitLockMap), !SectionHopLockMap) -> Table
mkWaterView ((((graph, statusMap), inventoryMap), exitLocks), hopLocks)
#! (_,_,pCost,nrPlugs, (plugLoc, distPlugs, _)) = smartShipPathToClosestObject Plug inventoryMap actorLoc alarmLoc statusMap exitLocks hopLocks graph
#! floodDist = shipShortestPath actorLoc alarmLoc statusMap exitLocks hopLocks graph
......@@ -175,7 +180,7 @@ handleAlarm (me, (alarmLoc, detector), (actorLoc, actor), priority)
= addTaskForUser title actor.userName Immediate (const taskToHandle)
>>* [ OnValue (ifValue isDone (\x -> viewInformation ("Task " <+++ title <+++ " succeeded, returning:") [] x @! ()))
, OnValue (ifValue isFailed (\x -> viewInformation ("Task " <+++ title <+++ " failed, returning:") [] x @! ()))
, OnAction (Action "Cancel task" []) (always (viewInformation "Canceled" [] ("Task " <+++ title <+++ " has been cancelled by you") @! ()))
, OnAction (Action "Cancel task") (always (viewInformation "Canceled" [] ("Task " <+++ title <+++ " has been cancelled by you") @! ()))
]
>>| return ()
where
......@@ -191,11 +196,11 @@ handleAlarm (me, (alarmLoc, detector), (actorLoc, actor), priority)
-> Task (MoveSt String)
taskToDo (alarmLoc, status) user shStatusMap shUserActor shInventoryMap
= viewSharedInformation ("Handle " <+++ toString status <+++ " in Section: " <+++ alarmLoc) [ViewAs todoTable] (sectionForUserShare user |*| myUserActorMap |*| shStatusMap |*| shInventoryMap |*| lockedExitsShare |*| lockedHopsShare |*| sharedGraph)
>>* [ OnAction (Action "Use Fire Extinguisher" []) (ifValue (mayUseExtinguisher status) (withUser useExtinquisher))
, OnAction (Action "Use FireBlanket" []) (ifValue (mayUseFireBlanket status) (withUser useFireBlanket))
, OnAction (Action "Use Plug" []) (ifValue (mayUsePlug status) (withUser usePlug))
, OnAction (Action "Smoke Investigated" []) (ifValue (mayDetectedSmoke status) (withUser smokeReport))
, OnAction (Action "I give up" []) (hasValue (withUser giveUp))
>>* [ OnAction (Action "Use Fire Extinguisher") (ifValue (mayUseExtinguisher status) (withUser useExtinquisher))
, OnAction (Action "Use FireBlanket") (ifValue (mayUseFireBlanket status) (withUser useFireBlanket))
, OnAction (Action "Use Plug") (ifValue (mayUsePlug status) (withUser usePlug))
, OnAction (Action "Smoke Investigated") (ifValue (mayDetectedSmoke status) (withUser smokeReport))
, OnAction (Action "I give up") (hasValue (withUser giveUp))
]
where
todoTable ((((((Just curSectionNo, userActorMap), statusMap), inventoryMap), exitLocks), hopLocks), curMap)
......@@ -346,7 +351,7 @@ simulateHandlingWithObject startLoc object objectLoc alarmLoc status user
>>| autoMove startLoc objectLoc shipShortestPath user myStatusMap myUserActorMap
>>= \objectReached -> if objectReached (pickupObject objectLoc object user myUserActorMap inventoryInSectionShare
>>| autoMove objectLoc alarmLoc shipShortestPath user myStatusMap myUserActorMap
>>= \targetReached -> if targetReached (waitForTimer {Time | hour = 0, min = 0, sec = 1}
>>= \targetReached -> if targetReached (waitForTimer 1
>>| useObject alarmLoc object user myUserActorMap inventoryInSectionShare
>>= \used -> if used (setAlarm user (alarmLoc, NormalStatus) myStatusMap @! True)
(return False))
......
implementation module C2.Apps.ShipAdventure.Editor
import iTasks
import iTasks.API.Extensions.SVG.SVGEditor
import iTasks._Framework.IWorld
import iTasks.Extensions.SVG.SVGEditor
import iTasks.Extensions.JSONFile
import iTasks.Internal.IWorld
import iTasks.UI.Layout, iTasks.UI.Definition
import System.Directory, System.File
import System.Directory, System.File, System.FilePath
import Text
import StdArray, StdFile
import StdMisc
......@@ -14,6 +15,11 @@ import C2.Apps.ShipAdventure.Images
import qualified Data.Map as DM
import qualified Data.IntMap.Strict as DIS
import qualified Data.Set as DS
from Graphics.Scalable import normalFontDef, above, class margin(..), instance margin (Span,Span), px
from Graphics.Scalable import :: ImageOffset, :: Host(..)
derive JSEncode Map2D, Section, Maybe, Coord2D, Borders, Border, IntMap, Device, DeviceType, DeviceKind, CableType, Map
derive JSEncode Network, Cable, Object, ObjectType, MapAction, SectionStatus, Dir
shipEditorTabs :: Task ()
shipEditorTabs = allTasks [ viewLayout <<@ Title "View Ship"
......@@ -23,7 +29,7 @@ shipEditorTabs = allTasks [ viewLayout <<@ Title "View Ship"
, manageCables <<@ Title "Manage Cables"
, exportShip <<@ Title "Export"
, importShip <<@ Title "Import"
] <<@ ArrangeWithTabs @! ()
] <<@ ArrangeWithTabs False @! ()
exportShip :: Task ()
exportShip
......@@ -37,8 +43,8 @@ importShip :: Task ()
importShip
= getMapNames
>>= \mapNames -> enterChoice "Select file" [] mapNames
>>* [ OnAction (Action "Import" []) (hasValue doImport)
, OnAction (Action "Refresh list" []) (always importShip)
>>* [ OnAction (Action "Import") (hasValue doImport)
, OnAction (Action "Refresh list") (always importShip)
]
where
doImport :: !String -> Task ()
......@@ -49,49 +55,39 @@ importShip
>>| importShip @! ()
getMap :: !String -> Task (!(!(!(!MySectionInventoryMap, !Network), !IntMap Cable), !IntMap Device), !Maps2D)
getMap mapName = mkInstantTask (const (getMap` mapName))
getMap mapName = get applicationDirectory >>- \curDir -> accWorldError (getMap` mapName curDir) id
where
getMap` :: !String !*IWorld -> *(!MaybeError (Dynamic, String) (!(!(!(!MySectionInventoryMap, !Network), !IntMap Cable), !IntMap Device), !Maps2D), !*IWorld)
getMap` mapName iworld
# (dir, iworld) = getCurrDir iworld
# (mjson, world) = readFile (dir </> (mapName +++ ".map")) iworld.world
# iworld = {iworld & world = world}
getMap` :: !String !String !*World -> *(!MaybeError String (!(!(!(!MySectionInventoryMap, !Network), !IntMap Cable), !IntMap Device), !Maps2D), !*World)
getMap` mapName dir world
# (mjson, world) = readFile (dir </> (mapName +++ ".map")) world
= case mjson of
Ok json -> case fromJSON (fromString json) of
Just gg -> (Ok gg, iworld)
_ -> err ("Failed to deserialize JSON: " +++ json) iworld
Error msg -> err (toString msg) iworld
Just gg -> (Ok gg, world)
_ -> err ("Failed to deserialize JSON: " +++ json) world
Error msg -> err (toString msg) world
where
err msg iworld
err msg world
# msg = "Failed to load map file " +++ mapName
= (Error (dynamic msg, msg), iworld)
= (Error msg, world)
getMapNames :: Task [String]
getMapNames = mkInstantTask (const getMapNames)
getMapNames = get applicationDirectory >>- \curDir -> accWorldError (getMapNames curDir) id
where
getMapNames :: !*IWorld -> *(!MaybeError (Dynamic, String) [String], !*IWorld)
getMapNames iworld
# (dir, iworld) = getCurrDir iworld
# (mfs, world) = readDirectory dir iworld.world
# iworld = {iworld & world = world}
getMapNames :: !String !*World -> *(!MaybeError String [String], !*World)
getMapNames dir world
# (mfs, world) = readDirectory dir world
= case mfs of
Ok fs
= (Ok (map dropExtension (filter (\x -> noDots x && onlyMaps x) fs)), iworld)
= (Ok (map dropExtension (filter (\x -> noDots x && onlyMaps x) fs)), world)
Error _
# msg = "Failed to read Tonic directory"
= (Error (dynamic msg, msg), iworld)
= (Error msg, world)
onlyMaps :: !String -> Bool
onlyMaps str = endsWith ".map" str
noDots :: !String -> Bool
noDots str = not (str.[0] == '.')
getCurrDir :: !*IWorld -> *(!String, !*IWorld)
getCurrDir iworld
# (server, iworld) = iworld!server
= (server.paths.appDirectory, iworld)
mapFont p = normalFontDef "Verdana" p
mapTitleFontSize =: 10.0
......@@ -197,7 +193,7 @@ where
imageEditor = fromSVGEditor
{ initView = fst
, renderImage = \((_, act), ((inventoryMap, network), allDevices)) (ms2d, _) _ ->
above [] [] [margin (px 5.0, px zero) (editLayoutImage act allDevices network inventoryMap idx m2d) \\ m2d <- ms2d & idx <- [0..]] Nothing
above [] [] [margin (px 5.0, px zero) (editLayoutImage act allDevices network inventoryMap idx m2d) \\ m2d <- ms2d & idx <- [0..]] NoHost
, updView = \m v -> fst m
, updModel = \(_,data) newClSt -> (newClSt,data)
}
......@@ -209,12 +205,14 @@ editLayout
, updateSharedInformation (Title "Edit map") [UpdateAs toMapActionForm fromMapActionForm] sharedEditShip @! ()
, (watch maps2DShare
-&&- enterChoiceWithShared (Title "Quick borders") [] (mapRead (\ship -> [mapId \\ {Map2D | mapId} <- ship]) maps2DShare)
>>* [ OnAction (Action "Add outer borders" []) (hasValue (uncurry (editOuterBorders Wall)))
, OnAction (Action "Remove outer borders" []) (hasValue (uncurry (editOuterBorders Open)))
>>* [ OnAction (Action "Add outer borders" ) (hasValue (uncurry (editOuterBorders Wall)))
, OnAction (Action "Remove outer borders" ) (hasValue (uncurry (editOuterBorders Open)))
]
) @! ()
] <<@ ApplyLayout layout @! ()
where
layout = idLayout
/*
layout = sequenceLayouts
[ insertSubAt [1] (ui UIContainer) // Group the 'tool' tasks
, moveSubAt[2] [1,0]
......@@ -222,6 +220,7 @@ where
, moveSubAt[2] [1,2]
, arrangeWithSideBar 1 LeftSide 350 False //Move the 'tool' tasks to the side
]
*/
editOuterBorders :: !Border !Maps2D !MapID -> Task ()
editOuterBorders border ship mapID = case getMap2DIndex mapID ship of
......@@ -280,6 +279,8 @@ editSectionContents
_ = viewInformation (Title "Please select section") [] "Please select section" @! ()
)
layout = idLayout
/*
layout = sequenceLayouts
[insertSubAt [1] (uia UIContainer (directionAttr Horizontal))
,moveSubAt [2] [1,0]
......@@ -287,6 +288,7 @@ editSectionContents
,moveSubAt [2] [1,2]
,arrangeWithSideBar 1 BottomSide 250 False
]
*/
mkDesc :: !Int !Coord2D !String -> String
mkDesc mid c2d str = str +++ " in section " +++ toString c2d +++ " on deck " +++ toString mid
......@@ -310,13 +312,13 @@ editSectionContents
, doorDepth :: !Real // the depth of drawn doors
}
:: EditForm =
{ map2DIndex :: !Hidden Maps2DIndex // the index position of this map within Maps2D
, mapId :: !Display MapID // the identification of the map containing this section
{ map2DIndex :: !Maps2DIndex // the index position of this map within Maps2D
, mapId :: !MapID // the identification of the map containing this section
, newMapId :: !MapID // new identification of this map
, section :: !Display Coord2D // the unique identification of the section
, section :: !Coord2D // the unique identification of the section
, sectionName :: !Maybe String // descriptive name, need not be unique
, up :: !VisualizationHint Bool // you can go down (except bottom floor)
, down :: !VisualizationHint Bool // you can go up (except top floor)
, up :: !Bool // you can go down (except bottom floor)
, down :: !Bool // you can go up (except top floor)
, outline :: !Maybe Shape2D
}
derive class iTask EditMaps, EditForm
......@@ -427,35 +429,35 @@ toMapActionForm (maps, _) = toMapActionForm (maps, FocusOnSection (0, zero))
editFormFromSection maps (idx, c2d) {Section | sectionName, hops}
# mapID = fromJust (getMapID idx maps)
# bottomFloor = length maps - 1
= { EditForm | map2DIndex = Hidden idx
, mapId = Display mapID
= { EditForm | map2DIndex = idx
, mapId = mapID
, newMapId = mapID
, section = Display c2d
, section = c2d
, sectionName = if (sectionName == "") Nothing (Just sectionName)
, up = if (idx == 0) VHHidden VHEditable (isMember (idx-1, c2d) hops)
, down = if (idx == bottomFloor) VHHidden VHEditable (isMember (idx+1, c2d) hops)
, up = (isMember (idx-1, c2d) hops)
, down = (isMember (idx+1, c2d) hops)
, outline = Nothing
}
defaultEditForm = { EditForm | map2DIndex = Hidden 0
, mapId = Display "ERROR"
defaultEditForm = { EditForm | map2DIndex = 0
, mapId = "ERROR"
, newMapId = "ERROR"
, section = Display {col = 0, row = 0}
, section = {col = 0, row = 0}
, sectionName = Nothing
, up = VHHidden False
, down = VHHidden False
, up = False
, down = False
, outline = Nothing
}
fromMapActionForm :: !(!Maps2D, !MapAction SectionStatus) !EditForm -> (!Maps2D, !MapAction SectionStatus)
//fromMapActionForm m v = m
fromMapActionForm (maps,edit) sectionE=:{EditForm | map2DIndex = Hidden idx,section=Display c,newMapId,up,down}
fromMapActionForm (maps,edit) sectionE=:{EditForm | map2DIndex = idx,section=c,newMapId,up,down}
= (updMap2D idx ((updateMapID newMapId) o (updSection c (updateSection (idx,c) sectionE))) (updHops (idx,c) up down maps),updateSelection (idx,c) edit)
where
new_hops = if (fromVisualizationHint up) [(idx-1,c)] [] ++ if (fromVisualizationHint down) [(idx+1,c)] []
new_hops = if up [(idx-1,c)] [] ++ if down [(idx+1,c)] []
updHops :: !Coord3D !(VisualizationHint Bool) !(VisualizationHint Bool) !Maps2D -> Maps2D
updHops :: !Coord3D !Bool !Bool !Maps2D -> Maps2D
updHops source=:(idx,c) up down maps
= case getMap2D idx maps of
Just map = case getSection c map of
......
......@@ -3,11 +3,21 @@ implementation module C2.Apps.ShipAdventure.Images
import C2.Framework.MapEnvironment
import C2.Apps.ShipAdventure.Core
import C2.Apps.ShipAdventure.Types
import Graphics.Scalable
import qualified Graphics.Scalable as GS
from Graphics.Scalable import <@<, class tuneImage
from Graphics.Scalable import px, rect, normalFontDef, overlay, above, text, scale, beside, empty, collage, line, xline, yline, polygon
from Graphics.Scalable import class toSVGColor(..), class margin(..), class *.(..), instance toSVGColor String
from Graphics.Scalable import instance tuneImage OnClickAttr, instance tuneImage FillAttr, instance tuneImage OpacityAttr
from Graphics.Scalable import instance tuneImage StrokeAttr, instance tuneImage DashAttr, instance tuneImage MaskAttr, instance tuneImage StrokeWidthAttr
from Graphics.Scalable import instance margin (Span,Span), instance margin (Span,Span,Span), instance *. Span, instance zero Span
from Graphics.Scalable import :: Span, :: FontDef, :: DashAttr(..), :: StrokeAttr(..), :: FillAttr(..), :: OnClickAttr(..), :: OpacityAttr(..), :: MaskAttr(..)
from Graphics.Scalable import :: StrokeWidthAttr(..), :: Host(..), :: ImageOffset, :: XYAlign(..), :: XAlign(..), :: YAlign(..), :: Slash(..), :: Markers
import qualified Data.IntMap.Strict as DIS
import qualified Data.Map as DM
import qualified Data.Set as DS
import qualified Data.List as DL
import Data.Maybe
derive class iTask RenderMode
......@@ -23,13 +33,13 @@ mapTitleImage idx hilite size2D=:(w, _) mapId
= margin (px zero, px zero, px (0.5 * mapTitleFontSize))
(overlay [(AtMiddleX, AtMiddleY)] []
[text (mapFont mapTitleFontSize) mapId]
(Just (rect (px w) (px (2.0 * mapTitleFontSize)) <@< {fill = if (hiliteThisMap hilite idx) hiliteSectionBackgroundColor (toSVGColor "white")})))
(Host (rect (px w) (px (2.0 * mapTitleFontSize)) <@< {fill = if (hiliteThisMap hilite idx) hiliteSectionBackgroundColor (toSVGColor "white")})))
// making an image from the map ...
maps2DImage :: !(Set Coord3D) !(MapAction SectionStatus) !RenderMode !Maps2D !SectionExitLockMap !SectionHopLockMap !MySectionInventoryMap !MySectionStatusMap !SectionUsersMap !(UserActorMap ObjectType ActorStatus) !(IntMap Device) !Network !*TagSource
-> Image (Maps2D, MapAction SectionStatus)
maps2DImage disabledSections act mngmnt ms2d exitLocks hopLocks inventoryMap statusMap sectionUsersMap userActorMap allDevices network tsrc
= above [] [] ('DL'.strictTRMap ((margin (px 5.0, px zero)) o (map2DImage disabledSections act mngmnt exitLocks hopLocks inventoryMap statusMap sectionUsersMap userActorMap allDevices network)) (zip2 [0..] ms2d)) Nothing
= above [] [] ('DL'.strictTRMap ((margin (px 5.0, px zero)) o (map2DImage disabledSections act mngmnt exitLocks hopLocks inventoryMap statusMap sectionUsersMap userActorMap allDevices network)) (zip2 [0..] ms2d)) NoHost
map2DImage :: !(Set Coord3D) !(MapAction SectionStatus) !RenderMode !SectionExitLockMap !SectionHopLockMap !MySectionInventoryMap !MySectionStatusMap !SectionUsersMap !(UserActorMap ObjectType ActorStatus) !(IntMap Device) !Network !(!Maps2DIndex, !Map2D)
-> Image (Maps2D, MapAction SectionStatus)
......@@ -37,15 +47,15 @@ map2DImage disabledSections act mngmnt exitLocks hopLocks inventoryMap statusMap
#! titleImg = mapTitleImage floorIdx (hilite act) size2D (toString mapId)
#! sectionsImg = sectionsImage disabledSections act mngmnt exitLocks hopLocks inventoryMap statusMap sectionUsersMap userActorMap allDevices network doors2D size2D floorIdx map2D
#! lowerImg = mask sectionsImg size2D shape2D
= above [] [] [titleImg, lowerImg] Nothing
= above [] [] [titleImg, lowerImg] NoHost
mask :: !(Image m) !Size2D !(Maybe Shape2D) -> Image m
mask image _ Nothing
= image
mask image (w,h) (Just shape)
#! shipshape = polygon Nothing [(px x, px y) \\ (x, y) <- shape]
#! maskshape = overlay [] [] [shipshape <@< {fill = toSVGColor "white"} <@< {stroke = toSVGColor "white"}] (Just (rect (px w) (px h)))
= overlay [] [] [image, shipshape <@< {fill = toSVGColor "none"} <@< {stroke = toSVGColor "black"}] Nothing <@< {MaskAttr | mask = maskshape}
#! maskshape = overlay [] [] [shipshape <@< {fill = toSVGColor "white"} <@< {stroke = toSVGColor "white"}] (Host (rect (px w) (px h)))
= overlay [] [] [image, shipshape <@< {fill = toSVGColor "none"} <@< {stroke = toSVGColor "black"}] NoHost <@< {MaskAttr | mask = maskshape}
sectionsImage :: !(Set Coord3D) !(MapAction SectionStatus) !RenderMode !SectionExitLockMap !SectionHopLockMap !MySectionInventoryMap !MySectionStatusMap !SectionUsersMap !(UserActorMap ObjectType ActorStatus) !(IntMap Device) !Network !Size2D !Size2D !Maps2DIndex ![[Section]]
......@@ -76,7 +86,7 @@ sectionsImage` mkSectionImage floorIdx (mwidth, mheight) sections=:[cols : _]
[ mkSectionImage dx dy cell floorIdx rowIdx colIdx
\\ (rowIdx, row) <- zip2 row_indices sections, (colIdx, cell) <- zip2 col_indices row
]
(Just (empty (px mwidth) (px mheight)))
(Host (empty (px mwidth) (px mheight)))
sectionsImage` _ _ _ _ = text (mapFont mapTitleFontSize) "No sections defined"
sectionImage :: !(Set Coord3D) !(Maybe EditHilite) !RenderMode !Bool !SectionExitLockMap !SectionHopLockMap !MyInventory !SectionStatus !MyActors !(IntMap Device) !Network !Size2D !Size2D !Section !Int !Int !Int
......@@ -90,13 +100,13 @@ sectionImage disabledSections hilite mngmnt zoomed exitLocks hopLocks inventoryM
!(Image (Maps2D, MapAction SectionStatus)) !(Image (Maps2D, MapAction SectionStatus)) !(Image (Maps2D, MapAction SectionStatus))
-> Image (Maps2D, MapAction SectionStatus)
mkRest hilite mngmnt exitLocks statusMap actorMap (swidth, sheight) {Section | borders={Borders | n, e, s, w},hops} canCloseDoors c3d inventory devices multiplier inventoryBadges deviceBadges cableBadges upDownExits hdoor vdoor hwall vwall
#! actorBadges = above (repeat AtMiddleX) [] ('DL'.strictTRMap (scale multiplier multiplier o mkActorBadge) actorMap) Nothing
#! actorBadges = above (repeat AtMiddleX) [] ('DL'.strictTRMap (scale multiplier multiplier o mkActorBadge) actorMap) NoHost
#! statusBadges = above (repeat AtLeft) []
[ mkStatusBadges statusMap c3d mngmnt multiplier [HasSmallFire, HasMediumFire, HasBigFire]
, mkStatusBadges statusMap c3d mngmnt multiplier [HasSmoke]
, mkStatusBadges statusMap c3d mngmnt multiplier [HasSomeWater, IsFlooded]
]
Nothing
NoHost
#! pxswidth = px swidth
#! pxsheight = px sheight
#! host = rect pxswidth pxsheight <@< {onclick = onClick (FocusOnSection c3d), local = False}
......@@ -108,7 +118,7 @@ sectionImage disabledSections hilite mngmnt zoomed exitLocks hopLocks inventoryM
(overlay (repeat (AtMiddleX, AtMiddleY)) [] [ host
, line Nothing Slash pxswidth pxsheight <@< {stroke = toSVGColor "red" }
, line Nothing Backslash pxswidth pxsheight <@< {stroke = toSVGColor "red" }
] Nothing)
] NoHost)
host
= overlay [ (AtMiddleX, AtTop), (AtRight, AtMiddleY), (AtMiddleX, AtBottom), (AtLeft, AtMiddleY) // Walls
, (AtLeft, AtTop), (AtRight, AtTop), (AtLeft, AtBottom), (AtRight, AtBottom) // Badges
......@@ -117,23 +127,23 @@ sectionImage disabledSections hilite mngmnt zoomed exitLocks hopLocks inventoryM
, (px 3.0, px 3.0), (px -3.0, px 3.0), (px 3.0, px -3.0), (px -6.0, px -3.0) // Badges
]
[ case n of Wall = hwall
Door = above (repeat AtMiddleX) [] [hwall, doorClick canCloseDoors c3d N (hdoor <@< doorFill exitLocks c3d N)] Nothing
Door = above (repeat AtMiddleX) [] [hwall, doorClick canCloseDoors c3d N (hdoor <@< doorFill exitLocks c3d N)] NoHost
Open = empty zero zero
, case e of Wall = vwall
Door = beside (repeat AtMiddleY) [] [doorClick canCloseDoors c3d E (vdoor <@< doorFill exitLocks c3d E), vwall] Nothing
Door = beside (repeat AtMiddleY) [] [doorClick canCloseDoors c3d E (vdoor <@< doorFill exitLocks c3d E), vwall] NoHost
Open = empty zero zero
, case s of Wall = hwall
Door = above (repeat AtMiddleX) [] [doorClick canCloseDoors c3d S (hdoor <@< doorFill exitLocks c3d S), hwall] Nothing
Door = above (repeat AtMiddleX) [] [doorClick canCloseDoors c3d S (hdoor <@< doorFill exitLocks c3d S), hwall] NoHost
Open = empty zero zero
, case w of Wall = vwall
Door = beside (repeat AtMiddleY) [] [vwall, doorClick canCloseDoors c3d W (vdoor <@< doorFill exitLocks c3d W)] Nothing
Door = beside (repeat AtMiddleY) [] [vwall, doorClick canCloseDoors c3d W (vdoor <@< doorFill exitLocks c3d W)] NoHost
Open = empty zero zero
, statusBadges, actorBadges, inventoryBadges, upDownExits
]
(Just host)
(Host host)
where
mkStatusBadges :: !SectionStatus !Coord3D !RenderMode !Real ![SectionStatus] -> Image (a, MapAction SectionStatus)
mkStatusBadges statusMap c3d mngmnt multiplier xs = beside (repeat AtMiddleY) [] ('DL'.reverseTR ('DL'.strictFoldl (mkStatusBadge statusMap c3d mngmnt multiplier) [] xs)) Nothing
mkStatusBadges statusMap c3d mngmnt multiplier xs = beside (repeat AtMiddleY) [] ('DL'.reverseTR ('DL'.strictFoldl (mkStatusBadge statusMap c3d mngmnt multiplier) [] xs)) NoHost
doorFill :: !SectionExitLockMap !Coord3D !Dir -> FillAttr a
doorFill exitLocks c3d dir
......@@ -158,14 +168,14 @@ sectionImage` f mngmnt zoomed hopLocks inventoryMap allDevices network (doorw, d
#! deviceBadges = 'DL'.strictTRMap (drawDevice c3d multiplier) devices
#! allBadges = inventoryBadges ++ deviceBadges
#! inventoryBadges = if (length allBadges > 0)
(beside (repeat AtMiddleY) [] allBadges Nothing)
(beside (repeat AtMiddleY) [] allBadges NoHost)
(empty zero zero)
#! cables = cablesForSection c3d network
#! cableBadges = if (length cables > 0)
(above (repeat AtMiddleX) [] ('DL'.strictTRMap mkCable cables) Nothing)
(above (repeat AtMiddleX) [] ('DL'.strictTRMap mkCable cables) NoHost)
(empty zero zero)
#! canCloseDoors = mngmnt === KitchenMode || mngmnt === DOffMode
#! upDownExits = beside [] [(px -3.0,zero)] ('DL'.strictTRMap (drawHop c3d hopLocks multiplier) hops) Nothing
#! upDownExits = beside [] [(px -3.0,zero)] ('DL'.strictTRMap (drawHop c3d hopLocks multiplier) hops) NoHost
#! hdoor = rect (px doorw) (px doord)
#! vdoor = rect (px doord) (px doorw)
#! hwall = xline Nothing (px swidth)
......@@ -184,7 +194,7 @@ sectionImage` f mngmnt zoomed hopLocks inventoryMap allDevices network (doorw, d
mkCable :: !Cable -> Image a
mkCable cable
#! linePiece = xline Nothing (px 4.0)
= beside (repeat AtMiddleY) [] [linePiece, text (mapFont mapTitleFontSize) (cable.Cable.description % (0, 1)), linePiece] Nothing
= beside (repeat AtMiddleY) [] [linePiece, text (mapFont mapTitleFontSize) (cable.Cable.description % (0, 1)), linePiece] NoHost
mkUpDown :: !Coord3D !Coord3D !SectionHopLockMap -> Image a
mkUpDown cur=:(curFloor, _) next=:(nextFloor, _) hopLocks
......@@ -192,7 +202,7 @@ mkUpDown cur=:(curFloor, _) next=:(nextFloor, _) hopLocks
Just xs -> 'DL'.elem next xs
_ -> False
#! goesUp = curFloor > nextFloor
= beside (repeat AtBottom) [] ('DL'.strictTRMap (\n -> rect (px 3.0) ((px 3.0) *. n)) (if goesUp [1,2,3] [3,2,1])) Nothing <@< { opacity = if l 0.3 1.0 }
= beside (repeat AtBottom) [] ('DL'.strictTRMap (\n -> rect (px 3.0) ((px 3.0) *. n)) (if goesUp [1,2,3] [3,2,1])) NoHost <@< { opacity = if l 0.3 1.0 }
mkStatusBadge :: !SectionStatus Coord3D !RenderMode !Real ![Image (a, MapAction SectionStatus)] !SectionStatus
-> [Image (a, MapAction SectionStatus)]
......@@ -221,9 +231,9 @@ mkActorBadge {actorStatus = {occupied}, userName, carrying}
#! actorBadge = mkActorBadgeBackground occupied
#! userStr = toString userName
#! userInitial = text myFontDef (userStr % (0,0)) <@< { fill = toSVGColor "white" }
#! actorBadge = overlay [(AtMiddleX, AtMiddleY)] [] [userInitial] (Just actorBadge)
#! actorBadge = overlay [(AtMiddleX, AtMiddleY)] [] [userInitial] (Host actorBadge)
#! inventory = 'DL'.strictTRMap (\i -> mkInventoryBadge False True (toString i % (0, 1))) carrying
= above (repeat AtMiddleX) [] [actorBadge : inventory] Nothing