Question

我在软件基础的"simple imperative programs"章节，一路上也在使用Agda进行练习。该书指出，在AST-s上做证明是乏味的，并继续在Coq中展示自动化工具。

如何减少Agda中的单调乏味？

这是一个示例代码：

open import Data.Nat hiding (_≤?_)
open import Function
open import Data.Bool
open import Relation.Binary.PropositionalEquality
open import Data.Empty
open import Data.Product
open import Data.Unit hiding (_≤?_)

data AExp : Set where
  ANum : ℕ → AExp
  APlus AMinus AMult : AExp → AExp → AExp

aeval : AExp → ℕ
aeval (ANum x) = x
aeval (APlus a b) = aeval a + aeval b 
aeval (AMinus a b) = aeval a ∸ aeval b  
aeval (AMult a b) = aeval a * aeval b

opt-0+ : AExp → AExp
opt-0+ (ANum x) = ANum x
opt-0+ (APlus (ANum 0) b) = b
opt-0+ (APlus a b) = APlus (opt-0+ a) (opt-0+ b)
opt-0+ (AMinus a b) = AMinus (opt-0+ a) (opt-0+ b)
opt-0+ (AMult a b) = AMult (opt-0+ a) (opt-0+ b)

opt-0+-sound : ∀ e → aeval (opt-0+ e) ≡ aeval e
opt-0+-sound (ANum x) = refl
opt-0+-sound (APlus (ANum zero) b) rewrite opt-0+-sound b = refl
opt-0+-sound (APlus (ANum (suc x)) b) rewrite opt-0+-sound b = refl
opt-0+-sound (APlus (APlus a a₁) b) rewrite opt-0+-sound (APlus a a₁) | opt-0+-sound b = refl
opt-0+-sound (APlus (AMinus a a₁) b) rewrite opt-0+-sound (AMinus a a₁) | opt-0+-sound b = refl
opt-0+-sound (APlus (AMult a a₁) b) rewrite opt-0+-sound (AMult a a₁) | opt-0+-sound b = refl
opt-0+-sound (AMinus a b) rewrite opt-0+-sound a | opt-0+-sound b = refl
opt-0+-sound (AMult a b) rewrite opt-0+-sound a | opt-0+-sound b = refl

这里有一些具体问题：

首先，如果我在普通的Haskell中编写一个未经验证的程序，我会考虑术语递归或使用泛型编程。我也可以在Agda中编写泛型转换函数：

transform : (AExp → AExp) → AExp → AExp
transform f (ANum x)     = f (ANum x)
transform f (APlus a b)  = f (APlus  (transform f a) (transform f b))
transform f (AMinus a b) = f (AMinus (transform f a) (transform f b))
transform f (AMult a b)  = f (AMult  (transform f a) (transform f b))

opt-0+ : AExp → AExp
opt-0+ = transform (λ {(APlus (ANum 0) b) → b; x → x})

但随后证据变得可怕。我也试图定义一个标准的变形，然后用它来定义评估和变换，然后尝试用作为变构的参数的函数（对应于构造函数）来证明事物，但我几乎失败了那种方法。所以，在这里我想知道是否有一种可行的“通用”方法来进行证明编写，这种方法只关注相关案例并跳过其他案例。

其次，在展开函数定义时，Agda没有考虑“捕获所有”模式。从我的证明中回忆起这部分：

opt-0+-sound (APlus (ANum zero) b) rewrite opt-0+-sound b = refl
opt-0+-sound (APlus (ANum (suc x)) b) rewrite opt-0+-sound b = refl
opt-0+-sound (APlus (APlus a a₁) b) rewrite opt-0+-sound (APlus a a₁) | opt-0+-sound b = refl
opt-0+-sound (APlus (AMinus a a₁) b) rewrite opt-0+-sound (AMinus a a₁) | opt-0+-sound b = refl
opt-0+-sound (APlus (AMult a a₁) b) rewrite opt-0+-sound (AMult a a₁) | opt-0+-sound b = refl

