Common.icl 5.68 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
implementation module C2.Framework.Common

import iTasks

from Data.IntMap.Strict import :: IntMap
import qualified Data.IntMap.Strict as DIS
import C2.Framework.Core
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
  }

mapState :: RWShared () MapState MapState
mapState = sharedStore "mapState" defSettings

selectedContactShare :: RWShared () (Maybe Entity) Entity
selectedContactShare = sdsLens "selectedContactShare" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) mapState
  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
39
  notify _ _ _ = \_ _ -> False
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

userMapState :: User -> Shared MapState
userMapState u = sharedStore ("userMapState" +++ toString u) defSettings

entityMap :: RWShared () EntityMap EntityMap
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 ()

contactWithId :: RWShared Int (Maybe Entity) Entity
contactWithId = sdsLens "contactWithId" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) mapState
  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
73
  notify idx _ _ = \_ idx` -> idx == idx`
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

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 ()
mapView` currentUser es = (updateSharedInformation () [UpdateAs toMap fromMap] (userMapState currentUser >+< entityMap) @! ()) 
  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
          # st = if contactMarker.ContactMapMarker.selected
                   {st & selection = mid}
                   st
          //= ('DIS'.put mid {Entity | m & selected = contactMarker.ContactMapMarker.selected} markers, st) // TODO FIXME
          = (markers, st)
        _ = (markers, st)


Bas Lijnse's avatar
Bas Lijnse committed
107
mapView :: (RWShared () r w) (r -> Bool) User [Entity] -> Task () | iTask r & iTask w
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145
mapView sh radarWorks currentUser es = (updateSharedInformation () [UpdateAs toMap fromMap] (mapState >*| sh) @! ())
  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
          # st = if contactMarker.ContactMapMarker.selected
                   {st & selection = mid}
                   st
          //= ('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