Skip to content

Commit 80a163a

Browse files
adamburkeghadamburkegh
committed
Deprecate probLoopRoll and fixed loop to prob conversion. Compress aggressively before noise reduction applied
1 parent 297fb41 commit 80a163a

File tree

4 files changed

+103
-71
lines changed

4 files changed

+103
-71
lines changed

‎src/main/haskell/OtherRules.hs‎

Lines changed: 30 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -60,12 +60,10 @@ fixedLoopRollLengthN (NodeN Seq ptl w)
6060
nptl = head rs
6161
fixedLoopRollLengthN x = x
6262

63-
{-
6463
loopRollEndPattern :: (Eq a) => PPTree a -> Float -> POper1 -> PPTree a
6564
loopRollEndPattern prev ct poper
6665
| ct > 1 = Node1 poper prev ct (weight prev)
6766
| ct <= 1 = prev
68-
-}
6967

7068
fixedLoopRollEndPattern :: (Eq a) => PPTree a -> Float -> PPTree a
7169
fixedLoopRollEndPattern prev ct = loopRollEndPattern prev ct FLoop
@@ -107,16 +105,43 @@ fixedLoopRollListN iptl prev ct
107105
fixedLoopRollListN ptl next 1
108106
where (next, ptl) = splitAt (length prev) iptl
109107

110-
111-
112108
loopRollEndPatternL :: (Eq a) => [PPTree a] -> Float -> POper1 -> [PPTree a]
113109
loopRollEndPatternL prev ct poper
114110
| ct > 1 = [Node1 poper (seqP prev w) ct w]
115111
| ct <= 1 = prev
116112
where w = weight $ head prev
117113

118114

119-
120115
fixedLoopRollEndPatternL :: (Eq a) => [PPTree a] -> Float -> [PPTree a]
121116
fixedLoopRollEndPatternL prev ct = loopRollEndPatternL prev ct FLoop
122117

118+
119+
loopFixToProb :: PRule a
120+
loopFixToProb (Node1 FLoop x m w) = Node1 PLoop x m w
121+
loopFixToProb x = x
122+
123+
124+
-- Not in the paper and not currently used
125+
-- no loops of subseq >= 2
126+
probLoopRoll :: Eq a => PRule a
127+
probLoopRoll (NodeN Seq (u1:ptl) w)
128+
| nptl /= ptl = NodeN Seq nptl w
129+
where nptl = probLoopRollList ptl u1 1
130+
probLoopRoll x = x
131+
132+
probLoopRollList :: (Eq a) => [PPTree a] -> PPTree a -> Float -> [PPTree a]
133+
probLoopRollList ((Node1 PLoop u1 r1 w1):ptl) prev ct
134+
| u1 =~= prev = probLoopRollList ptl (seqMerge u1 prev) (ct+r1-1)
135+
| not(u1 =~= prev) = probLoopRollEndPattern prev ct:
136+
probLoopRollList ptl u1 r1
137+
probLoopRollList (u1:ptl) prev ct
138+
| u1 =~= prev = probLoopRollList ptl (seqMerge u1 prev) (ct+1)
139+
| not (u1 =~= prev) = probLoopRollEndPattern prev ct:
140+
probLoopRollList ptl u1 1
141+
probLoopRollList [] prev ct = [probLoopRollEndPattern prev ct]
142+
143+
144+
probLoopRollEndPattern :: (Eq a) => PPTree a -> Float -> PPTree a
145+
probLoopRollEndPattern prev ct = loopRollEndPattern prev ct PLoop
146+
147+

‎src/main/haskell/Toothpaste.hs‎

Lines changed: 37 additions & 45 deletions
Original file line numberDiff line numberDiff line change
@@ -143,40 +143,6 @@ fixedLoopRollExisting x = x
143143
fixedLoopRoll :: (Eq a, Ord a) => PRule a
144144
fixedLoopRoll pt = fixedLoopRollExisting $ fixedLoopRollSingle pt
145145

