Agda中非繁瑣的AST轉換證明

Question

我正處於軟件基礎的“簡單命令式程序”一章中，一直在與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 ，它們不會改變任何適當的子表達式的“含義”（對於f0為Num _ ，對於f1為APlus _ _等等），我們可以用任何表達式來折疊這些功能沒有改變它的“意義”。 這是一個簡單的例子：

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

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

現在我們需要可判定的平等機制來“記住”被覆蓋的案例。 我將發布一個鏈接到下面的整個代碼，因為有很多樣板。 這是引理，你要證明：

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 ： ≟AExp可以減少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必須返回具有相同“含義”的兩個術語的元組。 回想一下這個例子：

_==_ : {α β : 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而不是_∘_ left λ f -> f ∘ left _∘_ left ）。 現在修復了。