Type Isos

Type Isos

module Function.Related.TypeIsomorphisms.NP where

import Level as L
open import Algebra
import Algebra.FunctionProperties as FP
open L using (Lift; lower; lift)
open import Type hiding (★)

open import Data.Fin using (Fin; zero; suc; pred)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_) renaming (_^_ to _**_)
open import Data.Maybe.NP
open import Data.Product.NP renaming (map to map×)
--open import Data.Product.N-ary
open import Data.Sum renaming (map to map⊎)
open import Data.Unit
open import Data.Empty
open import Data.Bits using (Bit; 0b; 1b; false; true; proj)

import Function.NP as F
open F using (Π)
import Function.Equality as FE
open FE using (_⟨$⟩_)
open import Function.Related as FR
open import Function.Related.TypeIsomorphisms public
import Function.Inverse.NP as Inv
open Inv using (_↔_; _∘_; sym; id; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)
open import Relation.Binary
open import Relation.Binary.Product.Pointwise
open import Relation.Binary.Sum
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_ ; _≢_)

Maybe-injective : ∀ {A B : Set} → Maybe A ↔ Maybe B → A ↔ B
Maybe-injective f = Iso.iso (g f) (g-empty f)
  module Maybe-injective where
    open Inverse using (injective; left-inverse-of; right-inverse-of)

    module _ {A B : Set}
      (f : Maybe A ↔ Maybe B)
      (tof-tot : ∀ x → to f (just x) ≢ nothing)
      (fof-tot : ∀ x → from f (just x) ≢ nothing) where

        CancelMaybe' : A ↔ B
        CancelMaybe' = inverses (⇒) (⇐) ⇐⇒ ⇒⇐ where

          ⇒ : _ → _
          ⇒ x with to f (just x) | tof-tot x
          ⇒ x | just y  | _ = y
          ⇒ x | nothing | p = ⊥-elim (p ≡.refl)

          ⇐ : _ → _
          ⇐ x with from f (just x) | fof-tot x
          ⇐ x | just y  | p = y
          ⇐ x | nothing | p = ⊥-elim (p ≡.refl)

          ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
          ⇐⇒ x with to f (just x)
                  | tof-tot x
                  | from f (just (⇒ x))
                  | fof-tot (⇒ x)
                  | left-inverse-of f (just x)
                  | right-inverse-of f (just (⇒ x))
          ⇐⇒ x | just x₁ | p | just x₂ | q | b | c  = just-injective (≡.trans (≡.sym (left-inverse-of f (just x₂))) (≡.trans (≡.cong (from f) c) b))
          ⇐⇒ x | just x₁ | p | nothing | q | _ | _  = ⊥-elim (q ≡.refl)
          ⇐⇒ x | nothing | p | z       | q | _ | _  = ⊥-elim (p ≡.refl)

          ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
          ⇒⇐ x with from f (just x)
                  | fof-tot x
                  | to f (just (⇐ x))
                  | tof-tot (⇐ x)
                  | right-inverse-of f (just x)
                  | left-inverse-of f (just (⇐ x))
          ⇒⇐ x | just x₁ | p | just x₂ | q | b | c = just-injective (≡.trans (≡.sym (right-inverse-of f (just x₂))) (≡.trans (≡.cong (to f) c) b))
          ⇒⇐ x | just x₁ | p | nothing | q | _ | _ = ⊥-elim (q ≡.refl)
          ⇒⇐ x | nothing | p | z       | q | _ | _ = ⊥-elim (p ≡.refl)

    module Iso {A B : Set}
      (f : Maybe A ↔ Maybe B)
      (f-empty : to f nothing ≡ nothing) where

      tof-tot : ∀ x → to f (just x) ≢ nothing
      tof-tot x eq with injective f (≡.trans eq (≡.sym f-empty))
      ... | ()

      f-empty' : from f nothing ≡ nothing
      f-empty' = ≡.trans (≡.sym (≡.cong (from f) f-empty)) (left-inverse-of f nothing)

      fof-tot : ∀ x → from f (just x) ≢ nothing
      fof-tot x eq with injective (sym f) (≡.trans eq (≡.sym f-empty'))
      ... | ()

      iso : A ↔ B
      iso = CancelMaybe' f tof-tot fof-tot

    module _ {A B : Set}
      (f : Maybe A ↔ Maybe B) where

      g : Maybe A ↔ Maybe B
      g = inverses (⇒) (⇐) ⇐⇒ ⇒⇐ where

          ⇒ : Maybe A → Maybe B
          ⇒ (just x) with to f (just x)
          ... | nothing = to f nothing
          ... | just y  = just y
          ⇒ nothing = nothing

          ⇐ : Maybe B → Maybe A
          ⇐ (just x) with from f (just x)
          ... | nothing = from f nothing
          ... | just y  = just y
          ⇐ nothing = nothing

          ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
          ⇐⇒ (just x) with to f (just x) | left-inverse-of f (just x)
          ⇐⇒ (just x) | just x₁ | p rewrite p = ≡.refl
          ⇐⇒ (just x) | nothing | p with to f nothing | left-inverse-of f nothing
          ⇐⇒ (just x) | nothing | p | just _ | q rewrite q = p
          ⇐⇒ (just x) | nothing | p | nothing | q = ≡.trans (≡.sym q) p
          ⇐⇒ nothing = ≡.refl

          ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
          ⇒⇐ (just x) with from f (just x) | right-inverse-of f (just x)
          ⇒⇐ (just x) | just x₁ | p rewrite p = ≡.refl
          ⇒⇐ (just x) | nothing | p with from f nothing | right-inverse-of f nothing
          ⇒⇐ (just x) | nothing | p | just _  | q rewrite q = p
          ⇒⇐ (just x) | nothing | p | nothing | q = ≡.trans (≡.sym q) p
          ⇒⇐ nothing = ≡.refl

      g-empty : to g nothing ≡ nothing
      g-empty = ≡.refl

private
    Setoid₀ : ★ _
    Setoid₀ = Setoid L.zero L.zero

Σ≡↔⊤ : ∀ {a} {A : ★ a} x → Σ A (_≡_ x) ↔ ⊤
Σ≡↔⊤ x = inverses (F.const _) (λ _ → _ , ≡.refl)
                  helper (λ _ → ≡.refl)
  where helper : (y : Σ _ (_≡_ x)) → (x , ≡.refl) ≡ y
        helper (.x , ≡.refl) = ≡.refl

module _ {a b c} {A : ★ a} {B : A → ★ b} {C : Σ A B → ★ c} where
    curried : Π (Σ A B) C ↔ Π A λ a → Π (B a) λ b → C (a , b)
    curried = inverses curry uncurry (λ _ → ≡.refl) (λ _ → ≡.refl)

module _ {a b c} {A : ★ a} {B : ★ b} {C : A → ★ c} (f : A ↔ B) where
  private
    left-f = Inverse.left-inverse-of f
    right-f = Inverse.right-inverse-of f
    coe : ∀ x → C x → C (from f (to f x))
    coe x = ≡.subst C (≡.sym (left-f x))
    ⇒ : Σ A C → Σ B (C F.∘ from f)
    ⇒ (x , p) = to f x , coe x p
    ⇐ : Σ B (C F.∘ from f) → Σ A C
    ⇐ = first (from f)
    ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
    ⇐⇒ (x , p) rewrite left-f x = ≡.refl
    ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
    ⇒⇐ p = mkΣ≡ (C F.∘ from f) (right-f (proj₁ p)) (helper p)
            where
                helper : ∀ p → ≡.subst (C F.∘ from f) (right-f (proj₁ p)) (coe (proj₁ (⇐ p)) (proj₂ (⇐ p))) ≡ proj₂ p
                helper p with to f (from f (proj₁ p)) | right-f (proj₁ p) | left-f (from f (proj₁ p))
                helper _ | ._ | ≡.refl | ≡.refl = ≡.refl
  first-iso : Σ A C ↔ Σ B (C F.∘ from f)
  first-iso = inverses (⇒) (⇐) ⇐⇒ ⇒⇐

module _ {a b c} {A : ★ a} {B : ★ b} {C : B → ★ c} (f : A ↔ B) where
  sym-first-iso : Σ A (C F.∘ to f) ↔ Σ B C
  sym-first-iso = sym (first-iso (sym f))

module _ {a b c} {A : ★ a} {B : A → ★ b} {C : A → ★ c} (f : ∀ x → B x ↔ C x) where
  private
    left-f = Inverse.left-inverse-of F.∘ f
    right-f = Inverse.right-inverse-of F.∘ f
    ⇒ : Σ A B → Σ A C
    ⇒ = second (to (f _))
    ⇐ : Σ A C → Σ A B
    ⇐ = second (from (f _))
    ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
    ⇐⇒ (x , y) rewrite left-f x y = ≡.refl
    ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
    ⇒⇐ (x , y) rewrite right-f x y = ≡.refl
  second-iso : Σ A B ↔ Σ A C
  second-iso = inverses (⇒) (⇐) ⇐⇒ ⇒⇐

module _ {a b c} {A : ★ a} {B : ★ b} {C : A ⊎ B → ★ c} where
  private
    S = Σ (A ⊎ B) C
    T = Σ A (C F.∘ inj₁) ⊎ Σ B (C F.∘ inj₂)
    ⇒ : S → T
    ⇒ (inj₁ x , y) = inj₁ (x , y)
    ⇒ (inj₂ x , y) = inj₂ (x , y)
    ⇐ : T → S
    ⇐ (inj₁ (x , y)) = inj₁ x , y
    ⇐ (inj₂ (x , y)) = inj₂ x , y
    ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
    ⇐⇒ (inj₁ _ , _) = ≡.refl
    ⇐⇒ (inj₂ _ , _) = ≡.refl
    ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
    ⇒⇐ (inj₁ _) = ≡.refl
    ⇒⇐ (inj₂ _) = ≡.refl

  Σ⊎-distrib : S ↔ T
  Σ⊎-distrib = inverses (⇒) (⇐) ⇐⇒ ⇒⇐

{- requires extensional equality
module _ {a b c} {A : ★ a} {B : ★ b} {C : A ⊎ B → ★ c} where
  private
    S = Π (A ⊎ B) C
    T = Π A (C F.∘ inj₁) × Π B (C F.∘ inj₂)
    ⇒ : S → T
    ⇒ f = f F.∘ inj₁ , f F.∘ inj₂
    ⇐ : T → S
    ⇐ (f , g) = [ f , g ]
    ⇐⇒ : ∀ f x → ⇐ (⇒ f) x ≡ f x
    ⇐⇒ f (inj₁ x) = ≡.refl
    ⇐⇒ f (inj₂ y) = ≡.refl
    ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
    ⇒⇐ (f , g) = ≡.refl

  Π×-distrib : S ↔ T
  Π×-distrib = inverses (⇒) (⇐) {!⇐⇒!} ⇒⇐
-}

⊎-ICommutativeMonoid : CommutativeMonoid _ _
⊎-ICommutativeMonoid = record {
                         _≈_ = Inv.Inverse;
                         _∙_ = _⊎-setoid_;
                         ε = ≡.setoid ⊥;
                         isCommutativeMonoid = record
                            { isSemigroup = record
                              { isEquivalence = Inv.isEquivalence
                              ; assoc = assoc
                              ; ∙-cong = _⊎-inverse_
                              }
                            ; identityˡ = left-identity
                            ; comm = comm
                            }
                         }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  left-identity : LeftIdentity (≡.setoid ⊥) _⊎-setoid_
  left-identity A = record
    { to = record
      { _⟨$⟩_ = [ (λ ()) , F.id ]
      ; cong  = cong-to
      }
    ; from = record
      { _⟨$⟩_ = inj₂
      ; cong = ₂∼₂
      }
    ; inverse-of = record
      { left-inverse-of = [ (λ ()) , (λ x → ₂∼₂ refl) ]
      ; right-inverse-of = λ x → refl
      }
    } where open Setoid A
            cong-to : Setoid._≈_ (≡.setoid ⊥ ⊎-setoid A) =[ _ ]⇒ _≈_
            cong-to (₁∼₂ ())
            cong-to (₁∼₁ x∼₁y) rewrite x∼₁y = refl
            cong-to (₂∼₂ x∼₂y) = x∼₂y

  assoc : Associative _⊎-setoid_
  assoc A B C = record
    { to = record
      { _⟨$⟩_ = [ [ inj₁ , inj₂ F.∘ inj₁ ] , inj₂ F.∘ inj₂ ]
      ; cong = cong-to
      }
    ; from = record
      { _⟨$⟩_ = [ inj₁ F.∘ inj₁ , [ inj₁ F.∘ inj₂ , inj₂ ] ]
      ; cong = cong-from
      }
    ; inverse-of = record
      { left-inverse-of = [ [ (λ _ → ₁∼₁ (₁∼₁ (refl A))) , (λ _ → ₁∼₁ (₂∼₂ (refl B)) ) ] , (λ _ → ₂∼₂ (refl C)) ]
      ; right-inverse-of = [ (λ _ → ₁∼₁ (refl A)) , [ (λ _ → ₂∼₂ (₁∼₁ (refl B))) , (λ _ → ₂∼₂ (₂∼₂ (refl C))) ] ]
      }
    } where
      open Setoid
      cong-to : _≈_ ((A ⊎-setoid B) ⊎-setoid C) =[ _ ]⇒ _≈_ (A ⊎-setoid (B ⊎-setoid C))
      cong-to (₁∼₂ ())
      cong-to (₁∼₁ (₁∼₂ ()))
      cong-to (₁∼₁ (₁∼₁ x∼₁y)) = ₁∼₁ x∼₁y
      cong-to (₁∼₁ (₂∼₂ x∼₂y)) = ₂∼₂ (₁∼₁ x∼₂y)
      cong-to (₂∼₂ x∼₂y) = ₂∼₂ (₂∼₂ x∼₂y)

      cong-from : _≈_ (A ⊎-setoid (B ⊎-setoid C)) =[ _ ]⇒ _≈_ ((A ⊎-setoid B) ⊎-setoid C)
      cong-from (₁∼₂ ())
      cong-from (₁∼₁ x∼₁y) = ₁∼₁ (₁∼₁ x∼₁y)
      cong-from (₂∼₂ (₁∼₂ ()))
      cong-from (₂∼₂ (₁∼₁ x∼₁y)) = ₁∼₁ (₂∼₂ x∼₁y)
      cong-from (₂∼₂ (₂∼₂ x∼₂y)) = ₂∼₂ x∼₂y

  comm : Commutative _⊎-setoid_
  comm A B = record
    { to = swap'
    ; from = swap'
    ; inverse-of = record
      { left-inverse-of  = inv A B
      ; right-inverse-of = inv B A
      }
    } where
      swap' : ∀ {A B} → A ⊎-setoid B FE.⟶ B ⊎-setoid A
      swap' {A} {B} = record
        { _⟨$⟩_ = [ inj₂ , inj₁ ]
        ; cong = cong
        } where
          cong : Setoid._≈_ (A ⊎-setoid B) =[ _ ]⇒ Setoid._≈_ (B ⊎-setoid A)
          cong (₁∼₂ ())
          cong (₁∼₁ x∼₁y) = ₂∼₂ x∼₁y
          cong (₂∼₂ x∼₂y) = ₁∼₁ x∼₂y

      inv : ∀ A B → ∀ x → Setoid._≈_ (A ⊎-setoid B) (swap' FE.∘ swap' {A} {B}⟨$⟩ x) x
      inv A B = [ (λ _ → ₁∼₁ (Setoid.refl A)) , (λ _ → ₂∼₂ (Setoid.refl B)) ]

×-ICommutativeMonoid : CommutativeMonoid _ _
×-ICommutativeMonoid = record {
                         _≈_ = Inv.Inverse;
                         _∙_ = _×-setoid_;
                         ε = ≡.setoid ⊤;
                         isCommutativeMonoid = record
                            { isSemigroup = record
                              { isEquivalence = Inv.isEquivalence
                              ; assoc = assoc
                              ; ∙-cong = _×-inverse_
                              }
                            ; identityˡ = left-identity
                            ; comm = comm
                            }
                         }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  left-identity : LeftIdentity (≡.setoid ⊤) _×-setoid_
  left-identity A = record
    { to = record
      { _⟨$⟩_ = proj₂
      ; cong = proj₂
      }
    ; from = record
      { _⟨$⟩_ = λ x → _ , x
      ; cong = λ x → ≡.refl , x
      }
    ; inverse-of = record
      { left-inverse-of = λ x → ≡.refl , (Setoid.refl A)
      ; right-inverse-of = λ x → Setoid.refl A
      }
    }

  assoc : Associative _×-setoid_
  assoc A B C = record
    { to = record
      { _⟨$⟩_ = < proj₁ F.∘ proj₁ , < proj₂ F.∘ proj₁ , proj₂ > >
      ; cong  = < proj₁ F.∘ proj₁ , < proj₂ F.∘ proj₁ , proj₂ > >
      }
    ; from = record
      { _⟨$⟩_ = < < proj₁ , proj₁ F.∘ proj₂ > , proj₂ F.∘ proj₂ >
      ; cong  = < < proj₁ , proj₁ F.∘ proj₂ > , proj₂ F.∘ proj₂ >
      }
    ; inverse-of = record
      { left-inverse-of = λ _ → Setoid.refl ((A ×-setoid B) ×-setoid C)
      ; right-inverse-of = λ _ → Setoid.refl (A ×-setoid (B ×-setoid C))
      }
    }

  comm : Commutative _×-setoid_
  comm A B = record
    { to = swap' {A} {B}
    ; from = swap' {B} {A}
    ; inverse-of = record
      { left-inverse-of = inv A B
      ; right-inverse-of = inv B A
      }
    } where
      swap' : ∀ {A B} → A ×-setoid B FE.⟶ B ×-setoid A
      swap' {A}{B} = record { _⟨$⟩_ = swap; cong = swap }

      inv : ∀ A B → ∀ x → Setoid._≈_ (A ×-setoid B) (swap' {B} {A} FE.∘ swap' {A} {B}⟨$⟩ x) x
      inv A B = λ x → Setoid.refl (A ×-setoid B)

×⊎-ICommutativeSemiring : CommutativeSemiring _ _
×⊎-ICommutativeSemiring = record
  { _≈_ = Inv.Inverse
  ; _+_ = _⊎-setoid_
  ; _*_ = _×-setoid_
  ; 0# = ≡.setoid ⊥
  ; 1# = ≡.setoid ⊤
  ; isCommutativeSemiring = record
    { +-isCommutativeMonoid = CommutativeMonoid.isCommutativeMonoid ⊎-ICommutativeMonoid
    ; *-isCommutativeMonoid = CommutativeMonoid.isCommutativeMonoid ×-ICommutativeMonoid
    ; distribʳ = distribʳ
    ; zeroˡ = zeroˡ
    }
  }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  distribʳ : _×-setoid_ DistributesOverʳ _⊎-setoid_
  distribʳ A B C = record
    { to = record
      { _⟨$⟩_ = uncurry [ curry inj₁ , curry inj₂ ]
      ; cong = cong-to
      }
    ; from = record
      { _⟨$⟩_ = frm
      ; cong = cong-from
      }
    ; inverse-of = record
      { left-inverse-of  = uncurry [ (λ x y → (₁∼₁ (refl B)) , (refl A)) , (λ x y → (₂∼₂ (refl C)) , (refl A)) ]
      ; right-inverse-of = [ uncurry (λ x y → ₁∼₁ ((refl B {x}) , (refl A {y})))
                           , uncurry (λ x y → ₂∼₂ ((refl C {x}) , (refl A {y}))) ]
      }
    } where
      open Setoid
      A' = Carrier A
      B' = Carrier B
      C' = Carrier C

      cong-to : _≈_ ((B ⊎-setoid C) ×-setoid A) =[ _ ]⇒ _≈_ ((B ×-setoid A) ⊎-setoid (C ×-setoid A))
      cong-to (₁∼₂ () , _)
      cong-to (₁∼₁ x∼₁y , A-rel) = ₁∼₁ (x∼₁y , A-rel)
      cong-to (₂∼₂ x∼₂y , A-rel) = ₂∼₂ (x∼₂y , A-rel)

      frm : B' × A' ⊎ C' × A' → (B' ⊎ C') × A'
      frm = [ map× inj₁ F.id , map× inj₂ F.id ]

      cong-from : _≈_ ((B ×-setoid A) ⊎-setoid (C ×-setoid A)) =[ _ ]⇒ _≈_ ((B ⊎-setoid C) ×-setoid A)
      cong-from (₁∼₂ ())
      cong-from (₁∼₁ (B-rel , A-rel)) = ₁∼₁ B-rel , A-rel
      cong-from (₂∼₂ (C-rel , A-rel)) = ₂∼₂ C-rel , A-rel

  zeroˡ : LeftZero (≡.setoid ⊥) _×-setoid_
  zeroˡ A = record
    { to = record
      { _⟨$⟩_ = proj₁
      ; cong = proj₁
      }
    ; from = record
      { _⟨$⟩_ = ⊥-elim
      ; cong = λ { {()} x }
      }
    ; inverse-of = record
      { left-inverse-of = λ x → ⊥-elim (proj₁ x)
      ; right-inverse-of = λ x → ⊥-elim x
      }
    }

module ×-CMon {a} = CommutativeMonoid (×-CommutativeMonoid FR.bijection a)
module ⊎-CMon {a} = CommutativeMonoid (⊎-CommutativeMonoid FR.bijection a)
module ×⊎° {a}    = CommutativeSemiring (×⊎-CommutativeSemiring FR.bijection a)

module ×-ICMon = CommutativeMonoid ×-ICommutativeMonoid
module ⊎-ICMon = CommutativeMonoid ⊎-ICommutativeMonoid
module ×⊎°I    = CommutativeSemiring ×⊎-ICommutativeSemiring

lift-⊎ : ∀ {A B : Set} → Inv.Inverse ((≡.setoid A) ⊎-setoid (≡.setoid B)) (≡.setoid (A ⊎ B))
lift-⊎ {A}{B} = record
  { to = record
    { _⟨$⟩_ = λ x → x
    ; cong = cong
    }
  ; from = record
    { _⟨$⟩_ = λ x → x
    ; cong = λ x → Setoid.reflexive (≡.setoid A ⊎-setoid ≡.setoid B) x
    }
  ; inverse-of = record
    { left-inverse-of = λ x → Setoid.refl (≡.setoid A ⊎-setoid ≡.setoid B)
    ; right-inverse-of = λ x → Setoid.refl (≡.setoid (A ⊎ B))
    }
  } where
    cong : Setoid._≈_ (≡.setoid A ⊎-setoid ≡.setoid B)  =[ _ ]⇒ Setoid._≈_ (≡.setoid (A ⊎ B))
    cong (₁∼₂ ())
    cong (₁∼₁ x∼₁y) = ≡.cong inj₁ x∼₁y
    cong (₂∼₂ x∼₂y) = ≡.cong inj₂ x∼₂y

swap-iso : ∀ {a b} {A : ★ a} {B : ★ b} → (A × B) ↔ (B × A)
swap-iso = inverses swap swap (λ _ → ≡.refl) (λ _ → ≡.refl)

module _ {a b c} {A : ★ a} {B : ★ b} {C : A × B → ★ c} where
  Σ×-swap : Σ (A × B) C ↔ Σ (B × A) (C F.∘ swap)
  Σ×-swap = first-iso swap-iso

Maybe↔Lift⊤⊎ : ∀ {ℓ a} {A : ★ a} → Maybe A ↔ (Lift {ℓ = ℓ} ⊤ ⊎ A)
Maybe↔Lift⊤⊎
  = inverses (maybe inj₂ (inj₁ _))
             [ F.const nothing , just ]
             (maybe (λ _ → ≡.refl) ≡.refl)
             [ (λ _ → ≡.refl) , (λ _ → ≡.refl) ]

Maybe↔⊤⊎ : ∀ {a} {A : ★ a} → Maybe A ↔ (⊤ ⊎ A)
Maybe↔⊤⊎
  = inverses (maybe inj₂ (inj₁ _))
             [ F.const nothing , just ]
             (maybe (λ _ → ≡.refl) ≡.refl)
             [ (λ _ → ≡.refl) , (λ _ → ≡.refl) ]

Maybe-cong : ∀ {a b} {A : ★ a} {B : ★ b} → A ↔ B → Maybe A ↔ Maybe B
Maybe-cong A↔B = sym Maybe↔⊤⊎ ∘ id ⊎-cong A↔B ∘ Maybe↔⊤⊎

Maybe∘Maybe^↔Maybe^∘Maybe : ∀ {a} {A : ★ a} n → Maybe (Maybe^ n A) ↔ Maybe^ n (Maybe A)
Maybe∘Maybe^↔Maybe^∘Maybe zero    = id
Maybe∘Maybe^↔Maybe^∘Maybe (suc n) = Maybe-cong (Maybe∘Maybe^↔Maybe^∘Maybe n)

Maybe^-cong : ∀ {a b} {A : ★ a} {B : ★ b} n → A ↔ B → Maybe^ n A ↔ Maybe^ n B
Maybe^-cong zero    = F.id
Maybe^-cong (suc n) = Maybe-cong F.∘ Maybe^-cong n

Vec0↔Lift⊤ : ∀ {a ℓ} {A : ★ a} → Vec A 0 ↔ Lift {_} {ℓ} ⊤
Vec0↔Lift⊤ = inverses _ (F.const []) (λ { [] → ≡.refl }) (λ _ → ≡.refl)

Vec0↔⊤ : ∀ {a} {A : ★ a} → Vec A 0 ↔ ⊤
Vec0↔⊤ = inverses _ (F.const []) (λ { [] → ≡.refl }) (λ _ → ≡.refl)

Vec∘suc↔A×Vec : ∀ {a} {A : ★ a} {n} → Vec A (suc n) ↔ (A × Vec A n)
Vec∘suc↔A×Vec
  = inverses (λ { (x ∷ xs) → x , xs }) (uncurry _∷_)
             (λ { (x ∷ xs) → ≡.refl }) (λ _ → ≡.refl)

infix 8 _^_

_^_ : ∀ {a} → ★ a → ℕ → ★ a
A ^ 0     = Lift ⊤
A ^ suc n = A × A ^ n

^↔Vec : ∀ {a} {A : ★ a} n → (A ^ n) ↔ Vec A n
^↔Vec zero    = sym Vec0↔Lift⊤
^↔Vec (suc n) = sym Vec∘suc↔A×Vec ∘ (id ×-cong (^↔Vec n))

Fin0↔⊥ : Fin 0 ↔ ⊥
Fin0↔⊥ = inverses (λ()) (λ()) (λ()) (λ())

Fin∘suc↔Maybe∘Fin : ∀ {n} → Fin (suc n) ↔ Maybe (Fin n)
Fin∘suc↔Maybe∘Fin {n}
  = inverses to' (maybe suc zero)
             (λ { zero → ≡.refl ; (suc n) → ≡.refl })
             (maybe (λ _ → ≡.refl) ≡.refl)
  where to' : Fin (suc n) → Maybe (Fin n)
        to' zero = nothing
        to' (suc n) = just n

Fin-injective : ∀ {m n} → Fin m ↔ Fin n → m ≡ n
Fin-injective = go _ _ where
    go : ∀ m n → Fin m ↔ Fin n → m ≡ n
    go zero    zero    iso = ≡.refl
    go zero    (suc n) iso with from iso zero
    ...                       | ()
    go (suc m) zero    iso with to iso zero
    ...                       | ()
    go (suc m) (suc n) iso = ≡.cong suc (go m n (Maybe-injective (Fin∘suc↔Maybe∘Fin ∘ iso ∘ sym Fin∘suc↔Maybe∘Fin)))

Lift↔id : ∀ {a} {A : ★ a} → Lift {a} {a} A ↔ A
Lift↔id = inverses lower lift (λ { (lift x) → ≡.refl }) (λ _ → ≡.refl)

⊤×A↔A : ∀ {A : ★₀} → (⊤ × A) ↔ A
⊤×A↔A = proj₁ ×-CMon.identity _ ∘ sym Lift↔id ×-cong id

A×⊤↔A : ∀ {A : ★₀} → (A × ⊤) ↔ A
A×⊤↔A = proj₂ ×-CMon.identity _ ∘ id ×-cong sym Lift↔id

⊥⊎A↔A : ∀ {A : ★₀} → (⊥ ⊎ A) ↔ A
⊥⊎A↔A = proj₁ ⊎-CMon.identity _ ∘ sym Lift↔id ⊎-cong id

A⊎⊥↔A : ∀ {A : ★₀} → (A ⊎ ⊥) ↔ A
A⊎⊥↔A = proj₂ ⊎-CMon.identity _ ∘ id ⊎-cong sym Lift↔id

⊥×A↔⊥ : ∀ {A : ★₀} → (⊥ × A) ↔ ⊥
⊥×A↔⊥ = Lift↔id ∘ proj₁ ×⊎°.zero _ ∘ sym (Lift↔id ×-cong id)

Maybe⊥↔⊤ : Maybe ⊥ ↔ ⊤
Maybe⊥↔⊤ = A⊎⊥↔A ∘ Maybe↔⊤⊎

Maybe^⊥↔Fin : ∀ n → Maybe^ n ⊥ ↔ Fin n
Maybe^⊥↔Fin zero    = sym Fin0↔⊥
Maybe^⊥↔Fin (suc n) = sym Fin∘suc↔Maybe∘Fin ∘ Maybe-cong (Maybe^⊥↔Fin n)

Maybe^⊤↔Fin1+ : ∀ n → Maybe^ n ⊤ ↔ Fin (suc n)
Maybe^⊤↔Fin1+ n = Maybe^⊥↔Fin (suc n) ∘ sym (Maybe∘Maybe^↔Maybe^∘Maybe n) ∘ Maybe^-cong n (sym Maybe⊥↔⊤)

Maybe-⊎ : ∀ {a} {A B : ★ a} → (Maybe A ⊎ B) ↔ Maybe (A ⊎ B)
Maybe-⊎ {a} = sym Maybe↔Lift⊤⊎ ∘ ⊎-CMon.assoc (Lift {_} {a} ⊤) _ _ ∘ (Maybe↔Lift⊤⊎ ⊎-cong id)

Maybe^-⊎-+ : ∀ {A} m n → (Maybe^ m ⊥ ⊎ Maybe^ n A) ↔ Maybe^ (m + n) A
Maybe^-⊎-+ zero    n = ⊥⊎A↔A
Maybe^-⊎-+ (suc m) n = Maybe-cong (Maybe^-⊎-+ m n) ∘ Maybe-⊎

Bit↔⊤⊎⊤ : Bit ↔ (⊤ ⊎ ⊤)
Bit↔⊤⊎⊤ = inverses (proj (inj₁ _ , inj₂ _)) [ F.const 0b , F.const 1b ] ⇐⇒ ⇒⇐
  where
  ⇐⇒ : (_ : Bit) → _
  ⇐⇒ true = ≡.refl
  ⇐⇒ false = ≡.refl
  ⇒⇐ : (_ : ⊤ ⊎ ⊤) → _
  ⇒⇐ (inj₁ _) = ≡.refl
  ⇒⇐ (inj₂ _) = ≡.refl

Fin-⊎-+ : ∀ m n → (Fin m ⊎ Fin n) ↔ Fin (m + n)
Fin-⊎-+ m n = Maybe^⊥↔Fin (m + n)
            ∘ Maybe^-⊎-+ m n
            ∘ sym (Maybe^⊥↔Fin m ⊎-cong Maybe^⊥↔Fin n)

Fin∘suc↔⊤⊎Fin : ∀ {n} → Fin (suc n) ↔ (⊤ ⊎ Fin n)
Fin∘suc↔⊤⊎Fin = Maybe↔⊤⊎ ∘ Fin∘suc↔Maybe∘Fin

Fin-×-* : ∀ m n → (Fin m × Fin n) ↔ Fin (m * n)
Fin-×-* zero n = (Fin 0 × Fin n) ↔⟨ Fin0↔⊥ ×-cong id ⟩
                 (⊥ × Fin n) ↔⟨ ⊥×A↔⊥ ⟩
                 ⊥ ↔⟨ sym Fin0↔⊥ ⟩
                 Fin 0 ∎
  where open EquationalReasoning hiding (sym)
Fin-×-* (suc m) n = (Fin (suc m) × Fin n) ↔⟨ Fin∘suc↔⊤⊎Fin ×-cong id ⟩
                    ((⊤ ⊎ Fin m) × Fin n) ↔⟨ ×⊎°.distribʳ (Fin n) ⊤ (Fin m) ⟩
                    ((⊤ × Fin n) ⊎ (Fin m × Fin n)) ↔⟨ ⊤×A↔A ⊎-cong Fin-×-* m n ⟩
                    (Fin n ⊎ Fin (m * n)) ↔⟨ Fin-⊎-+ n (m * n) ⟩
                    Fin (suc m * n) ∎
  where open EquationalReasoning hiding (sym)
-- -}

module Function.Related.TypeIsomorphisms.NP where

import Level as L
open import Algebra
import Algebra.FunctionProperties as FP
open L using (Lift; lower; lift)
open import Type hiding (★)

open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_) renaming (_^_ to _**_)
open import Data.Maybe.NP
open import Data.Product.NP renaming (map to map×)
--open import Data.Product.N-ary
open import Data.Sum renaming (map to map⊎)
open import Data.Unit
open import Data.Empty
open import Data.Bits using (Bit; 0b; 1b; false; true; proj)

