Common.icl 5.78 KB
Newer Older
1 2 3 4 5 6 7
implementation module C2.Framework.Common

import iTasks

from Data.IntMap.Strict import :: IntMap
import qualified Data.IntMap.Strict as DIS
import C2.Framework.Core
Mart Lubbers's avatar
Mart Lubbers committed
8
import C2.Apps.ShipAdventure.Types
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26
import C2.Framework.Util
import C2.Framework.Entity
import C2.Framework.ContactPosition
import Math.Geometry

derive class iTask MapState

defSettings :: MapState
defSettings =
  { perspective = { ContactMapPerspective
                  | center = (deg 1.442384, deg 46.590828)
                  , zoom   = 8
                  , cursor = Nothing
                  }
  , entities    = 'DIS'.newMap
  , selection   = -1
  }

27
mapState :: SimpleSDSLens MapState
28 29
mapState = sharedStore "mapState" defSettings

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
30 31
selectedContactShare :: SDSLens () (Maybe Entity) Entity
selectedContactShare = sdsLens "selectedContactShare" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) Nothing mapState
32 33 34 35 36 37 38 39
  where
  read :: () MapState -> MaybeError TaskException (Maybe Entity)
  read _ {selection, entities} = Ok ('DIS'.get selection entities)

  write :: () MapState Entity -> MaybeError TaskException (Maybe MapState)
  write _ st=:{selection, entities} e = Ok (Just {st & entities = 'DIS'.put selection e entities})

  notify :: () MapState Entity -> SDSNotifyPred ()
Mart Lubbers's avatar
Mart Lubbers committed
40
  notify _ _ _ = \_ _ -> False
41

42
userMapState :: User -> SimpleSDSLens MapState
43 44
userMapState u = sharedStore ("userMapState" +++ toString u) defSettings

45
entityMap :: SimpleSDSLens EntityMap
46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
entityMap = sharedStore "entityMap" 'DIS'.newMap

registerEntity :: (Int -> Entity) -> Task Entity
registerEntity mkE
  =          get mapState
  >>- \ms -> let nextIdx = 'DIS'.size ms.entities
                 newE    = mkE nextIdx in
             set {ms & entities = 'DIS'.put nextIdx newE ms.entities} mapState
  >>|        return newE

updateEntity :: Int (Entity -> Entity) -> Task ()
updateEntity n f
  # focus = sdsFocus n contactWithId
  =          get focus
  >>- \mc -> case mc of
               Just e -> set (f e) focus @! ()
               _      -> return ()

Haye Böhm's avatar
Fix CI  
Haye Böhm committed
64 65
contactWithId :: SDSLens Int (Maybe Entity) Entity
contactWithId = sdsLens "contactWithId" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) Nothing mapState
66 67 68 69 70 71 72 73
  where
  read :: Int MapState -> MaybeError TaskException (Maybe Entity)
  read idx {entities} = Ok ('DIS'.get idx entities)

  write :: Int MapState Entity -> MaybeError TaskException (Maybe MapState)
  write idx st=:{entities} e = Ok (Just {st & entities = 'DIS'.put idx e entities})

  notify :: Int MapState Entity -> SDSNotifyPred Int
Mart Lubbers's avatar
Mart Lubbers committed
74
  notify idx _ _ = \_ idx` -> idx == idx`
75 76 77 78 79 80 81 82

resetMapState :: Task ()
resetMapState = set defSettings mapState @! ()

periodicallyUpdateEntity :: !Int -> Task ()
periodicallyUpdateEntity n = updateEntity n moveEntity // TODO FIXME PERFORMANCE doTaskPeriodically 1 (updateEntity n moveEntity) <<@ NoUserInterface

mapView` :: User [Entity] -> Task ()
83
mapView` currentUser es = (updateSharedInformation [UpdateSharedAs toMap fromMap (const o Just)] (userMapState currentUser >*< entityMap) @! ())
84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99
  where
  toMap :: (MapState, EntityMap) -> LeafletMap
  toMap ({MapState | perspective}, markers)
    = toLeafletMap { ContactMap
                   | perspective = perspective
                   , markers     = map (entityToMarker o snd) ('DIS'.toList markers)
                   }
  fromMap :: (MapState, EntityMap) LeafletMap -> (MapState, EntityMap)
  fromMap (st, entities) leafletMap
    # contactMap = fromLeafletMap leafletMap
    # (es, st) = foldr updMapMarkers (entities, st) contactMap.ContactMap.markers
    = ({MapState | st & perspective = contactMap.ContactMap.perspective}, es)
  updMapMarkers contactMarker (markers, st)
    # mid = toInt contactMarker.ContactMapMarker.markerId
    = case 'DIS'.get mid markers of
        Just m
100 101 102
          //# st = if contactMarker.ContactMapMarker.selected
           //        {st & selection = mid}
            //       st
103 104 105 106 107
          //= ('DIS'.put mid {Entity | m & selected = contactMarker.ContactMapMarker.selected} markers, st) // TODO FIXME
          = (markers, st)
        _ = (markers, st)


Haye Böhm's avatar
Fix CI  
Haye Böhm committed
108
mapView :: (sds () r w) (r -> Bool) User [Entity] -> Task () | iTask r & iTask w & RWShared sds
109
mapView sh radarWorks currentUser es = (updateSharedInformation [UpdateSharedAs toMap fromMap (const o Just)] (mapState >*| sh) @! ())
110 111 112 113 114 115 116 117 118 119 120 121 122 123
  where
  toMap ({perspective, entities = markers}, shval)
    = toLeafletMap { ContactMap
                   | perspective = perspective
                   , markers     = if (radarWorks shval) (map (entityToMarker o snd) ('DIS'.toList markers)) []
                   }
  fromMap (st=:{entities}, _) leafletMap
    # contactMap = fromLeafletMap leafletMap
    # (es, st) = foldr updMapMarkers (entities, st) contactMap.ContactMap.markers
    = {st & perspective = contactMap.ContactMap.perspective, entities = es}
  updMapMarkers contactMarker (markers, st)
    # mid = toInt contactMarker.ContactMapMarker.markerId
    = case 'DIS'.get mid markers of
        Just m
124 125 126
          //# st = if contactMarker.ContactMapMarker.selected
           //        {st & selection = mid}
            //       st
127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
          //= ('DIS'.put mid {Entity | m & selected = contactMarker.ContactMapMarker.selected} markers, st) TODO FIXME
          = (markers, st)
        _ = (markers, st)

entityToMarker :: Entity -> ContactMapMarker
entityToMarker se
  = { ContactMapMarker
    | markerId = toString se.Entity.e_id
    , title    = Just ("{classification} " +++ toString se.Entity.e_id)
    , position = toPos se.Entity.e_position
    , type     = Just CMOther // TODO "{classification}"
    , heading  = case se.Entity.e_position of
                    MovingPos mp -> Just (toDeg mp.mp_direction)
                    _            -> Nothing
    , selected = False // TODO FIXME se.Entity.selected
    }
    where
    toPos (MovingPos mp) = mp.mp_position
    toPos _              = (deg 0.0, deg 0.0) // TODO FIXME