Repository: GaloisInc/cryptol
Pull request #1824: type simplification: improve subtraction cancellation with exponents
Author: login: danmatichuk
Created: 2025-03-07T23:15:11Z | Merged: 2025-03-14T01:41:05Z

this allows for the subtraction cancellation rule
to still apply after some exponent simplification
steps have already occurred

fixes #1812

Linked issue #1812: Incomplete reasoning about exponentiation: `2^^h + 2^^h - 2^^h` does not always simplify to `2^^h`
Consider:

    // See if Cryptol knows that 2^^h + (2^^h - 2^^h) == 2^^h

    f : {h} (fin h) => [2^^h + (2^^h - 2^^h)]
    f = g`{h}

    g : {h} (fin h) => [2^^h]
    g = zero

    // See if Cryptol knows that (2^^h + 2^^h) - 2^^h == 2^^h

    ff : {h} (fin h) => [(2^^h + 2^^h) - 2^^h]
    ff = gg`{h}

    gg : {h} (fin h) => [2^^h]
    gg = zero


This is seeing if Cryptol can successfully conclude that `2^^h + 2^^h - 2^^h == 2^^h` with different groupings of the `(+)` operator. Surprisingly, Cryptol succeeds in the first case (`2^^h + (2^^h - 2^^h) == 2^^h`), but fails in the second case (`(2^^h + 2^^h) - 2^^h == 2^^h`):

    [error] at Bug.cry:12:1--12:12:
      Failed to validate user-specified signature.
        in the definition of 'Main::ff', at Bug.cry:12:1--12:3,
        we need to show that
          for any type h
          assuming
            • fin h
          the following constraints hold:
            • 2 ^^ (1 + h) - 2 ^^ h == 2 ^^ h
                arising from
                matching types
                at Bug.cry:12:6--12:8


Normally, Cryptol's typechecker has no problem concluding that `(x + x) - x == x`. As the error message above indicates, however, I think Cryptol's typechecker is getting confused because it first rewrites `(2^^h + 2^^h)` to `2 ^^ (1 + h)`, which imperils the typechecker's ability to cancel out `2^^h` terms.

Diff:
diff --git a/src/Cryptol/TypeCheck/SimpType.hs b/src/Cryptol/TypeCheck/SimpType.hs
index cfe77e3af..d10eae55d 100644
--- a/src/Cryptol/TypeCheck/SimpType.hs
+++ b/src/Cryptol/TypeCheck/SimpType.hs
@@ -59,13 +59,16 @@ tAdd x y
   | Just (n,x1) <- isSumK x = addK n (tAdd x1 y)
   | Just (n,y1) <- isSumK y = addK n (tAdd x y1)
   | Just v <- matchMaybe (do (a,b) <- (|-|) y
-                             guard (x == b)
-                             return a) = v
+                             ((guard (x == b) >> return a)
+                              -- added to handle this case: 2 ^^ (1 + h) - 1 == 2 ^^ h - 1 + 2 ^^ h
+                              <|> (same x a >>= \x2 -> return (tSub x2 b)))
+                              ) = v
   | Just v <- matchMaybe (do (a,b) <- (|-|) x
-                             guard (b == y)
-                             return a) = v
+                             ((guard (b == y) >> return a)
+                              <|> (same y a >>= \y2 -> return (tSub y2 b)))
+                             ) = v
 
-  | Just v <- matchMaybe (factor <|> same <|> swapVars) = v
+  | Just v <- matchMaybe (factor <|> same x y <|> swapVars) = v
 
   | otherwise           = tf2 TCAdd x y
   where
@@ -101,8 +104,8 @@ tAdd x y
               guard (a == a')
               return (tMul a (tAdd b1 b2))
 
-  same = do guard (x == y)
-            return (tMul (tNum (2 :: Int)) x)
+  same x1 y1 = do guard (x1 == y1)
+                  return (tMul (tNum (2 :: Int)) x1)
 
   swapVars = do a <- aTVar x
                 b <- aTVar y
@@ -133,6 +136,23 @@ tSub x y
                                 <|> (guard (b == y) >> return a))
                        = v
 
