add the commutations function

rudymatela · Feb 9, 2024 · cbceab1 · cbceab1
1 parent 9736c30
commit cbceab1
Show file tree

Hide file tree

Showing 2 changed files with 36 additions and 0 deletions.
diff --git a/src/Test/Speculate/Expr/Core.hs b/src/Test/Speculate/Expr/Core.hs
@@ -28,6 +28,9 @@ module Test.Speculate.Expr.Core
   , unification
   , isCanonInstanceOf
   , hasCanonInstanceOf
+
+  -- * Commuting
+  , commutations
   )
 where
 
@@ -136,3 +139,17 @@ e1           `hasCanonInstanceOf` e2 | e1   `isCanonInstanceOf` e2 = True
 (e1f :$ e1x) `hasCanonInstanceOf` e2 | e1f `hasCanonInstanceOf` e2 ||
                                        e1x `hasCanonInstanceOf` e2 = True
 _            `hasCanonInstanceOf` _                                = False
+
+commutations :: [Expr] -> Expr -> [Expr]
+commutations cos  =  cmms
+  where
+  cmms (eo :$ ex :$ ey)  |  isValue eo && eo `elem` cos
+                        =  concat [ [eo :$ ex' :$ ey', eo :$ ey' :$ ex']
+                                  | ex' <- cmms ex
+                                  , ey' <- cmms ey
+                                  ]
+  cmms (ef :$ ex)  =  [ ef' :$ ex'
+                     | ef' <- cmms ef
+                     , ex' <- cmms ex
+                     ]
+  cmms e  =  [e]
diff --git a/test/expr.hs b/test/expr.hs
@@ -59,6 +59,25 @@ tests n =
             , (yy,ff2 xx xx)
             ]
 
+  , commutations [plus]  (xx -+- yy)  ==  [xx -+- yy, yy -+- xx]
+  , commutations [times] (xx -*- yy)  ==  [xx -*- yy, yy -*- xx]
+  , commutations [times] (xx -+- yy)  ==  [xx -+- yy]
+  , commutations [plus]  (xx -*- yy)  ==  [xx -*- yy]
+
+  , commutations [plus]  (xx -+- (yy -+- zz))
+    ==  [ xx -+- (yy -+- zz)
+        , (yy -+- zz) -+- xx
+        , xx -+- (zz -+- yy)
+        , (zz -+- yy) -+- xx
+        ]
+
+  , commutations [plus,times]  (xx -+- (yy -*- zz))
+    ==  [ xx -+- (yy -*- zz)
+        , (yy -*- zz) -+- xx
+        , xx -+- (zz -*- yy)
+        , (zz -*- yy) -+- xx
+        ]
+
   , constifications xx == map constify [xx]
 
   , constifications (xx -+- yy)