在第一行下面的所有情况下，Agda都不记得我们已经涵盖了opt-0+的唯一相关案例，因此我们必须再次写出每个构造函数。随着构造函数的增加，这个问题显得越来越令人厌烦。是否有消除样板情况的技巧？

Answer 1

让我们稍微概括一下transform：

foldAExp : {A : Set} -> (ℕ -> A) -> (_ _ _ : A -> A -> A) -> AExp -> A
foldAExp f0 f1 f2 f3 (ANum x)     = f0 x
foldAExp f0 f1 f2 f3 (APlus a b)  = f1 (foldAExp f0 f1 f2 f3 a) (foldAExp f0 f1 f2 f3 b)
foldAExp f0 f1 f2 f3 (AMinus a b) = f2 (foldAExp f0 f1 f2 f3 a) (foldAExp f0 f1 f2 f3 b)
foldAExp f0 f1 f2 f3 (AMult a b)  = f3 (foldAExp f0 f1 f2 f3 a) (foldAExp f0 f1 f2 f3 b)

现在我们可以编写这个函数了：

generalize : ∀ f0 f1 f2 f3
           -> (∀ x   -> aeval (f0 x)   ≡ aeval (ANum x))
           -> (∀ a b -> aeval (f1 a b) ≡ aeval (APlus a b))
           -> (∀ a b -> aeval (f2 a b) ≡ aeval (AMinus a b))
           -> (∀ a b -> aeval (f3 a b) ≡ aeval (AMult a b))
           -> (∀ e -> aeval (foldAExp f0 f1 f2 f3 e) ≡ aeval e)
generalize f0 f1 f2 f3 p0 p1 p2 p3 (ANum x) = p0 x
generalize f0 f1 f2 f3 p0 p1 p2 p3 (APlus a b)
  rewrite p1 (foldAExp f0 f1 f2 f3 a) (foldAExp f0 f1 f2 f3 b)
  | generalize f0 f1 f2 f3 p0 p1 p2 p3 a | generalize f0 f1 f2 f3 p0 p1 p2 p3 b = refl
generalize f0 f1 f2 f3 p0 p1 p2 p3 (AMinus a b)
  rewrite p2 (foldAExp f0 f1 f2 f3 a) (foldAExp f0 f1 f2 f3 b)
  | generalize f0 f1 f2 f3 p0 p1 p2 p3 a | generalize f0 f1 f2 f3 p0 p1 p2 p3 b = refl
generalize f0 f1 f2 f3 p0 p1 p2 p3 (AMult a b)
  rewrite p3 (foldAExp f0 f1 f2 f3 a) (foldAExp f0 f1 f2 f3 b)
  | generalize f0 f1 f2 f3 p0 p1 p2 p3 a | generalize f0 f1 f2 f3 p0 p1 p2 p3 b = refl

因此，如果我们有f0，f1，f2和f3这样的功能，则不会改变＆＃34;含义＆＃34;任何适当的子表达式（Num _为f0，APlus _ _为f1等等），我们可以使用这些函数折叠任何表达式而不更改其＆＃34;含义＆＃34 ;.这是一个简单的例子：

idAExp : AExp → AExp
idAExp = foldAExp ANum APlus AMinus AMult

idAExp-sound : ∀ e → aeval (idAExp e) ≡ aeval e
idAExp-sound = generalize _ _ _ _ (λ _ → refl) (λ _ _ → refl) (λ _ _ → refl) (λ _ _ → refl)

现在我们需要可判定的平等机制来记住＆＃34;涵盖案件。我将发布下面整个代码的链接，因为有很多样板。这是引理，你要证明：

0+-f1 : AExp -> AExp -> AExp
0+-f1 a         b with a ≟AExp ANum 0
0+-f1 .(ANum 0) b | yes refl = b
0+-f1  a        b | no  p    = APlus a b

opt-0+ : AExp → AExp
opt-0+ = foldAExp ANum 0+-f1 AMinus AMult