import Function.NP as F
open F using (Π)
import Function.Equality as FE
open FE using (_⟨$⟩_)
open import Function.Related as FR
open import Function.Related.TypeIsomorphisms public
import Function.Inverse.NP as Inv
open Inv using (_↔_; _∘_; sym; id; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)
open import Relation.Binary
open import Relation.Binary.Product.Pointwise
open import Relation.Binary.Sum
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_ ; _≢_)

module CancelMaybe where
  private
    module _ {A : Set} where
      just-inj : {x y : A} → Maybe.just x ≡ just y → x ≡ y
      just-inj ≡.refl = ≡.refl

    module _ {A B : Set}
      (f : Maybe A ↔ Maybe B)
      (tof-tot : ∀ x → Inverse.to f ⟨$⟩ just x ≢ nothing)
      (fof-tot : ∀ x → Inverse.from f ⟨$⟩ just x ≢ nothing) where

        CancelMaybe' : A ↔ B
        CancelMaybe' = inverses (⇒) (⇐) ⇐⇒ ⇒⇐ where
          to = λ x → Inverse.to f ⟨$⟩ x
          from = λ x → Inverse.from f ⟨$⟩ x

          ⇒ : _ → _
          ⇒ x with to (just x) | tof-tot x
          ⇒ x | just x₁ | _ = x₁
          ⇒ x | nothing | p = ⊥-elim (p ≡.refl)

          ⇐ : _ → _
          ⇐ x with from (just x) | fof-tot x
          ⇐ x | just x₁ | p = x₁
          ⇐ x | nothing | p = ⊥-elim (p ≡.refl)

          ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
          ⇐⇒ x with to (just x)
                  | tof-tot x
                  | from (just (⇒ x))
                  | fof-tot (⇒ x)
                  | Inverse.left-inverse-of f (just x)
                  | Inverse.right-inverse-of f (just (⇒ x))
          ⇐⇒ x | just x₁ | p | just x₂ | q | b | c  = just-inj (≡.trans (≡.sym (Inverse.left-inverse-of f (just x₂))) (≡.trans (≡.cong from c) b))
          ⇐⇒ x | just x₁ | p | nothing | q | _ | _  = ⊥-elim (q ≡.refl)
          ⇐⇒ x | nothing | p | z       | q | _ | _  = ⊥-elim (p ≡.refl)

          ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
          ⇒⇐ x with from (just x)
                  | fof-tot x
                  | to (just (⇐ x))
                  | tof-tot (⇐ x)
                  | Inverse.right-inverse-of f (just x)
                  | Inverse.left-inverse-of f (just (⇐ x))
          ⇒⇐ x | just x₁ | p | just x₂ | q | b | c = just-inj (≡.trans (≡.sym (Inverse.right-inverse-of f (just x₂))) (≡.trans (≡.cong to c) b))
          ⇒⇐ x | just x₁ | p | nothing | q | _ | _ = ⊥-elim (q ≡.refl)
          ⇒⇐ x | nothing | p | z       | q | _ | _ = ⊥-elim (p ≡.refl)

    module _ {A B : Set}
      (f : Maybe A ↔ Maybe B)
      (f-empty : Inverse.to f ⟨$⟩ nothing ≡ nothing) where

      tof-tot : ∀ x → Inverse.to f ⟨$⟩ just x ≢ nothing
      tof-tot x eq with Inverse.injective f (≡.trans eq (≡.sym f-empty))
      ... | ()

      f-empty' : Inverse.from f ⟨$⟩ nothing ≡ nothing
      f-empty' = ≡.trans (≡.sym (≡.cong (λ x → Inverse.from f ⟨$⟩ x) f-empty)) (Inverse.left-inverse-of f nothing)

      fof-tot : ∀ x → Inverse.from f ⟨$⟩ just x ≢ nothing
      fof-tot x eq with Inverse.injective (sym f) (≡.trans eq (≡.sym f-empty'))
      ... | ()

      iso : A ↔ B
      iso = CancelMaybe' f tof-tot fof-tot

    module _ {A B : Set}
      (f : Maybe A ↔ Maybe B) where

      g : Maybe A ↔ Maybe B
      g = inverses (⇒) (⇐) ⇐⇒ ⇒⇐ where
          to = λ x → Inverse.to f ⟨$⟩ x
          from = λ x → Inverse.from f ⟨$⟩ x

          ⇒ : Maybe A → Maybe B
          ⇒ (just x) with to (just x)
          ... | nothing = to nothing
          ... | just y  = just y
          ⇒ nothing = nothing

          ⇐ : Maybe B → Maybe A
          ⇐ (just x) with from (just x)
          ... | nothing = from nothing
          ... | just y  = just y
          ⇐ nothing = nothing

          ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
          ⇐⇒ (just x) with to (just x) | Inverse.left-inverse-of f (just x)
          ⇐⇒ (just x) | just x₁ | p rewrite p = ≡.refl
          ⇐⇒ (just x) | nothing | p with to nothing | Inverse.left-inverse-of f nothing
          ⇐⇒ (just x₁) | nothing | p | just x | q rewrite q = p
          ⇐⇒ (just x) | nothing | p | nothing | q = ≡.trans (≡.sym q) p
          ⇐⇒ nothing = ≡.refl

          ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
          ⇒⇐ (just x) with from (just x) | Inverse.right-inverse-of f (just x)
          ⇒⇐ (just x) | just x₁ | p rewrite p = ≡.refl
          ⇒⇐ (just x) | nothing | p with from nothing | Inverse.right-inverse-of f nothing
          ⇒⇐ (just x₁) | nothing | p | just x | q rewrite q = p
          ⇒⇐ (just x) | nothing | p | nothing | q = ≡.trans (≡.sym q) p
          ⇒⇐ nothing = ≡.refl

      g-empty : Inverse.to g ⟨$⟩ nothing ≡ nothing
      g-empty = ≡.refl

      iso' : A ↔ B
      iso' = iso g g-empty
  CancelMaybe : ∀ {A B : Set} → Maybe A ↔ Maybe B → A ↔ B
  CancelMaybe f = iso' f

private
    Setoid₀ : ★ _
    Setoid₀ = Setoid L.zero L.zero

Σ≡↔⊤ : ∀ {a} {A : ★ a} x → Σ A (_≡_ x) ↔ ⊤
Σ≡↔⊤ x = inverses (F.const _) (λ _ → _ , ≡.refl)
                  helper (λ _ → ≡.refl)
  where helper : (y : Σ _ (_≡_ x)) → (x , ≡.refl) ≡ y
        helper (.x , ≡.refl) = ≡.refl

module _ {a b c} {A : ★ a} {B : A → ★ b} {C : Σ A B → ★ c} where
    curried : Π (Σ A B) C ↔ Π A λ a → Π (B a) λ b → C (a , b)
    curried = inverses curry uncurry (λ _ → ≡.refl) (λ _ → ≡.refl)

module _ {a b c} {A : ★ a} {B : ★ b} {C : A → ★ c} (f : A ↔ B) where
  private
    left-f = Inv.Inverse.left-inverse-of f
    right-f = Inv.Inverse.right-inverse-of f
    coe : ∀ x → C x → C (from f (to f x))
    coe x = ≡.subst C (≡.sym (left-f x))
    ⇒ : Σ A C → Σ B (C F.∘ from f)
    ⇒ (x , p) = to f x , coe x p
    ⇐ : Σ B (C F.∘ from f) → Σ A C
    ⇐ = first (from f)
    ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
    ⇐⇒ (x , p) rewrite left-f x = ≡.refl
    ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
    ⇒⇐ p = mkΣ≡ (C F.∘ from f) (right-f (proj₁ p)) (helper p)
            where
                helper : ∀ p → ≡.subst (C F.∘ from f) (right-f (proj₁ p)) (coe (proj₁ (⇐ p)) (proj₂ (⇐ p))) ≡ proj₂ p
                helper p with to f (from f (proj₁ p)) | right-f (proj₁ p) | left-f (from f (proj₁ p))
                helper _ | ._ | ≡.refl | ≡.refl = ≡.refl
  first-iso : Σ A C ↔ Σ B (C F.∘ from f)
  first-iso = inverses (⇒) (⇐) ⇐⇒ ⇒⇐

module _ {a b c} {A : ★ a} {B : ★ b} {C : B → ★ c} (f : A ↔ B) where
  sym-first-iso : Σ A (C F.∘ to f) ↔ Σ B C
  sym-first-iso = sym (first-iso (sym f))

module _ {a b c} {A : ★ a} {B : A → ★ b} {C : A → ★ c} (f : ∀ x → B x ↔ C x) where
  private
    left-f = Inv.Inverse.left-inverse-of F.∘ f
    right-f = Inv.Inverse.right-inverse-of F.∘ f
    ⇒ : Σ A B → Σ A C
    ⇒ = second (to (f _))
    ⇐ : Σ A C → Σ A B
    ⇐ = second (from (f _))
    ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
    ⇐⇒ (x , y) rewrite left-f x y = ≡.refl
    ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
    ⇒⇐ (x , y) rewrite right-f x y = ≡.refl
  second-iso : Σ A B ↔ Σ A C
  second-iso = inverses (⇒) (⇐) ⇐⇒ ⇒⇐

module _ {a b c} {A : ★ a} {B : ★ b} {C : A ⊎ B → ★ c} where
  private
    S = Σ (A ⊎ B) C
    T = Σ A (C F.∘ inj₁) ⊎ Σ B (C F.∘ inj₂)
    ⇒ : S → T
    ⇒ (inj₁ x , y) = inj₁ (x , y)
    ⇒ (inj₂ x , y) = inj₂ (x , y)
    ⇐ : T → S
    ⇐ (inj₁ (x , y)) = inj₁ x , y
    ⇐ (inj₂ (x , y)) = inj₂ x , y
    ⇐⇒ : ∀ x → ⇐ (⇒ x) ≡ x
    ⇐⇒ (inj₁ _ , _) = ≡.refl
    ⇐⇒ (inj₂ _ , _) = ≡.refl
    ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
    ⇒⇐ (inj₁ _) = ≡.refl
    ⇒⇐ (inj₂ _) = ≡.refl

  Σ⊎-distrib : S ↔ T
  Σ⊎-distrib = inverses (⇒) (⇐) ⇐⇒ ⇒⇐

{- requires extensional equality
module _ {a b c} {A : ★ a} {B : ★ b} {C : A ⊎ B → ★ c} where
  private
    S = Π (A ⊎ B) C
    T = Π A (C F.∘ inj₁) × Π B (C F.∘ inj₂)
    ⇒ : S → T
    ⇒ f = f F.∘ inj₁ , f F.∘ inj₂
    ⇐ : T → S
    ⇐ (f , g) = [ f , g ]
    ⇐⇒ : ∀ f x → ⇐ (⇒ f) x ≡ f x
    ⇐⇒ f (inj₁ x) = ≡.refl
    ⇐⇒ f (inj₂ y) = ≡.refl
    ⇒⇐ : ∀ x → ⇒ (⇐ x) ≡ x
    ⇒⇐ (f , g) = ≡.refl

  Π×-distrib : S ↔ T
  Π×-distrib = inverses (⇒) (⇐) {!⇐⇒!} ⇒⇐
-}

⊎-ICommutativeMonoid : CommutativeMonoid _ _
⊎-ICommutativeMonoid = record {
                         _≈_ = Inv.Inverse;
                         _∙_ = _⊎-setoid_;
                         ε = ≡.setoid ⊥;
                         isCommutativeMonoid = record
                            { isSemigroup = record
                              { isEquivalence = Inv.isEquivalence
                              ; assoc = assoc
                              ; ∙-cong = _⊎-inverse_
                              }
                            ; identityˡ = left-identity
                            ; comm = comm
                            }
                         }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  left-identity : LeftIdentity (≡.setoid ⊥) _⊎-setoid_
  left-identity A = record
    { to = record
      { _⟨$⟩_ = [ (λ ()) , F.id ]
      ; cong  = cong-to
      }
    ; from = record
      { _⟨$⟩_ = inj₂
      ; cong = ₂∼₂
      }
    ; inverse-of = record
      { left-inverse-of = [ (λ ()) , (λ x → ₂∼₂ refl) ]
      ; right-inverse-of = λ x → refl
      }
    } where open Setoid A
            cong-to : Setoid._≈_ (≡.setoid ⊥ ⊎-setoid A) =[ _ ]⇒ _≈_
            cong-to (₁∼₂ ())
            cong-to (₁∼₁ x∼₁y) rewrite x∼₁y = refl
            cong-to (₂∼₂ x∼₂y) = x∼₂y

  assoc : Associative _⊎-setoid_
  assoc A B C = record
    { to = record
      { _⟨$⟩_ = [ [ inj₁ , inj₂ F.∘ inj₁ ] , inj₂ F.∘ inj₂ ]
      ; cong = cong-to
      }
    ; from = record
      { _⟨$⟩_ = [ inj₁ F.∘ inj₁ , [ inj₁ F.∘ inj₂ , inj₂ ] ]
      ; cong = cong-from
      }
    ; inverse-of = record
      { left-inverse-of = [ [ (λ _ → ₁∼₁ (₁∼₁ (refl A))) , (λ _ → ₁∼₁ (₂∼₂ (refl B)) ) ] , (λ _ → ₂∼₂ (refl C)) ]
      ; right-inverse-of = [ (λ _ → ₁∼₁ (refl A)) , [ (λ _ → ₂∼₂ (₁∼₁ (refl B))) , (λ _ → ₂∼₂ (₂∼₂ (refl C))) ] ]
      }
    } where
      open Setoid
      cong-to : _≈_ ((A ⊎-setoid B) ⊎-setoid C) =[ _ ]⇒ _≈_ (A ⊎-setoid (B ⊎-setoid C))
      cong-to (₁∼₂ ())
      cong-to (₁∼₁ (₁∼₂ ()))
      cong-to (₁∼₁ (₁∼₁ x∼₁y)) = ₁∼₁ x∼₁y
      cong-to (₁∼₁ (₂∼₂ x∼₂y)) = ₂∼₂ (₁∼₁ x∼₂y)
      cong-to (₂∼₂ x∼₂y) = ₂∼₂ (₂∼₂ x∼₂y)

      cong-from : _≈_ (A ⊎-setoid (B ⊎-setoid C)) =[ _ ]⇒ _≈_ ((A ⊎-setoid B) ⊎-setoid C)
      cong-from (₁∼₂ ())
      cong-from (₁∼₁ x∼₁y) = ₁∼₁ (₁∼₁ x∼₁y)
      cong-from (₂∼₂ (₁∼₂ ()))
      cong-from (₂∼₂ (₁∼₁ x∼₁y)) = ₁∼₁ (₂∼₂ x∼₁y)
      cong-from (₂∼₂ (₂∼₂ x∼₂y)) = ₂∼₂ x∼₂y

  comm : Commutative _⊎-setoid_
  comm A B = record
    { to = swap'
    ; from = swap'
    ; inverse-of = record
      { left-inverse-of  = inv A B
      ; right-inverse-of = inv B A
      }
    } where
      swap' : ∀ {A B} → A ⊎-setoid B FE.⟶ B ⊎-setoid A
      swap' {A} {B} = record
        { _⟨$⟩_ = [ inj₂ , inj₁ ]
        ; cong = cong
        } where
          cong : Setoid._≈_ (A ⊎-setoid B) =[ _ ]⇒ Setoid._≈_ (B ⊎-setoid A)
          cong (₁∼₂ ())
          cong (₁∼₁ x∼₁y) = ₂∼₂ x∼₁y
          cong (₂∼₂ x∼₂y) = ₁∼₁ x∼₂y

      inv : ∀ A B → ∀ x → Setoid._≈_ (A ⊎-setoid B) (swap' FE.∘ swap' {A} {B}⟨$⟩ x) x
      inv A B = [ (λ _ → ₁∼₁ (Setoid.refl A)) , (λ _ → ₂∼₂ (Setoid.refl B)) ]

×-ICommutativeMonoid : CommutativeMonoid _ _
×-ICommutativeMonoid = record {
                         _≈_ = Inv.Inverse;
                         _∙_ = _×-setoid_;
                         ε = ≡.setoid ⊤;
                         isCommutativeMonoid = record
                            { isSemigroup = record
                              { isEquivalence = Inv.isEquivalence
                              ; assoc = assoc
                              ; ∙-cong = _×-inverse_
                              }
                            ; identityˡ = left-identity
                            ; comm = comm
                            }
                         }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  left-identity : LeftIdentity (≡.setoid ⊤) _×-setoid_
  left-identity A = record
    { to = record
      { _⟨$⟩_ = proj₂
      ; cong = proj₂
      }
    ; from = record
      { _⟨$⟩_ = λ x → _ , x
      ; cong = λ x → ≡.refl , x
      }
    ; inverse-of = record
      { left-inverse-of = λ x → ≡.refl , (Setoid.refl A)
      ; right-inverse-of = λ x → Setoid.refl A
      }
    }

  assoc : Associative _×-setoid_
  assoc A B C = record
    { to = record
      { _⟨$⟩_ = < proj₁ F.∘ proj₁ , < proj₂ F.∘ proj₁ , proj₂ > >
      ; cong  = < proj₁ F.∘ proj₁ , < proj₂ F.∘ proj₁ , proj₂ > >
      }
    ; from = record
      { _⟨$⟩_ = < < proj₁ , proj₁ F.∘ proj₂ > , proj₂ F.∘ proj₂ >
      ; cong  = < < proj₁ , proj₁ F.∘ proj₂ > , proj₂ F.∘ proj₂ >
      }
    ; inverse-of = record
      { left-inverse-of = λ _ → Setoid.refl ((A ×-setoid B) ×-setoid C)
      ; right-inverse-of = λ _ → Setoid.refl (A ×-setoid (B ×-setoid C))
      }
    }

  comm : Commutative _×-setoid_
  comm A B = record
    { to = swap' {A} {B}
    ; from = swap' {B} {A}
    ; inverse-of = record
      { left-inverse-of = inv A B
      ; right-inverse-of = inv B A
      }
    } where
      swap' : ∀ {A B} → A ×-setoid B FE.⟶ B ×-setoid A
      swap' {A}{B} = record { _⟨$⟩_ = swap; cong = swap }

      inv : ∀ A B → ∀ x → Setoid._≈_ (A ×-setoid B) (swap' {B} {A} FE.∘ swap' {A} {B}⟨$⟩ x) x
      inv A B = λ x → Setoid.refl (A ×-setoid B)

×⊎-ICommutativeSemiring : CommutativeSemiring _ _
×⊎-ICommutativeSemiring = record
  { _≈_ = Inv.Inverse
  ; _+_ = _⊎-setoid_
  ; _*_ = _×-setoid_
  ; 0# = ≡.setoid ⊥
  ; 1# = ≡.setoid ⊤
  ; isCommutativeSemiring = record
    { +-isCommutativeMonoid = CommutativeMonoid.isCommutativeMonoid ⊎-ICommutativeMonoid
    ; *-isCommutativeMonoid = CommutativeMonoid.isCommutativeMonoid ×-ICommutativeMonoid
    ; distribʳ = distribʳ
    ; zeroˡ = zeroˡ
    }
  }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  distribʳ : _×-setoid_ DistributesOverʳ _⊎-setoid_
  distribʳ A B C = record
    { to = record
      { _⟨$⟩_ = uncurry [ curry inj₁ , curry inj₂ ]
      ; cong = cong-to
      }
    ; from = record
      { _⟨$⟩_ = frm
      ; cong = cong-from
      }
    ; inverse-of = record
      { left-inverse-of  = uncurry [ (λ x y → (₁∼₁ (refl B)) , (refl A)) , (λ x y → (₂∼₂ (refl C)) , (refl A)) ]
      ; right-inverse-of = [ uncurry (λ x y → ₁∼₁ ((refl B {x}) , (refl A {y})))
                           , uncurry (λ x y → ₂∼₂ ((refl C {x}) , (refl A {y}))) ]
      }
    } where
      open Setoid
      A' = Carrier A
      B' = Carrier B
      C' = Carrier C

      cong-to : _≈_ ((B ⊎-setoid C) ×-setoid A) =[ _ ]⇒ _≈_ ((B ×-setoid A) ⊎-setoid (C ×-setoid A))
      cong-to (₁∼₂ () , _)
      cong-to (₁∼₁ x∼₁y , A-rel) = ₁∼₁ (x∼₁y , A-rel)
      cong-to (₂∼₂ x∼₂y , A-rel) = ₂∼₂ (x∼₂y , A-rel)

      frm : B' × A' ⊎ C' × A' → (B' ⊎ C') × A'
      frm = [ map× inj₁ F.id , map× inj₂ F.id ]

      cong-from : _≈_ ((B ×-setoid A) ⊎-setoid (C ×-setoid A)) =[ _ ]⇒ _≈_ ((B ⊎-setoid C) ×-setoid A)
      cong-from (₁∼₂ ())
      cong-from (₁∼₁ (B-rel , A-rel)) = ₁∼₁ B-rel , A-rel
      cong-from (₂∼₂ (C-rel , A-rel)) = ₂∼₂ C-rel , A-rel

  zeroˡ : LeftZero (≡.setoid ⊥) _×-setoid_
  zeroˡ A = record
    { to = record
      { _⟨$⟩_ = proj₁
      ; cong = proj₁
      }
    ; from = record
      { _⟨$⟩_ = ⊥-elim
      ; cong = λ { {()} x }
      }
    ; inverse-of = record
      { left-inverse-of = λ x → ⊥-elim (proj₁ x)
      ; right-inverse-of = λ x → ⊥-elim x
      }
    }

module ×-CMon {a} = CommutativeMonoid (×-CommutativeMonoid FR.bijection a)
module ⊎-CMon {a} = CommutativeMonoid (⊎-CommutativeMonoid FR.bijection a)
module ×⊎° {a}    = CommutativeSemiring (×⊎-CommutativeSemiring FR.bijection a)

module ×-ICMon = CommutativeMonoid ×-ICommutativeMonoid
module ⊎-ICMon = CommutativeMonoid ⊎-ICommutativeMonoid
module ×⊎°I    = CommutativeSemiring ×⊎-ICommutativeSemiring

lift-⊎ : ∀ {A B : Set} → Inv.Inverse ((≡.setoid A) ⊎-setoid (≡.setoid B)) (≡.setoid (A ⊎ B))
lift-⊎ {A}{B} = record
  { to = record
    { _⟨$⟩_ = λ x → x
    ; cong = cong
    }
  ; from = record
    { _⟨$⟩_ = λ x → x
    ; cong = λ x → Setoid.reflexive (≡.setoid A ⊎-setoid ≡.setoid B) x
    }
  ; inverse-of = record
    { left-inverse-of = λ x → Setoid.refl (≡.setoid A ⊎-setoid ≡.setoid B)
    ; right-inverse-of = λ x → Setoid.refl (≡.setoid (A ⊎ B))
    }
  } where
    cong : Setoid._≈_ (≡.setoid A ⊎-setoid ≡.setoid B)  =[ _ ]⇒ Setoid._≈_ (≡.setoid (A ⊎ B))
    cong (₁∼₂ ())
    cong (₁∼₁ x∼₁y) = ≡.cong inj₁ x∼₁y
    cong (₂∼₂ x∼₂y) = ≡.cong inj₂ x∼₂y

swap-iso : ∀ {a b} {A : ★ a} {B : ★ b} → (A × B) ↔ (B × A)
swap-iso = inverses swap swap (λ _ → ≡.refl) (λ _ → ≡.refl)

module _ {a b c} {A : ★ a} {B : ★ b} {C : A × B → ★ c} where
  Σ×-swap : Σ (A × B) C ↔ Σ (B × A) (C F.∘ swap)
  Σ×-swap = first-iso swap-iso

Maybe↔Lift⊤⊎ : ∀ {ℓ a} {A : ★ a} → Maybe A ↔ (Lift {ℓ = ℓ} ⊤ ⊎ A)
Maybe↔Lift⊤⊎
  = inverses (maybe inj₂ (inj₁ _))
             [ F.const nothing , just ]
             (maybe (λ _ → ≡.refl) ≡.refl)
             [ (λ _ → ≡.refl) , (λ _ → ≡.refl) ]

Maybe↔⊤⊎ : ∀ {a} {A : ★ a} → Maybe A ↔ (⊤ ⊎ A)
Maybe↔⊤⊎
  = inverses (maybe inj₂ (inj₁ _))
             [ F.const nothing , just ]
             (maybe (λ _ → ≡.refl) ≡.refl)
             [ (λ _ → ≡.refl) , (λ _ → ≡.refl) ]

Maybe-cong : ∀ {a b} {A : ★ a} {B : ★ b} → A ↔ B → Maybe A ↔ Maybe B
Maybe-cong A↔B = sym Maybe↔⊤⊎ ∘ id ⊎-cong A↔B ∘ Maybe↔⊤⊎

Maybe∘Maybe^↔Maybe^∘Maybe : ∀ {a} {A : ★ a} n → Maybe (Maybe^ n A) ↔ Maybe^ n (Maybe A)
Maybe∘Maybe^↔Maybe^∘Maybe zero    = id
Maybe∘Maybe^↔Maybe^∘Maybe (suc n) = Maybe-cong (Maybe∘Maybe^↔Maybe^∘Maybe n)

Maybe^-cong : ∀ {a b} {A : ★ a} {B : ★ b} n → A ↔ B → Maybe^ n A ↔ Maybe^ n B
Maybe^-cong zero    = F.id
Maybe^-cong (suc n) = Maybe-cong F.∘ Maybe^-cong n

Vec0↔Lift⊤ : ∀ {a ℓ} {A : ★ a} → Vec A 0 ↔ Lift {_} {ℓ} ⊤
Vec0↔Lift⊤ = inverses _ (F.const []) (λ { [] → ≡.refl }) (λ _ → ≡.refl)

Vec0↔⊤ : ∀ {a} {A : ★ a} → Vec A 0 ↔ ⊤
Vec0↔⊤ = inverses _ (F.const []) (λ { [] → ≡.refl }) (λ _ → ≡.refl)

Vec∘suc↔A×Vec : ∀ {a} {A : ★ a} {n} → Vec A (suc n) ↔ (A × Vec A n)
Vec∘suc↔A×Vec
  = inverses (λ { (x ∷ xs) → x , xs }) (uncurry _∷_)
             (λ { (x ∷ xs) → ≡.refl }) (λ _ → ≡.refl)

infix 8 _^_

_^_ : ∀ {a} → ★ a → ℕ → ★ a
A ^ 0     = Lift ⊤
A ^ suc n = A × A ^ n

^↔Vec : ∀ {a} {A : ★ a} n → (A ^ n) ↔ Vec A n
^↔Vec zero    = sym Vec0↔Lift⊤
^↔Vec (suc n) = sym Vec∘suc↔A×Vec ∘ (id ×-cong (^↔Vec n))

Fin0↔⊥ : Fin 0 ↔ ⊥
Fin0↔⊥ = inverses (λ()) (λ()) (λ()) (λ())

Fin∘suc↔Maybe∘Fin : ∀ {n} → Fin (suc n) ↔ Maybe (Fin n)
Fin∘suc↔Maybe∘Fin {n}
  = inverses to' (maybe suc zero)
             (λ { zero → ≡.refl ; (suc n) → ≡.refl })
             (maybe (λ _ → ≡.refl) ≡.refl)
  where to' : Fin (suc n) → Maybe (Fin n)
        to' zero = nothing
        to' (suc n) = just n

Lift↔id : ∀ {a} {A : ★ a} → Lift {a} {a} A ↔ A
Lift↔id = inverses lower lift (λ { (lift x) → ≡.refl }) (λ _ → ≡.refl)

⊤×A↔A : ∀ {A : ★₀} → (⊤ × A) ↔ A
⊤×A↔A = proj₁ ×-CMon.identity _ ∘ sym Lift↔id ×-cong id

A×⊤↔A : ∀ {A : ★₀} → (A × ⊤) ↔ A
A×⊤↔A = proj₂ ×-CMon.identity _ ∘ id ×-cong sym Lift↔id

⊥⊎A↔A : ∀ {A : ★₀} → (⊥ ⊎ A) ↔ A
⊥⊎A↔A = proj₁ ⊎-CMon.identity _ ∘ sym Lift↔id ⊎-cong id

A⊎⊥↔A : ∀ {A : ★₀} → (A ⊎ ⊥) ↔ A
A⊎⊥↔A = proj₂ ⊎-CMon.identity _ ∘ id ⊎-cong sym Lift↔id

⊥×A↔⊥ : ∀ {A : ★₀} → (⊥ × A) ↔ ⊥
⊥×A↔⊥ = Lift↔id ∘ proj₁ ×⊎°.zero _ ∘ sym (Lift↔id ×-cong id)

Maybe⊥↔⊤ : Maybe ⊥ ↔ ⊤
Maybe⊥↔⊤ = A⊎⊥↔A ∘ Maybe↔⊤⊎

Maybe^⊥↔Fin : ∀ n → Maybe^ n ⊥ ↔ Fin n
Maybe^⊥↔Fin zero    = sym Fin0↔⊥
Maybe^⊥↔Fin (suc n) = sym Fin∘suc↔Maybe∘Fin ∘ Maybe-cong (Maybe^⊥↔Fin n)

Maybe^⊤↔Fin1+ : ∀ n → Maybe^ n ⊤ ↔ Fin (suc n)
Maybe^⊤↔Fin1+ n = Maybe^⊥↔Fin (suc n) ∘ sym (Maybe∘Maybe^↔Maybe^∘Maybe n) ∘ Maybe^-cong n (sym Maybe⊥↔⊤)

Maybe-⊎ : ∀ {a} {A B : ★ a} → (Maybe A ⊎ B) ↔ Maybe (A ⊎ B)
Maybe-⊎ {a} = sym Maybe↔Lift⊤⊎ ∘ ⊎-CMon.assoc (Lift {_} {a} ⊤) _ _ ∘ (Maybe↔Lift⊤⊎ ⊎-cong id)

Maybe^-⊎-+ : ∀ {A} m n → (Maybe^ m ⊥ ⊎ Maybe^ n A) ↔ Maybe^ (m + n) A
Maybe^-⊎-+ zero    n = ⊥⊎A↔A
Maybe^-⊎-+ (suc m) n = Maybe-cong (Maybe^-⊎-+ m n) ∘ Maybe-⊎

Bit↔⊤⊎⊤ : Bit ↔ (⊤ ⊎ ⊤)
Bit↔⊤⊎⊤ = inverses (proj (inj₁ _ , inj₂ _)) [ F.const 0b , F.const 1b ] ⇐⇒ ⇒⇐
  where
  ⇐⇒ : (_ : Bit) → _
  ⇐⇒ true = ≡.refl
  ⇐⇒ false = ≡.refl
  ⇒⇐ : (_ : ⊤ ⊎ ⊤) → _
  ⇒⇐ (inj₁ _) = ≡.refl
  ⇒⇐ (inj₂ _) = ≡.refl

Fin-⊎-+ : ∀ m n → (Fin m ⊎ Fin n) ↔ Fin (m + n)
Fin-⊎-+ m n = Maybe^⊥↔Fin (m + n)
            ∘ Maybe^-⊎-+ m n
            ∘ sym (Maybe^⊥↔Fin m ⊎-cong Maybe^⊥↔Fin n)

Fin∘suc↔⊤⊎Fin : ∀ {n} → Fin (suc n) ↔ (⊤ ⊎ Fin n)
Fin∘suc↔⊤⊎Fin = Maybe↔⊤⊎ ∘ Fin∘suc↔Maybe∘Fin

Fin-×-* : ∀ m n → (Fin m × Fin n) ↔ Fin (m * n)
Fin-×-* zero n = (Fin 0 × Fin n) ↔⟨ Fin0↔⊥ ×-cong id ⟩
                 (⊥ × Fin n) ↔⟨ ⊥×A↔⊥ ⟩
                 ⊥ ↔⟨ sym Fin0↔⊥ ⟩
                 Fin 0 ∎
  where open EquationalReasoning hiding (sym)
Fin-×-* (suc m) n = (Fin (suc m) × Fin n) ↔⟨ Fin∘suc↔⊤⊎Fin ×-cong id ⟩
                    ((⊤ ⊎ Fin m) × Fin n) ↔⟨ ×⊎°.distribʳ (Fin n) ⊤ (Fin m) ⟩
                    ((⊤ × Fin n) ⊎ (Fin m × Fin n)) ↔⟨ ⊤×A↔A ⊎-cong Fin-×-* m n ⟩
                    (Fin n ⊎ Fin (m * n)) ↔⟨ Fin-⊎-+ n (m * n) ⟩
                    Fin (suc m * n) ∎
  where open EquationalReasoning hiding (sym)
-- -}


Prove that application preserves change equivalence

As demanded by Tillmann in
https://github.com/ps-mr/ilc/commit/46789e08b7a8bbd95738f9bf14b3ff8644151772#commitcomment-5742787.

Old-commit-hash: c6ca7c1a871e61d203684d8c4f36a91e24a0222d

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Parametric.Change.Equivalence where

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit

-- Extension Point: None (currently). Do we need to allow plugins to customize
-- this concept?
Structure : Set
Structure = Unit

module Structure (unused : Structure) where

  module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
    -- Delta-observational equivalence: these asserts that two changes
    -- give the same result when applied to a base value.
    _≙_ : ∀ dx dy → Set a
    dx ≙ dy = x ⊞ dx ≡ x ⊞ dy

    -- _≙_ is indeed an equivalence relation:
    ≙-refl : ∀ {dx} → dx ≙ dx
    ≙-refl = refl

    ≙-symm : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
    ≙-symm ≙ = sym ≙

    ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
    ≙-trans ≙₁ ≙₂ = trans ≙₁ ≙₂

    -- TODO: we want to show that all functions of interest respect
    -- delta-observational equivalence, so that two d.o.e. changes can be
    -- substituted for each other freely.
    --
    -- * That should be be true for
    --   functions using changes parametrically.
    --
    -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
    --   this is proved below on both contexts at once by fun-change-respects.
    --
    -- * Finally, change algebra operations should respect d.o.e.
    --
    -- Stating the general result, though, seems hard, we should
    -- rather have lemmas proving that certain classes of functions respect this
    -- equivalence.

  module _ {a} {b} {c} {d} {A : Set a} {B : Set b}
    {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}} where

    module FC = FunctionChanges A B {{CA}} {{CB}}
    open FC using (changeAlgebra; incrementalization)
    open FC.FunctionChange

    fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
      df₁ ≙ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
    fun-change-respects {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = lemma
      where
        open ≡-Reasoning
        open import Postulate.Extensionality
        -- This type signature just expands the goal manually a bit.
        lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
        -- Informally: use incrementalization on both sides and then apply
        -- congruence.
        lemma =
          begin
            f x ⊞ apply df₁ x dx₁
          ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
            (f ⊞ df₁) (x ⊞ dx₁)
          ≡⟨ cong (f ⊞ df₁) dx₁≙dx₂ ⟩
            (f ⊞ df₁) (x ⊞ dx₂)
          ≡⟨ cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
            (f ⊞ df₂) (x ⊞ dx₂)
          ≡⟨ incrementalization f df₂ x dx₂ ⟩
            f x ⊞ apply df₂ x dx₂
          ∎

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Parametric.Change.Equivalence where

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit

-- Extension Point: None (currently). Do we need to allow plugins to customize
-- this concept?
Structure : Set
Structure = Unit

module Structure (unused : Structure) where

  module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
    -- Delta-observational equivalence: these asserts that two changes
    -- give the same result when applied to a base value.
    _≙_ : ∀ dx dy → Set a
    dx ≙ dy = x ⊞ dx ≡ x ⊞ dy

    -- _≙_ is indeed an equivalence relation:
    ≙-refl : ∀ {dx} → dx ≙ dx
    ≙-refl = refl

    ≙-symm : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
    ≙-symm ≙ = sym ≙

    ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
    ≙-trans ≙₁ ≙₂ = trans ≙₁ ≙₂

    -- TODO: we want to show that all functions of interest respect
    -- delta-observational equivalence, so that two d.o.e. changes can be
    -- substituted for each other freely. That should be true for functions
    -- using changes parametrically, for derivatives and function changes, and
    -- for functions using only the interface to changes (including the fact
    -- that function changes are functions). Stating the general result, though,
    -- seems hard, we should rather have lemmas proving that certain classes of
    -- functions respect this equivalence.


Removed unused code.

Removed unused code.

Ignore-this: 3d26992a8909f6f5c83b3145ec136c54

darcs-hash:20100719033523-3bd4e-9c455816cf14148a738f6c8f20ee26a9b593bc8a.gz

module Test.Succeed.LogicalConstants where

infix  4 _≡_

postulate
  D   : Set
  _≡_ : D → D → Set

------------------------------------------------------------------------------
-- The conjuction data type

module Conjunction where

  -- N.B. It is not necessary to define neither the data constructor
  -- _,_, nor the projections -- because the ATPs implement it.
  data _∧_ (A B : Set) : Set where

  -- Testing the data constructor and the projections.
  postulate
    A B     : Set
    _,_     : A → B → A ∧ B
    ∧-proj₁ : A ∧ B → A
    ∧-proj₂ : A ∧ B → B
  {-# ATP prove _,_ #-}
  {-# ATP prove ∧-proj₁ #-}
  {-# ATP prove ∧-proj₂ #-}

------------------------------------------------------------------------------
-- The negation

module Negation where

  infix 3 ¬

  data ⊥ : Set where

  ¬ : Set → Set
  ¬ A = A → ⊥

  postulate
    true false : D

  postulate
    true≠false : ¬ (true ≡ false)
  {-# ATP axiom true≠false #-}

  postulate
    testContradiction : (d : D) → true ≡ false → d ≡ true
  {-# ATP prove testContradiction #-}

------------------------------------------------------------------------------
-- The disjunction data type

module Disjunction where
  infixr 1 _∨_

  -- N.B. It is not necessary to define neither the data constructors
  -- inj₁ and inj₂ nor the disyunction elimination because the ATP
  -- implements them.
  data _∨_ (A B : Set) : Set where

  -- Testing the data constructors and the elimination.
  postulate
    A B C : Set
    inj₁  : A → A ∨ B
    inj₂  : B → A ∨ B
    [_,_] : (A → C) → (B → C) → A ∨ B → C
  {-# ATP prove inj₁ #-}
  {-# ATP prove inj₂ #-}
  {-# ATP prove [_,_] #-}

------------------------------------------------------------------------------
-- The existential type of D

module ExistentialQuantifier where

  data ∃D (P : D → Set) : Set where

  postulate
    test : (d : D) → ∃D (λ e → e ≡ d)
  {-# ATP prove test #-}

module Test.Succeed.LogicalConstants where

infix  4 _≡_

postulate
  D   : Set
  _≡_ : D → D → Set

------------------------------------------------------------------------------
-- The conjuction data type

module Conjunction where

  -- N.B. It is not necessary to define neither the data constructor
  -- _,_, nor the projections -- because the ATPs implement it.
  data _∧_ (A B : Set) : Set where

  -- Testing the data constructor and the projections.
  postulate
    A B     : Set
    d e     : D
    _,_     : A → B → A ∧ B
    ∧-proj₁ : A ∧ B → A
    ∧-proj₂ : A ∧ B → B
  {-# ATP prove _,_ #-}
  {-# ATP prove ∧-proj₁ #-}
  {-# ATP prove ∧-proj₂ #-}

------------------------------------------------------------------------------
-- The negation

module Negation where

  infix 3 ¬

  data ⊥ : Set where

  ¬ : Set → Set
  ¬ A = A → ⊥

  postulate
    true false : D

  postulate
    true≠false : ¬ (true ≡ false)
  {-# ATP axiom true≠false #-}

  postulate
    testContradiction : (d : D) → true ≡ false → d ≡ true
  {-# ATP prove testContradiction #-}

------------------------------------------------------------------------------
-- The disjunction data type

module Disjunction where
  infixr 1 _∨_

  -- N.B. It is not necessary to define neither the data constructors
  -- inj₁ and inj₂ nor the disyunction elimination because the ATP
  -- implements them.
  data _∨_ (A B : Set) : Set where

  -- Testing the data constructors and the elimination.
  postulate
    A B C : Set
    inj₁  : A → A ∨ B
    inj₂  : B → A ∨ B
    [_,_] : (A → C) → (B → C) → A ∨ B → C
  {-# ATP prove inj₁ #-}
  {-# ATP prove inj₂ #-}
  {-# ATP prove [_,_] #-}

------------------------------------------------------------------------------
-- The existential type of D

module ExistentialQuantifier where

  data ∃D (P : D → Set) : Set where

  postulate
    test : (d : D) → ∃D (λ e → e ≡ d)
  {-# ATP prove test #-}


Only renaming.

Only renaming.

Ignore-this: c0e0e712590c149fdb1dd4ebdd4efff0

darcs-hash:20100804165205-3bd4e-9ff2eb215b46180dcd0688fb7cf46f72a2769e14.gz

------------------------------------------------------------------------------
-- Predicate logic examples
------------------------------------------------------------------------------

-- This module contains some examples showing the use of the ATPs to
-- prove theorems from predicate logic.

module Examples.Logic.Predicate where

open import Examples.Logic.Constants

------------------------------------------------------------------------------
-- We postulate some predicate symbols.
postulate
  P⁰    : Set
  P¹ Q¹ : D → Set
  P²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
postulate
  ∀DI : ((x : D) → P¹ x) → ∀D P¹
  ∀DE : ∀D P¹ → (t : D) → P¹ t
  -- This elimination rule cannot prove in Coq because in Coq we can
  -- have empty domains. We do not have this problem because the ATPs
  -- assume a non-empty domain.
  ∃DI : ((t : D) → P¹ t) → ∃D P¹
  -- TODO: ∃E : (x : D) → ∃D P¹ → (P¹ x → Q¹ x) → Q¹ x
{-# ATP prove ∀DI #-}
{-# ATP prove ∀DE #-}
{-# ATP prove ∃DI #-}
-- {-# ATP prove ∃DE #-}

-- Generalization of De Morgan's laws.
postulate
  gDM₁ : ¬ (∀D P¹) ↔ ∃D (λ x → ¬ (P¹ x))
  gDM₂ : ¬ (∃D P¹) ↔ ∀D (λ x  → ¬ (P¹ x))
  gDM₃ : ∀D P¹     ↔ ¬ (∃D (λ x → ¬ (P¹ x)))
  gDM₄ : ∃D P¹     ↔ ¬ (∀D (λ x → ¬ (P¹ x)))
{-# ATP prove gDM₁ #-}
{-# ATP prove gDM₂ #-}
{-# ATP prove gDM₃ #-}
{-# ATP prove gDM₄ #-}

-- The order of quantifiers of the same sort is irrelevant.
postulate
  ord₁ : ∀D (λ x → ∀D (λ y → P² x y)) ↔ ∀D (λ y → ∀D (λ x → P² x y))
  ord₂ : ∃D (λ x → ∃D (λ y → P² x y)) ↔ ∃D (λ y → ∃D (λ x → P² x y))
{-# ATP prove ord₁ #-}
{-# ATP prove ord₂ #-}

-- Quantification over a variable that does not occur can be delete.
postulate
  erase₁ : ∀D (λ _ → P⁰) ↔ P⁰
  erase₂ : ∃D (λ _ → P⁰) ↔ P⁰
{-# ATP prove erase₁ #-}
{-# ATP prove erase₂ #-}

-- Distributes laws for the quantifiers.
postulate
  dist₁ : ∀D (λ x → P¹ x ∧ Q¹ x) ↔ (∀D P¹ ∧ ∀D Q¹)
  dist₂ : ∃D (λ x → P¹ x ∨ Q¹ x) ↔ (∃D P¹ ∨ ∃D Q¹)
{-# ATP prove dist₁ #-}
{-# ATP prove dist₂ #-}

------------------------------------------------------------------------------
-- Predicate logic examples
------------------------------------------------------------------------------

-- This module contains some examples showing the use of the ATPs to
-- prove theorems from predicate logic.

module Examples.Logic.Predicate where

open import Examples.Logic.Constants

------------------------------------------------------------------------------
-- We postulate some predicate symbols.
postulate
  P⁰    : Set
  P¹ Q¹ : D → Set
  P²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
postulate
  ∀I : ((x : D) → P¹ x) → ∀D P¹
  ∀E : ∀D P¹ → (t : D) → P¹ t
  -- This elimination rule cannot prove in Coq because in Coq we can
  -- have empty domains. We do not have this problem because the ATPs
  -- assume a non-empty domain.
  ∃I : ((t : D) → P¹ t) → ∃D P¹
  -- TODO: ∃E : (x : D) → ∃D P¹ → (P¹ x → Q¹ x) → Q¹ x
{-# ATP prove ∀I #-}
{-# ATP prove ∀E #-}
{-# ATP prove ∃I #-}
-- {-# ATP prove ∃E #-}

-- Generalization of De Morgan's laws.
postulate
  gDM₁ : ¬ (∀D P¹) ↔ ∃D (λ x → ¬ (P¹ x))
  gDM₂ : ¬ (∃D P¹) ↔ ∀D (λ x  → ¬ (P¹ x))
  gDM₃ : ∀D P¹     ↔ ¬ (∃D (λ x → ¬ (P¹ x)))
  gDM₄ : ∃D P¹     ↔ ¬ (∀D (λ x → ¬ (P¹ x)))
{-# ATP prove gDM₁ #-}
{-# ATP prove gDM₂ #-}
{-# ATP prove gDM₃ #-}
{-# ATP prove gDM₄ #-}

-- The order of quantifiers of the same sort is irrelevant.
postulate
  ord₁ : ∀D (λ x → ∀D (λ y → P² x y)) ↔ ∀D (λ y → ∀D (λ x → P² x y))
  ord₂ : ∃D (λ x → ∃D (λ y → P² x y)) ↔ ∃D (λ y → ∃D (λ x → P² x y))
{-# ATP prove ord₁ #-}
{-# ATP prove ord₂ #-}

-- Quantification over a variable that does not occur can be delete.
postulate
  erase₁ : ∀D (λ _ → P⁰) ↔ P⁰
  erase₂ : ∃D (λ _ → P⁰) ↔ P⁰
{-# ATP prove erase₁ #-}
{-# ATP prove erase₂ #-}

-- Distributes laws for the quantifiers.
postulate
  dist₁ : ∀D (λ x → P¹ x ∧ Q¹ x) ↔ (∀D P¹ ∧ ∀D Q¹)
  dist₂ : ∃D (λ x → P¹ x ∨ Q¹ x) ↔ (∃D P¹ ∨ ∃D Q¹)
{-# ATP prove dist₁ #-}
{-# ATP prove dist₂ #-}


Cosmetic changes.

Cosmetic changes.

Ignore-this: 3f66058c406361406bb3a5ee91414be3

darcs-hash:20110720040502-3bd4e-75c92a13a9ca594309249684d6305b39fd088f13.gz

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

module FOTC.Data.Stream.PropertiesI where

open import FOTC.Base

open import FOTC.Base.PropertiesI

open import FOTC.Data.Stream.Type

open import FOTC.Relation.Binary.Bisimilarity

------------------------------------------------------------------------------

tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
tailS {x} {xs} h = subst Stream (sym (∧-proj₂ (∷-injective x∷xs≡e∷es))) Ses
  where
  unfold : ∃ λ e → ∃ λ es → x ∷ xs ≡ e ∷ es ∧ Stream es
  unfold = Stream-gfp₁ h

  e : D
  e = ∃-proj₁ unfold

  es : D
  es = ∃-proj₁ (∃-proj₂ unfold)

  x∷xs≡e∷es : x ∷ xs ≡ e ∷ es
  x∷xs≡e∷es = ∧-proj₁ (∃-proj₂ (∃-proj₂ unfold))

  Ses : Stream es
  Ses = ∧-proj₂ (∃-proj₂ (∃-proj₂ unfold))

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P₁ helper₁ (ys , xs≈ys)
                         , Stream-gfp₂ P₂ helper₂ (xs , xs≈ys)
  where
  P₁ : D → Set
  P₁ ws = ∃ λ zs → ws ≈ zs

  helper₁ : ∀ {ws} → P₁ ws →
            ∃ (λ w' → ∃ (λ ws' → ws ≡ w' ∷ ws' ∧ P₁ ws'))
  helper₁ {ws} (zs , ws≈zs) = w' , ws' , ws≡w'∷ws' , (zs' , ws'≈zs')
    where
    unfold-≈ : ∃ λ w' → ∃ λ ws' → ∃ λ zs' →
               ws' ≈ zs' ∧ ws ≡ w' ∷ ws' ∧ zs ≡ w' ∷ zs'

    unfold-≈ = ≈-gfp₁ ws≈zs

    w' : D
    w' = ∃-proj₁ unfold-≈

    ws' : D
    ws' = ∃-proj₁ (∃-proj₂ unfold-≈)

    zs' : D
    zs' = ∃-proj₁ (∃-proj₂ (∃-proj₂ unfold-≈))

    ws'≈zs' : ws' ≈ zs'
    ws'≈zs' = ∧-proj₁ (∃-proj₂ (∃-proj₂ (∃-proj₂ unfold-≈)))

    ws≡w'∷ws' : ws ≡ w' ∷ ws'
    ws≡w'∷ws' = ∧-proj₁ (∧-proj₂ (∃-proj₂ (∃-proj₂ (∃-proj₂ unfold-≈))))

  P₂ : D → Set
  P₂ zs = ∃ λ ws → ws ≈ zs

  helper₂ : ∀ {zs} → P₂ zs → ∃ (λ z' → ∃ (λ zs' → zs ≡ z' ∷ zs' ∧ P₂ zs'))
  helper₂   {zs} (ws , ws≈zs) = w' , zs' , zs≡w'∷zs' , ws' , ws'≈zs'
    where
    unfold-≈ : ∃ λ w' → ∃ λ ws' → ∃ λ zs' →
               ws' ≈ zs' ∧ ws ≡ w' ∷ ws' ∧ zs ≡ w' ∷ zs'

    unfold-≈ = ≈-gfp₁ ws≈zs

    w' : D
    w' = ∃-proj₁ unfold-≈

    ws' : D
    ws' = ∃-proj₁ (∃-proj₂ unfold-≈)

    zs' : D
    zs' = ∃-proj₁ (∃-proj₂ (∃-proj₂ unfold-≈))

    ws'≈zs' : ws' ≈ zs'
    ws'≈zs' = ∧-proj₁ (∃-proj₂ (∃-proj₂ (∃-proj₂ unfold-≈)))

    zs≡w'∷zs' : zs ≡ w' ∷ zs'
    zs≡w'∷zs' = ∧-proj₂ (∧-proj₂ (∃-proj₂ (∃-proj₂ (∃-proj₂ unfold-≈))))


refactor grouphomomorphism

refactor grouphomomorphism

{-# OPTIONS --without-K #-}
module Explore.GroupHomomorphism where

open import Level
open import Algebra.FunctionProperties
open import Data.Product
open import Function using (_∘_ ; flip)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Relation.Binary.PropositionalEquality.NP hiding (_∙_)

open import Explore.Core
open import Explore.Properties
open import Explore.Sum

{-
 I had some problems with using the standard library definiton of Groups
 so I rolled my own, therefor I need some boring proofs first

-}
record Group (G : Set) : Set where
  field
    _∙_ : G → G → G
    ε   : G
    -_  : G → G

  -- laws
  field
    assoc    : Associative _≡_ _∙_
    identity : Identity _≡_ ε _∙_
    inverse  : Inverse _≡_ ε -_ _∙_

  -- derived property
  help : ∀ x y → x ≡ (x ∙ y) ∙ - y
  help x y = x
           ≡⟨ sym (proj₂ identity x) ⟩
             x ∙ ε
           ≡⟨ cong (_∙_ x) (sym (proj₂ inverse y)) ⟩
             x ∙ (y ∙ - y)
           ≡⟨ sym (assoc x y (- y)) ⟩
             (x ∙ y) ∙ (- y)
           ∎
    where open ≡-Reasoning

  unique-1g : ∀ x y → x ∙ y ≡ y → x ≡ ε
  unique-1g x y eq = x
                   ≡⟨ help x y ⟩
                     (x ∙ y) ∙ - y
                   ≡⟨ cong (flip _∙_ (- y)) eq ⟩
                     y ∙ - y
                   ≡⟨ proj₂ inverse y ⟩
                     ε
                   ∎
    where open ≡-Reasoning

  unique-/ : ∀ x y → x ∙ y ≡ ε → x ≡ - y
  unique-/ x y eq = x
                  ≡⟨ help x y ⟩
                    (x ∙ y) ∙ - y
                  ≡⟨ cong (flip _∙_ (- y)) eq ⟩
                    ε ∙ - y
                  ≡⟨ proj₁ identity (- y) ⟩
                    - y
                  ∎
    where open ≡-Reasoning

module _ {A B : Set}(GA : Group A)(GB : Group B) where
  open Group GA using (-_) renaming (_∙_ to _+_; ε to 0g)
  open Group GB using (unique-1g ; unique-/) renaming (_∙_ to _*_; ε to 1g; -_ to 1/_)

  GroupHomomorphism : (A → B) → Set
  GroupHomomorphism f = ∀ x y → f (x + y) ≡ f x * f y

  module GroupHomomorphismProp {f}(f-homo : GroupHomomorphism f) where
    f-pres-ε : f 0g ≡ 1g
    f-pres-ε = unique-1g (f 0g) (f 0g) part
      where open ≡-Reasoning
            open Group GA using (identity)
            part = f 0g * f 0g
                 ≡⟨ sym (f-homo 0g 0g) ⟩
                   f (0g + 0g)
                 ≡⟨ cong f (proj₁ identity 0g) ⟩
                   f 0g
                 ∎

    f-pres-inv : ∀ x → f (- x) ≡ 1/ f x
    f-pres-inv x = unique-/ (f (- x)) (f x) part
      where open ≡-Reasoning
            open Group GA using (inverse)
            part = f (- x) * f x
                 ≡⟨ sym (f-homo (- x) x) ⟩
                   f (- x + x)
                 ≡⟨ cong f (proj₁ inverse x) ⟩
                   f 0g
                 ≡⟨ f-pres-ε ⟩
                   1g
                 ∎

module _ {A B}(GA : Group A)(GB : Group B)
         (f : A → B)
         (exploreA : Explore zero A)(f-homo : GroupHomomorphism GA GB f)
         ([f] : B → A)(f-sur : ∀ b → f ([f] b) ≡ b)
         (explore-ext : ExploreExt exploreA)
         where
  open Group GA using (-_) renaming (_∙_ to _+_ ; ε to 0g)
  open Group GB using ()   renaming (_∙_ to _*_ ; ε to 1g ; -_ to 1/_)
  open GroupHomomorphismProp GA GB f-homo

  {- How all this is related to elgamal

  the Group GA is ℤq with modular addition as operation
  the Group GB is the cyclic group with order q

  f is g^, the proof only need that it is a group homomorphism
  and that it has a right inverse

  we require that the explore (for type A) function (should work with only summation)
  is Stable under addition of GA (notice that we have flip in there that is so that
  we don't need commutativity

  finally we require that the explore function respects extensionality
  -}

  {-
    While this proof looks complicated it basically just adds inverse of m₀ and then adds m₁ (from image of f)
    we need the homomorphic property to pull out the values.

  -}

  module _ {X}(z : X)(op : X → X → X)
           (sui : ∀ k → StableUnder' exploreA z op (flip (Group._∙_ GA) k))
    where
  -- this proof isn't actually any hard..
    thm : ∀ (O : B → X) m₀ m₁ → exploreA z op (λ x → O (f x * m₀)) ≡ exploreA z op (λ x → O (f x * m₁))
    thm O m₀ m₁ = explore (λ x → O (f x * m₀))
                 ≡⟨ sui (- [f] m₀) (λ x → O (f x * m₀)) ⟩
                   explore (λ x → O (f (x + - [f] m₀)  * m₀))
                 ≡⟨ explore-ext z op (λ x → cong O (lemma1 x)) ⟩
                   explore (λ x → O (f x ))
                 ≡⟨ sui ([f] m₁) (O ∘ f) ⟩
                   explore (λ x → O (f (x + [f] m₁)))
                 ≡⟨ explore-ext z op (λ x → cong O (lemma2 x)) ⟩
                   explore (λ x → O (f x * m₁))
                 ∎
     where
      open ≡-Reasoning
      explore = exploreA z op

      lemma1 : ∀ x → f (x + - [f] m₀) * m₀ ≡ f x
      lemma1 x rewrite f-homo x (- [f] m₀)
                     | f-pres-inv ([f] m₀)
                     | f-sur m₀
                     | Group.assoc GB (f x) (1/ m₀) m₀
                     | proj₁ (Group.inverse GB) m₀
                     | proj₂ (Group.identity GB) (f x) = refl

      lemma2 : ∀ x → f (x + [f] m₁) ≡ f x * m₁
      lemma2 x rewrite f-homo x ([f] m₁)
                     | f-sur m₁ = refl

{-# OPTIONS --without-K #-}
module Explore.GroupHomomorphism where

open import Level
open import Algebra.FunctionProperties
open import Data.Product
open import Function using (_∘_ ; flip)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Relation.Binary.PropositionalEquality.NP hiding (_∙_)

open import Explore.Core
open import Explore.Properties
open import Explore.Sum

record Group (G : Set) : Set where
  field
    _∙_ : G → G → G
    ε   : G
    -_  : G → G

  -- laws
  field
    assoc    : Associative _≡_ _∙_
    identity : Identity _≡_ ε _∙_
    inverse  : Inverse _≡_ ε -_ _∙_

GroupHomomorphism : ∀ {A B : Set} → Group A → Group B →(A → B) → Set
GroupHomomorphism GA GB f = ∀ x y → f (x + y) ≡ f x * f y
  where
    open Group GA renaming (_∙_ to _+_)
    open Group GB renaming (_∙_ to _*_)

module _ {A B}(GA : Group A)(GB : Group B)
         (f : A → B)
         (exploreA : Explore zero A)(f-homo : GroupHomomorphism GA GB f)
         ([f] : B → A)(f-sur : ∀ b → f ([f] b) ≡ b)
         (explore-ext : ExploreExt exploreA)
         where
  open Group GA using (-_) renaming (_∙_ to _+_ ; ε to 0g)
  open Group GB using ()   renaming (_∙_ to _*_ ; ε to 1g ; -_ to 1/_)

  {- How all this is related to elgamal

  the Group GA is ℤq with modular addition as operation
  the Group GB is the cyclic group with order q

  f is g^, the proof only need that it is a group homomorphism
  and that it has a right inverse

  we require that the explore (for type A) function (should work with only summation)
  is Stable under addition of GA (notice that we have flip in there that is so that
  we don't need commutativity

  finally we require that the explore function respects extensionality
  -}

  {-
   I had some problems with using the standard library definiton of Groups
   so I rolled my own, therefor I need some boring proofs first

  -}

  help : ∀ x y → x ≡ (x * y) * 1/ y
  help x y = x
           ≡⟨ sym (proj₂ identity x) ⟩
             x * 1g
           ≡⟨ cong (_*_ x) (sym (proj₂ inverse y)) ⟩
             x * (y * 1/ y)
           ≡⟨ sym (assoc x y (1/ y)) ⟩
             (x * y) * (1/ y)
           ∎
    where open ≡-Reasoning
          open Group GB

  unique-1g : ∀ x y → x * y ≡ y → x ≡ 1g
  unique-1g x y eq = x
                   ≡⟨ help x y ⟩
                     (x * y) * 1/ y
                   ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                     y * 1/ y
                   ≡⟨ proj₂ inverse y ⟩
                     1g
                   ∎
    where open ≡-Reasoning
          open Group GB

  unique-/ : ∀ x y → x * y ≡ 1g → x ≡ 1/ y
  unique-/ x y eq = x
                  ≡⟨ help x y ⟩
                    (x * y) * 1/ y
                  ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                    1g * 1/ y
                  ≡⟨ proj₁ identity (1/ y) ⟩
                    1/ y
                  ∎
    where open ≡-Reasoning
          open Group GB

  f-pres-ε : f 0g ≡ 1g
  f-pres-ε = unique-1g (f 0g) (f 0g) part
    where open ≡-Reasoning
          open Group GA
          part = f 0g * f 0g
               ≡⟨ sym (f-homo 0g 0g) ⟩
                 f (0g + 0g)
               ≡⟨ cong f (proj₁ identity 0g) ⟩
                 f 0g
               ∎

  f-pres-inv : ∀ x → f (- x) ≡ 1/ f x
  f-pres-inv x = unique-/ (f (- x)) (f x) part
    where open ≡-Reasoning
          open Group GA hiding (-_)
          part = f (- x) * f x
               ≡⟨ sym (f-homo (- x) x) ⟩
                 f (- x + x)
               ≡⟨ cong f (proj₁ inverse x) ⟩
                 f 0g
               ≡⟨ f-pres-ε ⟩
                 1g
               ∎
  {-
    While this proof looks complicated it basically just adds inverse of m₀ and then adds m₁ (from image of f)
    we need the homomorphic property to pull out the values.

  -}

  module _ {X}(z : X)(op : X → X → X)
           (sui : ∀ k → StableUnder' exploreA z op (flip (Group._∙_ GA) k))
    where
  -- this proof isn't actually any hard..
    thm : ∀ (O : B → X) m₀ m₁ → exploreA z op (λ x → O (f x * m₀)) ≡ exploreA z op (λ x → O (f x * m₁))
    thm O m₀ m₁ = explore (λ x → O (f x * m₀))
                 ≡⟨ sui (- [f] m₀) (λ x → O (f x * m₀)) ⟩
                   explore (λ x → O (f (x + - [f] m₀)  * m₀))
                 ≡⟨ explore-ext z op (λ x → cong O (lemma1 x)) ⟩
                   explore (λ x → O (f x ))
                 ≡⟨ sui ([f] m₁) (O ∘ f) ⟩
                   explore (λ x → O (f (x + [f] m₁)))
                 ≡⟨ explore-ext z op (λ x → cong O (lemma2 x)) ⟩
                   explore (λ x → O (f x * m₁))
                 ∎
     where
      open ≡-Reasoning
      explore = exploreA z op

      lemma1 : ∀ x → f (x + - [f] m₀) * m₀ ≡ f x
      lemma1 x rewrite f-homo x (- [f] m₀)
                     | f-pres-inv ([f] m₀)
                     | f-sur m₀
                     | Group.assoc GB (f x) (1/ m₀) m₀
                     | proj₁ (Group.inverse GB) m₀
                     | proj₂ (Group.identity GB) (f x) = refl

      lemma2 : ∀ x → f (x + [f] m₁) ≡ f x * m₁
      lemma2 x rewrite f-homo x ([f] m₁)
                     | f-sur m₁ = refl


Minor changes.

Minor changes.


ExplicitNil: extend correctness of optimized derivation
to support bag union and difference

Old-commit-hash: 40f74c6acb6b271d0654bbc62228aba5fbfc8edf

{-
Communicate to derivatives that changes to certain arguments
are always nil (i. e., certain arguments are stable).
-}

module ExplicitNil where

open import TaggedDeltaTypes

open import Data.Nat
open import Data.Bool
open import Data.Sum hiding (map)
open import Data.Product hiding (map)
open import Data.Unit using (⊤ ; tt)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
open import Relation.Binary.Core using (Decidable)
open import Relation.Nullary.Core using (yes ; no)

ext³ : ∀
  {A : Set}
  {B : A → Set}
  {C : (a : A) → B a → Set }
  {D : (a : A) → (b : B a) → C a b → Set}
  {f g : (a : A) → (b : B a) → (c : C a b) → D a b c} →
  ((a : A) (b : B a) (c : C a b) → f a b c ≡ g a b c) → f ≡ g

ext³ fabc=gabc = ext (λ a → ext (λ b → ext (λ c → fabc=gabc a b c)))
  where ext = extensionality

proj-H : ∀ {Γ : Context} {ρ : ΔEnv Γ} {us vs} →
  Honest ρ (FV-union us vs) → Honest ρ us × Honest ρ vs
proj-H {∅} {us = ∅} {vs = ∅} clearly = clearly , clearly
proj-H {us = alter us} {alter vs} (alter H) =
  let uss , vss = proj-H H in alter uss , alter vss
proj-H {us = alter us} {abide vs} (abide eq H) =
  let uss , vss = proj-H H in
  alter uss , abide eq vss
proj-H {us = abide us} {alter vs} (abide eq H) =
  let uss , vss = proj-H H in
  abide eq uss , alter vss
proj-H {us = abide us} {abide vs} (abide eq H) =
  let uss , vss = proj-H H in
  abide eq uss , abide eq vss

-- Equivalence proofs are unique
equivalence-unique : ∀ {A : Set} {a b : A} → ∀ {p q : a ≡ b} → p ≡ q
equivalence-unique {p = refl} {refl} = refl

-- Product of singletons are singletons (for example)
product-unique : ∀ {A : Set} {B : A → Set} →
  (∀ {a b : A} → a ≡ b) →
  (∀ {a : A} {c d : B a} → c ≡ d) →
  (∀ {p q : Σ A B} → p ≡ q)
product-unique {A} {B} lhs rhs {a , c} {b , d}
  rewrite lhs {a} {b} = cong (_,_ b) rhs

-- Validity proofs are (extensionally) unique (as functions)
validity-unique : ∀ {τ} {v : ⟦ τ ⟧} {dv : ΔVal τ} →
  ∀ {p q : valid v dv} → p ≡ q
validity-unique {nats} = equivalence-unique
validity-unique {bags} = refl
validity-unique {σ ⇒ τ} =  ext³ (λ v dv R[v,dv] →
  product-unique validity-unique equivalence-unique)

stabilityVar : ∀ {τ Γ} {x : Var Γ τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (select-just x)) →
  ⟦ x ⟧ (ignore ρ) ⊕ ⟦ x ⟧ΔVar ρ ≡ ⟦ x ⟧ (ignore ρ)

stabilityVar {x = this} (abide proof _) = proof
stabilityVar {x = that y} (alter H) = stabilityVar {x = y} H

stability : ∀ {τ Γ} {t : Term Γ τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (FV t)) →
    ⟦ t ⟧ (ignore ρ) ⊕ ⟦ derive t ⟧Δ ρ (unrestricted t)
  ≡ ⟦ t ⟧ (ignore ρ)

-- Boilerplate begins
stabilityAbs : ∀ {σ τ Γ} {t : Term (σ • Γ) τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (FV (abs t))) →
  (v : ⟦ σ ⟧) →
    ⟦ t ⟧ (v • ignore ρ) ⊕
    ⟦ derive t ⟧Δ (cons v (v ⊝ v) R[v,u⊝v] ρ) (unrestricted t)
  ≡ ⟦ t ⟧ (v • ignore ρ)
stabilityAbs {t = t} {ρ} H v with FV t | inspect FV t
... | abide vars | [ case0 ] = stability {t = t} Ht
  where
  Ht : Honest (cons v (v ⊝ v) R[v,u⊝v] ρ) (FV t)
  Ht rewrite case0 = abide v⊕[u⊝v]=u H
... | alter vars | [ case1 ] = stability {t = t} Ht
  where
  Ht : Honest (cons v (v ⊝ v) R[v,u⊝v] ρ) (FV t)
  Ht rewrite case1 = alter H
-- Boilerplate ends

stability {t = nat n} H = refl
stability {t = bag b} H = b++∅=b
stability {t = union s t} {ρ} H =
  let
    a = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
    da = ⟦ derive s ⟧Δ ρ (unrestricted s)
    db = ⟦ derive t ⟧Δ ρ (unrestricted t)
    Hs , Ht = proj-H H
  in
    begin
      (a ++ b) ++ (da ++ db)
    ≡⟨ [a++b]++[c++d]=[a++c]++[b++d] ⟩
      (a ++ da) ++ (b ++ db)
    ≡⟨ cong₂ _++_ (stability {t = s} Hs) (stability {t = t} Ht) ⟩
      a ++ b
    ∎ where open ≡-Reasoning
stability {t = diff s t} {ρ} H =
  let
    a = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
    da = ⟦ derive s ⟧Δ ρ (unrestricted s)
    db = ⟦ derive t ⟧Δ ρ (unrestricted t)
    Hs , Ht = proj-H H
  in
    begin
      (a \\ b) ++ (da \\ db)
    ≡⟨ [a\\b]++[c\\d]=[a++c]\\[b++d] ⟩
      (a ++ da) \\ (b ++ db)
    ≡⟨ cong₂ _\\_ (stability {t = s} Hs) (stability {t = t} Ht) ⟩
      a \\ b
    ∎ where open ≡-Reasoning
stability {t = var x} H = stabilityVar H
stability {t = abs t} {ρ} H = extensionality (stabilityAbs {t = t} H)
stability {t = app s t} {ρ} H =
  let
    f = ⟦ s ⟧ (ignore ρ)
    v = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧Δ ρ (unrestricted s)
    dv = ⟦ derive t ⟧Δ ρ (unrestricted t)
    Hs , Ht = proj-H H
  in
    begin
      f v ⊕ df v dv (validity {t = t})
    ≡⟨ sym (corollary s t) ⟩
      (f ⊕ df) (v ⊕ dv)
    ≡⟨ stability {t = s} Hs ⟨$⟩ stability {t = t} Ht ⟩
      f v
    ∎ where open ≡-Reasoning
stability {t = add s t} H =
  let Hs , Ht = proj-H H
  in cong₂ _+_ (stability {t = s} Hs) (stability {t = t} Ht)
stability {t = map s t} {ρ} H =
  let
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧Δ ρ (unrestricted s)
    db = ⟦ derive t ⟧Δ ρ (unrestricted t)
    Hs , Ht = proj-H H
    map = mapBag
  in
  begin
    map f b ⊕ (map (f ⊕ df) (b ⊕ db) ⊝ map f b)
  ≡⟨ b++[d\\b]=d ⟩
    map (f ⊕ df) (b ⊕ db)
  ≡⟨ cong₂ map (stability {t = s} Hs) (stability {t = t} Ht) ⟩
    map f b
  ∎ where open ≡-Reasoning

eq-map : ∀ {Γ}
  (s    : Term Γ (nats ⇒ nats))
  (t    : Term Γ bags)
  (ρ    : ΔEnv Γ)
  (H    : Honest ρ (FV s)) →
    ⟦ Δmap₁ s (derive t) ⟧Δ ρ (cons (unrestricted t) H tt tt)
  ≡ ⟦ Δmap₀ s (derive s) t (derive t) ⟧Δ ρ (unrestricted (map s t))

eq-map s t ρ H =
  let
    ds = derive s
    dt = derive t
    f  = ⟦ s ⟧ (ignore ρ)
    v  = ⟦ t ⟧ (ignore ρ)
    df = ⟦ ds ⟧Δ ρ (unrestricted s)
    dv = ⟦ dt ⟧Δ ρ (unrestricted t)

    eq1 : ⟦ Δmap₀ s ds t dt ⟧Δ ρ (unrestricted (map s t))
        ≡ mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v
    eq1 = refl

    eq2 : mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v
        ≡ mapBag f dv
    eq2 = trans
      (cong (λ hole → hole ⊝ mapBag f v) (trans
        (cong (λ hole → mapBag hole (v ⊕ dv)) (stability {t = s} H))
        map-over-++))
      [b++d]\\b=d

    eq3 : mapBag f dv
        ≡ ⟦ Δmap₁ s (derive t) ⟧Δ ρ (cons (unrestricted t) H tt tt)
    eq3 = refl

  in sym (trans eq1 (trans eq2 eq3))

-- Vars test
none-selected? : ∀ {Γ} → (vs : Vars Γ) → (vs ≡ select-none) ⊎ ⊤
none-selected? ∅ = inj₁ refl
none-selected? (abide vs) = inj₂ tt
none-selected? (alter vs) with none-selected? vs
... | inj₁ vs=∅ rewrite vs=∅ = inj₁ refl
... | inj₂ _ = inj₂ tt

closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ select-none) ⊎ ⊤
closed? t = none-selected? (FV t)

vacuous-honesty : ∀ {Γ} {ρ : ΔEnv Γ} → Honest ρ select-none
vacuous-honesty {∅} {∅} = clearly
vacuous-honesty {τ • Γ} {cons _ _ _ ρ} = alter (vacuous-honesty {ρ = ρ})

-- Immunity of closed terms to dishonest environments
immune : ∀ {τ Γ} {t : Term Γ τ} →
  (FV t ≡ select-none) → ∀ {ρ} → Honest ρ (FV t)
immune {t = t} eq rewrite eq = vacuous-honesty

-- Ineffectual first optimization step
derive1 : ∀ {τ Γ} → Term Γ τ → ΔTerm Γ τ
derive1 (map s t) with closed? s
... | inj₁ is-closed = Δmap₁ s (derive t)
... | inj₂ tt = derive (map s t)
derive1 others = derive others

valid1 : ∀ {τ Γ} (t : Term Γ τ) {ρ : ΔEnv Γ} → derive1 t is-valid-for ρ
valid1 (nat n) = tt
valid1 (bag b) = tt
valid1 (union s t) = cons (unrestricted s) (unrestricted t) tt tt
valid1 (diff s t) = cons (unrestricted s) (unrestricted t) tt tt
valid1 (var x) = tt
valid1 (abs t) = λ _ _ _ → unrestricted t
valid1 (app s t) =
  cons (unrestricted s) (unrestricted t) (validity {t = t}) tt
valid1 (add s t) =
  cons (unrestricted s) (unrestricted t) tt tt
valid1 (map s t) {ρ} with closed? s
... | inj₂ tt = cons (unrestricted s) (unrestricted t) tt tt
... | inj₁ if-closed =
  cons (unrestricted t) (immune {t = s} if-closed) tt tt

correct1 : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv Γ} →
  ⟦ derive1 t ⟧Δ ρ (valid1 t) ≡ ⟦ derive t ⟧Δ ρ (unrestricted t)

correct1 {t = nat n} = refl
correct1 {t = bag b} = refl
correct1 {t = var x} = refl
correct1 {t = abs t} = refl
correct1 {t = app s t} = refl
correct1 {t = union s t} = refl
correct1 {t = diff s t} = refl
correct1 {t = add s t} = refl
correct1 {t = map s t} {ρ} with closed? s
... | inj₂ tt = refl
... | inj₁ if-closed = eq-map s t ρ (immune {t = s} if-closed)

-- derive2 = derive1 + congruence
derive2 : ∀ {τ Γ} → Term Γ τ → ΔTerm Γ τ
derive2 (abs t) = Δabs (derive2 t)
derive2 (app s t) = Δapp (derive2 s) t (derive2 t)
derive2 (add s t) = Δadd (derive2 s) (derive2 t)
derive2 (union s t) = Δunion (derive2 s) (derive2 t)
derive2 (diff s t) = Δdiff (derive2 s) (derive2 t)
derive2 (map s t) with closed? s
... | inj₁ is-closed = Δmap₁ s (derive2 t)
... | inj₂ tt = Δmap₀ s (derive2 s) t (derive2 t)
derive2 others = derive others

valid2 : ∀ {τ Γ} (t : Term Γ τ) {ρ : ΔEnv Γ} → derive2 t is-valid-for ρ
correct2 : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv Γ} →
  ⟦ derive2 t ⟧Δ ρ (valid2 t) ≡ ⟦ derive t ⟧Δ ρ (unrestricted t)

valid2 (nat n) = tt
valid2 (bag b) = tt
valid2 (var x) = tt
valid2 (abs t) = λ _ _ _ → valid2 t
valid2 (app s t) {ρ} = cons (valid2 s) (valid2 t) V tt
  where
  V : valid (⟦ t ⟧ (ignore ρ)) (⟦ derive2 t ⟧Δ ρ (valid2 t))
  V rewrite correct2 {t = t} {ρ} = validity {t = t} {ρ}
valid2 (add s t) = cons (valid2 s) (valid2 t) tt tt
valid2 (union s t) = cons (valid2 s) (valid2 t) tt tt
valid2 (diff s t) = cons (valid2 s) (valid2 t) tt tt
valid2 (map s t) {ρ} with closed? s
... | inj₂ tt = cons (valid2 s) (valid2 t) tt tt
... | inj₁ if-closed =
  cons (valid2 t) (immune {t = s} if-closed) tt tt

correct2 {t = nat n} = refl
correct2 {t = bag b} = refl
correct2 {t = var x} = refl
correct2 {t = abs t} = ext³ (λ _ _ _ → correct2 {t = t})
correct2 {t = app {σ} {τ} s t} {ρ} = ≅-to-≡ eq-all where
  open import Relation.Binary.HeterogeneousEquality hiding (cong₂)
  import Relation.Binary.HeterogeneousEquality as HET
  df0 : ΔVal (σ ⇒ τ)
  df0 = ⟦ derive s ⟧Δ ρ (unrestricted s)
  df2 : ΔVal (σ ⇒ τ)
  df2 = ⟦ derive2 s ⟧Δ ρ (valid2 s)
  dv0 : ΔVal σ
  dv0 = ⟦ derive t ⟧Δ ρ (unrestricted t)
  dv2 : ΔVal σ
  dv2 = ⟦ derive2 t ⟧Δ ρ (valid2 t)
  v   : ⟦ σ ⟧
  v   = ⟦ t ⟧ (ignore ρ)
  eq-df : df2 ≡ df0
  eq-df = correct2 {t = s}
  eq-dv : dv2 ≡ dv0
  eq-dv = correct2 {t = t}
  eq-all : df2 v dv2 (caddr (valid2 (app s t) {ρ}))
         ≅ df0 v dv0 (validity {t = t} {ρ})
  eq-all rewrite eq-dv = HET.cong
    (λ hole → hole v dv0 (validity {t = t} {ρ})) (≡-to-≅ eq-df)
    -- found without intuition by trial-and-error
correct2 {t = add s t} {ρ} =
  let
    cs = correct2 {t = s} {ρ}
    ct = correct2 {t = t} {ρ}
  in cong₂ _,_ (cong₂ _+_ (cong proj₁ cs) (cong proj₁ ct))
               (cong₂ _+_ (cong proj₂ cs) (cong proj₂ ct))
correct2 {t = union s t} {ρ} =
  cong₂ _++_ (correct2 {t = s} {ρ}) (correct2 {t = t} {ρ})
correct2 {t = diff s t} {ρ} =
  cong₂ _\\_ (correct2 {t = s} {ρ}) (correct2 {t = t} {ρ})
correct2 {t = map s t} {ρ} with closed? s
... | inj₂ tt =
  let
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
  in
    cong₂ (λ h1 h2 → mapBag (f ⊕ h1) (b ⊕ h2) \\ mapBag f b)
    (correct2 {t = s}) (correct2 {t = t})
... | inj₁ if-closed = trans
  (cong (mapBag (⟦ s ⟧ (ignore ρ))) (correct2 {t = t}))
  (eq-map s t ρ (immune {t = s} if-closed))

---------------
-- Example 3 --
---------------

-- [+1] = λ x → x + 1
[+1] : ∀ {Γ} → Term Γ (nats ⇒ nats)
[+1] = (abs (add (var this) (nat 1)))

-- inc = λ bag → map [+1] bag
inc : Term ∅ (bags ⇒ bags)
inc = abs (map [+1] (var this))

-- Program transformation in example 3
-- Sadly, `inc` is not executable, for `Bag` is an abstract type
-- whose existence we postulated.
--
-- derive2 inc = λ bag dbag → map [+1] dbag
example-3 : derive2 inc ≡ Δabs (Δmap₁ [+1] (Δvar this))
example-3 = refl

-- Correctness of optimized derivation on `inc`
--
-- ⟦ derive2 inc ⟧ <embedded-proof> = ⟦ derive inc ⟧ <another-proof>
example-3-correct :
  ⟦ derive2 inc ⟧Δ ∅ (valid2 inc) ≡ ⟦ derive inc ⟧Δ ∅ (unrestricted inc)
example-3-correct = correct2 {t = inc} {∅}

{-
Communicate to derivatives that changes to certain arguments
are always nil (i. e., certain arguments are stable).
-}

module ExplicitNil where

open import TaggedDeltaTypes

open import Data.Nat
open import Data.Bool
open import Data.Sum hiding (map)
open import Data.Product hiding (map)
open import Data.Unit using (⊤ ; tt)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
open import Relation.Binary.Core using (Decidable)
open import Relation.Nullary.Core using (yes ; no)

ext³ : ∀
  {A : Set}
  {B : A → Set}
  {C : (a : A) → B a → Set }
  {D : (a : A) → (b : B a) → C a b → Set}
  {f g : (a : A) → (b : B a) → (c : C a b) → D a b c} →
  ((a : A) (b : B a) (c : C a b) → f a b c ≡ g a b c) → f ≡ g

ext³ fabc=gabc = ext (λ a → ext (λ b → ext (λ c → fabc=gabc a b c)))
  where ext = extensionality

proj-H : ∀ {Γ : Context} {ρ : ΔEnv Γ} {us vs} →
  Honest ρ (FV-union us vs) → Honest ρ us × Honest ρ vs
proj-H {∅} {us = ∅} {vs = ∅} clearly = clearly , clearly
proj-H {us = alter us} {alter vs} (alter H) =
  let uss , vss = proj-H H in alter uss , alter vss
proj-H {us = alter us} {abide vs} (abide eq H) =
  let uss , vss = proj-H H in
  alter uss , abide eq vss
proj-H {us = abide us} {alter vs} (abide eq H) =
  let uss , vss = proj-H H in
  abide eq uss , alter vss
proj-H {us = abide us} {abide vs} (abide eq H) =
  let uss , vss = proj-H H in
  abide eq uss , abide eq vss

-- Equivalence proofs are unique
equivalence-unique : ∀ {A : Set} {a b : A} → ∀ {p q : a ≡ b} → p ≡ q
equivalence-unique {p = refl} {refl} = refl

-- Product of singletons are singletons (for example)
product-unique : ∀ {A : Set} {B : A → Set} →
  (∀ {a b : A} → a ≡ b) →
  (∀ {a : A} {c d : B a} → c ≡ d) →
  (∀ {p q : Σ A B} → p ≡ q)
product-unique {A} {B} lhs rhs {a , c} {b , d}
  rewrite lhs {a} {b} = cong (_,_ b) rhs

-- Validity proofs are (extensionally) unique (as functions)
validity-unique : ∀ {τ} {v : ⟦ τ ⟧} {dv : ΔVal τ} →
  ∀ {p q : valid v dv} → p ≡ q
validity-unique {nats} = equivalence-unique
validity-unique {bags} = refl
validity-unique {σ ⇒ τ} =  ext³ (λ v dv R[v,dv] →
  product-unique validity-unique equivalence-unique)

stabilityVar : ∀ {τ Γ} {x : Var Γ τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (select-just x)) →
  ⟦ x ⟧ (ignore ρ) ⊕ ⟦ x ⟧ΔVar ρ ≡ ⟦ x ⟧ (ignore ρ)

stabilityVar {x = this} (abide proof _) = proof
stabilityVar {x = that y} (alter H) = stabilityVar {x = y} H

stability : ∀ {τ Γ} {t : Term Γ τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (FV t)) →
    ⟦ t ⟧ (ignore ρ) ⊕ ⟦ derive t ⟧Δ ρ (unrestricted t)
  ≡ ⟦ t ⟧ (ignore ρ)

-- Boilerplate begins
stabilityAbs : ∀ {σ τ Γ} {t : Term (σ • Γ) τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (FV (abs t))) →
  (v : ⟦ σ ⟧) →
    ⟦ t ⟧ (v • ignore ρ) ⊕
    ⟦ derive t ⟧Δ (cons v (v ⊝ v) R[v,u⊝v] ρ) (unrestricted t)
  ≡ ⟦ t ⟧ (v • ignore ρ)
stabilityAbs {t = t} {ρ} H v with FV t | inspect FV t
... | abide vars | [ case0 ] = stability {t = t} Ht
  where
  Ht : Honest (cons v (v ⊝ v) R[v,u⊝v] ρ) (FV t)
  Ht rewrite case0 = abide v⊕[u⊝v]=u H
... | alter vars | [ case1 ] = stability {t = t} Ht
  where
  Ht : Honest (cons v (v ⊝ v) R[v,u⊝v] ρ) (FV t)
  Ht rewrite case1 = alter H
-- Boilerplate ends

stability {t = nat n} H = refl
stability {t = bag b} H = b++∅=b
stability {t = var x} H = stabilityVar H
stability {t = abs t} {ρ} H = extensionality (stabilityAbs {t = t} H)
stability {t = app s t} {ρ} H =
  let
    f = ⟦ s ⟧ (ignore ρ)
    v = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧Δ ρ (unrestricted s)
    dv = ⟦ derive t ⟧Δ ρ (unrestricted t)
    Hs , Ht = proj-H H
  in
    begin
      f v ⊕ df v dv (validity {t = t})
    ≡⟨ sym (corollary s t) ⟩
      (f ⊕ df) (v ⊕ dv)
    ≡⟨ stability {t = s} Hs ⟨$⟩ stability {t = t} Ht ⟩
      f v
    ∎ where open ≡-Reasoning
stability {t = add s t} H =
  let Hs , Ht = proj-H H
  in cong₂ _+_ (stability {t = s} Hs) (stability {t = t} Ht)
stability {t = map s t} {ρ} H =
  let
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧Δ ρ (unrestricted s)
    db = ⟦ derive t ⟧Δ ρ (unrestricted t)
    Hs , Ht = proj-H H
    map = mapBag
  in
  begin
    map f b ⊕ (map (f ⊕ df) (b ⊕ db) ⊝ map f b)
  ≡⟨ b++[d\\b]=d ⟩
    map (f ⊕ df) (b ⊕ db)
  ≡⟨ cong₂ map (stability {t = s} Hs) (stability {t = t} Ht) ⟩
    map f b
  ∎ where open ≡-Reasoning

eq-map : ∀ {Γ}
  (s    : Term Γ (nats ⇒ nats))
  (t    : Term Γ bags)
  (ρ    : ΔEnv Γ)
  (H    : Honest ρ (FV s)) →
    ⟦ Δmap₁ s (derive t) ⟧Δ ρ (cons (unrestricted t) H tt tt)
  ≡ ⟦ Δmap₀ s (derive s) t (derive t) ⟧Δ ρ (unrestricted (map s t))

eq-map s t ρ H =
  let
    ds = derive s
    dt = derive t
    f  = ⟦ s ⟧ (ignore ρ)
    v  = ⟦ t ⟧ (ignore ρ)
    df = ⟦ ds ⟧Δ ρ (unrestricted s)
    dv = ⟦ dt ⟧Δ ρ (unrestricted t)

    eq1 : ⟦ Δmap₀ s ds t dt ⟧Δ ρ (unrestricted (map s t))
        ≡ mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v
    eq1 = refl

    eq2 : mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v
        ≡ mapBag f dv
    eq2 = trans
      (cong (λ hole → hole ⊝ mapBag f v) (trans
        (cong (λ hole → mapBag hole (v ⊕ dv)) (stability {t = s} H))
        map-over-++))
      [b++d]\\b=d

    eq3 : mapBag f dv
        ≡ ⟦ Δmap₁ s (derive t) ⟧Δ ρ (cons (unrestricted t) H tt tt)
    eq3 = refl

  in sym (trans eq1 (trans eq2 eq3))

-- Vars test
none-selected? : ∀ {Γ} → (vs : Vars Γ) → (vs ≡ select-none) ⊎ ⊤
none-selected? ∅ = inj₁ refl
none-selected? (abide vs) = inj₂ tt
none-selected? (alter vs) with none-selected? vs
... | inj₁ vs=∅ rewrite vs=∅ = inj₁ refl
... | inj₂ _ = inj₂ tt

closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ select-none) ⊎ ⊤
closed? t = none-selected? (FV t)

vacuous-honesty : ∀ {Γ} {ρ : ΔEnv Γ} → Honest ρ select-none
vacuous-honesty {∅} {∅} = clearly
vacuous-honesty {τ • Γ} {cons _ _ _ ρ} = alter (vacuous-honesty {ρ = ρ})

-- Immunity of closed terms to dishonest environments
immune : ∀ {τ Γ} {t : Term Γ τ} →
  (FV t ≡ select-none) → ∀ {ρ} → Honest ρ (FV t)
immune {t = t} eq rewrite eq = vacuous-honesty

-- Ineffectual first optimization step
derive1 : ∀ {τ Γ} → Term Γ τ → ΔTerm Γ τ
derive1 (map s t) with closed? s
... | inj₁ is-closed = Δmap₁ s (derive t)
... | inj₂ tt = derive (map s t)
derive1 others = derive others

valid1 : ∀ {τ Γ} (t : Term Γ τ) {ρ : ΔEnv Γ} → derive1 t is-valid-for ρ
valid1 (nat n) = tt
valid1 (bag b) = tt
valid1 (var x) = tt
valid1 (abs t) = λ _ _ _ → unrestricted t
valid1 (app s t) =
  cons (unrestricted s) (unrestricted t) (validity {t = t}) tt
valid1 (add s t) =
  cons (unrestricted s) (unrestricted t) tt tt
valid1 (map s t) {ρ} with closed? s
... | inj₂ tt = cons (unrestricted s) (unrestricted t) tt tt
... | inj₁ if-closed =
  cons (unrestricted t) (immune {t = s} if-closed) tt tt

correct1 : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv Γ} →
  ⟦ derive1 t ⟧Δ ρ (valid1 t) ≡ ⟦ derive t ⟧Δ ρ (unrestricted t)

correct1 {t = nat n} = refl
correct1 {t = bag b} = refl
correct1 {t = var x} = refl
correct1 {t = abs t} = refl
correct1 {t = app s t} = refl
correct1 {t = add s t} = refl
correct1 {t = map s t} {ρ} with closed? s
... | inj₂ tt = refl
... | inj₁ if-closed = eq-map s t ρ (immune {t = s} if-closed)

-- derive2 = derive1 + congruence
derive2 : ∀ {τ Γ} → Term Γ τ → ΔTerm Γ τ
derive2 (abs t) = Δabs (derive2 t)
derive2 (app s t) = Δapp (derive2 s) t (derive2 t)
derive2 (add s t) = Δadd (derive2 s) (derive2 t)
derive2 (map s t) with closed? s
... | inj₁ is-closed = Δmap₁ s (derive2 t)
... | inj₂ tt = Δmap₀ s (derive2 s) t (derive2 t)
derive2 others = derive others

valid2 : ∀ {τ Γ} (t : Term Γ τ) {ρ : ΔEnv Γ} → derive2 t is-valid-for ρ
correct2 : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv Γ} →
  ⟦ derive2 t ⟧Δ ρ (valid2 t) ≡ ⟦ derive t ⟧Δ ρ (unrestricted t)

valid2 (nat n) = tt
valid2 (bag b) = tt
valid2 (var x) = tt
valid2 (abs t) = λ _ _ _ → valid2 t
valid2 (app s t) {ρ} = cons (valid2 s) (valid2 t) V tt
  where
  V : valid (⟦ t ⟧ (ignore ρ)) (⟦ derive2 t ⟧Δ ρ (valid2 t))
  V rewrite correct2 {t = t} {ρ} = validity {t = t} {ρ}
valid2 (add s t) = cons (valid2 s) (valid2 t) tt tt
valid2 (map s t) {ρ} with closed? s
... | inj₂ tt = cons (valid2 s) (valid2 t) tt tt
... | inj₁ if-closed =
  cons (valid2 t) (immune {t = s} if-closed) tt tt

correct2 {t = nat n} = refl
correct2 {t = bag b} = refl
correct2 {t = var x} = refl
correct2 {t = abs t} = ext³ (λ _ _ _ → correct2 {t = t})
correct2 {t = app {σ} {τ} s t} {ρ} = ≅-to-≡ eq-all where
  open import Relation.Binary.HeterogeneousEquality hiding (cong₂)
  import Relation.Binary.HeterogeneousEquality as HET
  df0 : ΔVal (σ ⇒ τ)
  df0 = ⟦ derive s ⟧Δ ρ (unrestricted s)
  df2 : ΔVal (σ ⇒ τ)
  df2 = ⟦ derive2 s ⟧Δ ρ (valid2 s)
  dv0 : ΔVal σ
  dv0 = ⟦ derive t ⟧Δ ρ (unrestricted t)
  dv2 : ΔVal σ
  dv2 = ⟦ derive2 t ⟧Δ ρ (valid2 t)
  v   : ⟦ σ ⟧
  v   = ⟦ t ⟧ (ignore ρ)
  eq-df : df2 ≡ df0
  eq-df = correct2 {t = s}
  eq-dv : dv2 ≡ dv0
  eq-dv = correct2 {t = t}
  eq-all : df2 v dv2 (caddr (valid2 (app s t) {ρ}))
         ≅ df0 v dv0 (validity {t = t} {ρ})
  eq-all rewrite eq-dv = HET.cong
    (λ hole → hole v dv0 (validity {t = t} {ρ})) (≡-to-≅ eq-df)
    -- found without intuition by trial-and-error
correct2 {t = add s t} {ρ} =
  let
    cs = correct2 {t = s} {ρ}
    ct = correct2 {t = t} {ρ}
  in cong₂ _,_ (cong₂ _+_ (cong proj₁ cs) (cong proj₁ ct))
               (cong₂ _+_ (cong proj₂ cs) (cong proj₂ ct))
correct2 {t = map s t} {ρ} with closed? s
... | inj₂ tt =
  let
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
  in
    cong₂ (λ h1 h2 → mapBag (f ⊕ h1) (b ⊕ h2) \\ mapBag f b)
    (correct2 {t = s}) (correct2 {t = t})
... | inj₁ if-closed = trans
  (cong (mapBag (⟦ s ⟧ (ignore ρ))) (correct2 {t = t}))
  (eq-map s t ρ (immune {t = s} if-closed))

---------------
-- Example 3 --
---------------

-- [+1] = λ x → x + 1
[+1] : ∀ {Γ} → Term Γ (nats ⇒ nats)
[+1] = (abs (add (var this) (nat 1)))

-- inc = λ bag → map [+1] bag
inc : Term ∅ (bags ⇒ bags)
inc = abs (map [+1] (var this))

-- Program transformation in example 3
-- Sadly, `inc` is not executable, for `Bag` is an abstract type
-- whose existence we postulated.
--
-- derive2 inc = λ bag dbag → map [+1] dbag
example-3 : derive2 inc ≡ Δabs (Δmap₁ [+1] (Δvar this))
example-3 = refl

-- Correctness of optimized derivation on `inc`
--
-- ⟦ derive2 inc ⟧ <embedded-proof> = ⟦ derive inc ⟧ <another-proof>
example-3-correct :
  ⟦ derive2 inc ⟧Δ ∅ (valid2 inc) ≡ ⟦ derive inc ⟧Δ ∅ (unrestricted inc)
example-3-correct = correct2 {t = inc} {∅}