purescript-studio/src/Model.purs at 17f950f99591efa02bf51b01d729adc20a3f7ecd · statebox/purescript-studio · GitHub

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
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
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
module Model where

import Prelude
import Data.Array ((..), length)
import Data.Bag (BagF(..))
import Data.FunctorWithIndex (mapWithIndex)
import Data.Map as Map
import Data.Map (Map)
import Data.Maybe (Maybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype)
import Data.Tuple.Nested (type (/\), (/\))

import Data.Petrinet.Representation.Dict (TransitionF, MarkingF, PlaceMarkingF, findTokens', NetRepF, NetObjF, NetApiF, mkNetObjF)
import Data.Vec2D (Vec2D)

data QueryF pid tid a
  = LoadNet (NetObjF pid tid Tokens Typedef) a
  | FireTransition tid a
  | FocusTransition tid a
  | FocusPlace pid a
  | UpdatePlace (PlaceQueryF pid a)
  | UpdateTransition (TransitionQueryF tid a)
  | FocusArc tid a
  | UpdateArc (ArcQueryF tid a)

data PlaceQueryF pid a
  = UpdatePlaceLabel pid String a

data TransitionQueryF tid a
  = UpdateTransitionName tid String a
  | UpdateTransitionType tid Typedef a

newtype Guard = Guard String

data ArcQueryF tid a
  = UpdateArcLabel tid String a

newtype Typedef = Typedef String

derive instance newtypeTypedef :: Newtype (Typedef)  _

-- | Messages sent to the outside world (i.e. parent components).
--   TODO This is a dummy placeholder for now.
data Msg = NetUpdated

type NetInfoFRow pid tid r =
  ( name   :: String
  , net    :: NetObjF pid tid Tokens Typedef
  , netApi :: NetApiF pid tid Tokens
  | r
  )

type NetInfoF pid tid r = Record (NetInfoFRow pid tid r)

-- types specialised to Int index ----------------------------------------------

type PID          = Int
type TID          = Int
type Tokens       = Int

type Transition   = TransitionF   PID Tokens
type Marking      = MarkingF      PID Tokens
type PlaceMarking = PlaceMarkingF PID Tokens

type NetRep = NetRepF PID TID Tokens Typedef ()

type NetObj = NetObjF PID TID Tokens Typedef

type NetApi = NetApiF PID TID Tokens

type NetInfo = Record (NetInfoFRow PID TID ())

-- empty net -------------------------------------------------------------------

emptyNetData :: NetRep
emptyNetData = mkNetRep mempty mempty (BagF mempty) mempty mempty mempty mempty mempty

emptyNet :: NetObj
emptyNet = mkNetObjF emptyNetData

emptyNetApi :: NetApi
emptyNetApi =
  { findTokens : findTokens' emptyNetData.marking
  }

emptyNetInfo :: NetInfo
emptyNetInfo = { net: emptyNet, netApi: emptyNetApi, name: "" }

--------------------------------------------------------------------------------

mkNetRep
  :: Array PID
  -> Array Transition
  -> Marking
  -> Array (PID /\ String)
  -> Array (PID /\ Vec2D)
  -> Array String
  -> Array Typedef
  -> Array Vec2D
  -> NetRep
mkNetRep places transitions marking placeLabels placePoints transitionLabels transitionTypes transitionPoints =
  { places:               places
  , transitionsDict:      transitionsDict
  , marking:              marking
  , placeLabelsDict:      placeLabelsDict
  , placePointsDict:      placePointsDict
  , transitionLabelsDict: transitionLabelsDict
  , transitionTypesDict:  transitionTypesDict
  , transitionPointsDict: transitionPointsDict
  }
  where
    -- TODO check +1
    firstTransitionIndex = length places + 1

    transitionsDict :: Map Int Transition
    transitionsDict = Map.fromFoldable $ zipWithIndexFrom firstTransitionIndex transitions

    placeLabelsDict :: Map Int String
    placeLabelsDict = Map.fromFoldable placeLabels

    placePointsDict = Map.fromFoldable placePoints

    transitionLabelsDict = Map.fromFoldable $ zipWithIndexFrom firstTransitionIndex transitionLabels

    transitionTypesDict = Map.fromFoldable $ zipWithIndexFrom firstTransitionIndex transitionTypes

    transitionPointsDict = Map.fromFoldable $ zipWithIndexFrom firstTransitionIndex transitionPoints

--------------------------------------------------------------------------------

zipWithIndexFrom :: forall v. Int -> Array v -> Array (Int /\ v)
zipWithIndexFrom i0 xs = mapWithIndex (\i x -> (i0+i) /\ x) xs