0+-p1 : ∀ a b -> aeval (0+-f1 a b) ≡ aeval (APlus a b)
0+-p1  a        b with a ≟AExp ANum 0
0+-p1 .(ANum 0) b | yes refl = refl
0+-p1  a        b | no  p    = refl

opt-0+-sound : ∀ e → aeval (opt-0+ e) ≡ aeval e
opt-0+-sound = generalize _ _ _ _ (λ _ → refl) 0+-p1 (λ _ _ → refl) (λ _ _ → refl)

让我们证明更加花哨的引理。

fancy-lem : ∀ a1 a2 b1 b2 -> a1 * b1 + a1 * b2 + a2 * b1 + a2 *  b2 ≡ (a1 + a2) * (b1 + b2)
fancy-lem = solve
  4
  (λ a1 a2 b1 b2 → a1 :* b1 :+ a1 :* b2 :+ a2 :* b1 :+ a2 :* b2 := (a1 :+ a2) :* (b1 :+ b2))
  refl
    where
      import Data.Nat.Properties
      open Data.Nat.Properties.SemiringSolver

现在我们希望在AExp术语上进行此类优化：

left : AExp -> AExp
left (ANum   x  ) = ANum x
left (APlus  a b) = a
left (AMinus a b) = a
left (AMult  a b) = a

right : AExp -> AExp
right (ANum x    ) = ANum x
right (APlus a b ) = b
right (AMinus a b) = b
right (AMult  a b) = b

fancy-f3 : AExp -> AExp -> AExp
fancy-f3 a b with left a | right a | left b | right b
fancy-f3 a b | a1 | a2 | b1 | b2 with a ≟AExp APlus a1 a2 | b ≟AExp APlus b1 b2
fancy-f3 .(APlus a1 a2) .(APlus b1 b2) | a1 | a2 | b1 | b2 | yes refl | yes refl =
  APlus (APlus (APlus (AMult a1 b1) (AMult a1 b2)) (AMult a2 b1)) (AMult a2 b2)
fancy-f3  a              b             | a1 | a2 | b1 | b2 | _        | _        = AMult a 

opt-fancy : AExp → AExp
opt-fancy = foldAExp ANum APlus AMinus fancy-f3

健全性证明：

fancy-p3 : ∀ a b -> aeval (fancy-f3 a b) ≡ aeval (AMult a b)
fancy-p3 a b with left a | right a | left b | right b
fancy-p3 a b | a1 | a2 | b1 | b2 with a ≟AExp APlus a1 a2 | b ≟AExp APlus b1 b2
fancy-p3 .(APlus a1 a2) .(APlus b1 b2) | a1 | a2 | b1 | b2 | yes refl | yes refl =
  fancy-lem (aeval a1) (aeval a2) (aeval b1) (aeval b2)
fancy-p3 .(APlus a1 a2)  b             | a1 | a2 | b1 | b2 | yes refl | no  _    = refl
fancy-p3  a             .(APlus b1 b2) | a1 | a2 | b1 | b2 | no  _    | yes refl = refl
fancy-p3  a              b             | a1 | a2 | b1 | b2 | no  _    | no  _    = refl

opt-fancy-sound : ∀ e → aeval (opt-fancy e) ≡ aeval e
opt-fancy-sound = generalize _ _ _ _ (λ _ → refl) (λ _ _ → refl) (λ _ _ → refl) fancy-p3

以下是整个代码：http://lpaste.net/106481 可以减少generalize和≟AExp中的样板量。这里描述了诀窍：http://rubrication.blogspot.ru/2012/03/decidable-equality-in-agda.html 对不起，如果有些东西显得很傻，我的浏览器就变得疯狂了。

修改

没有必要使用凌乱的foldAExp东西。通常transform使事情变得更容易。以下是一些定义：

