Skip to content

Commit d0d8f7d

Browse files
epostepost
committedJan 17, 2020
stbx-core: Petri net execution folding experiments. #307 
1 parent ef6450e commit d0d8f7d

File tree

1 file changed

+216
-0
lines changed

1 file changed

+216
-0
lines changed
 

‎stbx-core/test/Statebox/Core/Execution/Experiment.purs

Lines changed: 216 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,216 @@
1+
module Test.Statebox.Core.Execution.Experiment where
2+
3+
import Prelude
4+
import Control.Monad.State
5+
6+
-- import Data.Array (length, (..))
7+
import Data.Foldable (foldl, foldr)
8+
import Data.Maybe (Maybe(..)) -- , fromMaybe, maybe)
9+
10+
import Statebox.Core.Execution (GluedMarking, StbxObj, Marked)
11+
import Statebox.Core (decode) as Stbx
12+
import Statebox.Core.Execution as Stbx
13+
import Statebox.Core.Types (GluedTransitionId(..), TID, Wiring)
14+
-- import Statebox.Core.Transaction (HashStr, TxSum, FiringTx, WiringTx, isExecution)
15+
16+
import Effect.Class (liftEffect)
17+
18+
import Test.Spec (Spec, describe, it)
19+
import Test.Spec.Assertions (shouldEqual)
20+
import Test.Spec.Console (write)
21+
import Debug.Trace (spy)
22+
23+
24+
25+
-- TODO when applying it using (modify fire 3) we want the TID first
26+
-- fire :: StbxObj -> TID -> Maybe Marked
27+
-- fire' :: GluedTransitionId -> StbxObj -> Maybe StbxObj
28+
fire' :: TID -> StbxObj -> Maybe StbxObj
29+
fire' tid s = map Stbx.fromMarked $ Stbx.fire s tid
30+
31+
-- -- state type: GluedMarking? StbxObj? anders?
32+
-- x1 :: forall m. StateT GluedMarking _
33+
-- x1 = do
34+
-- modify Stbx.fire
35+
36+
--------------------------------------------------------------------------------
37+
38+
-- hmm, perhaps monadic proggies like this would be convenient if we're
39+
-- *generating* code from a statebox protocol, but i'm not sure how useful this
40+
-- is for our use case here
41+
42+
-- glued TID?
43+
-- enabledTIDs :: forall m. StateT (Maybe StbxObj) m (Array TID)
44+
enabledTIDs :: State (Maybe StbxObj) (Array TID)
45+
enabledTIDs = do
46+
s0 <- get
47+
let s1 = fire'' 3 s0
48+
put s1
49+
50+
s2 <- modify $ fire'' 2
51+
pure [42]
52+
where
53+
-- get inside the Maybe
54+
fire'' tid soM = soM >>= fire' tid
55+
56+
--------------------------------------------------------------------------------
57+
58+
-- TODO TxSum or sth?
59+
execTrace1_txs :: Array _
60+
execTrace1_txs = []
61+
62+
-- TODO glued tid?
63+
execTrace1_tids :: Array TID
64+
execTrace1_tids = [3, 2, 4, 1]
65+
66+
-- from tx view code ------------------------------------------------------------------------------
67+
68+
type GluedTID = TID
69+
-- TODO should really be (Set GluedTID) instead of Array
70+
type NetState = { marking :: Unit, enabled :: Array GluedTID }
71+
72+
-- computeNetState :: Array GluedTID -> NetState
73+
computeNetState :: Array GluedTID -> NetState
74+
computeNetState tids = foldr (\tid acc -> { marking: unit
75+
, enabled: acc.enabled <> [tid]
76+
})
77+
{ marking: unit, enabled: [] }
78+
tids
79+
80+
-- what to do in case of failing fire?
81+
-- - record in history log which firings were successful
82+
-- - have the state be non-optional? but with indications re up to which firing it was successful?
83+
84+
type NetState' =
85+
{ stbxObjM :: Maybe StbxObj -- TODO either? we want to give reasons for failure, eg transition doesnt exist or not enabled
86+
, log :: Array TID -- we also want to log markings
87+
}
88+
89+
-- type LogEntry = { tid :: TID, marking :: ... }
90+
91+
foldrNetState' :: StbxObj -> Array GluedTID -> NetState'
92+
foldrNetState' initialState tids =
93+
foldr (\tid previousState ->
94+
{ stbxObjM: fire' tid =<< previousState.stbxObjM
95+
, log: previousState.log <> [tid]
96+
}
97+
)
98+
(mkState initialState)
99+
tids
100+
where
101+
mkState :: StbxObj -> NetState'
102+
mkState o = { stbxObjM: pure o, log: mempty }
103+
104+
foldlNetState' :: StbxObj -> Array GluedTID -> NetState'
105+
foldlNetState' initialState tids =
106+
foldl (\previousState tid ->
107+
{ stbxObjM: fire' tid =<< previousState.stbxObjM
108+
, log: previousState.log <> [tid]
109+
}
110+
)
111+
(mkState initialState)
112+
tids
113+
where
114+
mkState :: StbxObj -> NetState'
115+
mkState o = { stbxObjM: pure o, log: mempty }
116+
117+
--------------------------------------------------------------------------------
118+
119+
-- TODO dedupe
120+
wiring1 :: Wiring
121+
wiring1 =
122+
{ nets: [ { name: "a"
123+
, partition: [0,1,0,1,0,0]
124+
, names: ["t","u"]
125+
, placeNames: Nothing
126+
}
127+
]
128+
, diagrams: [ { name: "z"
129+
, width: 1
130+
, pixels: [1,2]
131+
, names: ["m","n"]
132+
}
133+
]
134+
, labels: [0,0]
135+
}
136+
137+
suite :: Spec Unit
138+
suite = do
139+
let
140+
s0 = spy "s0" $ Stbx.fromWiring wiring1
141+
describe "Stbx" do
142+
it "koekjedepoekje" do
143+
-- so <- liftEffect $ Stbx.decode "0a20dce4021c8f117e89c479665f6d61ff650b150af375d6498b593da6afa8d2ca9f1afa010add010a0a70726976696c656467651001100010021000100210001006100010011000100310001003100010011000100210001004100010031000100510001004100010051000100110001005100010021000100510001006100010021000100610001003100010061000100510001000100310001a036275791a07666f7253616c651a05626c6f636b1a07756e626c6f636b1a047363616e1a086e6f74536f6c64321a0873686f774f7665721a076e6f74536f6c641a066e6f53686f771a04627579271a076275794261636b1a096e6f745265736f6c641a0663726561746512160a046d61696e10011801220a70726976696c656467651800"
144+
145+
let
146+
-- s0 = spy "s0" $ Stbx.fromWiring wiring1
147+
transitions = spy "transitions" $ Stbx.gluedTransitions s0
148+
transitionCount = spy "transitionCount" $ Stbx.transitionCount s0
149+
transitionIds = spy "transitionIds" $ Stbx.transitionIds s0
150+
151+
e0 = spy "e0" $ Stbx.enabledMaybe s0 0
152+
e1 = spy "e1" $ Stbx.enabledMaybe s0 1
153+
e2 = spy "e2" $ Stbx.enabledMaybe s0 2
154+
es = spy "es" $ Stbx.enabledTransitionIds s0
155+
156+
liftEffect $ write $ show e0
157+
liftEffect $ write $ show e1
158+
liftEffect $ write $ show e2
159+
liftEffect $ write $ show es
160+
161+
-- liftEffect $ write "hoi poes"
162+
let s0Dump = spy "s0" s0
163+
164+
es `shouldEqual` (GluedTransitionId <$> [0])
165+
166+
it "should produce expected results from sequence of firings #1" do
167+
let s0sl = spy "s0s" $ foldlNetState' s0 $ []
168+
let s1sl = spy "s1s" $ foldlNetState' s0 $ [0]
169+
let s2sl = spy "s2s" $ foldlNetState' s0 $ [0,1]
170+
let s3sl = spy "s3s" $ foldlNetState' s0 $ [0,1,2]
171+
172+
-- TODO oh right, wait, bc we do foldR instead of foldL this should be flipped too
173+
let s0s = spy "s0s" $ foldrNetState' s0 $ [2,1,0]
174+
175+
liftEffect $ write "\n"
176+
liftEffect $ write $ show $ spy "marking" $ Stbx.marking <$> s0s.stbxObjM
177+
liftEffect $ write "\n"
178+
liftEffect $ write $ show $ spy "enabled trs" $ Stbx.enabledTransitionIds <$> s0s.stbxObjM
179+
liftEffect $ write "\n"
180+
liftEffect $ write $ show $ spy "marking s0sl" $ Stbx.marking <$> s0sl.stbxObjM
181+
liftEffect $ write "\n"
182+
liftEffect $ write $ show $ spy "marking s1sl" $ Stbx.marking <$> s1sl.stbxObjM
183+
liftEffect $ write "\n"
184+
liftEffect $ write $ show $ spy "marking s2sl" $ Stbx.marking <$> s2sl.stbxObjM
185+
liftEffect $ write "\n"
186+
liftEffect $ write $ show $ spy "marking s3sl" $ Stbx.marking <$> s3sl.stbxObjM
187+
s0s.log `shouldEqual` ([0,1,2])
188+
189+
-- let decodedJsonString = Stbx.stbxObjToJsonString decodedStbxObj
190+
-- 1 `shouldEqual` 2
191+
192+
it "should produce expected results from sequence of firings #1" do
193+
let s0sl = spy "s0s" $ foldlNetState' s0 $ []
194+
let s1sl = spy "s1s" $ foldlNetState' s0 $ [0,0,0]
195+
let s2sl = spy "s2s" $ foldlNetState' s0 $ [0,0,0,1]
196+
let s3sl = spy "s3s" $ foldlNetState' s0 $ [0,0,0,1,1]
197+
198+
-- TODO oh right, wait, bc we do foldR instead of foldL this should be flipped too
199+
let s0s = spy "s0s" $ foldrNetState' s0 $ [2,1,0]
200+
201+
liftEffect $ write "\n"
202+
liftEffect $ write $ show $ spy "marking" $ Stbx.marking <$> s0s.stbxObjM
203+
liftEffect $ write "\n"
204+
liftEffect $ write $ show $ spy "enabled trs" $ Stbx.enabledTransitionIds <$> s0s.stbxObjM
205+
liftEffect $ write "\n"
206+
liftEffect $ write $ show $ spy "marking s0sl" $ Stbx.marking <$> s0sl.stbxObjM
207+
liftEffect $ write "\n"
208+
liftEffect $ write $ show $ spy "marking s1sl" $ Stbx.marking <$> s1sl.stbxObjM
209+
liftEffect $ write "\n"
210+
liftEffect $ write $ show $ spy "marking s2sl" $ Stbx.marking <$> s2sl.stbxObjM
211+
liftEffect $ write "\n"
212+
liftEffect $ write $ show $ spy "marking s3sl" $ Stbx.marking <$> s3sl.stbxObjM
213+
s0s.log `shouldEqual` ([0,1,2])
214+
215+
-- let decodedJsonString = Stbx.stbxObjToJsonString decodedStbxObj
216+
-- 1 `shouldEqual` 2

0 commit comments

Comments
 (0)