+    --    x^^(n+h) - x^^h 
+    -- ~> (x^^n * x^^h) - x^^h 
+    -- ~> ((x^^n - 1) * x^^h
+    -- allows subtraction cancelling to occur when
+    -- (2^^h + 2^^h) has been rewritten into 2^^(1+h)
+  | Just v <- matchMaybe $ 
+      do (x_base,x_exp) <- (|^|) x
+         (y_base,y_exp) <- (|^|) y
+         guard (x_base == y_base)
+         x_exp_sum <- anAdd x_exp
+         matchSwap x_exp_sum $ \(h,n) -> 
+           do guard (h == y_exp)
+              let x_to_n = tExp x_base n
+              let lhs = tSub x_to_n (tNum (1 :: Int))
+              return $ tMul lhs y
+       = v
+
   | Just v <- matchMaybe (do (a,b) <- (|-|) y
                              return (tSub (tAdd x b) a)) = v
 
diff --git a/src/Cryptol/TypeCheck/Solver/Numeric.hs b/src/Cryptol/TypeCheck/Solver/Numeric.hs
index 1ea8dea23..fdd26b80a 100644
--- a/src/Cryptol/TypeCheck/Solver/Numeric.hs
+++ b/src/Cryptol/TypeCheck/Solver/Numeric.hs
@@ -151,12 +151,21 @@ tryGeqExp _ x y =
 
 
 tryGeqThanSub :: Ctxt -> Type -> Type -> Match Solved
-tryGeqThanSub _ x y =
+tryGeqThanSub ctxt x y =
 
   -- t1 >= t1 - t2
-  do (a,_) <- (|-|) y
-     guard (x == a)
-     return (SolvedIf [])
+  (do (a,_) <- (|-|) y
+      guard (x == a)
+      return (SolvedIf []))
+  <|> do
+    (x1, x2) <- (|-|) x
+    (y1, y2) <- (|-|) y
+    let x1Fin = iIsFin (typeInterval (intervals ctxt) x1)
+    -- (x - z) >= (y - z)  only if x >= y
+    ((guard (x2 == y2) >> return (SolvedIf [x1 >== y1]))
+     <|>
+    -- (z - x) >= (z - y)  only if y >= x and fin z
+     (guard (x1 == y1 && x1Fin) >> return (SolvedIf [y2 >== x2])))
 
 tryGeqThanVar :: Ctxt -> Type -> TVar -> Match Solved
 tryGeqThanVar _ctxt ty x =
diff --git a/src/Cryptol/Utils/Patterns.hs b/src/Cryptol/Utils/Patterns.hs
index 0e25b33d7..8c052f9b3 100644
--- a/src/Cryptol/Utils/Patterns.hs
+++ b/src/Cryptol/Utils/Patterns.hs
@@ -86,6 +86,10 @@ match m = matchDefault (error "Pattern match failure.") m
 matchMaybe :: Match a -> Maybe a
 matchMaybe (Match m) = m Nothing Just
 
+-- | Attempt matching the given pattern against a tuple, 
+--   making a second attempt with the values swapped if the first fails.
+matchSwap :: (a, a) -> Pat (a, a) b -> Match b
+matchSwap (x, y) n = n (x, y) <|> n (y, x)
 
 list :: [Pat a b] -> Pat [a] [b]
 list [] = \a ->
diff --git a/tests/issues/issue_1812.cry b/tests/issues/issue_1812.cry
new file mode 100644
index 000000000..ce09af76f
--- /dev/null
+++ b/tests/issues/issue_1812.cry
@@ -0,0 +1,19 @@
+f : {h} (fin h) => [2^^h + (2^^h - 2^^h)]
+f = g`{h}
+
+g : {h} (fin h) => [2^^h]
+g = zero
+
+// See if Cryptol knows that (2^^h + 2^^h) - 2^^h == 2^^h
+
+ff : {h} (fin h) => [(2^^h + 2^^h) - 2^^h]
+ff = gg`{h}
+
+gg : {h} (fin h) => [2^^h]
+gg = zero
+
+jj : {h} (fin h) => [2 ^^ (1 + h) - 1]
+jj = kk`{h}
+
+kk : {h} (fin h, 2 ^^ (1 + h) - 1 >= 2 ^^ h - 1) => [2 ^^ h - 1 + 2 ^^ h]
+kk = zero
\ No newline at end of file
diff --git a/tests/issues/issue_1812.icry.stdout b/tests/issues/issue_1812.icry.stdout
new file mode 100644
index 000000000..57a1d7a1c
--- /dev/null
+++ b/tests/issues/issue_1812.icry.stdout
@@ -0,0 +1,3 @@
+Loading module Cryptol
+Loading module Cryptol
+Loading module Main


Reviews:
user: login: RyanGlScott
body: I agree that it's fine to have a mix of rules. That being said, I'm less clear on how to make the order in which they're applied explicit. Is it guaranteed that this newly added rule always occurs _after_ `(x^^h + x^^h)` has been rewritten to `x^^(1+h)`, for instance? (I wasn't able to say this with 100% certainly after a quick glance at the code, but I am admittedly not as familiar with the rewriting parts of Cryptol as @yav is.)
state: COMMENTED
author_association: CONTRIBUTOR
submitted_at: 2025-03-10T22:50:05Z
user: login: yav
body: I think the one new rule is a bit wrong, but I am not sure if it is actually needed for this fix.
state: CHANGES_REQUESTED
author_association: MEMBER
submitted_at: 2025-03-13T21:09:33Z
user: login: danmatichuk
state: COMMENTED
author_association: CONTRIBUTOR
submitted_at: 2025-03-13T21:43:31Z
user: login: danmatichuk
state: COMMENTED
author_association: CONTRIBUTOR
submitted_at: 2025-03-13T21:45:48Z
user: login: danmatichuk
state: COMMENTED
author_association: CONTRIBUTOR
submitted_at: 2025-03-13T22:01:07Z
user: login: yav
state: COMMENTED
author_association: MEMBER
submitted_at: 2025-03-13T22:08:47Z
user: login: yav
body: LGTM
state: APPROVED
author_association: MEMBER
submitted_at: 2025-03-13T22:40:54Z

Review comments:
diff_hunk: @@ -86,6 +86,10 @@ match m = matchDefault (error "Pattern match failure.") m
 matchMaybe :: Match a -> Maybe a
 matchMaybe (Match m) = m Nothing Just
 
+-- | Attempt matching the given pattern against a tuple, 
+--   making a second attempt with the values swapped if the first fails.
+matchSwap :: (a, a) -> (Pat (a, a) b) -> Match b
path: src/Cryptol/Utils/Patterns.hs
user: login: RyanGlScott
body: Redundant parentheses:

```suggestion
matchSwap :: (a, a) -> Pat (a, a) b -> Match b
```
created_at: 2025-03-10T22:37:16Z
author_association: CONTRIBUTOR
diff_hunk: @@ -154,9 +154,14 @@ tryGeqThanSub :: Ctxt -> Type -> Type -> Match Solved
 tryGeqThanSub _ x y =
 
   -- t1 >= t1 - t2
-  do (a,_) <- (|-|) y
-     guard (x == a)
-     return (SolvedIf [])
+  (do (a,_) <- (|-|) y
+      guard (x == a)
+      return (SolvedIf []))
+  <|> do
path: src/Cryptol/TypeCheck/Solver/Numeric.hs
user: login: yav
body: Could you add a comment here describing what the code does, like this:
```
(x - z) >= (y - z)  only if x >= y
```
I don't think the 2nd rule added is correct, namely:
```
(z - x) >= (z - y) only if y >= x
```
The counter example is `inf - 2 >= inf - 1` but it is not the case that `1 >= 2`.

The module `Cryptol.TypeCheck.Solver.InfNat` is a good reference for the semantics of the type operations, which are a bit tricky because of infinity and partiality.

created_at: 2025-03-13T20:33:05Z
author_association: MEMBER
diff_hunk: @@ -59,11 +59,13 @@ tAdd x y
   | Just (n,x1) <- isSumK x = addK n (tAdd x1 y)
   | Just (n,y1) <- isSumK y = addK n (tAdd x y1)
   | Just v <- matchMaybe (do (a,b) <- (|-|) y
-                             guard (x == b)
-                             return a) = v
+                             ((guard (x == b) >> return a)
+                              <|> (guard (x == a) >> return (tSub (tAdd x a) b)))
+                              ) = v
   | Just v <- matchMaybe (do (a,b) <- (|-|) x
-                             guard (b == y)
-                             return a) = v
+                             ((guard (b == y) >> return a)
+                              <|> (guard (a == y) >> return (tSub (tAdd y a) b)))
path: src/Cryptol/TypeCheck/SimpType.hs
user: login: yav
body: This new rule says: `(a - b) + a   ~>   (a + a) - b`.    It seems correct, but what's the motivation for adding it?  Also I wonder if we are going to do it, if we should just rewrite it it `2 * a - b`?
created_at: 2025-03-13T20:44:24Z
author_association: MEMBER
diff_hunk: @@ -59,11 +59,13 @@ tAdd x y
   | Just (n,x1) <- isSumK x = addK n (tAdd x1 y)
   | Just (n,y1) <- isSumK y = addK n (tAdd x y1)
   | Just v <- matchMaybe (do (a,b) <- (|-|) y
-                             guard (x == b)
-                             return a) = v
+                             ((guard (x == b) >> return a)
+                              <|> (guard (x == a) >> return (tSub (tAdd x a) b)))
+                              ) = v
   | Just v <- matchMaybe (do (a,b) <- (|-|) x
-                             guard (b == y)
-                             return a) = v
+                             ((guard (b == y) >> return a)
+                              <|> (guard (a == y) >> return (tSub (tAdd y a) b)))
path: src/Cryptol/TypeCheck/SimpType.hs
user: login: danmatichuk
body: It's needed to address exactly that case, where we've simplified one side to from `a + a` to `2a` but the same simplification doesn't apply on the other side because of the subtraction.

It may be the case that this kind of reasoning should be pushed into the solver, rather than the simplifier, however.
created_at: 2025-03-13T21:43:31Z
author_association: CONTRIBUTOR
diff_hunk: @@ -154,9 +154,14 @@ tryGeqThanSub :: Ctxt -> Type -> Type -> Match Solved
 tryGeqThanSub _ x y =
 
   -- t1 >= t1 - t2
-  do (a,_) <- (|-|) y
-     guard (x == a)
-     return (SolvedIf [])
+  (do (a,_) <- (|-|) y
+      guard (x == a)
+      return (SolvedIf []))
+  <|> do
path: src/Cryptol/TypeCheck/Solver/Numeric.hs
user: login: danmatichuk
body: Ah right, I see. I think I'd discounted it because `inf - 1` would always be simplified into `inf`, but you're right that it makes sense to guard against this explicitly here.
created_at: 2025-03-13T21:45:48Z
author_association: CONTRIBUTOR
diff_hunk: @@ -59,11 +59,13 @@ tAdd x y
   | Just (n,x1) <- isSumK x = addK n (tAdd x1 y)
   | Just (n,y1) <- isSumK y = addK n (tAdd x y1)
   | Just v <- matchMaybe (do (a,b) <- (|-|) y
-                             guard (x == b)
-                             return a) = v
+                             ((guard (x == b) >> return a)
+                              <|> (guard (x == a) >> return (tSub (tAdd x a) b)))
+                              ) = v
   | Just v <- matchMaybe (do (a,b) <- (|-|) x
-                             guard (b == y)
-                             return a) = v
+                             ((guard (b == y) >> return a)
+                              <|> (guard (a == y) >> return (tSub (tAdd y a) b)))
path: src/Cryptol/TypeCheck/SimpType.hs
user: login: danmatichuk
body: Here is the outstanding goal if that rule is removed:
`2 ^^ (1 + h) - 1 == 2 ^^ h - 1 + 2 ^^ h`
created_at: 2025-03-13T22:01:07Z
author_association: CONTRIBUTOR
diff_hunk: @@ -59,11 +59,13 @@ tAdd x y
   | Just (n,x1) <- isSumK x = addK n (tAdd x1 y)
   | Just (n,y1) <- isSumK y = addK n (tAdd x y1)
   | Just v <- matchMaybe (do (a,b) <- (|-|) y
-                             guard (x == b)
-                             return a) = v
+                             ((guard (x == b) >> return a)
+                              <|> (guard (x == a) >> return (tSub (tAdd x a) b)))
+                              ) = v
   | Just v <- matchMaybe (do (a,b) <- (|-|) x
-                             guard (b == y)
-                             return a) = v
+                             ((guard (b == y) >> return a)
+                              <|> (guard (a == y) >> return (tSub (tAdd y a) b)))
path: src/Cryptol/TypeCheck/SimpType.hs
user: login: yav
body: Ah, yes, that makes sense.  I'd say let's rewrite it directly to `2*a - b` and maybe paste exactly this example above it, so that we remember what it's for.
created_at: 2025-03-13T22:08:46Z
author_association: MEMBER

PR comments:
user: login: RyanGlScott
created_at: 2025-03-08T15:23:35Z
body: Thank you for the PR.

I wonder if it would be worth thinking a bit about our approach for picking the order in which we apply simplification rules. The rules that this PR adds is somewhat odd in that it exists (at least in part) to reverse some of the steps performed by an earlier simplification rule. Perhaps if we applied the subtraction cancellation rule earlier, then we wouldn't need to have this additional rule in the first place?

What are your thoughts, @yav?
author_association: CONTRIBUTOR
user: login: danmatichuk
created_at: 2025-03-10T18:41:16Z
body: Yeah the problem right now is that the simplification strategy is exclusively bottom-up, but in general I don't see a problem with having a mix, other than making sure we're careful to distinguish them.
author_association: CONTRIBUTOR
user: login: sauclovian-g
created_at: 2025-03-10T22:11:35Z
body: My thought is that priorities are often a good thing in rewrite systems and it's probably ok to do all linear arithmetic rewrites first and then move on to the more exotic/less decidable stuff. (That would at least solve this particular problem)
author_association: CONTRIBUTOR