Commit 1b66842d authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'master' into simplified-interaction-api

parents c25db9d5 17af588b
Pipeline #28171 failed with stage
in 1 minute and 12 seconds
...@@ -25,6 +25,8 @@ import Incidone.Extensions.CrewLists ...@@ -25,6 +25,8 @@ import Incidone.Extensions.CrewLists
derive class iTask CommunicationAttempt derive class iTask CommunicationAttempt
derive class iTask ActionPlan derive class iTask ActionPlan
derive gDefault ActionStatus, ItemMeta, ActionProgress
actionStatuses :: SDSLens () [(InstanceNo,InstanceNo,ActionStatus)] () actionStatuses :: SDSLens () [(InstanceNo,InstanceNo,ActionStatus)] ()
actionStatuses = mapRead (map toActionStatus) detachedTaskInstances actionStatuses = mapRead (map toActionStatus) detachedTaskInstances
......
...@@ -7,6 +7,8 @@ import Text, Text.HTML, Data.List, iTasks.Internal.HtmlUtil ...@@ -7,6 +7,8 @@ import Text, Text.HTML, Data.List, iTasks.Internal.HtmlUtil
derive class iTask WallContent derive class iTask WallContent
derive gDefault ContactMap, ContactMapLayer, ContactMapLayerDefinition, ContactMapMarker, ContactMapRegion, ContactTrack, ContactMapMarkerType, DateTime
wallContent :: SimpleSDSLens WallContent wallContent :: SimpleSDSLens WallContent
wallContent = sharedStore "WallContent" (WallOverview defaultValue) wallContent = sharedStore "WallContent" (WallOverview defaultValue)
......
...@@ -7,6 +7,8 @@ import Incidone.Util.TaskPatterns ...@@ -7,6 +7,8 @@ import Incidone.Util.TaskPatterns
import qualified Data.Map as DM import qualified Data.Map as DM
import Data.Functor import Data.Functor
derive gDefault AISContact, DateTime, ContactTrack, Degrees, AIVDM5, AIVDMCNB
syncAISStream :: Task () syncAISStream :: Task ()
syncAISStream = withShared ([],False,[],False) (\channel -> (sync channel -&&- consume channel) @! ()) syncAISStream = withShared ([],False,[],False) (\channel -> (sync channel -&&- consume channel) @! ())
where where
......
...@@ -21,5 +21,4 @@ derive JSONEncode Temperature, Meters, Feet, Miles, Knots, Degrees, Contac ...@@ -21,5 +21,4 @@ derive JSONEncode Temperature, Meters, Feet, Miles, Knots, Degrees, Contac
derive JSONDecode Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort derive JSONDecode Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gText Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort derive gText Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gEditor Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort derive gEditor Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gDefault Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gEq Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort derive gEq Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
...@@ -29,6 +29,4 @@ gText{|IncidentShort|} _ i = [maybe "" incidentTitle i] ...@@ -29,6 +29,4 @@ gText{|IncidentShort|} _ i = [maybe "" incidentTitle i]
derive JSONEncode Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort derive JSONEncode Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive JSONDecode Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort derive JSONDecode Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gEditor Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort derive gEditor Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gDefault Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gEq Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort derive gEq Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
...@@ -13,6 +13,8 @@ import Data.Map.GenJSON ...@@ -13,6 +13,8 @@ import Data.Map.GenJSON
import Text, Text.HTML, Data.Either, Data.Functor import Text, Text.HTML, Data.Either, Data.Functor
import iTasks.UI.Editor.Controls import iTasks.UI.Editor.Controls
derive gDefault Contact, ContactMap, ContactStatus, ContactAccessLevel, Credentials, ContactPhoto, ContactTrack, ContactType, Degrees, Document, ContactMapLayer, DateTime, ContactMapLayerDefinition, ContactMapMarker, ContactMapRegion, ContactMapMarkerType
CONVERT_BIN :== "/opt/local/bin/convert" CONVERT_BIN :== "/opt/local/bin/convert"
//CONVERT_BIN :== "/usr/bin/convert" //CONVERT_BIN :== "/usr/bin/convert"
......
...@@ -4,6 +4,9 @@ import Incidone.OP.Concepts ...@@ -4,6 +4,9 @@ import Incidone.OP.Concepts
import Text, Text.HTML import Text, Text.HTML
import iTasks.Extensions.DateTime import iTasks.Extensions.DateTime
derive gDefault ContactGeo, CommunicationMean, NewCommunicationMean, ContactStatus, ContactAccessLevel, Credentials, ContactPhoto, ContactTrack, ContactType
derive gDefault DateTime, Contact, Degrees, CommunicationMeanType, Document
class contactTitle a :: a -> String class contactTitle a :: a -> String
instance contactTitle Contact instance contactTitle Contact
where where
......
...@@ -5,6 +5,8 @@ import Incidone.OP.IncidentManagementTasks ...@@ -5,6 +5,8 @@ import Incidone.OP.IncidentManagementTasks
import Incidone.OP.ContactManagementTasks import Incidone.OP.ContactManagementTasks
import Incidone.OP.CommunicationManagementTasks import Incidone.OP.CommunicationManagementTasks
derive gDefault NewContact, IncidentShort, ContactType
generateTestIncident :: Bool -> Task IncidentNo generateTestIncident :: Bool -> Task IncidentNo
generateTestIncident closed generateTestIncident closed
= randomChoice [YachtEngineProblems,YachtAground,Medevac] = randomChoice [YachtEngineProblems,YachtAground,Medevac]
......
...@@ -9,6 +9,7 @@ import Incidone.Util.SQLSDS ...@@ -9,6 +9,7 @@ import Incidone.Util.SQLSDS
import Data.Functor, Data.Either, Data.Tuple, Data.Func import Data.Functor, Data.Either, Data.Tuple, Data.Func
derive class iTask ContactFilter derive class iTask ContactFilter
derive gDefault PhoneCall, RadioCall, EmailMessage, P2000Message, WeatherData, PersonDetails, VesselDetails, SurferDetails, DiverDetails, AirplaneDetails, HelicopterDetails, CommunicationMean, WeatherType, Gender, VesselType, CommunicationMeanType, Feet, Knots, Meters, Temperature, Degrees, Miles
dbReadSDS :: String -> SDSSequence QueryDef [r] () | mbFromSQL r & TC r dbReadSDS :: String -> SDSSequence QueryDef [r] () | mbFromSQL r & TC r
dbReadSDS notifyId = databaseDef >++> sqlReadSDS notifyId dbReadSDS notifyId = databaseDef >++> sqlReadSDS notifyId
......
...@@ -22,6 +22,7 @@ import Text.HTML ...@@ -22,6 +22,7 @@ import Text.HTML
| IncorrectDatabaseTables | IncorrectDatabaseTables
derive class iTask DatabaseProblem derive class iTask DatabaseProblem
derive gDefault ContactMap, ContactMapLayer, ContactMapLayerDefinition, ContactMapMarker, ContactMapRegion, ContactTrack, ContactMapMarkerType, DateTime
configureIncidone :: [Workspace -> Task ()] configureIncidone :: [Workspace -> Task ()]
configureIncidone = map const [configureDatabase <<@ (Title "Database") configureIncidone = map const [configureDatabase <<@ (Title "Database")
......
...@@ -23,9 +23,7 @@ ...@@ -23,9 +23,7 @@
<!-- load iTasks viewport --> <!-- load iTasks viewport -->
<script type="text/javascript"> <script type="text/javascript">
window.onload = function() { window.onload = function() {
ABC.loading_promise.finally(function(){ itasks.viewport({syncTitle: true}, document.body);
itasks.viewport({syncTitle: true}, document.body);
});
}; };
</script> </script>
</head> </head>
......
...@@ -149,8 +149,8 @@ editDeviceToDevice dev ...@@ -149,8 +149,8 @@ editDeviceToDevice dev
:: EditDeviceType = :: EditDeviceType =
{ kind :: !DeviceKind { kind :: !DeviceKind
, requires :: ![(!CableType, !Capacity)] , requires :: ![(CableType, Capacity)]
, produces :: ![(!CableType, !Capacity)] , produces :: ![(CableType, Capacity)]
} }
:: EditDevice = :: EditDevice =
......
...@@ -64,9 +64,9 @@ from C2.Apps.ShipAdventure.Images import :: RenderMode ...@@ -64,9 +64,9 @@ from C2.Apps.ShipAdventure.Images import :: RenderMode
// physical devices // physical devices
:: Network = :: Network =
{ devices :: !Map Coord3D [DeviceId] // [Coord3D |-> DeviceIds] { devices :: !Map Coord3D [DeviceId] // [Coord3D |-> DeviceIds]
, cables :: !IntMap Cable // [CableId |-> Cable] , cables :: !IntMap Cable // [CableId |-> Cable]
, cableMapping :: !IntMap [(!Operational, !Coord3D)] // [CableId |-> Coord3Ds] , cableMapping :: !IntMap [(Operational, Coord3D)] // [CableId |-> Coord3Ds]
} }
:: Device = :: Device =
{ description :: !String { description :: !String
...@@ -95,8 +95,8 @@ from C2.Apps.ShipAdventure.Images import :: RenderMode ...@@ -95,8 +95,8 @@ from C2.Apps.ShipAdventure.Images import :: RenderMode
:: PPDeviceType = :: PPDeviceType =
{ kind :: !DeviceKind { kind :: !DeviceKind
, requires :: ![(!CableType, !Capacity)] , requires :: ![(CableType, Capacity)]
, produces :: ![(!CableType, !Capacity)] , produces :: ![(CableType, Capacity)]
} }
:: CommandAim = :: CommandAim =
...@@ -169,8 +169,8 @@ cablesInSectionShare :: SDSLens Coord3D [Cable] [Cable] ...@@ -169,8 +169,8 @@ cablesInSectionShare :: SDSLens Coord3D [Cable] [Cable]
cablesForSection :: !Coord3D !Network -> [Cable] cablesForSection :: !Coord3D !Network -> [Cable]
allActiveAlarms :: SDSLens () [(!Coord3D, !SectionStatus)] () allActiveAlarms :: SDSLens () [(Coord3D, SectionStatus)] ()
allAvailableActors :: SDSLens () [(!Coord3D, !MyActor)] () allAvailableActors :: SDSLens () [(Coord3D, MyActor)] ()
// setting and resetting of the detection systems: // setting and resetting of the detection systems:
...@@ -203,7 +203,7 @@ allImperiledCommandAims :: !(IntMap Device) !CapabilityToDeviceKindMap ![Command ...@@ -203,7 +203,7 @@ allImperiledCommandAims :: !(IntMap Device) !CapabilityToDeviceKindMap ![Command
deviceIsDisabledInSection :: !Coord3D !Device !(IntMap Device) !Network -> Bool deviceIsDisabledInSection :: !Coord3D !Device !(IntMap Device) !Network -> Bool
isOperational :: !CableId !(IntMap [(!Operational, !Coord3D)]) -> Bool isOperational :: !CableId !(IntMap [(Operational, Coord3D)]) -> Bool
devicesForCable :: !Cable !(IntMap Device) !Network -> [Device] devicesForCable :: !Cable !(IntMap Device) !Network -> [Device]
......
...@@ -224,7 +224,7 @@ toPPDeviceType { DeviceType | kind, requires, produces } = { PPDeviceType ...@@ -224,7 +224,7 @@ toPPDeviceType { DeviceType | kind, requires, produces } = { PPDeviceType
, produces = 'DM'.toList produces , produces = 'DM'.toList produces
} }
isOperational :: !CableId !(IntMap [(!Operational, !Coord3D)]) -> Bool isOperational :: !CableId !(IntMap [(Operational, Coord3D)]) -> Bool
isOperational cableId cableMapping = and [b \\ (b, _) <- fromMaybe [] ('DIS'.get cableId cableMapping)] isOperational cableId cableMapping = and [b \\ (b, _) <- fromMaybe [] ('DIS'.get cableId cableMapping)]
smokeDetector :: DeviceType smokeDetector :: DeviceType
...@@ -383,22 +383,22 @@ patchCable roomNo cableId network = { network & cableMapping = 'DIS'.alter (fmap ...@@ -383,22 +383,22 @@ patchCable roomNo cableId network = { network & cableMapping = 'DIS'.alter (fmap
inventoryInSectionShare :: FocusedSectionInventoryShare ObjectType inventoryInSectionShare :: FocusedSectionInventoryShare ObjectType
inventoryInSectionShare = mapLens "inventoryInSectionShare" myInventoryMap (Just 'DIS'.newMap) inventoryInSectionShare = mapLens "inventoryInSectionShare" myInventoryMap (Just 'DIS'.newMap)
allAvailableActors :: SDSLens () [(!Coord3D, !MyActor)] () allAvailableActors :: SDSLens () [(Coord3D, MyActor)] ()
allAvailableActors allAvailableActors
= /*toReadOnly */ (sdsProject (SDSLensRead readActors) (SDSBlindWrite \_. Ok Nothing) Nothing (sectionUsersShare |*| myUserActorMap)) = /*toReadOnly */ (sdsProject (SDSLensRead readActors) (SDSBlindWrite \_. Ok Nothing) Nothing (sectionUsersShare |*| myUserActorMap))
where where
readActors :: !(SectionUsersMap, UserActorMap ObjectType ActorStatus) -> MaybeError TaskException [(!Coord3D, !MyActor)] readActors :: !(SectionUsersMap, UserActorMap ObjectType ActorStatus) -> MaybeError TaskException [(Coord3D, MyActor)]
readActors (sectionUsersMap, userActorMap) readActors (sectionUsersMap, userActorMap)
= Ok [(c3d, a) \\ us <- 'DM'.elems sectionUsersMap = Ok [(c3d, a) \\ us <- 'DM'.elems sectionUsersMap
, u <- us , u <- us
, Just (c3d, a) <- [findUser u sectionUsersMap userActorMap] , Just (c3d, a) <- [findUser u sectionUsersMap userActorMap]
| a.actorStatus.occupied === Available] | a.actorStatus.occupied === Available]
allActiveAlarms :: SDSLens () [(!Coord3D, !SectionStatus)] () allActiveAlarms :: SDSLens () [(Coord3D, SectionStatus)] ()
allActiveAlarms allActiveAlarms
= /*toReadOnly */ (sdsProject (SDSLensRead readAlarms) (SDSBlindWrite \_. Ok Nothing) Nothing myStatusMap) = /*toReadOnly */ (sdsProject (SDSLensRead readAlarms) (SDSBlindWrite \_. Ok Nothing) Nothing myStatusMap)
where where
readAlarms :: !MySectionStatusMap -> MaybeError TaskException [(!Coord3D, !SectionStatus)] readAlarms :: !MySectionStatusMap -> MaybeError TaskException [(Coord3D, SectionStatus)]
readAlarms statusMap = Ok [ (number, status) \\ (number, status) <- 'DM'.toList statusMap readAlarms statusMap = Ok [ (number, status) \\ (number, status) <- 'DM'.toList statusMap
| isHigh status] | isHigh status]
......
...@@ -29,7 +29,7 @@ import Data.GenLexOrd ...@@ -29,7 +29,7 @@ import Data.GenLexOrd
:: MapID :== String // identification of one map :: MapID :== String // identification of one map
:: Border = Open | Door | Wall :: Border = Open | Door | Wall
:: Size2D :== (!Real, !Real) // width and height :: Size2D :== (!Real, !Real) // width and height
:: Shape2D :== [(!Real, !Real)] // outline in terms of Map2D.size coordinates (origin at left-top, max at right-bottom) :: Shape2D :== [(Real, Real)] // outline in terms of Map2D.size coordinates (origin at left-top, max at right-bottom)
:: Maps2DIndex :== Int // index in Maps2D (0..length Maps2D-1) :: Maps2DIndex :== Int // index in Maps2D (0..length Maps2D-1)
:: Coord2D = { col :: !Int // x-coordinate (0.., identifies column) :: Coord2D = { col :: !Int // x-coordinate (0.., identifies column)
, row :: !Int // y-coordinate (0.., identifies row) , row :: !Int // y-coordinate (0.., identifies row)
...@@ -37,7 +37,7 @@ import Data.GenLexOrd ...@@ -37,7 +37,7 @@ import Data.GenLexOrd
:: Coord3D :== (!Maps2DIndex, !Coord2D) // (index in Maps2D, {col,row} in map) :: Coord3D :== (!Maps2DIndex, !Coord2D) // (index in Maps2D, {col,row} in map)
:: Dir = N | E | W | S // north, east, west, south :: Dir = N | E | W | S // north, east, west, south
:: Graph :== Map Coord3D [(!Maybe Dir, !Coord3D)] :: Graph :== Map Coord3D [(Maybe Dir, Coord3D)]
/******************************************************************************************************************** /********************************************************************************************************************
* *
...@@ -145,7 +145,7 @@ moveAround :: !(DrawMapForActor r o a) !User ...@@ -145,7 +145,7 @@ moveAround :: !(DrawMapForActor r o a) !User
// finds all actors currently walking on the map, find all objects in the map // finds all actors currently walking on the map, find all objects in the map
findAllObjects :: !(SectionInventoryMap o) -> [(!Coord3D, !Object o)] | iTask o findAllObjects :: !(SectionInventoryMap o) -> [(Coord3D, Object o)] | iTask o
findUser :: !User !SectionUsersMap !(UserActorMap o a) -> Maybe (!Coord3D, !Actor o a) | iTask o & iTask a findUser :: !User !SectionUsersMap !(UserActorMap o a) -> Maybe (!Coord3D, !Actor o a) | iTask o & iTask a
// update the status of an actor, unique username is used as identification // update the status of an actor, unique username is used as identification
......
...@@ -132,7 +132,7 @@ colToGraph floorIdx rowIdx (graph, colIdx) section ...@@ -132,7 +132,7 @@ colToGraph floorIdx rowIdx (graph, colIdx) section
#! graph = 'DM'.put (floorIdx, currCoord2D) (getCoord3Ds section floorIdx currCoord2D section.borders) graph #! graph = 'DM'.put (floorIdx, currCoord2D) (getCoord3Ds section floorIdx currCoord2D section.borders) graph
= (graph, colIdx + 1) = (graph, colIdx + 1)
getCoord3Ds :: !Section !Int !Coord2D !Borders -> [(!Maybe Dir, !Coord3D)] getCoord3Ds :: !Section !Int !Coord2D !Borders -> [(Maybe Dir, Coord3D)]
getCoord3Ds section floorIdx currCoord2D borders getCoord3Ds section floorIdx currCoord2D borders
#! acc = [] #! acc = []
#! acc = addOnOpening floorIdx borders.n N currCoord2D acc #! acc = addOnOpening floorIdx borders.n N currCoord2D acc
...@@ -142,7 +142,7 @@ getCoord3Ds section floorIdx currCoord2D borders ...@@ -142,7 +142,7 @@ getCoord3Ds section floorIdx currCoord2D borders
#! acc = acc ++ map (\h -> (Nothing, h)) section.hops #! acc = acc ++ map (\h -> (Nothing, h)) section.hops
= acc = acc
where where
addOnOpening :: !Int !Border !Dir !Coord2D ![(!Maybe Dir, !Coord3D)] -> [(!Maybe Dir, !Coord3D)] addOnOpening :: !Int !Border !Dir !Coord2D ![(Maybe Dir, Coord3D)] -> [(Maybe Dir, Coord3D)]
addOnOpening _ Wall _ _ acc = acc addOnOpening _ Wall _ _ acc = acc
addOnOpening floorIdx b dir coord2D acc = [(Just dir, (floorIdx, twin dir coord2D)) : acc] addOnOpening floorIdx b dir coord2D acc = [(Just dir, (floorIdx, twin dir coord2D)) : acc]
...@@ -684,7 +684,7 @@ doorIsLocked roomNo exit lockMap ...@@ -684,7 +684,7 @@ doorIsLocked roomNo exit lockMap
// utility functions to find things located in the map // utility functions to find things located in the map
findAllObjects :: !(SectionInventoryMap o) -> [(!Coord3D, !Object o)] | iTask o findAllObjects :: !(SectionInventoryMap o) -> [(Coord3D, Object o)] | iTask o
findAllObjects objectMap = [ (roomNo, object) findAllObjects objectMap = [ (roomNo, object)
\\ (roomNo, objects) <- 'DM'.toList objectMap \\ (roomNo, objects) <- 'DM'.toList objectMap
, object <- 'DIS'.elems objects , object <- 'DIS'.elems objects
......
...@@ -9,6 +9,8 @@ import System.Directory, System.FilePath ...@@ -9,6 +9,8 @@ import System.Directory, System.FilePath
import Cadastre.SDS, ChamberOfCommerce.SDS, Compensation.SDS, CivilAffairs.SDS import Cadastre.SDS, ChamberOfCommerce.SDS, Compensation.SDS, CivilAffairs.SDS
import StdArray, StdFile import StdArray, StdFile
derive gDefault Date
batchProcessing :: Task () batchProcessing :: Task ()
batchProcessing batchProcessing
= pay = pay
......
...@@ -23,7 +23,7 @@ filterDirs _ = True ...@@ -23,7 +23,7 @@ filterDirs _ = True
seq [] = tuple (Ok []) seq [] = tuple (Ok [])
seq [e:es] = e >>= \a->seq es >>= \as->tuple (Ok [a:as]) seq [e:es] = e >>= \a->seq es >>= \as->tuple (Ok [a:as])
recurse :: FilePath -> .(*World -> *(MaybeError OSError [FilePath], !*World)) recurse :: FilePath -> .(*World -> *(MaybeError OSError [FilePath], *World))
recurse root recurse root
| endsWith ".dcl" root = tuple (Ok [root]) | endsWith ".dcl" root = tuple (Ok [root])
= getFileInfo root >>= \fi->if fi.directory = getFileInfo root >>= \fi->if fi.directory
......
...@@ -6,14 +6,15 @@ import iTasks.UI.Definition ...@@ -6,14 +6,15 @@ import iTasks.UI.Definition
import StdFunctions, Data.List, Text.HTML import StdFunctions, Data.List, Text.HTML
playWithMaps :: Task () playWithMaps :: Task ()
playWithMaps = withShared ({defaultValue & icons = shipIcons, tilesUrls = ["/tiles/{z}/{x}/{y}.png"]},defaultValue) (\m -> playWithMaps = withShared ({defaultValue & icons = shipIcons},defaultValue) (\m ->
((allTasks [managePerspective m, manageState m, manageMapObjects m]) <<@ ScrollContent) ((allTasks [managePerspective m, manageState m, manageMapObjects m]) <<@ ScrollContent)
-&&- -&&-
manipulateMap m manipulateMap m
) <<@ ArrangeWithSideBar 0 LeftSide True @! () ) <<@ ArrangeWithSideBar 0 LeftSide True @! ()
derive gDefault LeafletSimpleState, LeafletObjectID
manipulateMap :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds manipulateMap :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
manipulateMap m = updateSharedInformation [UpdateSharedUsing id (flip const) const (customLeafletEditor eventHandlers)] m manipulateMap m = updateSharedInformation [UpdateSharedUsing id (flip const) const (customLeafletEditor eventHandlers defaultValue)] m
<<@ ApplyLayout (layoutSubUIs (SelectByPath [1]) (setUIAttributes (sizeAttr FlexSize FlexSize))) @! () <<@ ApplyLayout (layoutSubUIs (SelectByPath [1]) (setUIAttributes (sizeAttr FlexSize FlexSize))) @! ()
where where
eventHandlers = {simpleStateEventHandlers & onHtmlEvent = onHtmlEvent} eventHandlers = {simpleStateEventHandlers & onHtmlEvent = onHtmlEvent}
......
...@@ -10,23 +10,26 @@ import Trax.UoD ...@@ -10,23 +10,26 @@ import Trax.UoD
:: RenderMode = ViewMode | PlayMode :: RenderMode = ViewMode | PlayMode
updateTraxEditor :: Bool -> UpdateSharedOption TraxSt TraxSt updateTraxEditor :: Bool -> UpdateSharedOption TraxSt TraxSt
updateTraxEditor turn = UpdateSharedUsing id (const id) const (fromSVGEditor updateTraxEditor turn = UpdateSharedUsing id (const id) const (fromSVGEditor
{ initView = id { initView = id
, renderImage = \_ -> toImage PlayMode turn , renderImage = \_ -> toImage PlayMode turn
, updModel = flip const , updModel = flip const
}) })
viewTraxEditor :: ViewOption TraxSt viewTraxEditor :: ViewOption TraxSt
viewTraxEditor = ViewUsing id (fromSVGEditor viewTraxEditor = ViewUsing id (fromSVGEditor
{ initView = id { initView = id
, renderImage = \_ -> toImage ViewMode False , renderImage = \_ -> toImage ViewMode False
, updModel = flip const , updModel = flip const
}) })
whiteColor = toSVGColor "white" whiteColor = toSVGColor "white"
redColor = toSVGColor "red" redColor = toSVGColor "red"
freeTileColor = toSVGColor "lightgrey" freeTileColor = toSVGColor "lightgrey"
transparentColor = toSVGColor "none" transparentColor = toSVGColor "none"
font = normalFontDef "Arial" 14.0
tileSize = px 50.0
toImage :: RenderMode Bool TraxSt *TagSource -> Image TraxSt toImage :: RenderMode Bool TraxSt *TagSource -> Image TraxSt
toImage ViewMode _ st _ toImage ViewMode _ st _
...@@ -34,65 +37,67 @@ toImage ViewMode _ st _ ...@@ -34,65 +37,67 @@ toImage ViewMode _ st _
toImage PlayMode my_turn st=:{turn} _ toImage PlayMode my_turn st=:{turn} _
= above (repeat AtMiddleX) [] Nothing [] [text font message, board it_is_my_turn tileSize st] NoHost = above (repeat AtMiddleX) [] Nothing [] [text font message, board it_is_my_turn tileSize st] NoHost
where where
it_is_my_turn = my_turn == turn it_is_my_turn = my_turn == turn
message = if it_is_my_turn "Select a tile" "Wait for other player..." message = if it_is_my_turn "Select a tile" "Wait for other player..."
board :: Bool Span TraxSt -> Image TraxSt board :: Bool Span TraxSt -> Image TraxSt
board it_is_my_turn d st=:{trax} board it_is_my_turn d st=:{trax}
| no_of_tiles trax == zero | no_of_tiles trax == zero
| it_is_my_turn = grid (Rows 2) (RowMajor, LeftToRight, TopToBottom) [] [] [] [] | it_is_my_turn = grid (Rows 2) (RowMajor, LeftToRight, TopToBottom) [] [] [] []
[ tileImage d tile <@< {onclick = start_with_this tile, local = False} [ tileImage d tile <@< {onclick = start_with_this tile, local = False}
\\ tile <- gFDomain{|*|} \\ tile <- gFDomain{|*|}
] NoHost ] NoHost
| otherwise = voidImage d | otherwise = voidImage d
| otherwise = grid (Rows (maxy - miny + 3)) (RowMajor, LeftToRight, TopToBottom) (repeat (AtMiddleX,AtMiddleY)) [] [] [] | otherwise = grid (Rows (maxy - miny + 3)) (RowMajor, LeftToRight, TopToBottom) (repeat (AtMiddleX,AtMiddleY)) [] [] []
[ case tile_at trax coord of [ case tile_at trax coord of
Nothing = if (it_is_my_turn && isMember coord free_coords) (freeImage d coord st) (voidImage d) Nothing = if (it_is_my_turn && isMember coord free_coords) (freeImage d coord st) (voidImage d)
Just tile = tileImage d tile Just tile = tileImage d tile
\\ row <- [miny - 1 .. maxy + 1] \\ row <- [miny - 1 .. maxy + 1]
, col <- [minx - 1 .. maxx + 1] , col <- [minx - 1 .. maxx + 1]
, let coord = fromTuple (col,row) , let coord = fromTuple (col,row)
] NoHost ] NoHost
where