transform : (AExp → AExp) → AExp → AExp transform f (ANum x) = f (ANum x) transform f (APlus a b) = f (APlus (transform f a) (transform f b)) transform f (AMinus a b) = f (AMinus (transform f a) (transform f b)) transform f (AMult a b) = f (AMult (transform f a) (transform f b)) generalize : ∀ f -> (∀ e -> aeval (f e) ≡ aeval e) -> (∀ e -> aeval (transform f e) ≡ aeval e) generalize f p (ANum x) = p (ANum x) generalize f p (APlus a b) rewrite p (APlus (transform f a) (transform f b)) | generalize f p a | generalize f p b = refl generalize f p (AMinus a b) rewrite p (AMinus (transform f a) (transform f b)) | generalize f p a | generalize f p b = refl generalize f p (AMult a b) rewrite p (AMult (transform f a) (transform f b)) | generalize f p a | generalize f p b = refl idAExp : AExp → AExp idAExp = transform id idAExp-sound : ∀ e → aeval (idAExp e) ≡ aeval e idAExp-sound = generalize _ (λ _ → refl)

整个代码：http://lpaste.net/106500

Answer 2

由于我们不需要no个案例的证明，因此切换到此数据类型可能更好：

data Dec' {p} (P : Set p) : Set p where
  yes : (p : P) → Dec' P
  no  : Dec' P

因为有n * (n - 1) no个案例和n yes个案例。所以这种表示非常具有可扩展性。

也可以自动完成所有这些可判定性。以下是转换的主要功能：

vecApply : {α γ : Level} {X : Set α} {Z : Set γ} -> (n : ℕ) -> nary n X Z -> Vec X n -> Z
vecApply  0      x  _       = x
vecApply (suc n) f (x ∷ xs) = vecApply n (f x) xs

replace' : (n : ℕ) -> nary n AExp (AExp × AExp) -> AExp -> AExp
replace' n f e with getSubterms n f e
replace' n f e | nothing = e
replace' n f e | just xs with vecApply n f xs
replace' n f e | just xs |  e' , e'' with e ≟AExp e'
replace' n f e | just xs | .e  , e'' | yes refl = e''
replace' n f e | just xs |  e' , e'' | no       = e

因此，您提供了一些函数，它接收n个参数并返回两个表达式。例如：

_==_ : {α β : Level} {A : Set α} {B : Set β} -> A -> B -> A × B
_==_ = _,_

0+-func : AExp -> AExp × AExp
0+-func = λ a2 -> APlus (ANum 0) a2 == a2

第一个表达式是您要查找的内容，第二个表达式用于替换第一个表达式。首先，您需要编写一个函数，找到所有适当的子表达式。例如

ex1-func : (_ _ : AExp) -> AExp × AExp
ex1-func = λ a1 b1 -> AMult (APlus a1 b1) (APlus a1 b1) == ANum 0

适用于ex1-func和此术语

let    a1 = ANum 0
in let b1 = ANum 1
in AMult (APlus a1 b1) (APlus a1 b1)

此函数应按此顺序返回ANum 0 ∷ ANum 1 ∷ []。要首先实现此目的，您需要确定某个表达式中的所有“漏洞”（上例中的a1和b1）。然后你需要删除重复项（a1有两个“漏洞”，而ex1-func（和任何其他函数）只接收两个漏洞的a1。

这是一个肮脏的解决方案：

enlarge : AExp -> AExp
enlarge a = APlus a a

size : AExp -> ℕ
size (APlus a _) = 1 + size a
size  _          = 0

small big : AExp
small = ANum 0
big   = enlarge small

transT : Set
transT = AExp -> AExp

transTs : Set
transTs = L.List transT

left : transT
left (ANum   x  ) = ANum x
left (APlus  a b) = a
left (AMinus a b) = a
left (AMult  a b) = a

right : transT
right (ANum   x  ) = ANum x
right (APlus  a b) = b
right (AMinus a b) = b
right (AMult  a b) = b