146-
-- remove when probLoopRoll converted to sim-merge style
147-
loopRollEndPattern :: (Eq a) => PPTree a -> Float -> POper1 -> PPTree a
148-
loopRollEndPattern prev ct poper
149-
| ct > 1 = Node1 poper prev ct (weight prev)
150-
| ct <= 1 = prev
151-
152-
153-
-- Not in the paper and not currently used
154-
-- no loops of subseq >= 2
155-
probLoopRoll :: Eq a => PRule a
156-
probLoopRoll (NodeN Seq (u1:ptl) w)
157-
| nptl /= ptl = NodeN Seq nptl w
158-
where nptl = probLoopRollList ptl u1 1
159-
probLoopRoll x = x
160-
161-
probLoopRollList :: (Eq a) => [PPTree a] -> PPTree a -> Float -> [PPTree a]
162-
probLoopRollList ((Node1 PLoop u1 r1 w1):ptl) prev ct
163-
| u1 =~= prev = probLoopRollList ptl (seqMerge u1 prev) (ct+r1-1)
164-
| not(u1 =~= prev) = probLoopRollEndPattern prev ct:
165-
probLoopRollList ptl u1 r1
166-
probLoopRollList (u1:ptl) prev ct
167-
| u1 =~= prev = probLoopRollList ptl (seqMerge u1 prev) (ct+1)
168-
| not (u1 =~= prev) = probLoopRollEndPattern prev ct:
169-
probLoopRollList ptl u1 1
170-
probLoopRollList [] prev ct = [probLoopRollEndPattern prev ct]
171-
172-
173-
probLoopRollEndPattern :: (Eq a) => PPTree a -> Float -> PPTree a
174-
probLoopRollEndPattern prev ct = loopRollEndPattern prev ct PLoop
175-
176-
177-
loopFixToProb :: PRule a
178-
loopFixToProb (Node1 FLoop x m w) = Node1 PLoop x m w
179-
loopFixToProb x = x
180146

181147
loopNest :: PRule a
182148
loopNest (Node1 FLoop (Node1 FLoop x r1 w1) r2 w2) = Node1 FLoop x (r1*r2) w2
@@ -190,14 +156,31 @@ loopGeo :: (Eq a, Ord a) => PRule a
190156
loopGeo = choiceChildMR loopGeoList
191157

192158
loopGeoList :: (Eq a) => LRule a
193-
loopGeoList ((Node1 FLoop u1 r1 w1):(Node1 FLoop u2 r2 w2):ptl)
159+
loopGeoList ((Node1 op1 u1 r1 w1):(Node1 op2 u2 r2 w2):ptl)
194160
| u1 =~= u2 = loopGeoList (
195161
Node1 PLoop (merge u1 u2)
196162
(((r1*w1)+(r2*w2))/(w1+w2))
197163
(w1+w2)
198164
:ptl)
199-
| otherwise = (Node1 FLoop u1 r1 w1) :
200-
loopGeoList ( (Node1 FLoop u2 r2 w2) :ptl)
165+
| otherwise = (Node1 op1 u1 r1 w1) :
166+
loopGeoList ( (Node1 op2 u2 r2 w2) :ptl)
167+
loopGeoList ((Node1 op1 u1 r1 w1):u2:ptl)
168+
| u1 =~= u2 = loopGeoList
169+
((Node1 PLoop (merge u1 u2)
170+
(((r1*w1)+w2)/(w1+w2))
171+
(w1+w2) )
172+
: ptl )
173+
| otherwise = (Node1 op1 u1 r1 w1) :
174+
loopGeoList (u2:ptl)
175+
where w2 = weight u2
176+
loopGeoList (u1:(Node1 op2 u2 r2 w2):ptl)
177+
| u1 =~= u2 = loopGeoList (
178+
(Node1 PLoop (merge u1 u2)
179+
(((w1)+(r2*w2))/(w1+w2))
180+
(w1+w2) )
181+
:ptl)
182+
| otherwise = u1: loopGeoList ( (Node1 op2 u2 r2 w2) :ptl)
183+
where w1 = weight u1
201184
loopGeoList (pt1:ptl) = pt1:loopGeoList ptl
202185
loopGeoList pt = pt
203186

