Commit 413250ec authored by Jurriën Stutterheim's avatar Jurriën Stutterheim

Add C2 demo to Applications examples

parent ec26688a
definition module C2.Apps.ShipAdventure.Core
import iTasks
myTasks :: [Workflow]
currentUserWalkAround :: Task ()
giveInstructions :: Task ()
This diff is collapsed.
definition module C2.Apps.ShipAdventure.Editor
import iTasks
import C2.Framework.MapEnvironment
import C2.Apps.ShipAdventure.Types
shipEditorTabs :: Task ()
sharedMapAction :: RWShared () (MapAction SectionStatus) (MapAction SectionStatus)
This diff is collapsed.
definition module C2.Apps.ShipAdventure.Images
import C2.Framework.MapEnvironment
import C2.Apps.ShipAdventure.Types
:: RenderMode
= PickRoomMode
| KitchenMode
| WalkAroundMode
| EditMode
| DOffMode
derive class iTask RenderMode
:: EditHilite = MapHilite !Maps2DIndex | SectionHilite !Maps2DIndex !Coord2D
mapTitleImage :: !Maps2DIndex !(Maybe EditHilite) !Size2D !String -> Image m
maps2DImage :: !(Set Coord3D) !(MapAction SectionStatus) !RenderMode !Maps2D !SectionExitLockMap !SectionHopLockMap !MySectionInventoryMap !MySectionStatusMap !SectionUsersMap !(UserActorMap ObjectType ActorStatus) !(IntMap Device) !Network !*TagSource
-> Image (Maps2D, MapAction SectionStatus)
map2DImage :: !(Set Coord3D) !(MapAction SectionStatus) !RenderMode !SectionExitLockMap !SectionHopLockMap !MySectionInventoryMap !MySectionStatusMap !SectionUsersMap !(UserActorMap ObjectType ActorStatus) !(IntMap Device) !Network !(!Maps2DIndex, !Map2D)
-> Image (Maps2D, MapAction SectionStatus)
roomImage :: !Coord3D !SectionExitLockMap !SectionHopLockMap !MyInventory !SectionStatus !MyActors !(IntMap Device) !Network !Bool !Section !Map2D !(MapAction SectionStatus) !*TagSource
-> Image (Maps2D, MapAction SectionStatus)
editLayoutImage :: !(MapAction SectionStatus) !(IntMap Device) !Network !MySectionInventoryMap !Maps2DIndex !Map2D
-> Image (Maps2D, MapAction SectionStatus)
This diff is collapsed.
definition module C2.Apps.ShipAdventure.PathFinding
import C2.Apps.ShipAdventure.Types
// given object to search for, current location and current map
smartShipPathToClosestObject :: !ObjectType !MySectionInventoryMap !Coord3D !Coord3D !MySectionStatusMap !SectionExitLockMap !SectionHopLockMap !Graph
-> (!Maybe MyObject, !Int, !Distance, !Int, !(!Coord3D, !Distance, !Maybe [Coord3D]))
// given object to search for, current location, target room to move to with object, and current map
shipShortestPath :: !Coord3D !Coord3D !MySectionStatusMap !SectionExitLockMap !SectionHopLockMap !Graph
-> Maybe (![Coord3D], !Distance)
// shortest path given the alarms set on the ship
implementation module C2.Apps.ShipAdventure.PathFinding
import C2.Framework.MapEnvironment
import C2.Apps.ShipAdventure.Types
// returns: distance, number of objects found, location of object, distance to object, shortest path to obejct
//shipPathToClosestObject :: Object Coord3D MyMap -> (Int,(Coord3D,Distance, Maybe ([Exit], Distance)))
//shipPathToClosestObject kind actorLoc curMap = pathToClosestObject shipShortestPath kind actorLoc curMap
smartShipPathToClosestObject :: !ObjectType !MySectionInventoryMap !Coord3D !Coord3D !MySectionStatusMap !SectionExitLockMap !SectionHopLockMap !Graph
-> (!Maybe MyObject, !Int, !Distance, !Int, !(!Coord3D, !Distance, !Maybe [Coord3D]))
smartShipPathToClosestObject kind inventoryMap actorLoc targetLoc statusMap exitLocks hopLocks curMap = smartPathToClosestObject shipShortestPath kind actorLoc targetLoc statusMap inventoryMap exitLocks hopLocks curMap
// shortest path given the alarms set on the ship
shipShortestPath :: !Coord3D !Coord3D !MySectionStatusMap !SectionExitLockMap !SectionHopLockMap !Graph -> Maybe (![Coord3D], !Distance)
shipShortestPath startCoord3D endCoord3D statusMap exitLocks hopLocks graph = shortestPath cost startCoord3D endCoord3D statusMap exitLocks hopLocks graph
where
cost :: !SectionStatus -> Int
cost status = 1 + statusCost status
statusCost :: !SectionStatus -> Int
statusCost HasSomeWater = 500
statusCost IsFlooded = 1000
statusCost HasSmoke = 400
statusCost HasSmallFire = 500
statusCost HasMediumFire = 750
statusCost HasBigFire = 1000
statusCost _ = 0
definition module C2.Apps.ShipAdventure.Scripting
import iTasks
import C2.Apps.ShipAdventure.Types
// script language
:: Target = Section Coord3D
| Nearest ObjectType
| TargetSection
:: Script = MoveTo Target
| Take ObjectType
| Drop ObjectType
| Use ObjectType
| ReSetTargetDetector
| If Condition [Script] [Script]
:: Condition = ObjectInCurrentSection ObjectType
| CarriesObject ObjectType
| ActorStatus ActorStatus
| And Condition Condition
| Or Condition Condition
derive class iTask Target, Script, Condition
handleFireScript :: Shared [Script]
handleFloodScript :: Shared [Script]
handleSmokeScript :: Shared [Script]
changeFireScript :: Task ()
changeFloodScript :: Task ()
changeSmokeScript :: Task ()
interperScript :: !(!Coord3D, !SectionStatus) !User ![Script] -> Task Bool
implementation module C2.Apps.ShipAdventure.Scripting
import iTasks
import C2.Apps.ShipAdventure.Types
import C2.Apps.ShipAdventure.PathFinding
import C2.Apps.ShipAdventure.Util
import qualified Data.IntMap.Strict as DIS
import qualified Data.Map as DM
// scripted simulation
derive class iTask Target, Script, Condition
handleFireScript :: Shared [Script]
handleFireScript = sharedStore "handleFireScript" []
handleFloodScript :: Shared [Script]
handleFloodScript = sharedStore "handleFloodScript" []
handleSmokeScript :: Shared [Script]
handleSmokeScript = sharedStore "handleSmokeScript" []
changeFireScript :: Task ()
changeFireScript = changeScript "Handling Fire" handleFireScript
changeFloodScript :: Task ()
changeFloodScript = changeScript "Handling Flood" handleFloodScript
changeSmokeScript :: Task ()
changeSmokeScript = changeScript "Handling Smoke" handleSmokeScript
changeScript :: !String !(Shared [Script]) -> Task ()
changeScript prompt script
= viewSharedInformation ("Current Script: " <+++ prompt) [ViewAs (\script -> [toString i +++ " : " +++ line \\ line <- map toSingleLineText script & i <- [1..]])] script
>>* [ OnAction (Action "Fine" []) (always (return ()))
, OnAction (Action "Change" []) (always ( updateSharedInformation ("Change Script: " <+++ prompt) [] script
>>| changeScript prompt script
))
]
interperScript :: !(!Coord3D, !SectionStatus) !User ![Script] -> Task Bool
interperScript (targetSection, status) user script
= get (sectionUsersShare |*| myUserActorMap)
>>- \(sectionUsersMap, userActorMap) -> case findUser user sectionUsersMap userActorMap of
Just user -> perform script user
_ -> return False
where
perform :: ![Script] !(!Coord3D, !MyActor) -> Task Bool
perform [] _ = return True
perform [MoveTo target:next] (actorLoc,actor)
= get (myStatusMap |*| myInventoryMap |*| lockedExitsShare |*| lockedHopsShare |*| sharedGraph)
>>- \((((statusMap, invMap), exitLocks), hopLocks), graph) ->
let newLoc = whereIs targetSection target actorLoc statusMap invMap exitLocks hopLocks graph
in autoMove actorLoc newLoc shipShortestPath actor.userName myStatusMap myUserActorMap
>>| perform next (newLoc,actor)
perform [Take objType`:next] (actorLoc,actor)
= get myInventoryMap
>>- \invMap -> case 'DM'.get actorLoc invMap of
Just inv
= case [obj \\ obj=:{Object | objType } <- 'DIS'.elems inv | objType` == objType] of
[obj : _] = pickupObject actorLoc obj actor.userName myUserActorMap inventoryInSectionShare
>>| perform next (actorLoc,actor)
_ = perform next (actorLoc, actor)
_ = perform next (actorLoc, actor)
perform [Drop objType`:next] (actorLoc,actor)
= case [obj \\ obj=:{Object | objType } <- actor.carrying | objType` == objType] of
[obj : _]
= dropObject actorLoc obj actor.userName myUserActorMap inventoryInSectionShare
>>| perform next (actorLoc,actor)
_ = perform next (actorLoc,actor)
perform [Use objType`:next] (actorLoc,actor)
= case [obj \\ obj=:{Object | objType } <- actor.carrying | objType` == objType] of
[obj : _]
= useObject actorLoc obj actor.userName myUserActorMap inventoryInSectionShare
>>| perform next (actorLoc,actor)
_ = perform next (actorLoc,actor)
perform [ReSetTargetDetector:next] (actorLoc,actor)
= setAlarm actor.userName (targetSection, NormalStatus) myStatusMap
>>| perform next (actorLoc,actor)
perform [If condition script1 script2:next] (actorLoc,actor)
= get myInventoryMap
>>= \invMap -> case 'DM'.get actorLoc invMap of
Just inv
| isTrue ('DIS'.elems inv) condition (actorLoc,actor) = perform (script1 ++ next) (actorLoc, actor)
_ = perform (script2 ++ next) (actorLoc, actor)
isTrue :: ![MyObject] !Condition !(!Coord3D, !MyActor) -> Bool
isTrue inv (ObjectInCurrentSection object) (actorLoc,actor)
= objTypeInList object inv
isTrue inv (CarriesObject object) (actorLoc,actor)
= isCarrying object actor
isTrue inv (ActorStatus status) (actorLoc,actor)
= status === actor.actorStatus
isTrue inv (And cond1 cond2) (actorLoc,actor)
= and [isTrue inv cond1 (actorLoc,actor), isTrue inv cond2 (actorLoc,actor)]
isTrue inv (Or cond1 cond2) (actorLoc,actor)
= or [isTrue inv cond1 (actorLoc,actor), isTrue inv cond2 (actorLoc,actor)]
whereIs :: Coord3D !Target Coord3D MySectionStatusMap MySectionInventoryMap SectionExitLockMap SectionHopLockMap Graph -> Coord3D
whereIs _ (Section nr) _ _ _ _ _ _ = nr
whereIs targetSection (Nearest object) actorLoc statusMap inventoryMap exitLocks hopLocks graph
#! (_,_,_,_,(objectLoc,_,_)) = smartShipPathToClosestObject object inventoryMap actorLoc targetSection statusMap exitLocks hopLocks graph
= objectLoc
whereIs targetSection TargetSection _ _ _ _ _ _ = targetSection
definition module C2.Apps.ShipAdventure.Types
import C2.Framework.MapEnvironment
import GenLexOrd
from C2.Apps.ShipAdventure.Images import :: RenderMode
:: MyActor :== Actor ObjectType ActorStatus
:: MyObject :== Object ObjectType
:: MySectionStatusMap :== SectionStatusMap SectionStatus
:: MySectionInventoryMap :== SectionInventoryMap ObjectType
:: MyInventory :== IntMap (Object ObjectType)
:: MyActors :== [Actor ObjectType ActorStatus]
:: MyDrawMapForActor :== DrawMapForActor SectionStatus ObjectType ActorStatus
:: SectionStatus
= NormalStatus
| HasSomeWater
| IsFlooded
| HasSmoke
| HasSmallFire
| HasMediumFire
| HasBigFire
:: ObjectType = FireExtinguisher
| FireBlanket
| Plug
:: ActorStatus = { occupied :: !Availability
, health :: !ActorHealth
, energy :: !ActorEnergy
}
:: Availability = Available | NotAvailable | Busy
:: ActorHealth = FullHealth | AScratch | CompletelyWorn
:: ActorEnergy = FullEnergy | SomewhatTired | Fatigued
:: Priority = Low | Normal | High | Highest
// logical devices
:: DeviceType =
{ kind :: !DeviceKind
, requires :: !Map CableType Capacity
, produces :: !Map CableType Capacity
}
:: DeviceKind = Radar
| Apar
| Sonar
| Hydrophone
| Radio
| PowerGenerator
| CoolingPump
| Gun
| GasTurbine
| DieselEngine
| SmokeDetector
| HeatSensor
| WaterSensor
:: CableType = PowerCable | CoolingPipe | DataCable
:: Capacity :== Int
// physical devices
:: Network =
{ devices :: !Map Coord3D [DeviceId] // [Coord3D |-> DeviceIds]
, cables :: !IntMap Cable // [CableId |-> Cable]
, cableMapping :: !IntMap [(!Operational, !Coord3D)] // [CableId |-> Coord3Ds]
}
:: Device =
{ description :: !String
, deviceType :: !DeviceType
, deviceId :: !DeviceId
, inCables :: ![CableId]
, outCables :: ![CableId]
}
:: DeviceId :== Int
:: CableId :== Int
:: Cable = // Edge
{ description :: !String
, cableId :: !CableId
, capacity :: !Capacity
, cableType :: !CableType
}
:: Operational :== Bool
:: PPDevice =
{ description :: !String
, deviceType :: !PPDeviceType
, deviceId :: !DeviceId
, inCables :: ![CableId]
, outCables :: ![CableId]
}
:: PPDeviceType =
{ kind :: !DeviceKind
, requires :: ![(!CableType, !Capacity)]
, produces :: ![(!CableType, !Capacity)]
}
:: CommandAim =
{ aimDescription :: !String
, requiredCapabilities :: ![Capability]
}
:: Capability
= Propulsion
| RadioCommunication
| SatelliteCommunication
| AirSensors
| SurfaceSensors
| SubsurfaceSensors
| SurfaceToAirOffence
| SurfaceToSurfaceOffence
| SurfaceToSubsurfaceOffence
| AirDefence
| SurfaceDefence
| SubsurfaceDefence
:: CapabilityExpr
= DeviceExpr DeviceKind
| CapAndExpr CapabilityExpr CapabilityExpr
| CapOrExpr CapabilityExpr CapabilityExpr
:: CapabilityToDeviceKindMap :== Map Capability CapabilityExpr
derive class iTask PPDevice, PPDeviceType, CommandAim, Capability, CapabilityExpr
derive gLexOrd CableType, Capability
derive class iTask ObjectType, ActorStatus, Availability, ActorHealth, ActorEnergy, DeviceType, SectionStatus
derive class iTask Cable, Priority, Network, Device, CableType, DeviceKind
instance == ObjectType
instance == Priority
instance == CableType
instance == Device
instance == DeviceType
instance == DeviceKind
instance == Capability
instance < CableType
instance < Capability
instance toString ObjectType
//instance toString Exit
instance toString SectionStatus
instance toString Device
// shared stores:
myUserActorMap :: UserActorShare ObjectType ActorStatus
myStatusMap :: RWShared () MySectionStatusMap MySectionStatusMap
myInventoryMap :: RWShared () MySectionInventoryMap MySectionInventoryMap
myNetwork :: RWShared () Network Network
myCables :: RWShared () (IntMap Cable) (IntMap Cable)
myDevices :: RWShared () (IntMap Device) (IntMap Device)
commandAims :: RWShared () [CommandAim] [CommandAim]
capabilityMap :: RWShared () CapabilityToDeviceKindMap CapabilityToDeviceKindMap
disabledSections :: RWShared () (Set Coord3D) (Set Coord3D)
deviceKindsForCapability :: RWShared Capability CapabilityExpr CapabilityExpr
statusInSectionShare :: RWShared Coord3D SectionStatus SectionStatus
inventoryInSectionShare :: FocusedSectionInventoryShare ObjectType
deviceIdInNetworkSectionShare :: RWShared Coord3D [DeviceId] [DeviceId]
devicesInSectionShare :: RWShared Coord3D [Device] [Device]
deviceWithIdShare :: RWShared DeviceId Device Device
cableWithIdShare :: RWShared CableId Cable Cable
cablesInSectionShare :: RWShared Coord3D [Cable] [Cable]
cablesForSection :: !Coord3D !Network -> [Cable]
allActiveAlarms :: ReadOnlyShared [(!Coord3D, !SectionStatus)]
allAvailableActors :: ReadOnlyShared [(!Coord3D, !MyActor)]
// setting and resetting of the detection systems:
setAlarm :: !User !(!Coord3D, !SectionStatus) !(Shared MySectionStatusMap) -> Task ()
// making images from a map
setSectionDetectors :: Task ()
cutCable :: !Coord3D !CableId !Network -> Network
patchCable :: !Coord3D !CableId !Network -> Network
viewDisabledDevices :: Task ()
hasFire :: !SectionStatus -> Bool
hasSmoke :: !SectionStatus -> Bool
hasWater :: !SectionStatus -> Bool
deviceIsEnabled :: !Device !(IntMap Device) !Network -> Bool
isDetector :: !DeviceKind -> Bool
updateMapStatus :: !RenderMode -> Task (MapAction SectionStatus)
allDisabledDevices :: !(IntMap Device) !Network -> [Device]
allImperiledCommandAims :: !(IntMap Device) !CapabilityToDeviceKindMap ![CommandAim] !Network -> [CommandAim]
deviceIsDisabledInSection :: !Coord3D !Device !(IntMap Device) !Network -> Bool
isOperational :: !CableId !(IntMap [(!Operational, !Coord3D)]) -> Bool
devicesForCable :: !Cable !(IntMap Device) !Network -> [Device]
devicesForCableInSection :: !Coord3D !Cable !(IntMap Device) !Network -> [Device]
toPPDevice :: !Device -> PPDevice
This diff is collapsed.
definition module C2.Apps.ShipAdventure.Util
import C2.Apps.ShipAdventure.Types
isCarrying :: !ObjectType !MyActor -> Bool
objTypeInList :: !ObjectType ![MyObject] -> Bool
implementation module C2.Apps.ShipAdventure.Util
import C2.Apps.ShipAdventure.Types
isCarrying :: !ObjectType !MyActor -> Bool
isCarrying objType` {Actor | carrying } = objTypeInList objType` carrying
objTypeInList :: !ObjectType ![MyObject] -> Bool
objTypeInList objType` objs = length [0 \\ {Object | objType } <- objs | objType == objType`] > 0
definition module C2.Framework.Common
import iTasks
from Data.IntMap.Strict import :: IntMap
from C2.Framework.Entity import :: Entity
from C2.Framework.ContactPosition import :: ContactMapPerspective
:: EntityMap :== IntMap Entity
:: MapState =
{ perspective :: ContactMapPerspective
, entities :: IntMap Entity
, selection :: Int
}
derive class iTask MapState
mapState :: RWShared () MapState MapState
entityMap :: RWShared () EntityMap EntityMap
registerEntity :: (Int -> Entity) -> Task Entity
updateEntity :: Int (Entity -> Entity) -> Task ()
contactWithId :: RWShared Int (Maybe Entity) Entity
selectedContactShare :: RWShared () (Maybe Entity) Entity
resetMapState :: Task ()
periodicallyUpdateEntity :: !Int -> Task ()
mapView :: (RWShared () r w) (r -> Bool) User [Entity] -> Task () | iTask r
userMapState :: User -> Shared MapState