directions : AExp -> AExp -> transTs
directions (ANum   _)     (ANum   _)     = L.[]
directions (APlus  a1 a2) (APlus  b1 b2) =
  L.map (λ f -> f ∘ left) (directions a1 b1) L.++ L.map (λ f -> f ∘ right) (directions a2 b2)
directions (AMinus a1 a2) (AMinus b1 b2) =
  L.map (λ f -> f ∘ left) (directions a1 b1) L.++ L.map (λ f -> f ∘ right) (directions a2 b2)
directions (AMult  a1 a2) (AMult  b1 b2) =
  L.map (λ f -> f ∘ left) (directions a1 b1) L.++ L.map (λ f -> f ∘ right) (directions a2 b2)
directions  _              _             = id L.∷ L.[]

add : {l : ℕ} -> ℕ -> transT -> Vec transTs l -> Vec transTs l  
add  _      d  []      = []
add  0      d (x ∷ xs) = (d L.∷ x) ∷ xs
add (suc n) d (x ∷ xs) = x ∷ add n d xs

naryApply : {α γ : Level} {X : Set α} {Z : Set γ} -> (n : ℕ) -> nary n X Z -> X -> Z
naryApply  0      x _ = x
naryApply (suc n) f x = naryApply n (f x) x

naryApplyWith : {α γ : Level} {X : Set α} {Z : Set γ}
              -> (n : ℕ) -> nary n X Z -> (X -> X) -> X -> Z
naryApplyWith  0      x _ _ = x
naryApplyWith (suc n) f g x = naryApplyWith n (f x) g (g x)

directionses : (n : ℕ) -> nary n AExp (AExp × AExp) -> Vec transTs n
directionses n f = L.foldr (λ f -> add (size (f e)) f) (replicate L.[]) $
  directions (proj₁ $ naryApply n f big) (proj₁ $ naryApply n f small) where
    e = proj₁ $ naryApplyWith n f enlarge small

open RawMonad {{...}}