@@ -622,8 +605,7 @@ baseRuleList = [
622605
TRule{rulename="loopConcFromChoice",trule=loopConcFromChoice},
623606
TRule{rulename="loopConcFromChoiceSuffix",
624607
trule=loopConcFromChoiceSuffix},
625-
TRule{rulename="loopConcSubsume",trule=loopConcSubsume},
626-
TRule{rulename="loopFixToProb", trule=loopFixToProb}
608+
TRule{rulename="loopConcSubsume",trule=loopConcSubsume}
627609
]
628610

629611

@@ -642,23 +624,33 @@ transform :: (Show a, Eq a, Ord a) => PPTree a -> PPTree a
642624
transform = transformRuleOrdered
643625

644626
transformNoise :: (Show a, Eq a, Ord a) => PPTree a -> Float -> PPTree a
645-
transformNoise pt noise = maxTransformRuleOrder pt (denoiseRuleList noise)
627+
transformNoise pt noise =
628+
maxTransformRuleOrder firstPass (denoiseRuleList noise)
629+
where firstPass = maxTransformRuleOrder pt baseRuleList
646630

647631
-- transformClean x = maxTransformBreadth x ruleList
648632
transformRuleOrdered :: (Show a, Eq a, Ord a) => PPTree a -> PPTree a
649633
transformRuleOrdered pt = maxTransformRuleOrder pt ruleList
650634

635+
exhaustTransform :: (Show a, Eq a) => PPTree a -> TRule a -> PPTree a
636+
exhaustTransform pt r | pt == tpt = pt
637+
| otherwise = exhaustTransform tpt r
638+
where tpt = transformPT pt r
639+
640+
651641
transformInRuleOrder :: (Show a, Eq a) => PPTRuleTransform a
652-
transformInRuleOrder pt [r] = transformPT pt r
642+
-- transformInRuleOrder pt [r] = transformPT pt r
643+
transformInRuleOrder pt [r] = exhaustTransform pt r
653644
transformInRuleOrder pt (r:rs) =
654645
transformInRuleOrder (transformInRuleOrder pt [r]) rs
655646
transformInRuleOrder x _ = x
656647

657648
maxTransformRuleOrder :: (Show a, Eq a) => PPTRuleTransform a
658-
maxTransformRuleOrder x rules | x == y = x
659-
| otherwise = maxTransformRuleOrder y rules
660-
where y = debug ("=== Count:" ++ show (ncount x)
661-
++ "===") (transformInRuleOrder x rules)
649+
maxTransformRuleOrder x rules
650+
| x == y = x
651+
| otherwise = maxTransformRuleOrder y rules
652+
where y = debug ("=== Count:" ++ show (ncount x)
653+
++ "===") (transformInRuleOrder x rules)
662654

663655

664656

‎src/test/haskell/OtherRulesTest.hs‎

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,10 +11,14 @@ la2 = Leaf "a" 2
1111
la3 = Leaf "a" 3
1212
lb = Leaf "b" 1
1313
lb2 = Leaf "b" 2
14+
lb3 = Leaf "b" 3
15+
1416
lc = Leaf "c" 1
1517
lc3 = Leaf "c" 3
1618
ld4 = Leaf "d" 4
1719

20+
saa = NodeN Seq [la,la] 1
21+
saaa = NodeN Seq [la,la,la] 1
1822
saaat = NodeN Seq [la,NodeN Seq [la,la] 1] 1
1923

2024

@@ -76,8 +80,29 @@ fixedLoopRollTestsNforN = [
7680
~=? fixedLoopRollListN [la,lb,lc] [la,lb,lc] 6
7781
]
7882

83+
probLoopRollTests = [
84+
"ploopRoll1" ~: la ~=? probLoopRoll la ,
85+
"ploopRoll2" ~: NodeN Seq [Node1 PLoop la 2 1] 1
86+
~=? probLoopRoll saa ,
87+
"ploopRoll3" ~: NodeN Seq [Node1 PLoop la 3 1] 1
88+
~=? probLoopRoll saaa ,
89+
"ploopRollMid1" ~: saaat ~=? probLoopRoll saaat ,
90+
"ploopRollMid2" ~: NodeN Seq [lb,Node1 PLoop la 3 1] 1
91+
~=? probLoopRoll (NodeN Seq [lb,la,la,la] 1),
92+
"ploopRollSim" ~: NodeN Seq [lb3,
93+
Node1 PLoop (NodeN Choice
94+
[Leaf "a" 1.5,
95+
Leaf "b" 1.5] 3) 2 3,
96+
la3] 3
97+
~=? probLoopRoll (NodeN Seq [lb3,NodeN Choice [la2,lb] 3,
98+
NodeN Choice [la,lb2] 3,
99+
la3] 3)
100+
]
101+
79102

