Skip to content

Commit 70f68d3

Browse files
marcoshmarcosh
committed
[#336] [stbx-core] tests for wiring tree linerisation
1 parent d7e5cad commit 70f68d3

File tree

2 files changed

+200
-7
lines changed

2 files changed

+200
-7
lines changed

Diff for: ‎stbx-core/src/Statebox/Core/WiringTree.purs

+31-7
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,13 @@
11
module Statebox.Core.WiringTree where
22

33
import Prelude
4-
import Control.Apply (lift3)
5-
import Data.Array (head, length, partition, range)
4+
import Data.Array ((:), head, length, partition, range, tail)
65
import Data.Either (Either(..), either)
76
import Data.Either.Nested (type (\/))
8-
import Data.Maybe (Maybe)
7+
import Data.Generic.Rep (class Generic)
8+
import Data.Generic.Rep.Eq (genericEq)
9+
import Data.Generic.Rep.Show (genericShow)
10+
import Data.Maybe (Maybe(..), fromMaybe, maybe)
911
import Data.Tuple.Nested ((/\))
1012

1113
import Data.ArrayMultiset (ArrayMultiset)
@@ -26,6 +28,15 @@ fromWiring wiring = Net <$> head wiring.nets
2628
data LinearizationError
2729
= DiagramNotYetAllowed
2830
| NLLDecodingFailed ErrNetEncoding
31+
| LenghtMismatchBetweenTransitionsAndNames
32+
33+
derive instance genericLinearizationError :: Generic LinearizationError _
34+
35+
instance eqLinearizationError :: Eq LinearizationError where
36+
eq = genericEq
37+
38+
instance showLinerizationError :: Show LinearizationError where
39+
show = genericShow
2940

3041
linearize :: WiringTree -> LinearizationError \/ Array (Glued Transition)
3142
linearize (Net net) = linearizeNet net
@@ -36,12 +47,25 @@ linearizeNet net = linearizePartitionsAndNames net.partition net.names
3647

3748
linearizePartitionsAndNames :: ArrayMultiset PID -> Array String -> LinearizationError \/ Array (Glued Transition)
3849
linearizePartitionsAndNames partition names =
39-
either (NLLDecodingFailed >>> Left) (Right <<< flip linearizeTransitionsAndNames names) $ fromNLL 0 partition
50+
either (NLLDecodingFailed >>> Left) (flip linearizeTransitionsAndNames names) $ fromNLL 0 partition
51+
52+
-- | this differs from the standard implementation of zipWith by the fact that it fails if the inputs are of different
53+
-- | length
54+
zip3With :: forall a b c d. (a -> b -> c -> d) -> Array a -> Array b -> Array c -> Maybe (Array d)
55+
zip3With f as bs cs = case head as, head bs, head cs of
56+
Nothing , Nothing , Nothing -> Just []
57+
(Just x), (Just y), (Just z) -> (f x y z : _) <$> zip3With f (tailSafe as) (tailSafe bs) (tailSafe cs)
58+
where
59+
tailSafe :: forall e. Array e -> Array e
60+
tailSafe = (fromMaybe []) <<< tail
61+
_ , _ , _ -> Nothing
4062

41-
-- TODO `lift3` does not consider the case where the arrays have different lengths; so add check and error
42-
linearizeTransitionsAndNames :: Array (TransitionF' PID) -> Array String -> Array (Glued Transition)
63+
linearizeTransitionsAndNames :: Array (TransitionF' PID) -> Array String -> LinearizationError \/ Array (Glued Transition)
4364
linearizeTransitionsAndNames transitions names =
44-
sortInitialInteriorFinal $ lift3 buildGluedTransition (range 0 (length transitions - 1)) transitions names
65+
maybe
66+
(Left LenghtMismatchBetweenTransitionsAndNames)
67+
(Right <<< sortInitialInteriorFinal)
68+
(zip3With buildGluedTransition (range 0 (length transitions - 1)) transitions names)
4569

4670
buildGluedTransition :: TID -> TransitionF' PID -> String -> Glued Transition
4771
buildGluedTransition tid (pre /\ post) name =

Diff for: ‎stbx-core/test/Statebox/Core/WiringTree.purs

+169
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,169 @@
1+
module Test.Statebox.Core.WiringTree where
2+
3+
import Prelude
4+
import Data.Either (Either(..))
5+
import Data.Maybe (Maybe(..))
6+
import Test.Spec (Spec, describe, it)
7+
import Test.Spec.Assertions (shouldEqual)
8+
9+
import Data.Petrinet.Representation.NLL (ErrNetEncoding(..))
10+
import Statebox.Core.Transition (Glued(..))
11+
import Statebox.Core.WiringTree (LinearizationError(..), WiringTree(..), linearize)
12+
13+
suite :: Spec Unit
14+
suite = do
15+
describe "WiringTree linearization" do
16+
it "should fail if the WiringTree contains a Diagram" do
17+
let diagram = { name: "diagram"
18+
, width: 1
19+
, pixels: [1]
20+
, names: ["a"]
21+
}
22+
wiringTree = Diagram diagram []
23+
24+
linearize wiringTree `shouldEqual` Left DiagramNotYetAllowed
25+
it "should fails is the Net contains an invalid NLL representation" do
26+
let net = { name: "net"
27+
, names: ["a"]
28+
, partition: [0]
29+
, placeNames: Nothing
30+
}
31+
wiringTree = Net net
32+
33+
linearize wiringTree `shouldEqual` Left (NLLDecodingFailed ErrOddLength)
34+
it "should linearize correctly a net with a single untouched transition" do
35+
let net = { name: "net"
36+
, names: ["a"]
37+
-- 1 -> 2
38+
, partition: [1, 0, 2, 0]
39+
, placeNames: Nothing
40+
}
41+
wiringTree = Net net
42+
gluedTransition = Untouched { name: "a"
43+
, path: [0, 0, 0]
44+
, tokens: { pre: [ { place: 1
45+
, tokens: 1
46+
}
47+
]
48+
, post: [ { place: 2
49+
, tokens: 1
50+
}
51+
]
52+
}
53+
, transition: 0
54+
}
55+
56+
linearize wiringTree `shouldEqual` Right [gluedTransition]
57+
it "should linearize correctly a net with a single initial transition" do
58+
let net = { name: "net"
59+
, names: ["a"]
60+
-- _ -> 1
61+
, partition: [0, 1, 0]
62+
, placeNames: Nothing
63+
}
64+
wiringTree = Net net
65+
gluedTransition = Initial { name: "a"
66+
, path: [0, 0, 0]
67+
, tokens: { pre: []
68+
, post: [ { place: 1
69+
, tokens: 1
70+
}
71+
]
72+
}
73+
, transition: 0
74+
}
75+
76+
linearize wiringTree `shouldEqual` Right [gluedTransition]
77+
it "should linearize correctly a net with a single final transition" do
78+
let net = { name: "net"
79+
, names: ["a"]
80+
-- 1 -> _
81+
, partition: [1, 0, 0]
82+
, placeNames: Nothing
83+
}
84+
wiringTree = Net net
85+
gluedTransition = Final { name: "a"
86+
, path: [0, 0, 0]
87+
, tokens: { pre: [ { place: 1
88+
, tokens: 1
89+
}
90+
]
91+
, post: []
92+
}
93+
, transition: 0
94+
}
95+
96+
linearize wiringTree `shouldEqual` Right [gluedTransition]
97+
it "should linearize correctly a net with a single transition which is both initial and final" do
98+
let net = { name: "net"
99+
, names: ["a"]
100+
-- _ -> _
101+
, partition: [0, 0]
102+
, placeNames: Nothing
103+
}
104+
wiringTree = Net net
105+
gluedTransition = Initial { name: "a"
106+
, path: [0, 0, 0]
107+
, tokens: { pre: []
108+
, post: []
109+
}
110+
, transition: 0
111+
}
112+
113+
linearize wiringTree `shouldEqual` Right [gluedTransition]
114+
it "should linearize correctly a net with multiple transitions" do
115+
let net = { name: "net"
116+
, names: ["a", "b", "c", "d"]
117+
-- a: _ -> 1
118+
-- b: 1 -> _
119+
-- c: 11 -> 2
120+
-- d: _ -> 22
121+
, partition: [0, 1, 0, 1, 0, 0, 1, 1, 0, 2, 0, 0, 2, 2, 0]
122+
, placeNames: Nothing
123+
}
124+
wiringTree = Net net
125+
a = Initial { name: "a"
126+
, path: [0, 0, 0]
127+
, tokens: { pre: []
128+
, post: [ { place: 1
129+
, tokens: 1
130+
}
131+
]
132+
}
133+
, transition: 0
134+
}
135+
b = Final { name: "b"
136+
, path: [0, 0, 0]
137+
, tokens: { pre: [ { place: 1
138+
, tokens: 1
139+
}
140+
]
141+
, post: []
142+
}
143+
, transition: 1
144+
}
145+
c = Untouched { name: "c"
146+
, path: [0, 0, 0]
147+
, tokens: { pre: [ { place: 1
148+
, tokens: 2
149+
}
150+
]
151+
, post: [ { place: 2
152+
, tokens: 1
153+
}
154+
]
155+
}
156+
, transition: 2
157+
}
158+
d = Initial { name: "d"
159+
, path: [0, 0, 0]
160+
, tokens: { pre: []
161+
, post: [ { place: 2
162+
, tokens: 2
163+
}
164+
]
165+
}
166+
, transition: 3
167+
}
168+
169+
linearize wiringTree `shouldEqual` Right [a, d, c, b]

0 commit comments

Comments
 (0)