Commit f3926d01 authored by Bas Lijnse's avatar Bas Lijnse

Merge branch...

Merge branch '224-older-applications-are-not-working-with-the-new-api-incidone-shipadventure' into 'master'

Resolve "Older applications are not working with the new API (Incidone, ShipAdventure)"

Closes #224

See merge request !160
parents 815c8f7e 5578633c
Pipeline #12436 passed with stage
in 2 minutes and 36 seconds
test: test:
before_script: before_script:
- install_clean.sh bundle-complete && apt-get update -qq && apt-get install -y -qq build-essential - install_clean.sh bundle-complete && apt-get update -qq && apt-get install -y -qq build-essential libsqlite3-dev libmariadbclient-dev-compat
image: "camilstaps/clean:nightly" image: "camilstaps/clean:nightly"
script: script:
- bash Tests/ci-tests.bash - bash Tests/ci-tests.bash
...@@ -120,7 +120,7 @@ manageIncidentWeather incidentNo ...@@ -120,7 +120,7 @@ manageIncidentWeather incidentNo
where where
weather = sdsFocus incidentNo incidentWeather weather = sdsFocus incidentNo incidentWeather
log = logIncidentWeatherUpdated incidentNo log = logIncidentWeatherUpdated incidentNo
viewWebWeather widgets = viewInformation (Title "Web weather info") [] (RawText widgets) viewWebWeather widgets = viewInformation (Title "Web weather info") [] (Html widgets)
manageIncidentLog :: IncidentNo -> Task () manageIncidentLog :: IncidentNo -> Task ()
manageIncidentLog incidentNo manageIncidentLog incidentNo
......
...@@ -57,7 +57,7 @@ doAuthenticated task ...@@ -57,7 +57,7 @@ doAuthenticated task
= ( enterCredentials = ( enterCredentials
>>* [OnAction (Action "Login") >>* [OnAction (Action "Login")
(hasValue (\cred -> verifyCredentials cred >>- executeTask task)) (hasValue (\cred -> verifyCredentials cred >>- executeTask task))
] ) <<@ ApplyLayout (beforeStep (sequenceLayouts (setUIAttributes (titleAttr "Login")) frameCompact)) //Compact layout before login, full screen afterwards ] ) <<@ ApplyLayout (beforeStep (sequenceLayouts [setUIAttributes (titleAttr "Login"), frameCompact])) //Compact layout before login, full screen afterwards
where where
enterCredentials :: Task Credentials enterCredentials :: Task Credentials
enterCredentials enterCredentials
...@@ -90,7 +90,7 @@ where ...@@ -90,7 +90,7 @@ where
workOnTasks = doIndependent tasks <<@ ArrangeWithTabs True workOnTasks = doIndependent tasks <<@ ArrangeWithTabs True
layoutControlDash = foldl1 sequenceLayouts layoutControlDash = sequenceLayouts
[moveSubUIs (SelectByPath [0,0]) [] 1 [moveSubUIs (SelectByPath [0,0]) [] 1
,moveSubUIs (SelectByPath [0,0]) [] 2 ,moveSubUIs (SelectByPath [0,0]) [] 2
,removeSubUIs (SelectByPath [0]) ,removeSubUIs (SelectByPath [0])
......
Version: 1.4
Global
ProjectRoot: .
Target: iTasks
Exec: {Project}/IncidoneCCC.exe
CodeGen
CheckStacks: False
CheckIndexes: True
Application
HeapSize: 209715200
StackSize: 1512000
ExtraMemory: 8192
IntialHeapSize: 204800
HeapSizeMultiplier: 4096
ShowExecutionTime: False
ShowGC: False
ShowStackSize: False
MarkingCollector: False
DisableRTSFlags: False
StandardRuntimeEnv: True
Profile
Memory: False
MemoryMinimumHeapSize: 0
Time: False
Stack: False
Dynamics: True
GenericFusion: False
DescExL: False
Output
Output: ShowConstructors
Font: Monaco
FontSize: 9
WriteStdErr: False
Link
LinkMethod: Static
GenerateRelocations: False
GenerateSymbolTable: False
GenerateLinkMap: False
LinkResources: False
ResourceSource:
GenerateDLL: False
ExportedNames:
Paths
Path: {Project}
Precompile:
Postlink:
MainModule
Name: IncidoneCCC
Dir: {Project}
Compiler
NeverMemoryProfile: False
NeverTimeProfile: False
StrictnessAnalysis: True
ListTypes: StrictExportTypes
ListAttributes: True
Warnings: True
Verbose: True
ReadableABC: False
ReuseUniqueNodes: True
Fusion: False
...@@ -15,8 +15,11 @@ import C2.Apps.ShipAdventure.Images ...@@ -15,8 +15,11 @@ import C2.Apps.ShipAdventure.Images
import qualified Data.Map as DM import qualified Data.Map as DM
import qualified Data.IntMap.Strict as DIS import qualified Data.IntMap.Strict as DIS
import qualified Data.Set as DS 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(..) import Graphics.Scalable.Image => qualified grid
import Graphics.Scalable.Types
//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 Map2D, Section, Maybe, Coord2D, Borders, Border, IntMap, Device, DeviceType, DeviceKind, CableType, Map
derive JSEncode Network, Cable, Object, ObjectType, MapAction, SectionStatus, Dir derive JSEncode Network, Cable, Object, ObjectType, MapAction, SectionStatus, Dir
...@@ -193,7 +196,8 @@ where ...@@ -193,7 +196,8 @@ where
imageEditor = fromSVGEditor imageEditor = fromSVGEditor
{ initView = fst { initView = fst
, renderImage = \((_, act), ((inventoryMap, network), allDevices)) (ms2d, _) _ -> , renderImage = \((_, act), ((inventoryMap, network), allDevices)) (ms2d, _) _ ->
above [] [] [margin (px 5.0, px zero) (editLayoutImage act allDevices network inventoryMap idx m2d) \\ m2d <- ms2d & idx <- [0..]] NoHost //TODO above [] [] [margin (px 5.0, px zero) (editLayoutImage act allDevices network inventoryMap idx m2d) \\ m2d <- ms2d & idx <- [0..]] NoHost
above [] [] Nothing [] [margin (px 5.0, px zero) (editLayoutImage act allDevices network inventoryMap idx m2d) \\ m2d <- ms2d & idx <- [0..]] NoHost
, updView = \m v -> fst m , updView = \m v -> fst m
, updModel = \(_,data) newClSt -> (newClSt,data) , updModel = \(_,data) newClSt -> (newClSt,data)
} }
...@@ -209,10 +213,10 @@ editLayout ...@@ -209,10 +213,10 @@ editLayout
, OnAction (Action "Remove outer borders" ) (hasValue (uncurry (editOuterBorders Open))) , OnAction (Action "Remove outer borders" ) (hasValue (uncurry (editOuterBorders Open)))
] ]
) @! () ) @! ()
] <<@ ApplyLayout layout @! () ] @! ()//TODO <<@ ApplyLayout layout @! ()
/*
where where
layout = idLayout layout = idLayout
/*
layout = sequenceLayouts layout = sequenceLayouts
[ insertSubAt [1] (ui UIContainer) // Group the 'tool' tasks [ insertSubAt [1] (ui UIContainer) // Group the 'tool' tasks
, moveSubAt[2] [1,0] , moveSubAt[2] [1,0]
...@@ -265,7 +269,7 @@ editSectionContents ...@@ -265,7 +269,7 @@ editSectionContents
[ChooseFromCheckGroup (\d -> d.Cable.description)] [ChooseFromCheckGroup (\d -> d.Cable.description)]
(mapRead ('DIS'.elems o fst) (myCables |+< focusedShare)) focusedShare (mapRead ('DIS'.elems o fst) (myCables |+< focusedShare)) focusedShare
) )
] <<@ ApplyLayout layout @! () ] @! () //TODO <<@ ApplyLayout layout @! ()
where where
updateSectionEditor :: !String ![ChoiceOption a] (Shared [a]) (Shared [a]) -> Task [a] | iTask a updateSectionEditor :: !String ![ChoiceOption a] (Shared [a]) (Shared [a]) -> Task [a] | iTask a
updateSectionEditor d updOpts listShare focusedShare updateSectionEditor d updOpts listShare focusedShare
...@@ -279,8 +283,8 @@ editSectionContents ...@@ -279,8 +283,8 @@ editSectionContents
_ = viewInformation (Title "Please select section") [] "Please select section" @! () _ = viewInformation (Title "Please select section") [] "Please select section" @! ()
) )
layout = idLayout
/* /*
layout = idLayout
layout = sequenceLayouts layout = sequenceLayouts
[insertSubAt [1] (uia UIContainer (directionAttr Horizontal)) [insertSubAt [1] (uia UIContainer (directionAttr Horizontal))
,moveSubAt [2] [1,0] ,moveSubAt [2] [1,0]
...@@ -497,7 +501,7 @@ initSection = {Section | sectionName = "" ...@@ -497,7 +501,7 @@ initSection = {Section | sectionName = ""
, borders = initBorders , borders = initBorders
, hops = [] , hops = []
} }
initBorders = {n=Open,e=Open,s=Open,w=Open} initBorders = {Borders|n=Open,e=Open,s=Open,w=Open}
frigate_outline =: [(0.0,0.5)] ++ port ++ [(1.0,0.5)] ++ starboard frigate_outline =: [(0.0,0.5)] ++ port ++ [(1.0,0.5)] ++ starboard
where where
port = [(0.006,0.048),(0.107,0.01),(0.179,0.0),(0.684,0.0),(0.719,0.01),(0.752,0.029),(0.787,0.067),(0.829,0.106),(0.852,0.135),(0.898,0.212),(0.926,0.279),(0.999,0.462)] port = [(0.006,0.048),(0.107,0.01),(0.179,0.0),(0.684,0.0),(0.719,0.01),(0.752,0.029),(0.787,0.067),(0.829,0.106),(0.852,0.135),(0.898,0.212),(0.926,0.279),(0.999,0.462)]
......
...@@ -3,15 +3,20 @@ implementation module C2.Apps.ShipAdventure.Images ...@@ -3,15 +3,20 @@ implementation module C2.Apps.ShipAdventure.Images
import C2.Framework.MapEnvironment import C2.Framework.MapEnvironment
import C2.Apps.ShipAdventure.Core import C2.Apps.ShipAdventure.Core
import C2.Apps.ShipAdventure.Types import C2.Apps.ShipAdventure.Types
import qualified Graphics.Scalable as GS
from Graphics.Scalable import <@<, class tuneImage import qualified Graphics.Scalable.Image as GS
from Graphics.Scalable import px, rect, normalFontDef, overlay, above, text, scale, beside, empty, collage, line, xline, yline, polygon import Graphics.Scalable.Image => qualified grid
from Graphics.Scalable import class toSVGColor(..), class margin(..), class *.(..), instance toSVGColor String import Graphics.Scalable.Types
from Graphics.Scalable import instance tuneImage OnClickAttr, instance tuneImage FillAttr, instance tuneImage OpacityAttr //import qualified Graphics.Scalable as GS
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 <@<, class tuneImage
from Graphics.Scalable import :: Span, :: FontDef, :: DashAttr(..), :: StrokeAttr(..), :: FillAttr(..), :: OnClickAttr(..), :: OpacityAttr(..), :: MaskAttr(..) //from Graphics.Scalable import px, rect, normalFontDef, overlay, above, text, scale, beside, empty, collage, line, xline, yline, polygon
from Graphics.Scalable import :: StrokeWidthAttr(..), :: Host(..), :: ImageOffset, :: XYAlign(..), :: XAlign(..), :: YAlign(..), :: Slash(..), :: Markers //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.IntMap.Strict as DIS
import qualified Data.Map as DM import qualified Data.Map as DM
...@@ -39,7 +44,8 @@ mapTitleImage idx hilite size2D=:(w, _) mapId ...@@ -39,7 +44,8 @@ mapTitleImage idx hilite size2D=:(w, _) mapId
maps2DImage :: !(Set Coord3D) !(MapAction SectionStatus) !RenderMode !Maps2D !SectionExitLockMap !SectionHopLockMap !MySectionInventoryMap !MySectionStatusMap !SectionUsersMap !(UserActorMap ObjectType ActorStatus) !(IntMap Device) !Network !*TagSource maps2DImage :: !(Set Coord3D) !(MapAction SectionStatus) !RenderMode !Maps2D !SectionExitLockMap !SectionHopLockMap !MySectionInventoryMap !MySectionStatusMap !SectionUsersMap !(UserActorMap ObjectType ActorStatus) !(IntMap Device) !Network !*TagSource
-> Image (Maps2D, MapAction SectionStatus) -> Image (Maps2D, MapAction SectionStatus)
maps2DImage disabledSections act mngmnt ms2d exitLocks hopLocks inventoryMap statusMap sectionUsersMap userActorMap allDevices network tsrc 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)) NoHost //TODO = 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
= above [] [] Nothing [] ('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) map2DImage :: !(Set Coord3D) !(MapAction SectionStatus) !RenderMode !SectionExitLockMap !SectionHopLockMap !MySectionInventoryMap !MySectionStatusMap !SectionUsersMap !(UserActorMap ObjectType ActorStatus) !(IntMap Device) !Network !(!Maps2DIndex, !Map2D)
-> Image (Maps2D, MapAction SectionStatus) -> Image (Maps2D, MapAction SectionStatus)
...@@ -47,13 +53,15 @@ map2DImage disabledSections act mngmnt exitLocks hopLocks inventoryMap statusMap ...@@ -47,13 +53,15 @@ map2DImage disabledSections act mngmnt exitLocks hopLocks inventoryMap statusMap
#! titleImg = mapTitleImage floorIdx (hilite act) size2D (toString mapId) #! 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 #! sectionsImg = sectionsImage disabledSections act mngmnt exitLocks hopLocks inventoryMap statusMap sectionUsersMap userActorMap allDevices network doors2D size2D floorIdx map2D
#! lowerImg = mask sectionsImg size2D shape2D #! lowerImg = mask sectionsImg size2D shape2D
= above [] [] [titleImg, lowerImg] NoHost //TODO = above [] [] [titleImg, lowerImg] NoHost
= above [] [] Nothing [] [titleImg, lowerImg] NoHost
mask :: !(Image m) !Size2D !(Maybe Shape2D) -> Image m mask :: !(Image m) !Size2D !(Maybe Shape2D) -> Image m
mask image _ Nothing mask image _ Nothing
= image = image
mask image (w,h) (Just shape) mask image (w,h) (Just shape)
#! shipshape = polygon Nothing [(px x, px y) \\ (x, y) <- shape] //TODO #! shipshape = polygon Nothing [(px x, px y) \\ (x, y) <- shape]
#! shipshape = polygon [(px x, px y) \\ (x, y) <- shape]
#! maskshape = overlay [] [] [shipshape <@< {fill = toSVGColor "white"} <@< {stroke = toSVGColor "white"}] (Host (rect (px w) (px h))) #! 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} = overlay [] [] [image, shipshape <@< {fill = toSVGColor "none"} <@< {stroke = toSVGColor "black"}] NoHost <@< {MaskAttr | mask = maskshape}
...@@ -100,8 +108,10 @@ sectionImage disabledSections hilite mngmnt zoomed exitLocks hopLocks inventoryM ...@@ -100,8 +108,10 @@ sectionImage disabledSections hilite mngmnt zoomed exitLocks hopLocks inventoryM
!(Image (Maps2D, MapAction SectionStatus)) !(Image (Maps2D, MapAction SectionStatus)) !(Image (Maps2D, MapAction SectionStatus)) !(Image (Maps2D, MapAction SectionStatus)) !(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 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) NoHost // TODO #! actorBadges = above (repeat AtMiddleX) [] ('DL'.strictTRMap (scale multiplier multiplier o mkActorBadge) actorMap) NoHost
#! statusBadges = above (repeat AtLeft) [] #! actorBadges = above (repeat AtMiddleX) [] Nothing [] ('DL'.strictTRMap (scale multiplier multiplier o mkActorBadge) actorMap) NoHost
//TODO #! statusBadges = above (repeat AtLeft) []
#! statusBadges = above (repeat AtLeft) [] Nothing []
[ mkStatusBadges statusMap c3d mngmnt multiplier [HasSmallFire, HasMediumFire, HasBigFire] [ mkStatusBadges statusMap c3d mngmnt multiplier [HasSmallFire, HasMediumFire, HasBigFire]
, mkStatusBadges statusMap c3d mngmnt multiplier [HasSmoke] , mkStatusBadges statusMap c3d mngmnt multiplier [HasSmoke]
, mkStatusBadges statusMap c3d mngmnt multiplier [HasSomeWater, IsFlooded] , mkStatusBadges statusMap c3d mngmnt multiplier [HasSomeWater, IsFlooded]
...@@ -116,8 +126,8 @@ sectionImage disabledSections hilite mngmnt zoomed exitLocks hopLocks inventoryM ...@@ -116,8 +126,8 @@ sectionImage disabledSections hilite mngmnt zoomed exitLocks hopLocks inventoryM
<@< {fill = if (hiliteThisSection hilite c3d) hiliteSectionBackgroundColor (toSVGColor "white")} <@< {fill = if (hiliteThisSection hilite c3d) hiliteSectionBackgroundColor (toSVGColor "white")}
#! host = if (mngmnt === DOffMode && 'DS'.member c3d disabledSections) #! host = if (mngmnt === DOffMode && 'DS'.member c3d disabledSections)
(overlay (repeat (AtMiddleX, AtMiddleY)) [] [ host (overlay (repeat (AtMiddleX, AtMiddleY)) [] [ host
, line Nothing Slash pxswidth pxsheight <@< {stroke = toSVGColor "red" } , line /*Nothing Slash */pxswidth pxsheight <@< {stroke = toSVGColor "red" }
, line Nothing Backslash pxswidth pxsheight <@< {stroke = toSVGColor "red" } , line /*Nothing Backslash */pxswidth pxsheight <@< {stroke = toSVGColor "red" }
] NoHost) ] NoHost)
host host
= overlay [ (AtMiddleX, AtTop), (AtRight, AtMiddleY), (AtMiddleX, AtBottom), (AtLeft, AtMiddleY) // Walls = overlay [ (AtMiddleX, AtTop), (AtRight, AtMiddleY), (AtMiddleX, AtBottom), (AtLeft, AtMiddleY) // Walls
...@@ -127,23 +137,28 @@ sectionImage disabledSections hilite mngmnt zoomed exitLocks hopLocks inventoryM ...@@ -127,23 +137,28 @@ 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 , (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 [ case n of Wall = hwall
Door = above (repeat AtMiddleX) [] [hwall, doorClick canCloseDoors c3d N (hdoor <@< doorFill exitLocks c3d N)] NoHost //TODO Door = above (repeat AtMiddleX) [] [hwall, doorClick canCloseDoors c3d N (hdoor <@< doorFill exitLocks c3d N)] NoHost
Door = above (repeat AtMiddleX) [] Nothing [] [hwall, doorClick canCloseDoors c3d N (hdoor <@< doorFill exitLocks c3d N)] NoHost
Open = empty zero zero Open = empty zero zero
, case e of Wall = vwall , case e of Wall = vwall
Door = beside (repeat AtMiddleY) [] [doorClick canCloseDoors c3d E (vdoor <@< doorFill exitLocks c3d E), vwall] NoHost //TODO Door = beside (repeat AtMiddleY) [] [doorClick canCloseDoors c3d E (vdoor <@< doorFill exitLocks c3d E), vwall] NoHost
Door = beside (repeat AtMiddleY) [] Nothing [] [doorClick canCloseDoors c3d E (vdoor <@< doorFill exitLocks c3d E), vwall] NoHost
Open = empty zero zero Open = empty zero zero
, case s of Wall = hwall , case s of Wall = hwall
Door = above (repeat AtMiddleX) [] [doorClick canCloseDoors c3d S (hdoor <@< doorFill exitLocks c3d S), hwall] NoHost //TODO Door = above (repeat AtMiddleX) [] [doorClick canCloseDoors c3d S (hdoor <@< doorFill exitLocks c3d S), hwall] NoHost
Door = above (repeat AtMiddleX) [] Nothing [] [doorClick canCloseDoors c3d S (hdoor <@< doorFill exitLocks c3d S), hwall] NoHost
Open = empty zero zero Open = empty zero zero
, case w of Wall = vwall , case w of Wall = vwall
Door = beside (repeat AtMiddleY) [] [vwall, doorClick canCloseDoors c3d W (vdoor <@< doorFill exitLocks c3d W)] NoHost //TODO Door = beside (repeat AtMiddleY) [] [vwall, doorClick canCloseDoors c3d W (vdoor <@< doorFill exitLocks c3d W)] NoHost
Door = beside (repeat AtMiddleY) [] Nothing [] [vwall, doorClick canCloseDoors c3d W (vdoor <@< doorFill exitLocks c3d W)] NoHost
Open = empty zero zero Open = empty zero zero
, statusBadges, actorBadges, inventoryBadges, upDownExits , statusBadges, actorBadges, inventoryBadges, upDownExits
] ]
(Host host) (Host host)
where where
mkStatusBadges :: !SectionStatus !Coord3D !RenderMode !Real ![SectionStatus] -> Image (a, MapAction SectionStatus) 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)) NoHost //TODO mkStatusBadges statusMap c3d mngmnt multiplier xs = beside (repeat AtMiddleY) [] ('DL'.reverseTR ('DL'.strictFoldl (mkStatusBadge statusMap c3d mngmnt multiplier) [] xs)) NoHost
mkStatusBadges statusMap c3d mngmnt multiplier xs = beside (repeat AtMiddleY) [] Nothing [] ('DL'.reverseTR ('DL'.strictFoldl (mkStatusBadge statusMap c3d mngmnt multiplier) [] xs)) NoHost
doorFill :: !SectionExitLockMap !Coord3D !Dir -> FillAttr a doorFill :: !SectionExitLockMap !Coord3D !Dir -> FillAttr a
doorFill exitLocks c3d dir doorFill exitLocks c3d dir
...@@ -168,18 +183,21 @@ sectionImage` f mngmnt zoomed hopLocks inventoryMap allDevices network (doorw, d ...@@ -168,18 +183,21 @@ sectionImage` f mngmnt zoomed hopLocks inventoryMap allDevices network (doorw, d
#! deviceBadges = 'DL'.strictTRMap (drawDevice c3d multiplier) devices #! deviceBadges = 'DL'.strictTRMap (drawDevice c3d multiplier) devices
#! allBadges = inventoryBadges ++ deviceBadges #! allBadges = inventoryBadges ++ deviceBadges
#! inventoryBadges = if (length allBadges > 0) #! inventoryBadges = if (length allBadges > 0)
(beside (repeat AtMiddleY) [] allBadges NoHost) //TODO (beside (repeat AtMiddleY) [] allBadges NoHost)
(beside (repeat AtMiddleY) [] Nothing [] allBadges NoHost)
(empty zero zero) (empty zero zero)
#! cables = cablesForSection c3d network #! cables = cablesForSection c3d network
#! cableBadges = if (length cables > 0) #! cableBadges = if (length cables > 0)
(above (repeat AtMiddleX) [] ('DL'.strictTRMap mkCable cables) NoHost) //TODO (above (repeat AtMiddleX) [] ('DL'.strictTRMap mkCable cables) NoHost)
(above (repeat AtMiddleX) [] Nothing [] ('DL'.strictTRMap mkCable cables) NoHost)
(empty zero zero) (empty zero zero)
#! canCloseDoors = mngmnt === KitchenMode || mngmnt === DOffMode #! canCloseDoors = mngmnt === KitchenMode || mngmnt === DOffMode
#! upDownExits = beside [] [(px -3.0,zero)] ('DL'.strictTRMap (drawHop c3d hopLocks multiplier) hops) NoHost //TODO #! upDownExits = beside [] [(px -3.0,zero)] ('DL'.strictTRMap (drawHop c3d hopLocks multiplier) hops) NoHost
#! upDownExits = beside [] [px -3.0] Nothing [] ('DL'.strictTRMap (drawHop c3d hopLocks multiplier) hops) NoHost
#! hdoor = rect (px doorw) (px doord) #! hdoor = rect (px doorw) (px doord)
#! vdoor = rect (px doord) (px doorw) #! vdoor = rect (px doord) (px doorw)
#! hwall = xline Nothing (px swidth) #! hwall = xline (px swidth)
#! vwall = yline Nothing (px sheight) #! vwall = yline (px sheight)
= f canCloseDoors c3d inventory devices multiplier inventoryBadges deviceBadges cableBadges upDownExits hdoor vdoor hwall vwall = f canCloseDoors c3d inventory devices multiplier inventoryBadges deviceBadges cableBadges upDownExits hdoor vdoor hwall vwall
where where
drawInventory :: !Real !(Object ObjectType) -> Image a drawInventory :: !Real !(Object ObjectType) -> Image a
...@@ -193,8 +211,9 @@ sectionImage` f mngmnt zoomed hopLocks inventoryMap allDevices network (doorw, d ...@@ -193,8 +211,9 @@ sectionImage` f mngmnt zoomed hopLocks inventoryMap allDevices network (doorw, d
mkCable :: !Cable -> Image a mkCable :: !Cable -> Image a
mkCable cable mkCable cable
#! linePiece = xline Nothing (px 4.0) #! linePiece = xline (px 4.0)
= beside (repeat AtMiddleY) [] [linePiece, text (mapFont mapTitleFontSize) (cable.Cable.description % (0, 1)), linePiece] NoHost //TODO = beside (repeat AtMiddleY) [] [linePiece, text (mapFont mapTitleFontSize) (cable.Cable.description % (0, 1)), linePiece] NoHost
= beside (repeat AtMiddleY) [] Nothing [] [linePiece, text (mapFont mapTitleFontSize) (cable.Cable.description % (0, 1)), linePiece] NoHost
mkUpDown :: !Coord3D !Coord3D !SectionHopLockMap -> Image a mkUpDown :: !Coord3D !Coord3D !SectionHopLockMap -> Image a
mkUpDown cur=:(curFloor, _) next=:(nextFloor, _) hopLocks mkUpDown cur=:(curFloor, _) next=:(nextFloor, _) hopLocks
...@@ -202,7 +221,8 @@ mkUpDown cur=:(curFloor, _) next=:(nextFloor, _) hopLocks ...@@ -202,7 +221,8 @@ mkUpDown cur=:(curFloor, _) next=:(nextFloor, _) hopLocks
Just xs -> 'DL'.elem next xs Just xs -> 'DL'.elem next xs
_ -> False _ -> False
#! goesUp = curFloor > nextFloor #! 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])) NoHost <@< { opacity = if l 0.3 1.0 } //TODO = 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 }
= beside (repeat AtBottom) [] Nothing [] ('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 mkStatusBadge :: !SectionStatus Coord3D !RenderMode !Real ![Image (a, MapAction SectionStatus)] !SectionStatus
-> [Image (a, MapAction SectionStatus)] -> [Image (a, MapAction SectionStatus)]
...@@ -233,7 +253,8 @@ mkActorBadge {actorStatus = {occupied}, userName, carrying} ...@@ -233,7 +253,8 @@ mkActorBadge {actorStatus = {occupied}, userName, carrying}
#! userInitial = text myFontDef (userStr % (0,0)) <@< { fill = toSVGColor "white" } #! userInitial = text myFontDef (userStr % (0,0)) <@< { fill = toSVGColor "white" }
#! actorBadge = overlay [(AtMiddleX, AtMiddleY)] [] [userInitial] (Host actorBadge) #! actorBadge = overlay [(AtMiddleX, AtMiddleY)] [] [userInitial] (Host actorBadge)
#! inventory = 'DL'.strictTRMap (\i -> mkInventoryBadge False True (toString i % (0, 1))) carrying #! inventory = 'DL'.strictTRMap (\i -> mkInventoryBadge False True (toString i % (0, 1))) carrying
= above (repeat AtMiddleX) [] [actorBadge : inventory] NoHost //TODO = above (repeat AtMiddleX) [] [actorBadge : inventory] NoHost
= above (repeat AtMiddleX) [] Nothing [] [actorBadge : inventory] NoHost
mkActorBadgeBackground :: !Availability -> Image a mkActorBadgeBackground :: !Availability -> Image a
mkActorBadgeBackground occupied = medBadgeImage <@< { fill = toSVGColor (case occupied of mkActorBadgeBackground occupied = medBadgeImage <@< { fill = toSVGColor (case occupied of
...@@ -298,7 +319,8 @@ editLayoutImage act allDevices network inventoryMap idx {Map2D | shape2D, doors2 ...@@ -298,7 +319,8 @@ editLayoutImage act allDevices network inventoryMap idx {Map2D | shape2D, doors2
#! titleImg = mapTitleImage idx (hilite act) size2D (hint mapId) <@< {onclick = onClick (FocusOnMap idx), local = False} #! titleImg = mapTitleImage idx (hilite act) size2D (hint mapId) <@< {onclick = onClick (FocusOnMap idx), local = False}
#! editImg = editSectionsImage (hilite act) allDevices network inventoryMap idx doors2D size2D map2D #! editImg = editSectionsImage (hilite act) allDevices network inventoryMap idx doors2D size2D map2D
#! bottomImg = mask editImg size2D shape2D #! bottomImg = mask editImg size2D shape2D
= above [] [] [titleImg, bottomImg] NoHost = above [] [] Nothing [] [titleImg, bottomImg] NoHost
//TODO = above [] [] [titleImg, bottomImg] NoHost
hint msg = msg +++ " (click in this area to edit this map)" hint msg = msg +++ " (click in this area to edit this map)"
......
...@@ -23,7 +23,13 @@ import C2.Apps.ShipAdventure.Editor ...@@ -23,7 +23,13 @@ import C2.Apps.ShipAdventure.Editor
derive gLexOrd CableType, Capability derive gLexOrd CableType, Capability
derive class iTask ObjectType, ActorStatus, Availability, ActorHealth, ActorEnergy, DeviceType, SectionStatus derive class iTask ObjectType, ActorStatus, Availability, ActorHealth, ActorEnergy, DeviceType, SectionStatus
derive class iTask Cable, Priority, Network, Device, CableType, DeviceKind, CommandAim, Set, Capability, CapabilityExpr derive class iTask Cable, Priority, Network, Device, CableType, DeviceKind, CommandAim, Capability, CapabilityExpr
derive gEditor Set
derive gDefault Set
derive gText Set
derive JSONEncode Set
derive JSONDecode Set
derive JSEncode Map2D, Coord2D, Map, IntMap, Dir, User, Maybe, Section, Borders, Border, MapAction, Object, Actor derive JSEncode Map2D, Coord2D, Map, IntMap, Dir, User, Maybe, Section, Borders, Border, MapAction, Object, Actor
derive JSEncode ObjectType, ActorStatus, Availability, ActorHealth, ActorEnergy, DeviceType, SectionStatus derive JSEncode ObjectType, ActorStatus, Availability, ActorHealth, ActorEnergy, DeviceType, SectionStatus
...@@ -286,7 +292,7 @@ deviceIdInNetworkSectionShare = sdsLens "deviceIdInNetworkSectionShare" (const ( ...@@ -286,7 +292,7 @@ deviceIdInNetworkSectionShare = sdsLens "deviceIdInNetworkSectionShare" (const (
write c3d network devIds = Ok (Just ({network & devices = 'DM'.put c3d devIds network.devices})) write c3d network devIds = Ok (Just ({network & devices = 'DM'.put c3d devIds network.devices}))
notify :: !Coord3D !Network ![DeviceId] -> SDSNotifyPred Coord3D notify :: !Coord3D !Network ![DeviceId] -> SDSNotifyPred Coord3D
notify c3d network devIds = \idx` -> c3d == idx` notify c3d network devIds = \_ idx` -> c3d == idx`
devicesInSectionShare :: RWShared Coord3D [Device] [Device] devicesInSectionShare :: RWShared Coord3D [Device] [Device]
devicesInSectionShare devicesInSectionShare
...@@ -360,8 +366,8 @@ cablesInSectionShare = sdsLens "cablesInSectionShare" (const ()) (SDSRead read) ...@@ -360,8 +366,8 @@ cablesInSectionShare = sdsLens "cablesInSectionShare" (const ()) (SDSRead read)
in if inList network in if inList network
{network & cableMapping = 'DIS'.put cable.cableId [(True, c3d) : coords] network.cableMapping} {network & cableMapping = 'DIS'.put cable.cableId [(True, c3d) : coords] network.cableMapping}
) network cables)) ) network cables))
notify :: !Coord3D !Network ![Cable] -> (Coord3D -> Bool) notify :: !Coord3D !Network ![Cable] -> SDSNotifyPred Coord3D
notify c3d oldNetwork newCables = \c3d` -> c3d === c3d` notify c3d oldNetwork newCables = \_ c3d` -> c3d === c3d`
cablesForSection :: !Coord3D !Network -> [Cable] cablesForSection :: !Coord3D !Network -> [Cable]
cablesForSection c3d { Network | cables, cableMapping } cablesForSection c3d { Network | cables, cableMapping }
......
...@@ -36,7 +36,7 @@ selectedContactShare = sdsLens "selectedContactShare" (const ()) (SDSRead read) ...@@ -36,7 +36,7 @@ selectedContactShare = sdsLens "selectedContactShare" (const ()) (SDSRead read)
write _ st=:{selection, entities} e = Ok (Just {st & entities = 'DIS'.put selection e entities}) write _ st=:{selection, entities} e = Ok (Just {st & entities = 'DIS'.put selection e entities})
notify :: () MapState Entity -> SDSNotifyPred () notify :: () MapState Entity -> SDSNotifyPred ()
notify _ _ _ = \_ -> False notify _ _ _ = \_ _ -> False
userMapState :: User -> Shared MapState userMapState :: User -> Shared MapState
userMapState u = sharedStore ("userMapState" +++ toString u) defSettings userMapState u = sharedStore ("userMapState" +++ toString u) defSettings
...@@ -70,7 +70,7 @@ contactWithId = sdsLens "contactWithId" (const ()) (SDSRead read) (SDSWrite writ ...@@ -70,7 +70,7 @@ contactWithId = sdsLens "contactWithId" (const ()) (SDSRead read) (SDSWrite writ
write idx st=:{entities} e = Ok (Just {st & entities = 'DIS'.put idx e entities}) write idx st=:{entities} e = Ok (Just {st & entities = 'DIS'.put idx e entities})