80103

81104
huTests = choiceSkipSuffixTests
82105
++ fixedLoopRollTestsNSingle ++ fixedLoopRollTestsNforN
106+
++ probLoopRollTests
107+
83108

‎src/test/haskell/ToothpasteTest.hs‎

Lines changed: 11 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -431,24 +431,6 @@ fixedLoopRollTests = [
431431
~=? fixedLoopRoll (NodeN Seq [la,lb,lc,la,lb,lc,la,lb,lc] 1)
432432
]
433433

434-
probLoopRollTests = [
435-
"ploopRoll1" ~: la ~=? probLoopRoll la ,
436-
"ploopRoll2" ~: NodeN Seq [Node1 PLoop la 2 1] 1
437-
~=? probLoopRoll saa ,
438-
"ploopRoll3" ~: NodeN Seq [Node1 PLoop la 3 1] 1
439-
~=? probLoopRoll saaa ,
440-
"ploopRollMid1" ~: saaat ~=? probLoopRoll saaat ,
441-
"ploopRollMid2" ~: NodeN Seq [lb,Node1 PLoop la 3 1] 1
442-
~=? probLoopRoll (NodeN Seq [lb,la,la,la] 1),
443-
"ploopRollSim" ~: NodeN Seq [lb3,
444-
Node1 PLoop (NodeN Choice
445-
[Leaf "a" 1.5,
446-
Leaf "b" 1.5] 3) 2 3,
447-
la3] 3
448-
~=? probLoopRoll (NodeN Seq [lb3,NodeN Choice [la2,lb] 3,
449-
NodeN Choice [la,lb2] 3,
450-
la3] 3)
451-
]
452434

453435
loopNestTests = [
454436
"loopNestFF1" ~: Node1 FLoop la5 6 5
@@ -472,8 +454,7 @@ loopGeoTests = [
472454
Node1 FLoop la 4 1] 2)
473455
~=? loopGeo (NodeN Choice [Node1 FLoop lb 2 1,
474456
Node1 FLoop la 4 1] 2),
475-
-- FLoop / PLoop merge depends on PLoop conversion
476-
"loopGeo3" ~: NodeN Choice [Node1 PLoop lb2 3 2, Node1 FLoop lb 3 1] 3
457+
"loopGeo3" ~: Node1 PLoop lb3 3 3
477458
~=? loopGeo (NodeN Choice [Node1 FLoop lb 2 1,
478459
Node1 FLoop lb 4 1,
479460
Node1 FLoop lb 3 1] 3),
@@ -485,6 +466,16 @@ loopGeoTests = [
485466
~=? loopGeo (NodeN Choice [lc,
486467
Node1 FLoop la 2 1,
487468
Node1 FLoop la 4 1,
469+
lb] 4),
470+
"loopGeoPartial3" ~: choiceP [Node1 PLoop la2 3 2, lb, lc] 4
471+
~=? loopGeo (NodeN Choice [lc,
472+
Node1 FLoop la 2 1,
473+
Node1 PLoop la 4 1,
474+
lb] 4),
475+
"loopGeoPartial4" ~: choiceP [Node1 PLoop la2 2 2, lb, lc] 4
476+
~=? loopGeo (NodeN Choice [lc,
477+
Node1 FLoop la 3 1,
478+
la,
488479
lb] 4)
489480
]
490481

@@ -786,7 +777,6 @@ ruleTests = silentSeqTests ++ silentConcTests
786777
++ concFromChoiceTests
787778
++ concSubsumeTests
788779
++ fixedLoopRollTests ++ loopNestTests ++ loopGeoTests
789-
++ probLoopRollTests
790780
++ loopChoiceFoldTests
791781
++ flattenTests
792782
++ choicePruneTests

0 commit comments

Comments
 (0)