getSubterms : (n : ℕ) -> nary n AExp (AExp × AExp) -> AExp -> Maybe (Vec AExp n)
getSubterms n f e = (λ _ -> map (λ fs -> lhead id fs e) dss) <$> flip (mapM M.monad) dss
  (L.sequence M.monad ∘ neighbWith (λ f g -> dec'ToMaybe⊤ $ f e ≟AExp g e)) where
    dss = directionses n f

我们的想法是将您的功能应用于两个不同的术语，然后找到差异。这里的“差异”是像left ∘ right ∘ right这样的函数列表（这很脏，但我想可以改进）。现在你可以导航了。然后再次应用此函数，但现在每个术语都比以前更大，因此可以区分它们（这就是size函数的作用）。最后，如果所有明确的孔都由identic表达式填充，则此函数会检查。如果是这样，它会在每个“相同的家族”中选择随机（实际上是第一个）表达，并将它们收集到一个向量中。

replace'函数中的其他内容非常简单。将变换函数应用于子表达式的向量，并将最终项与原始项进行比较。如果它们是相同的，那么你找到了一个子表达式，可以转换为转换函数。

现在您需要从一个子项移动到所有子项：

replace : (n : ℕ) -> nary n AExp (AExp × AExp) -> AExp -> AExp 
replace n f = transform (replace' n f)

这就是改造的全部。证明东西非常对称。

sound' : ∀ n f
       -> soundnessProof n f
       -> ∀ e -> aeval (replace' n f e) ≡ aeval e
sound' n f p e with getSubterms n f e
sound' n f p e | nothing = refl
sound' n f p e | just xs with vecApply n f xs | vecApplyProof p xs
sound' n f p e | just xs |  e' , e'' | p' with e ≟AExp e'
sound' n f p e | just xs | .e  , e'' | p' | yes refl = p'
sound' n f p e | just xs |  e' , e'' | p' | no       = refl

唯一的区别 - sound'会为您的转化功能获得完整性。

soundnessProof : (n : ℕ) -> nary n AExp (AExp × AExp) -> Set 
soundnessProof  0      (e' , e'') = aeval e'' ≡ aeval e'
soundnessProof (suc n)     f      = ∀ x -> soundnessProof n (f x)

这就是说，对于所有参数f，必须返回具有identic“含义”的两个术语的元组。回想一下这个例子：

_==_ : {α β : Level} {A : Set α} {B : Set β} -> A -> B -> A × B
_==_ = _,_

0+-func : AExp -> AExp × AExp
0+-func = λ a2 -> APlus (ANum 0) a2 == a2

vecApplyProof在值级别是对称的，但在类型级别稍微复杂一些：

vecApplyProof : {n : ℕ} {f : nary n AExp (AExp × AExp)}
               -> soundnessProof n f -> (xs : Vec AExp n)
               -> uncurry (λ p1 p2 -> aeval p2 ≡ aeval p1) $ vecApply n f xs
vecApplyProof {0}     p  _       = p
vecApplyProof {suc n} p (x ∷ xs) = vecApplyProof {n} (p x) xs

您还需要从一个子表达式转移到所有子表达式：

generalize : ∀ f -> (∀ e -> aeval (f e) ≡ aeval e)
           -> (∀ e -> aeval (transform f e) ≡ aeval e)
generalize f p (ANum x)    = p (ANum x)
generalize f p (APlus a b)  rewrite p (APlus  (transform f a) (transform f b))
  | generalize f p a | generalize f p b = refl
generalize f p (AMinus a b) rewrite p (AMinus (transform f a) (transform f b))
  | generalize f p a | generalize f p b = refl
generalize f p (AMult a b)  rewrite p (AMult  (transform f a) (transform f b))
  | generalize f p a | generalize f p b = refl

sound : (n : ℕ) -> (f : nary n AExp (AExp × AExp))
      -> soundnessProof n f
      -> (∀ e -> aeval (replace n f e) ≡ aeval e)
sound n f p = generalize _ (sound' n f p)

最后一个例子：

fancy-func : (_ _ _ _ : AExp) -> AExp × AExp
fancy-func = λ a1 a2 b1 b2 -> AMult (APlus a1 a2) (APlus b1 b2) ==
  APlus (APlus (APlus (AMult a1 b1) (AMult a1 b2)) (AMult a2 b1)) (AMult a2 b2)

opt-fancy : AExp → AExp
opt-fancy = replace 4 fancy-func

test-opt-fancy :
  let    a1 = ANum 0
  in let a2 = AMinus a1 a1
  in let b1 = ANum 1
  in let b2 = AMinus b1 b1
  in opt-fancy (AMinus (AMult (APlus a1 a2) (APlus b1 b2)) (ANum 0)) ≡
    (AMinus (APlus (APlus (APlus (AMult a1 b1) (AMult a1 b2)) (AMult a2 b1)) (AMult a2 b2)) (ANum 0)) 
test-opt-fancy = refl

fancy-lem : ∀ a1 a2 b1 b2 -> a1 * b1 + a1 * b2 + a2 * b1 + a2 *  b2 ≡ (a1 + a2) * (b1 + b2)
fancy-lem = solve
  4
  (λ a1 a2 b1 b2 → a1 :* b1 :+ a1 :* b2 :+ a2 :* b1 :+ a2 :* b2 := (a1 :+ a2) :* (b1 :+ b2))
  refl
    where
      import Data.Nat.Properties
      open Data.Nat.Properties.SemiringSolver

opt-fancy-sound : ∀ e → aeval (opt-fancy e) ≡ aeval e
opt-fancy-sound = sound 4 fancy-func
  (λ a1 a2 b1 b2 -> fancy-lem (aeval a1) (aeval a2) (aeval b1) (aeval b2))

整个故事：http://lpaste.net/106670

编辑： directions函数（_∘_ left代替λ f -> f ∘ left）中的编写策略错误。现在修好了。

Agda中非繁琐的AST转换证明

2 个答案: