Scripting.icl 5.34 KB
Newer Older
1 2 3 4 5 6 7 8 9
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
10
import Data.Map.GenJSON
11 12 13 14 15

// scripted simulation

derive class iTask Target, Script, Condition

16
handleFireScript :: SimpleSDSLens [Script]
17 18
handleFireScript = sharedStore "handleFireScript" []

19
handleFloodScript :: SimpleSDSLens [Script]
20 21
handleFloodScript = sharedStore "handleFloodScript" []

22
handleSmokeScript :: SimpleSDSLens [Script]
23 24 25
handleSmokeScript = sharedStore "handleSmokeScript" []

changeFireScript :: Task ()
26
changeFireScript = changeScript "Handling Fire" handleFireScript
27 28

changeFloodScript :: Task ()
29
changeFloodScript = changeScript "Handling Flood" handleFloodScript
30 31

changeSmokeScript :: Task ()
32
changeSmokeScript = changeScript "Handling Smoke" handleSmokeScript
33

34
changeScript :: !String !(Shared sds [Script]) -> Task () | RWShared sds
35 36
changeScript prompt script
  =   viewSharedInformation ("Current Script: " <+++ prompt) [ViewAs (\script -> [toString i +++ " : " +++ line \\ line <- map toSingleLineText script & i <- [1..]])] script
Bas Lijnse's avatar
Bas Lijnse committed
37 38
  >>* [ OnAction (Action "Fine") (always (return ()))
      , OnAction (Action "Change") (always (   updateSharedInformation ("Change Script: " <+++ prompt) [] script
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
                                              >>| 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