cleanup of ChurchRosser.agda

cleanup of ChurchRosser.agda

module ChurchRosser where
open import Data.Empty
open import Data.Product
open import Data.List
open import Data.List.Any as Any
open Any.Membership-≡
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality using (_≡_)

open import Core
open import Core-Lemmas
open import Reduction
open import Typing

data _* (R : PTerm ↝ PTerm) : PTerm ↝ PTerm where
  base : ∀ {a b} -> R a b -> (R *) a b
  refl : ∀ {a} -> (R *) a a
  trans : ∀ {a b c} -> (R *) a b -> (R *) b c -> (R *) a c

->β*-⊢ : ∀ {Γ m m' τ} -> Γ ⊢ m ∶ τ -> (_->β_ *) m m' -> Γ ⊢ m' ∶ τ
->β*-⊢ Γ⊢m∶τ (base m->βm') = ->β-⊢ Γ⊢m∶τ m->βm'
->β*-⊢ Γ⊢m∶τ refl = Γ⊢m∶τ
->β*-⊢ Γ⊢m∶τ (trans m->β*m' m->β*m'') = ->β*-⊢ (->β*-⊢ Γ⊢m∶τ m->β*m') m->β*m''

DP : (R : PTerm ↝ PTerm)(T : PTerm ↝ PTerm) -> Set
DP R T = ∀ {a b c} -> R a b -> T a c -> ∃ (λ d → (T b d) × (R c d))

DP->||->||-imp-DP->||->||* : DP (_->||_) (_->||_) -> DP (_->||_) (_->||_ *)
DP->||->||-imp-DP->||->||* DP->||->|| {b = b} a->||b (base a->||c) = d , (base b->||d , c->||d)
  where
  d = proj₁ (DP->||->|| a->||b a->||c)
  b->||d = proj₁ (proj₂ (DP->||->|| a->||b a->||c))
  c->||d = proj₂ (proj₂ (DP->||->|| a->||b a->||c))

DP->||->||-imp-DP->||->||* DP->||->|| {b = b} a->||b refl = b , (refl , a->||b)
DP->||->||-imp-DP->||->||* DP->||->|| {a} {b} {c} a->||b (trans {b = g} a->||*g g->||*c) =
  d , ((trans b->||*g' g'->||*d) , c->||d)
  where
  left-IH : ∃ (λ g' → (_->||_ *) b g' × (g ->|| g'))
  left-IH = DP->||->||-imp-DP->||->||* DP->||->|| a->||b a->||*g

  g' = proj₁ left-IH
  b->||*g' = proj₁ (proj₂ left-IH)
  g->||g' = proj₂ (proj₂ left-IH)

  right-IH : ∃ (λ d → (_->||_ *) g' d × (c ->|| d))
  right-IH = DP->||->||-imp-DP->||->||* DP->||->|| g->||g' g->||*c

  d = proj₁ right-IH
  g'->||*d = proj₁ (proj₂ right-IH)
  c->||d = proj₂ (proj₂ right-IH)

DP->||->||-imp-DP->||*->||* : DP (_->||_) (_->||_) -> DP (_->||_ *) (_->||_ *)
DP->||->||-imp-DP->||*->||* DP->||->|| (base a->||b) a->||*c = d , (b->||*d , base c->||d)
  where
  d = proj₁ (DP->||->||-imp-DP->||->||* DP->||->|| a->||b a->||*c)
  b->||*d = proj₁ (proj₂ (DP->||->||-imp-DP->||->||* DP->||->|| a->||b a->||*c))
  c->||d = proj₂ (proj₂ (DP->||->||-imp-DP->||->||* DP->||->|| a->||b a->||*c))

DP->||->||-imp-DP->||*->||* DP->||->|| refl a->||*c = _ , (a->||*c , refl)
DP->||->||-imp-DP->||*->||* DP->||->|| {a} {b} {c} (trans {b = g} a->||*g g->||*b) a->||*c =
  d , b->||*d , (trans c->||*g' g'->||*d)
  where
  left-IH : ∃ (λ g' → (_->||_ *) g g' × (_->||_ *) c g')
  left-IH = DP->||->||-imp-DP->||*->||* DP->||->|| a->||*g a->||*c

  g' = proj₁ left-IH
  c->||*g' = proj₂ (proj₂ left-IH)
  g->||*g' = proj₁ (proj₂ left-IH)

  right-IH : ∃ (λ d → (_->||_ *) b d × (_->||_ *) g' d)
  right-IH = DP->||->||-imp-DP->||*->||* DP->||->|| g->||*b g->||*g'

  d = proj₁ right-IH
  g'->||*d = proj₂ (proj₂ right-IH)
  b->||*d = proj₁ (proj₂ right-IH)

->||-refl : ∀ {s} -> Term s -> s ->|| s
->||-refl var = refl
->||-refl (lam L cf) = abs L (λ {x} z → ->||-refl (cf z))
->||-refl (app trm-s trm-s₁) = app (->||-refl trm-s) (->||-refl trm-s₁)
->||-refl Y = reflY

->β-imp->|| : ∀ {m m'} -> m ->β m' -> m ->|| m'
->β-imp->|| (redL trm-n m->βm') = app (->β-imp->|| m->βm') (->||-refl trm-n)
->β-imp->|| (redR trm-m n->βn') = app (->||-refl trm-m) (->β-imp->|| n->βn')
->β-imp->|| (abs L x) = abs L (λ {x₁} z → ->β-imp->|| (x z))
->β-imp->|| (beta {m} (lam L cf) trm-n) =
  beta L {m' = m} (λ {x} x∉L → ->||-refl (cf x∉L)) (->||-refl trm-n)
->β-imp->|| (Y trm-m) = Y (->||-refl trm-m)

->β*-imp->||* : ∀ {m m'} -> (_->β_ *) m m' -> (_->||_ *) m m'
->β*-imp->||* (base m->βm') = base (->β-imp->|| m->βm')
->β*-imp->||* refl = refl
->β*-imp->||* (trans m->β*m' m->β*m'') =
  trans (->β*-imp->||* m->β*m') (->β*-imp->||* m->β*m'')

redL* : ∀ {m m' n} -> (_->β_ *) m m' -> Term n -> (_->β_ *) (app m n) (app m' n)
redL* (base x) trm-n = base (redL trm-n x)
redL* refl trm-n = refl
redL* (trans m->β*o o->β*m') trm-n = trans (redL* m->β*o trm-n) (redL* o->β*m' trm-n)

redR* : ∀ {m n n'} -> (_->β_ *) n n' -> Term m -> (_->β_ *) (app m n) (app m n')
redR* (base x) trm-m = base (redR trm-m x)
redR* refl trm-m = refl
redR* (trans n->β*o o->β*n) trm-m = trans (redR* n->β*o trm-m) (redR* o->β*n trm-m)

abs' : ∀ {m m' x} -> m ->β m' -> (lam (* x ^ m)) ->β (lam (* x ^ m'))
abs' {m} {m'} {x} m->βm' = abs [] body
  where
  body : ∀ {y} -> y ∉ [] -> ((* x ^ m) ^' y) ->β ((* x ^ m') ^' y)
  body {y} y∉ rewrite
    *^-^≡subst m x y {0} (->β-Term-l m->βm') |
    *^-^≡subst m' x y {0} (->β-Term-r m->βm') = lem2-5-1->β m m' x y m->βm'

abs*' : ∀ {m m' x} -> (_->β_ *) m m' -> (_->β_ *) (lam (* x ^ m)) (lam (* x ^ m'))
abs*' (base m->βm') = base (abs' m->βm')
abs*' refl = refl
abs*' (trans m->β*m' m->β*m'') = trans (abs*' m->β*m') (abs*' m->β*m'')

abs* : ∀ {m m'} L -> (cf : ∀ {x} -> x ∉ L -> (_->β_ *) (m ^' x) (m' ^' x)) -> (_->β_ *) (lam m) (lam m')
abs* {m} {m'} L cf = body
  where
  x = ∃fresh (L ++ FV m ++ FV m')

  x∉ : x ∉ (L ++ FV m ++ FV m')
  x∉ = ∃fresh-spec (L ++ FV m ++ FV m')

  subst : ∀ m -> x ∉ FV m -> _≡_ {_} {PTerm} (lam m) (lam (* x ^ (m ^' x)))
  subst m x∉m rewrite
    fv-^-*^-refl x m {0} x∉m = _≡_.refl

  body : (_->β_ *) (lam m) (lam m')
  body rewrite
    subst m (∉-cons-l _ _ (∉-cons-r L _ x∉)) |
    subst m' (∉-cons-r (FV m) _ (∉-cons-r L _ x∉)) = abs*' (cf (∉-cons-l _ _ x∉))

->||-imp->β* : ∀ {m m'} -> m ->|| m' -> (_->β_ *) m m'
->||-imp->β* refl = refl
->||-imp->β* reflY = refl
->||-imp->β* (app {m} {m'} {n} {n'} m->||m' n->||n') =
  trans {b = (app m n')}
    (redR* (->||-imp->β* n->||n') (->||-Term-l m->||m'))
    (redL* (->||-imp->β* m->||m') (->||-Term-r n->||n'))
->||-imp->β* (abs L cf) = abs* L (λ x∉ → ->||-imp->β* (cf x∉))
->||-imp->β* (beta L {m} {m'} {n} {n'} cf n->||n') =
  trans {b = app (lam m') n}
    (redL* (abs* L (λ {x} z → ->||-imp->β* (cf z))) (->||-Term-l n->||n'))
    (trans {b = app (lam m') n'}
      (redR* (->||-imp->β* n->||n') (lam L (λ x∉L → ->||-Term-r (cf x∉L))))
      (base (beta (lam L (λ x∉L → ->||-Term-r (cf x∉L))) (->||-Term-r n->||n'))))
->||-imp->β* (Y {m} {m'} {τ} m->||m') =
  trans {b = app m (app (Y τ) m)}
    (base (Y (->||-Term-l m->||m')))
    (trans {b = app m' (app (Y τ) m)}
      (redL* (->||-imp->β* m->||m') (app Y (->||-Term-l m->||m')))
      (redR* (redR* (->||-imp->β* m->||m') Y) (->||-Term-r m->||m')))

->||*-imp->β* : ∀ {m m'} -> (_->||_ *) m m' -> (_->β_ *) m m'
->||*-imp->β* (base m->||m') = ->||-imp->β* m->||m'
->||*-imp->β* refl = refl
->||*-imp->β* (trans m->||*m' n->||*n') = trans (->||*-imp->β* m->||*m') (->||*-imp->β* n->||*n')

church-rosser-⊢ : ∀ {Γ τ a b c} -> Γ ⊢ a ∶ τ -> (_->β_ *) a b -> (_->β_ *) a c ->
  ∃(λ d -> ((_->β_ *) b d × (_->β_ *) c d) × Γ ⊢ d ∶ τ)
church-rosser-⊢ {Γ} {τ} {a} {b} {c} Γ⊢a∶τ a->β*b a->β*c =
  d , (b->β*d , c->β*d) , ->β*-⊢ Γ⊢a∶τ a->β*d
  where
  a->||*b = ->β*-imp->||* a->β*b
  a->||*c = ->β*-imp->||* a->β*c

  d-spec : ∃ (λ d → ((_->||_ *) b d) × ((_->||_ *) c d))
  d-spec = DP->||->||-imp-DP->||*->||* lem2-5-2 a->||*b a->||*c

  d = proj₁ d-spec
  b->β*d = ->||*-imp->β* (proj₁ (proj₂ d-spec))
  c->β*d = ->||*-imp->β* (proj₂ (proj₂ d-spec))
  a->β*d = trans a->β*b b->β*d

module ChurchRosser where
open import Data.Empty
open import Data.Product
open import Data.List
open import Data.List.Any as Any
open Any.Membership-≡
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality using (_≡_)

open import Core
open import Core-Lemmas
open import Reduction
open import Typing

data _* (R : PTerm ↝ PTerm) : PTerm ↝ PTerm where
  base : ∀ {a b} -> R a b -> (R *) a b
  refl : ∀ {a} -> (R *) a a
  trans : ∀ {a b c} -> (R *) a b -> (R *) b c -> (R *) a c

->β*-⊢ : ∀ {Γ m m' τ} -> Γ ⊢ m ∶ τ -> (_->β_ *) m m' -> Γ ⊢ m' ∶ τ
->β*-⊢ Γ⊢m∶τ (base m->βm') = ->β-⊢ Γ⊢m∶τ m->βm'
->β*-⊢ Γ⊢m∶τ refl = Γ⊢m∶τ
->β*-⊢ Γ⊢m∶τ (trans m->β*m' m->β*m'') = ->β*-⊢ (->β*-⊢ Γ⊢m∶τ m->β*m') m->β*m''

DP : (R : PTerm ↝ PTerm)(T : PTerm ↝ PTerm) -> Set
DP R T = ∀ {a b c} -> R a b -> T a c -> ∃ (λ d → (T b d) × (R c d))

DP->||->||-imp-DP->||->||* : DP (_->||_) (_->||_) -> DP (_->||_) (_->||_ *)
DP->||->||-imp-DP->||->||* DP->||->|| {b = b} a->||b (base a->||c) = d , (base b->||d , c->||d)
  where
  d = proj₁ (DP->||->|| a->||b a->||c)
  b->||d = proj₁ (proj₂ (DP->||->|| a->||b a->||c))
  c->||d = proj₂ (proj₂ (DP->||->|| a->||b a->||c))

DP->||->||-imp-DP->||->||* DP->||->|| {b = b} a->||b refl = b , (refl , a->||b)
DP->||->||-imp-DP->||->||* DP->||->|| {a} {b} {c} a->||b (trans {b = g} a->||*g g->||*c) =
  d , ((trans b->||*g' g'->||*d) , c->||d)
  where
  left-IH : ∃ (λ g' → (_->||_ *) b g' × (g ->|| g'))
  left-IH = DP->||->||-imp-DP->||->||* DP->||->|| a->||b a->||*g

  g' = proj₁ left-IH
  b->||*g' = proj₁ (proj₂ left-IH)
  g->||g' = proj₂ (proj₂ left-IH)

  right-IH : ∃ (λ d → (_->||_ *) g' d × (c ->|| d))
  right-IH = DP->||->||-imp-DP->||->||* DP->||->|| g->||g' g->||*c

  d = proj₁ right-IH
  g'->||*d = proj₁ (proj₂ right-IH)
  c->||d = proj₂ (proj₂ right-IH)

DP->||->||-imp-DP->||*->||* : DP (_->||_) (_->||_) -> DP (_->||_ *) (_->||_ *)
DP->||->||-imp-DP->||*->||* DP->||->|| (base a->||b) a->||*c = d , (b->||*d , base c->||d)
  where
  d = proj₁ (DP->||->||-imp-DP->||->||* DP->||->|| a->||b a->||*c)
  b->||*d = proj₁ (proj₂ (DP->||->||-imp-DP->||->||* DP->||->|| a->||b a->||*c))
  c->||d = proj₂ (proj₂ (DP->||->||-imp-DP->||->||* DP->||->|| a->||b a->||*c))

DP->||->||-imp-DP->||*->||* DP->||->|| refl a->||*c = _ , (a->||*c , refl)
DP->||->||-imp-DP->||*->||* DP->||->|| {a} {b} {c} (trans {b = g} a->||*g g->||*b) a->||*c =
  d , b->||*d , (trans c->||*g' g'->||*d)
  where
  left-IH : ∃ (λ g' → (_->||_ *) g g' × (_->||_ *) c g')
  left-IH = DP->||->||-imp-DP->||*->||* DP->||->|| a->||*g a->||*c

  g' = proj₁ left-IH
  c->||*g' = proj₂ (proj₂ left-IH)
  g->||*g' = proj₁ (proj₂ left-IH)

  right-IH : ∃ (λ d → (_->||_ *) b d × (_->||_ *) g' d)
  right-IH = DP->||->||-imp-DP->||*->||* DP->||->|| g->||*b g->||*g'

  d = proj₁ right-IH
  g'->||*d = proj₂ (proj₂ right-IH)
  b->||*d = proj₁ (proj₂ right-IH)

->||-refl : ∀ {s} -> Term s -> s ->|| s
->||-refl var = refl
->||-refl (lam L cf) = abs L (λ {x} z → ->||-refl (cf z))
->||-refl (app trm-s trm-s₁) = app (->||-refl trm-s) (->||-refl trm-s₁)
->||-refl Y = reflY

->β-imp->|| : ∀ {m m'} -> m ->β m' -> m ->|| m'
->β-imp->|| (redL trm-n m->βm') = app (->β-imp->|| m->βm') (->||-refl trm-n)
->β-imp->|| (redR trm-m n->βn') = app (->||-refl trm-m) (->β-imp->|| n->βn')
->β-imp->|| (abs L x) = abs L (λ {x₁} z → ->β-imp->|| (x z))
->β-imp->|| (beta {m} (lam L cf) trm-n) =
  beta L {m' = m} (λ {x} x∉L → ->||-refl (cf x∉L)) (->||-refl trm-n)
->β-imp->|| (Y trm-m) = Y (->||-refl trm-m)

->β*-imp->||* : ∀ {m m'} -> (_->β_ *) m m' -> (_->||_ *) m m'
->β*-imp->||* (base m->βm') = base (->β-imp->|| m->βm')
->β*-imp->||* refl = refl
->β*-imp->||* (trans m->β*m' m->β*m'') =
  trans (->β*-imp->||* m->β*m') (->β*-imp->||* m->β*m'')

redL* : ∀ {m m' n} -> (_->β_ *) m m' -> Term n -> (_->β_ *) (app m n) (app m' n)
redL* (base x) trm-n = base (redL trm-n x)
redL* refl trm-n = refl
redL* (trans m->β*o o->β*m') trm-n = trans (redL* m->β*o trm-n) (redL* o->β*m' trm-n)

redR* : ∀ {m n n'} -> (_->β_ *) n n' -> Term m -> (_->β_ *) (app m n) (app m n')
redR* (base x) trm-m = base (redR trm-m x)
redR* refl trm-m = refl
redR* (trans n->β*o o->β*n) trm-m = trans (redR* n->β*o trm-m) (redR* o->β*n trm-m)

abs' : ∀ {m m' x} -> m ->β m' -> (lam (* x ^ m)) ->β (lam (* x ^ m'))
abs' {m} {m'} {x} m->βm' = abs [] body
  where
  body : ∀ {y} -> y ∉ [] -> ((* x ^ m) ^' y) ->β ((* x ^ m') ^' y)
  body {y} y∉ rewrite
    *^-^≡subst m x y {0} (->β-Term-l m->βm') |
    *^-^≡subst m' x y {0} (->β-Term-r m->βm') = lem2-5-1->β m m' x y m->βm'

abs*' : ∀ {m m' x} -> (_->β_ *) m m' -> (_->β_ *) (lam (* x ^ m)) (lam (* x ^ m'))
abs*' (base m->βm') = base (abs' m->βm')
abs*' refl = refl
abs*' (trans m->β*m' m->β*m'') = trans (abs*' m->β*m') (abs*' m->β*m'')

abs* : ∀ {m m'} L -> (cf : ∀ {x} -> x ∉ L -> (_->β_ *) (m ^' x) (m' ^' x)) -> (_->β_ *) (lam m) (lam m')
abs* {m} {m'} L cf = body
  where
  x = ∃fresh (L ++ FV m ++ FV m')

  x∉ : x ∉ (L ++ FV m ++ FV m')
  x∉ = ∃fresh-spec (L ++ FV m ++ FV m')

  subst : ∀ m -> x ∉ FV m -> _≡_ {_} {PTerm} (lam m) (lam (* x ^ (m ^' x)))
  subst m x∉m rewrite
    fv-^-*^-refl x m {0} x∉m = _≡_.refl

  body : (_->β_ *) (lam m) (lam m')
  body rewrite
    subst m (∉-cons-l _ _ (∉-cons-r L _ x∉)) |
    subst m' (∉-cons-r (FV m) _ (∉-cons-r L _ x∉)) = abs*' (cf (∉-cons-l _ _ x∉))

->||-imp->β* : ∀ {m m'} -> m ->|| m' -> (_->β_ *) m m'
->||-imp->β* refl = refl
->||-imp->β* reflY = refl
->||-imp->β* (app {m} {m'} {n} {n'} m->||m' n->||n') =
  trans {b = (app m n')}
    (redR* (->||-imp->β* n->||n') (->||-Term-l m->||m'))
    (redL* (->||-imp->β* m->||m') (->||-Term-r n->||n'))
->||-imp->β* (abs L cf) = abs* L (λ x∉ → ->||-imp->β* (cf x∉))
->||-imp->β* (beta L {m} {m'} {n} {n'} cf n->||n') =
  trans {b = app (lam m') n}
    (redL* (abs* L (λ {x} z → ->||-imp->β* (cf z))) (->||-Term-l n->||n'))
    (trans {b = app (lam m') n'}
      (redR* (->||-imp->β* n->||n') (lam L (λ x∉L → ->||-Term-r (cf x∉L))))
      (base (beta (lam L (λ x∉L → ->||-Term-r (cf x∉L))) (->||-Term-r n->||n'))))
->||-imp->β* (Y {m} {m'} {τ} m->||m') =
  trans {b = app m (app (Y τ) m)}
    (base (Y (->||-Term-l m->||m')))
    (trans {b = app m' (app (Y τ) m)}
      (redL* (->||-imp->β* m->||m') (app Y (->||-Term-l m->||m')))
      (redR* (redR* (->||-imp->β* m->||m') Y) (->||-Term-r m->||m')))

->||*-imp->β* : ∀ {m m'} -> (_->||_ *) m m' -> (_->β_ *) m m'
->||*-imp->β* (base m->||m') = ->||-imp->β* m->||m'
->||*-imp->β* refl = refl
->||*-imp->β* (trans m->||*m' n->||*n') = trans (->||*-imp->β* m->||*m') (->||*-imp->β* n->||*n')

church-rosser-⊢ : ∀ {Γ τ a b c} -> Γ ⊢ a ∶ τ -> (_->β_ *) a b -> (_->β_ *) a c ->
  ∃(λ d -> ((_->β_ *) b d × (_->β_ *) c d) × Γ ⊢ d ∶ τ)
church-rosser-⊢ {Γ} {τ} {a} {b} {c} Γ⊢a∶τ a->β*b a->β*c =
  d , (b->β*d , c->β*d) , ->β*-⊢ Γ⊢a∶τ a->β*d
  where
  a->||*b = ->β*-imp->||* a->β*b
  a->||*c = ->β*-imp->||* a->β*c

  d-spec : ∃ (λ d → ((_->||_ *) b d) × ((_->||_ *) c d))
  d-spec = DP->||->||-imp-DP->||*->||* lem2-5-2 a->||*b a->||*c

  d = proj₁ d-spec
  b->||*d = proj₁ (proj₂ d-spec)
  c->||*d = proj₂ (proj₂ d-spec)
  a->||*d = trans a->||*b b->||*d
  a->β*d = ->||*-imp->β* a->||*d
  b->β*d = ->||*-imp->β* b->||*d
  c->β*d = ->||*-imp->β* c->||*d


Final sugared generic eliminator for Desc/Mu in Agda model.

This combines the case eliminator for tags with the
projecting + substituting eliminator for Mu.

The result is specialized to tagged descriptions, which result from
elaborating datatype declarations.

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.PropositionalDesc where

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

elimEq : (A : Set) (x : A) (P : (y : A) → x ≡ y → Set)
  → P x refl
  → (y : A) (p : x ≡ y) → P y p
elimEq A .x P prefl x refl = prefl

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Cases : (E : Enum) (P : Tag E → Set) → Set
Cases [] P = ⊤
Cases (l ∷ E) P = P here × Cases E λ t → P (there t)

case : (E : Enum) (P : Tag E → Set) (cs : Cases E P) (t : Tag E) → P t
case (l ∷ E) P (c , cs) here = c
case (l ∷ E) P (c , cs) (there t) = case E (λ t → P (there t)) cs t

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

data Desc (I : Set) : Set₁ where
  `End : (i : I) → Desc I
  `Rec : (i : I) (D : Desc I) → Desc I
  `Arg : (A : Set) (B : A → Desc I) → Desc I
  `RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : (I : Set) (D : Desc I) (X : ISet I) → ISet I
El I (`End j) X i = j ≡ i
El I (`Rec j D) X i = X j × El I D X i
El I (`Arg A B) X i = Σ A (λ a → El I (B a) X i)
El I (`RecFun A B D) X i = ((a : A) → X (B a)) × El I D X i

data μ (I : Set) (D : Desc I) (i : I) : Set where
  con : El I D (μ I D) i → μ I D i

All : (I : Set) (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El I D X i) → Set
All I (`End j) X P i q = ⊤
All I (`Rec j D) X P i (x , xs) = P j x × All I D X P i xs
All I (`Arg A B) X P i (a , b) = All I (B a) X P i b
All I (`RecFun A B D) X P i (f , xs) = ((a : A) → P (B a) (f a)) × All I D X P i xs

caseD : (E : Enum) (I : Set) (cs : Cases E (λ _ → Desc I)) (t : Tag E) → Desc I
caseD E I cs t = case E (λ _ → Desc I) cs t

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

UncurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
UncurriedEl I D X = {i : I} → El I D X i → X i

CurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
CurriedEl I (`End i) X = X i
CurriedEl I (`Rec j D) X = (x : X j) → CurriedEl I D X
CurriedEl I (`Arg A B) X = (a : A) → CurriedEl I (B a) X
CurriedEl I (`RecFun A B D) X = ((a : A) → X (B a)) → CurriedEl I D X

curryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : UncurriedEl I D X) → CurriedEl I D X
curryEl I (`End i) X cn = cn refl
curryEl I (`Rec i D) X cn = λ x → curryEl I D X (λ xs → cn (x , xs))
curryEl I (`Arg A B) X cn = λ a → curryEl I (B a) X (λ xs → cn (a , xs))
curryEl I (`RecFun A B D) X cn = λ f → curryEl I D X (λ xs → cn (f , xs))

uncurryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : CurriedEl I D X) → UncurriedEl I D X
uncurryEl I (`End i) X cn refl = cn
uncurryEl I (`Rec i D) X cn (x , xs) = uncurryEl I D X (cn x) xs
uncurryEl I (`Arg A B) X cn (a , xs) = uncurryEl I (B a) X (cn a) xs
uncurryEl I (`RecFun A B D) X cn (f , xs) = uncurryEl I D X (cn f) xs

con2 : (I : Set) (D : Desc I) → CurriedEl I D (μ I D)
con2 I D = curryEl I D (μ I D) con

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

UncurriedAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : {i : I} → El I D X i → X i)
  → Set
UncurriedAll I D X P cn =
  (i : I) (xs : El I D X i) → All I D X P i xs → P i (cn xs)

CurriedAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  → Set
CurriedAll I (`End i) X P cn =
  P i (cn refl)
CurriedAll I (`Rec i D) X P cn =
  (x : X i) → P i x → CurriedAll I D X P (λ xs → cn (x , xs))
CurriedAll I (`Arg A B) X P cn =
  (a : A) → CurriedAll I (B a) X P (λ xs → cn (a , xs))
CurriedAll I (`RecFun A B D) X P cn =
  (f : (a : A) → X (B a)) (ihf : (a : A) → P (B a) (f a)) → CurriedAll I D X P (λ xs → cn (f , xs))

curryAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : UncurriedAll I D X P cn)
  → CurriedAll I D X P cn
curryAll I (`End i) X P cn pf =
  pf i refl tt
curryAll I (`Rec i D) X P cn pf =
  λ x ih → curryAll I D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryAll I (`Arg A B) X P cn pf =
  λ a → curryAll I (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)
curryAll I (`RecFun A B D) X P cn pf =
  λ f ihf → curryAll I D X P (λ xs → cn (f , xs)) (λ i xs ihs → pf i (f , xs) (ihf , ihs))

uncurryAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : CurriedAll I D X P cn)
  → UncurriedAll I D X P cn
uncurryAll I (`End .i) X P cn pf i refl tt =
  pf
uncurryAll I (`Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryAll I D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryAll I (`Arg A B) X P cn pf i (a , xs) ihs =
  uncurryAll I (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs
uncurryAll I (`RecFun A B D) X P cn pf i (f , xs) (ihf , ihs) =
  uncurryAll I D X P (λ ys → cn (f , ys)) (pf f ihf) i xs ihs

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

ind :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : UncurriedAll I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x

hyps :
  (I : Set)
  (D₁ : Desc I)
  (P : (i : I) → μ I D₁ i → Set)
  (pcon : UncurriedAll I D₁ (μ I D₁) P con)
  (D₂ : Desc I)
  (i : I)
  (xs : El I D₂ (μ I D₁) i)
  → All I D₂ (μ I D₁) P i xs

ind I D P pcon i (con xs) = pcon i xs (hyps I D P pcon D i xs)

hyps I D P pcon (`End j) i q = tt
hyps I D P pcon (`Rec j A) i (x , xs) = ind I D P pcon j x , hyps I D P pcon A i xs
hyps I D P pcon (`Arg A B) i (a , b) = hyps I D P pcon (B a) i b
hyps I D P pcon (`RecFun A B E) i (f , xs) = (λ a → ind I D P pcon (B a) (f a)) , hyps I D P pcon E i xs

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

ind2 :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : CurriedAll I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x
ind2 I D P pcon i x = ind I D P (uncurryAll I D (μ I D) P con pcon) i x

elim :
  (I : Set)
  (E : Enum)
  (Cs : Tag E → Desc I)
  → let D = `Arg (Tag E) Cs in
  (P : (i : I) → μ I D i → Set)
  (cs : Cases E (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs))))
  (i : I)
  (x : μ I D i)
  → P i x
elim I E Cs P cs i x =
  let D = `Arg (Tag E) Cs in
  ind2 I D P (case E (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs))) cs) i x

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

module Sugared where

  data ℕT : Set where `zero `suc : ℕT
  data VecT : Set where `nil `cons : VecT

  ℕD : Desc ⊤
  ℕD = `Arg ℕT λ
    { `zero → `End tt
    ; `suc → `Rec tt (`End tt)
    }

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (`zero , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (`suc , n , refl)

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg VecT λ
    { `nil  → `End zero
    ; `cons → `Arg (ℕ tt) λ n → `Arg A λ _ → `Rec n (`End (suc n))
    }

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (`nil , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (`cons , n , x , xs , refl)

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

  add : ℕ tt → ℕ tt → ℕ tt
  add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → n
      ; tt (`suc , m , q) (ih , tt) n → suc (ih n)
      }
    )
    tt

  mult : ℕ tt → ℕ tt → ℕ tt
  mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → zero
      ; tt (`suc , m , q) (ih , tt) n → add n (ih n)
      }
    )
    tt

  append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
  append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
    (λ
      { .(con (`zero , refl)) (`nil , refl) ih n ys → ys
      ; .(con (`suc , m , refl)) (`cons , m , x , xs , refl) (ih , tt) n ys → cons A (add m n) x (ih n ys)
      }
    )

  concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
    (λ
      { .(con (`zero , refl)) (`nil , refl) tt → nil A
      ; .(con (`suc , n , refl)) (`cons , n , xs , xss , refl) (ih , tt) → append A m xs (mult n m) ih
      }
    )

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

module Desugared where

  ℕT : Enum
  ℕT = "zero" ∷ "suc" ∷ []

  VecT : Enum
  VecT = "nil" ∷ "cons" ∷ []

  ℕC : Tag ℕT → Desc ⊤
  ℕC = caseD ℕT ⊤
    ( `End tt
    , `Rec tt (`End tt)
    , tt
    )

  ℕD : Desc ⊤
  ℕD = `Arg (Tag ℕT) ℕC

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (here , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (there here , n , refl)

  zero2 : ℕ tt
  zero2 = con2 ⊤ ℕD here

  suc2 : ℕ tt → ℕ tt
  suc2 = con2 ⊤ ℕD (there here)

  VecC : (A : Set) → Tag VecT → Desc (ℕ tt)
  VecC A = caseD VecT (ℕ tt)
    ( `End zero
    , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
    , tt
    )

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg (Tag VecT) (VecC A)

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (here , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (there here , n , x , xs , refl)

  nil2 : (A : Set) → Vec A zero
  nil2 A = con2 (ℕ tt) (VecD A) here

  cons2 : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons2 A = con2 (ℕ tt) (VecD A) (there here)

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

  module Induction where

    add : ℕ tt → ℕ tt → ℕ tt
    add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → n)
        , (λ m,q ih,tt n → suc (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → zero)
        , (λ m,q ih,tt n → add n (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ m t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) m)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) m (t , c))
               (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
        )
        ( (λ q ih n ys → subst (λ m → Vec A (add m n)) q ys)
        , (λ m',x,xs,q ih,tt n ys →
            let m' = proj₁ m',x,xs,q
                x = proj₁ (proj₂ m',x,xs,q)
                q = proj₂ (proj₂ (proj₂ m',x,xs,q))
                ih = proj₁ ih,tt
            in
            subst (λ m → Vec A (add m n)) q (cons A (add m' n) x (ih n ys))
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC (Vec A m) t) (Vec (Vec A m)) n)
               (ih : All (ℕ tt) (VecD (Vec A m)) (Vec (Vec A m)) (λ n xss → Vec A (mult n m)) n (t , c))
               → Vec A (mult n m)
        )
        ( (λ q ih → subst (λ n → Vec A (mult n m)) q (nil A))
        , (λ n',xs,xss,q ih,tt →
            let n' = proj₁ n',xs,xss,q
                xs = proj₁ (proj₂ n',xs,xss,q)
                q = proj₂ (proj₂ (proj₂ n',xs,xss,q))
                ih = proj₁ ih,tt
            in
            subst (λ n → Vec A (mult n m)) q (append A m xs (mult n' m) ih)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

  module Eliminator where

    elimℕ : (P : (ℕ tt) → Set)
      (pzero : P zero)
      (psuc : (m : ℕ tt) → P m → P (suc m))
      (n : ℕ tt)
      → P n
    elimℕ P pzero psuc = ind ⊤ ℕD (λ u n → P n)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → P n) u (t , c))
               → P (con (t , c))
        )
        ( (λ q ih →
            elimEq ⊤ tt (λ u q → P (con (here , q)))
              pzero
              u q
          )
        , (λ n,q ih,tt →
            elimEq ⊤ tt (λ u q → P (con (there here , proj₁ n,q , q)))
              (psuc (proj₁ n,q) (proj₁ ih,tt))
              u (proj₂ n,q)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    elimVec : (A : Set) (P : (n : ℕ tt) → Vec A n → Set)
      (pnil : P zero (nil A))
      (pcons : (n : ℕ tt) (a : A) (xs : Vec A n) → P n xs → P (suc n) (cons A n a xs))
      (n : ℕ tt)
      (xs : Vec A n)
      → P n xs
    elimVec A P pnil pcons = ind (ℕ tt) (VecD A) (λ n xs → P n xs)
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) n)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ n xs → P n xs) n (t , c))
               → P n (con (t , c))
        )
        ( (λ q ih →
            elimEq (ℕ tt) zero (λ n q → P n (con (here , q)))
              pnil
              n q
          )
        , (λ n',x,xs,q ih,tt →
            let n' = proj₁ n',x,xs,q
                x = proj₁ (proj₂ n',x,xs,q)
                xs = proj₁ (proj₂ (proj₂ n',x,xs,q))
                q = proj₂ (proj₂ (proj₂ n',x,xs,q))
                ih = proj₁ ih,tt
            in
            elimEq (ℕ tt) (suc n') (λ n q → P n (con (there here , n' , x , xs , q)))
              (pcons n' x xs ih )
              n q
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

    add : ℕ tt → ℕ tt → ℕ tt
    add = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → n)
      (λ m ih n → suc (ih n))

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → zero)
      (λ m ih n → add n (ih n))

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elimVec A (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elimVec (Vec A m) (λ n xss → Vec A (mult n m))
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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

  module GenericEliminator where

    add : ℕ tt → ℕ tt → ℕ tt
    add = elim ⊤ ℕT ℕC _
      ( (λ n → n)
      , (λ m ih n → suc (ih n))
      , tt
      )
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elim ⊤ ℕT ℕC _
      ( (λ n → zero)
      , (λ m ih n → add n (ih n))
      , tt
      )
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elim (ℕ tt) VecT (VecC A) _
      ( (λ n ys → ys)
      , (λ m x xs ih n ys → cons A (add m n) x (ih n ys))
      , tt
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elim (ℕ tt) VecT (VecC (Vec A m)) _
      ( (nil A)
      , (λ n xs xss ih → append A m xs (mult n m) ih)
      , tt
      )

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

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.PropositionalDesc where

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

elimEq : (A : Set) (x : A) (P : (y : A) → x ≡ y → Set)
  → P x refl
  → (y : A) (p : x ≡ y) → P y p
elimEq A .x P prefl x refl = prefl

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Cases : (E : Enum) (P : Tag E → Set) → Set
Cases [] P = ⊤
Cases (l ∷ E) P = P here × Cases E λ t → P (there t)

case : (E : Enum) (P : Tag E → Set) (cs : Cases E P) (t : Tag E) → P t
case (l ∷ E) P (c , cs) here = c
case (l ∷ E) P (c , cs) (there t) = case E (λ t → P (there t)) cs t

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

data Desc (I : Set) : Set₁ where
  `End : (i : I) → Desc I
  `Rec : (i : I) (D : Desc I) → Desc I
  `Arg : (A : Set) (B : A → Desc I) → Desc I
  `RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : (I : Set) (D : Desc I) (X : ISet I) → ISet I
El I (`End j) X i = j ≡ i
El I (`Rec j D) X i = X j × El I D X i
El I (`Arg A B) X i = Σ A (λ a → El I (B a) X i)
El I (`RecFun A B D) X i = ((a : A) → X (B a)) × El I D X i

data μ (I : Set) (D : Desc I) (i : I) : Set where
  con : El I D (μ I D) i → μ I D i

All : (I : Set) (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El I D X i) → Set
All I (`End j) X P i q = ⊤
All I (`Rec j D) X P i (x , xs) = P j x × All I D X P i xs
All I (`Arg A B) X P i (a , b) = All I (B a) X P i b
All I (`RecFun A B D) X P i (f , xs) = ((a : A) → P (B a) (f a)) × All I D X P i xs

caseD : (E : Enum) (I : Set) (cs : Cases E (λ _ → Desc I)) (t : Tag E) → Desc I
caseD E I cs t = case E (λ _ → Desc I) cs t

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

UncurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
UncurriedEl I D X = {i : I} → El I D X i → X i

CurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
CurriedEl I (`End i) X = X i
CurriedEl I (`Rec j D) X = (x : X j) → CurriedEl I D X
CurriedEl I (`Arg A B) X = (a : A) → CurriedEl I (B a) X
CurriedEl I (`RecFun A B D) X = ((a : A) → X (B a)) → CurriedEl I D X

curryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : UncurriedEl I D X) → CurriedEl I D X
curryEl I (`End i) X cn = cn refl
curryEl I (`Rec i D) X cn = λ x → curryEl I D X (λ xs → cn (x , xs))
curryEl I (`Arg A B) X cn = λ a → curryEl I (B a) X (λ xs → cn (a , xs))
curryEl I (`RecFun A B D) X cn = λ f → curryEl I D X (λ xs → cn (f , xs))

uncurryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : CurriedEl I D X) → UncurriedEl I D X
uncurryEl I (`End i) X cn refl = cn
uncurryEl I (`Rec i D) X cn (x , xs) = uncurryEl I D X (cn x) xs
uncurryEl I (`Arg A B) X cn (a , xs) = uncurryEl I (B a) X (cn a) xs
uncurryEl I (`RecFun A B D) X cn (f , xs) = uncurryEl I D X (cn f) xs

con2 : (I : Set) (D : Desc I) → CurriedEl I D (μ I D)
con2 I D = curryEl I D (μ I D) con

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

UncurriedAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : {i : I} → El I D X i → X i)
  → Set
UncurriedAll I D X P cn =
  (i : I) (xs : El I D X i) → All I D X P i xs → P i (cn xs)

CurriedAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  → Set
CurriedAll I (`End i) X P cn =
  P i (cn refl)
CurriedAll I (`Rec i D) X P cn =
  (x : X i) → P i x → CurriedAll I D X P (λ xs → cn (x , xs))
CurriedAll I (`Arg A B) X P cn =
  (a : A) → CurriedAll I (B a) X P (λ xs → cn (a , xs))
CurriedAll I (`RecFun A B D) X P cn =
  (f : (a : A) → X (B a)) (ihf : (a : A) → P (B a) (f a)) → CurriedAll I D X P (λ xs → cn (f , xs))

curryAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : UncurriedAll I D X P cn)
  → CurriedAll I D X P cn
curryAll I (`End i) X P cn pf =
  pf i refl tt
curryAll I (`Rec i D) X P cn pf =
  λ x ih → curryAll I D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryAll I (`Arg A B) X P cn pf =
  λ a → curryAll I (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)
curryAll I (`RecFun A B D) X P cn pf =
  λ f ihf → curryAll I D X P (λ xs → cn (f , xs)) (λ i xs ihs → pf i (f , xs) (ihf , ihs))

uncurryAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : CurriedAll I D X P cn)
  → UncurriedAll I D X P cn
uncurryAll I (`End .i) X P cn pf i refl tt =
  pf
uncurryAll I (`Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryAll I D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryAll I (`Arg A B) X P cn pf i (a , xs) ihs =
  uncurryAll I (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs
uncurryAll I (`RecFun A B D) X P cn pf i (f , xs) (ihf , ihs) =
  uncurryAll I D X P (λ ys → cn (f , ys)) (pf f ihf) i xs ihs

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

ind :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : UncurriedAll I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x

hyps :
  (I : Set)
  (D₁ : Desc I)
  (P : (i : I) → μ I D₁ i → Set)
  (pcon : UncurriedAll I D₁ (μ I D₁) P con)
  (D₂ : Desc I)
  (i : I)
  (xs : El I D₂ (μ I D₁) i)
  → All I D₂ (μ I D₁) P i xs

ind I D P pcon i (con xs) = pcon i xs (hyps I D P pcon D i xs)

hyps I D P pcon (`End j) i q = tt
hyps I D P pcon (`Rec j A) i (x , xs) = ind I D P pcon j x , hyps I D P pcon A i xs
hyps I D P pcon (`Arg A B) i (a , b) = hyps I D P pcon (B a) i b
hyps I D P pcon (`RecFun A B E) i (f , xs) = (λ a → ind I D P pcon (B a) (f a)) , hyps I D P pcon E i xs

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

ind2 :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : CurriedAll I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x
ind2 I D P pcon i x = ind I D P (uncurryAll I D (μ I D) P con pcon) i x

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

module Sugared where

  data ℕT : Set where `zero `suc : ℕT
  data VecT : Set where `nil `cons : VecT

  ℕD : Desc ⊤
  ℕD = `Arg ℕT λ
    { `zero → `End tt
    ; `suc → `Rec tt (`End tt)
    }

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (`zero , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (`suc , n , refl)

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg VecT λ
    { `nil  → `End zero
    ; `cons → `Arg (ℕ tt) λ n → `Arg A λ _ → `Rec n (`End (suc n))
    }

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (`nil , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (`cons , n , x , xs , refl)

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

  add : ℕ tt → ℕ tt → ℕ tt
  add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → n
      ; tt (`suc , m , q) (ih , tt) n → suc (ih n)
      }
    )
    tt

  mult : ℕ tt → ℕ tt → ℕ tt
  mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → zero
      ; tt (`suc , m , q) (ih , tt) n → add n (ih n)
      }
    )
    tt

  append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
  append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
    (λ
      { .(con (`zero , refl)) (`nil , refl) ih n ys → ys
      ; .(con (`suc , m , refl)) (`cons , m , x , xs , refl) (ih , tt) n ys → cons A (add m n) x (ih n ys)
      }
    )

  concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
    (λ
      { .(con (`zero , refl)) (`nil , refl) tt → nil A
      ; .(con (`suc , n , refl)) (`cons , n , xs , xss , refl) (ih , tt) → append A m xs (mult n m) ih
      }
    )

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

module Desugared where

  ℕT : Enum
  ℕT = "zero" ∷ "suc" ∷ []

  VecT : Enum
  VecT = "nil" ∷ "cons" ∷ []

  ℕC : Tag ℕT → Desc ⊤
  ℕC = caseD ℕT ⊤
    ( `End tt
    , `Rec tt (`End tt)
    , tt
    )

  ℕD : Desc ⊤
  ℕD = `Arg (Tag ℕT) ℕC

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (here , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (there here , n , refl)

  zero2 : ℕ tt
  zero2 = con2 ⊤ ℕD here

  suc2 : ℕ tt → ℕ tt
  suc2 = con2 ⊤ ℕD (there here)

  VecC : (A : Set) → Tag VecT → Desc (ℕ tt)
  VecC A = caseD VecT (ℕ tt)
    ( `End zero
    , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
    , tt
    )

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg (Tag VecT) (VecC A)

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (here , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (there here , n , x , xs , refl)

  nil2 : (A : Set) → Vec A zero
  nil2 A = con2 (ℕ tt) (VecD A) here

  cons2 : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons2 A = con2 (ℕ tt) (VecD A) (there here)

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

  module Induction where

    add : ℕ tt → ℕ tt → ℕ tt
    add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → n)
        , (λ m,q ih,tt n → suc (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → zero)
        , (λ m,q ih,tt n → add n (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ m t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) m)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) m (t , c))
               (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
        )
        ( (λ q ih n ys → subst (λ m → Vec A (add m n)) q ys)
        , (λ m',x,xs,q ih,tt n ys →
            let m' = proj₁ m',x,xs,q
                x = proj₁ (proj₂ m',x,xs,q)
                q = proj₂ (proj₂ (proj₂ m',x,xs,q))
                ih = proj₁ ih,tt
            in
            subst (λ m → Vec A (add m n)) q (cons A (add m' n) x (ih n ys))
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC (Vec A m) t) (Vec (Vec A m)) n)
               (ih : All (ℕ tt) (VecD (Vec A m)) (Vec (Vec A m)) (λ n xss → Vec A (mult n m)) n (t , c))
               → Vec A (mult n m)
        )
        ( (λ q ih → subst (λ n → Vec A (mult n m)) q (nil A))
        , (λ n',xs,xss,q ih,tt →
            let n' = proj₁ n',xs,xss,q
                xs = proj₁ (proj₂ n',xs,xss,q)
                q = proj₂ (proj₂ (proj₂ n',xs,xss,q))
                ih = proj₁ ih,tt
            in
            subst (λ n → Vec A (mult n m)) q (append A m xs (mult n' m) ih)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

  module Eliminator where

    elimℕ : (P : (ℕ tt) → Set)
      (pzero : P zero)
      (psuc : (m : ℕ tt) → P m → P (suc m))
      (n : ℕ tt)
      → P n
    elimℕ P pzero psuc = ind ⊤ ℕD (λ u n → P n)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → P n) u (t , c))
               → P (con (t , c))
        )
        ( (λ q ih →
            elimEq ⊤ tt (λ u q → P (con (here , q)))
              pzero
              u q
          )
        , (λ n,q ih,tt →
            elimEq ⊤ tt (λ u q → P (con (there here , proj₁ n,q , q)))
              (psuc (proj₁ n,q) (proj₁ ih,tt))
              u (proj₂ n,q)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    elimVec : (A : Set) (P : (n : ℕ tt) → Vec A n → Set)
      (pnil : P zero (nil A))
      (pcons : (n : ℕ tt) (a : A) (xs : Vec A n) → P n xs → P (suc n) (cons A n a xs))
      (n : ℕ tt)
      (xs : Vec A n)
      → P n xs
    elimVec A P pnil pcons = ind (ℕ tt) (VecD A) (λ n xs → P n xs)
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) n)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ n xs → P n xs) n (t , c))
               → P n (con (t , c))
        )
        ( (λ q ih →
            elimEq (ℕ tt) zero (λ n q → P n (con (here , q)))
              pnil
              n q
          )
        , (λ n',x,xs,q ih,tt →
            let n' = proj₁ n',x,xs,q
                x = proj₁ (proj₂ n',x,xs,q)
                xs = proj₁ (proj₂ (proj₂ n',x,xs,q))
                q = proj₂ (proj₂ (proj₂ n',x,xs,q))
                ih = proj₁ ih,tt
            in
            elimEq (ℕ tt) (suc n') (λ n q → P n (con (there here , n' , x , xs , q)))
              (pcons n' x xs ih )
              n q
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

    add : ℕ tt → ℕ tt → ℕ tt
    add = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → n)
      (λ m ih n → suc (ih n))

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → zero)
      (λ m ih n → add n (ih n))

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elimVec A (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elimVec (Vec A m) (λ n xss → Vec A (mult n m))
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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

  module GenericEliminator where

    add : ℕ tt → ℕ tt → ℕ tt
    add = ind2 ⊤ ℕD _
      (case ℕT _
        ( (λ n → n)
        , (λ m ih n → suc (ih n))
        , tt
        )
      )
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind2 ⊤ ℕD _
      (case ℕT _
        ( (λ n → zero)
        , (λ m ih n → add n (ih n))
        , tt
        )
      )
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = ind2 (ℕ tt) (VecD A) _
      (case VecT _
        ( (λ n ys → ys)
        , (λ m x xs ih n ys → cons A (add m n) x (ih n ys))
        , tt
        )
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = ind2 (ℕ tt) (VecD (Vec A m)) _
      (case VecT _
        ( (nil A)
        , (λ n xs xss ih → append A m xs (mult n m) ih)
        , tt
        )
      )

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


Added a different version of wellFoundedInd-N₂.

Ignore-this: c1a3d7e996665a522e734367d7df7b1a

darcs-hash:20100505162359-3bd4e-fe9a22b379062c77ef1c3bd5d50151e422c0942b.gz

------------------------------------------------------------------------------
-- Well-founded induction on the lexicographic order on N
------------------------------------------------------------------------------

module LTC.Data.N.Induction.Lexicographic where

open import LTC.Minimal

open import LTC.Data.N
open import Postulates using ( wellFoundedLT )
open import LTC.Relation.Inequalities

import MyStdLib.Induction.Lexicographic
open module LexicographicLT₂ = MyStdLib.Induction.Lexicographic LT LT
open import MyStdLib.Induction.WellFounded

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

-- Well-founded induction on the lexicographic order on N.
wellFoundedInd-N₂ :
  (P : D × D → Set) →
  ((mn : D × D) →
       (( op : D × D) → LT₂ op mn → N₂ op → P op) →
       N₂ mn → P mn) →
  {mn : D × D } → N₂ mn → P mn
wellFoundedInd-N₂ P accH {mn} =
  wellFoundedInd {D × D}
                 {LT₂}
                 {λ xy → N₂ xy → P xy}
                 (wellFoundedLexi wellFoundedLT wellFoundedLT)
                 accH
                 mn

-- A version without use the data type N₂.
wellFoundedInd-N₂' :
  (P : D × D → Set) →
  ((mn : D × D) →
       (( op : D × D) → LT₂ op mn → N (×-proj₁ op) → N (×-proj₂ op) → P op) →
       N (×-proj₁ mn) → N (×-proj₂ mn) → P mn) →
  {mn : D × D } → N (×-proj₁ mn) → N (×-proj₂ mn) → P mn
wellFoundedInd-N₂' P accH {mn} =
  wellFoundedInd {D × D}
                 {LT₂}
                 {λ xy → N (×-proj₁ xy) → N (×-proj₂ xy) → P xy}
                 (wellFoundedLexi wellFoundedLT wellFoundedLT)
                 accH
                 mn

------------------------------------------------------------------------------
-- Well-founded induction on the lexicographic order on N
------------------------------------------------------------------------------

module LTC.Data.N.Induction.Lexicographic where

open import LTC.Minimal

open import LTC.Data.N
open import Postulates using ( wellFoundedLT )
open import LTC.Relation.Inequalities

import MyStdLib.Induction.Lexicographic
open module LexicographicLT₂ = MyStdLib.Induction.Lexicographic LT LT
open import MyStdLib.Induction.WellFounded

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

wellFoundedInd-N₂ :
  (P : D × D → Set) →
  ((mn : D × D) →
       (( op : D × D) → LT₂ op mn → N₂ op → P op) →
       N₂ mn → P mn) →
  {mn : D × D } → N₂ mn → P mn
wellFoundedInd-N₂ P accH {mn} =
  wellFoundedInd {D × D}
                 {LT₂}
                 {λ xy → N₂ xy → P xy}
                 (wellFoundedLexi wellFoundedLT wellFoundedLT)
                 accH
                 mn


Only white spaces.

Only white spaces.

Ignore-this: 7e7ce7ddc8733882ff7663f6213fc31b

darcs-hash:20100916165334-3bd4e-4af66f15aeaee3ced653775d9a17dea2f52ab444.gz


example of export from module

example of export from module

open import Base

open import Id

module SemiGroups where

test : Type → Type
test A = (a : A) → (a == a)

assoc : {A : Type} → (A → A → A) → Type
assoc {A} _*_ = (x : A) → (y : A) → (z : A) → ((x * y) * z) == (x * (y * z))

semiGroup : (A : Type) → Type
semiGroup A = Σ (A → A → A) (λ op → assoc op)

module SemiGroup(A : Type)(_·_ : A → A → A)(ass : (assoc _·_)) where
  leftId : A → Type
  leftId x = (y : A) → ((x · y) == y)

  rightId : A → Type
  rightId x = (y : A) → ((y · x) == y)

  Id = λ a → (leftId a) × (rightId a)

  idUnique : (x y : A) → leftId x → rightId y → y == x
  idUnique x y lidx ridy = sym (lidx y) && ridy x

open import Nat

ass+ : assoc _+_
ass+ zero y z = refl (y + z)
ass+ (succ x) y z = succ # ass+ x y z

module AddNatSG = SemiGroup ℕ _+_ ass+

lftId : {A : Type} → semiGroup A → A → Type
lftId {A} [ a , x ] a₁ = lfid a₁ where
  module SG = SemiGroup A a x
  lfid = SG.leftId


fussing with unicity

fussing with unicity


Product: cleanup

Product: cleanup

-- move this to product
{-# OPTIONS --universe-polymorphism #-}
module Data.Product.NP where

open import Type hiding (★)
open import Level
open import Data.Product public hiding (∃)
open import Relation.Binary.PropositionalEquality
open import Relation.Unary.NP hiding (Decidable)
open import Relation.Binary
open import Relation.Nullary
open import Function
open import Function.Injection using (Injection; module Injection)
open import Relation.Unary.Logical
open import Relation.Binary.Logical

∃ : ∀ {a b} {A : ★ a} → (A → ★ b) → ★ (a ⊔ b)
∃ = Σ _

first : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c} →
          (f : A → B) → A × C → B × C
first f (x , y) = (f x , y)

second : ∀ {a p q} {A : ★ a} {P : A → ★ p} {Q : A → ★ q} →
           (∀ {x} → P x → Q x) → Σ A P → Σ A Q
second f (x , y) = (x , f y)

second′ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c} →
           (B → C) → A × B → A × C
second′ f = second f

syntax ∃ (λ x → e) = ∃[ x ] e

record [Σ] {a b aₚ bₚ}
           {A : ★ a}
           {B : A → ★ b}
           (Aₚ : A → ★ aₚ)
           (Bₚ : {x : A} (xₚ : Aₚ x)
                 → B x → ★ bₚ)
           (p : Σ A B) : ★ (aₚ ⊔ bₚ) where
  constructor _[,]_
  field
    [proj₁] : Aₚ (proj₁ p)
    [proj₂] : Bₚ [proj₁] (proj₂ p)
open [Σ] public
infixr 4 _[,]_

syntax [Σ] Aₚ (λ xₚ → e) = [ xₚ ∶ Aₚ ][×][ e ]

[∃] : ∀ {a aₚ b bₚ} →
        (∀i⟨ Aₚ ∶ [★] {a} aₚ ⟩[→] ((Aₚ [→] [★] {b} bₚ) [→] [★] _)) ∃
[∃] {xₚ = Aₚ} = [Σ] Aₚ

syntax [∃] (λ Aₚ → f) = [∃][ Aₚ ] f

_[×]_ : ∀ {a b aₚ bₚ} → ([★] {a} aₚ [→] [★] {b} bₚ [→] [★] _) _×_
_[×]_ Aₚ Bₚ = [Σ] Aₚ (λ _ → Bₚ)

private

  Dec⟦★⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂}
               (Aᵣ : ⟦★⟧ aᵣ A₁ A₂)
             → ★ _
  Dec⟦★⟧ Aᵣ = ∀ x₁ x₂ → Dec (Aᵣ x₁ x₂)

  Dec⟦Pred⟧ : ∀ {a₁ a₂ p₁ p₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂}
                (Aᵣ : ⟦★⟧ aᵣ A₁ A₂)
                {P₁ : Pred p₁ A₁} {P₂ : Pred p₂ A₂} {pᵣ}
              → (Pᵣ : ⟦Pred⟧ pᵣ Aᵣ P₁ P₂) → ★ _
  Dec⟦Pred⟧ {A₁ = A₁} {A₂} Aᵣ {P₁} {P₂} Pᵣ = ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) y₁ y₂ → Dec (Pᵣ xᵣ y₁ y₂) -- Dec⟦★⟧ Aᵣ ⇒ Dec⟦★⟧ Pᵣ

record ⟦Σ⟧ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
           {A₁ : ★ a₁} {A₂ : ★ a₂}
           {B₁ : A₁ → ★ b₁}
           {B₂ : A₂ → ★ b₂}
           (Aᵣ : A₁ → A₂ → ★ aᵣ)
           (Bᵣ : {x₁ : A₁} {x₂ : A₂} (xᵣ : Aᵣ x₁ x₂)
                → B₁ x₁ → B₂ x₂ → ★ bᵣ)
           (p₁ : Σ A₁ B₁) (p₂ : Σ A₂ B₂) : ★ (aᵣ ⊔ bᵣ) where
  constructor _⟦,⟧_
  field
    ⟦proj₁⟧ : Aᵣ (proj₁ p₁) (proj₁ p₂)
    ⟦proj₂⟧ : Bᵣ ⟦proj₁⟧ (proj₂ p₁) (proj₂ p₂)
open ⟦Σ⟧ public
infixr 4 _⟦,⟧_

syntax ⟦Σ⟧ Aᵣ (λ xᵣ → e) = [ xᵣ ∶ Aᵣ ]⟦×⟧[ e ]

⟦∃⟧ : ∀ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
        {A₁ : ★ a₁} {A₂ : ★ a₂}
        {Aᵣ : A₁ → A₂ → ★ aᵣ}
        {B₁ : A₁ → ★ b₁}
        {B₂ : A₂ → ★ b₂}
        (Bᵣ : ⟦Pred⟧ bᵣ Aᵣ B₁ B₂)
        (p₁ : Σ A₁ B₁) (p₂ : Σ A₂ B₂) → ★ _
⟦∃⟧ = ⟦Σ⟧ _

syntax ⟦∃⟧ (λ xᵣ → e) = ⟦∃⟧[ xᵣ ] e

_⟦×⟧_ : ∀ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
          {A₁ : ★ a₁} {A₂ : ★ a₂}
          {B₁ : ★ b₁} {B₂ : ★ b₂}
          (Aᵣ : A₁ → A₂ → ★ aᵣ)
          (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (p₁ : A₁ × B₁) (p₂ : A₂ × B₂) → ★ (aᵣ ⊔ bᵣ)
_⟦×⟧_ Aᵣ Bᵣ = ⟦Σ⟧ Aᵣ (λ _ → Bᵣ)

{-
_⟦×⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : ★ a₁} {A₂ : ★ a₂} (Aᵣ : A₁ → A₂ → ★ aᵣ)
          {b₁ b₂ bᵣ} {B₁ : ★ b₁} {B₂ : ★ b₂} (Bᵣ : B₁ → B₂ → ★ bᵣ)
          (p₁ : A₁ × B₁) (p₂ : A₂ × B₂) → ★ _
_⟦×⟧_ Aᵣ Bᵣ = λ p₁ p₂ → Aᵣ (proj₁ p₁) (proj₁ p₂) ×
                        Bᵣ (proj₂ p₁) (proj₂ p₂)
-}

{- One can give these two types to ⟦_,_⟧:

⟦_,_⟧' : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ}
       {A₁ : ★ a₁} {A₂ : ★ a₂}
       {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂}
       {Aᵣ : ⟦★⟧ aᵣ A₁ A₂}
       {Bᵣ : ⟦Pred⟧ Aᵣ bᵣ B₁ B₂}
       {x₁ x₂ y₁ y₂}
       (xᵣ : Aᵣ x₁ x₂)
       (yᵣ : Bᵣ xᵣ y₁ y₂)
     → ⟦Σ⟧ Aᵣ Bᵣ (x₁ , y₁) (x₂ , y₂)
⟦_,_⟧' = ⟦_,_⟧

⟦_,_⟧'' : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ}
       {A₁ : ★ a₁} {A₂ : ★ a₂}
       {B₁ : A₁ → ★ b₁} {B₂ : A₂ → ★ b₂}
       {Aᵣ : ⟦★⟧ aᵣ A₁ A₂}
       {Bᵣ : ⟦Pred⟧ Aᵣ bᵣ B₁ B₂}
       {p₁ p₂}
       (⟦proj₁⟧ : Aᵣ (proj₁ p₁) (proj₁ p₂))
       (⟦proj₂⟧ : Bᵣ ⟦proj₁⟧ (proj₂ p₁) (proj₂ p₂))
     → ⟦Σ⟧ Aᵣ Bᵣ p₁ p₂
⟦_,_⟧'' = ⟦_,_⟧
-}

dec⟦Σ⟧ : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ A₁ A₂ B₁ B₂}
       {Aᵣ : ⟦★⟧ {a₁} {a₂} aᵣ A₁ A₂}
       {Bᵣ : ⟦Pred⟧ {b₁} {b₂} bᵣ Aᵣ B₁ B₂}
       (decAᵣ : Dec⟦★⟧ Aᵣ)
       -- (substAᵣ : ∀ {x y ℓ} {p q} (P : Aᵣ x y → ★ ℓ) → P p → P q)
       (uniqAᵣ : ∀ {x y} (p q : Aᵣ x y) → p ≡ q)
       (decBᵣ : Dec⟦Pred⟧ Aᵣ {_} {_} {bᵣ {-BUG: with _ here Agda loops-}} Bᵣ)
     → Dec⟦★⟧ (⟦Σ⟧ Aᵣ Bᵣ)
dec⟦Σ⟧ {Bᵣ = Bᵣ} decAᵣ uniqAᵣ decBᵣ (x₁ , y₁) (x₂ , y₂) with decAᵣ x₁ x₂
... | no ¬xᵣ = no (¬xᵣ ∘ ⟦proj₁⟧)
... | yes xᵣ with decBᵣ xᵣ y₁ y₂
...           | yes yᵣ = yes (xᵣ ⟦,⟧ yᵣ)
...           | no ¬yᵣ = no (¬yᵣ ∘ f ∘ ⟦proj₂⟧)
  where f : ∀ {xᵣ'} → Bᵣ xᵣ' y₁ y₂ → Bᵣ xᵣ y₁ y₂
        f {xᵣ'} yᵣ rewrite uniqAᵣ xᵣ' xᵣ = yᵣ

module Dec₂ where
  map₂′ : ∀ {p₁ p₂ q} {P₁ : ★ p₁} {P₂ : ★ p₂} {Q : ★ q}
          → (P₁ → P₂ → Q) → (Q → P₁) → (Q → P₂) → Dec P₁ → Dec P₂ → Dec Q
  map₂′ _   π₁  _   (no ¬p₁)  _         = no (¬p₁ ∘ π₁)
  map₂′ _   _   π₂  _         (no ¬p₂)  = no (¬p₂ ∘ π₂)
  map₂′ mk  _   _   (yes p₁)  (yes p₂)  = yes (mk p₁ p₂)

dec⟦×⟧ : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ}
           {A₁ : ★ a₁} {A₂ : ★ a₂}
           {B₁ : ★ b₁} {B₂ : ★ b₂}
           {Aᵣ : ⟦★⟧ aᵣ A₁ A₂}
           {Bᵣ : ⟦★⟧ bᵣ B₁ B₂}
           (decAᵣ : Dec⟦★⟧ Aᵣ)
           (decBᵣ : Dec⟦★⟧ Bᵣ)
         → Dec⟦★⟧ (Aᵣ ⟦×⟧ Bᵣ)
dec⟦×⟧ decAᵣ decBᵣ (x₁ , y₁) (x₂ , y₂) with decAᵣ x₁ x₂
... | no ¬xᵣ = no (¬xᵣ ∘ ⟦proj₁⟧)
... | yes xᵣ with decBᵣ y₁ y₂
...           | yes yᵣ = yes (xᵣ ⟦,⟧ yᵣ)
...           | no ¬yᵣ = no (¬yᵣ ∘ ⟦proj₂⟧)

Σ,-injective₂ : ∀ {a b} {A : ★ a} {B : A → ★ b} {x : A} {y z : B x} → ((x , y) ∶ Σ A B) ≡ (x , z) → y ≡ z
Σ,-injective₂ refl = refl

Σ,-injective₁ : ∀ {a b} {A : ★ a} {B : A → ★ b} {x₁ x₂ : A} {y₁ : B x₁} {y₂ : B x₂} → ((x₁ , y₁) ∶ Σ A B) ≡ (x₂ , y₂) → x₁ ≡ x₂
Σ,-injective₁ refl = refl

proj₁-injective : ∀ {a b} {A : ★ a} {B : A → ★ b} {x y : Σ A B}
                    (B-uniq : ∀ {z} (p₁ p₂ : B z) → p₁ ≡ p₂)
                  → proj₁ x ≡ proj₁ y → x ≡ y
proj₁-injective {x = (a , p₁)} {y = (_ , p₂)} B-uniq eq rewrite sym eq
  = cong (λ p → (a , p)) (B-uniq p₁ p₂)

proj₂-irrelevance : ∀ {a b} {A : ★ a} {B C : A → ★ b} {x₁ x₂ : A}
                      {y₁ : B x₁} {y₂ : B x₂} {z₁ : C x₁} {z₂ : C x₂}
                    → (C-uniq : ∀ {z} (p₁ p₂ : C z) → p₁ ≡ p₂)
                    → ((x₁ , y₁) ∶ Σ A B) ≡ (x₂ , y₂)
                    → ((x₁ , z₁) ∶ Σ A C) ≡ (x₂ , z₂)
proj₂-irrelevance C-uniq = proj₁-injective C-uniq ∘ Σ,-injective₁

≟Σ : ∀ {A : ★₀} {P : A → ★₀}
       (decA : Decidable {A = A} _≡_)
       (decP : ∀ x → Decidable {A = P x} _≡_)
     → Decidable {A = Σ A P} _≡_
≟Σ decA decP (w₁ , p₁) (w₂ , p₂) with decA w₁ w₂
≟Σ decA decP (w  , p₁) (.w , p₂) | yes refl with decP w p₁ p₂
≟Σ decA decP (w  , p)  (.w , .p) | yes refl | yes refl = yes refl
≟Σ decA decP (w  , p₁) (.w , p₂) | yes refl | no  p≢
    = no (p≢ ∘ Σ,-injective₂)
≟Σ decA decP (w₁ , p₁) (w₂ , p₂) | no w≢ = no (w≢ ∘ cong proj₁)

≟Σ' : ∀ {A : ★₀} {P : A → ★₀}
       (decA : Decidable {A = A} _≡_)
       (uniqP : ∀ {x} (p q : P x) → p ≡ q)
     → Decidable {A = Σ A P} _≡_
≟Σ' decA uniqP (w₁ , p₁) (w₂ , p₂) with decA w₁ w₂
≟Σ' decA uniqP (w  , p₁) (.w , p₂) | yes refl
  = yes (cong (λ p → (w , p)) (uniqP p₁ p₂))
≟Σ' decA uniqP (w₁ , p₁) (w₂ , p₂) | no w≢ = no (w≢ ∘ cong proj₁)

proj₁-Injection : ∀ {a b} {A : ★ a} {B : A →  ★ b}
                  → (∀ {x} (p₁ p₂ : B x) → p₁ ≡ p₂)
                  → Injection (setoid (Σ A B))
                              (setoid A)
proj₁-Injection {B = B} B-uniq
     = record { to        = →-to-⟶ (proj₁ {B = B})
              ; injective = proj₁-injective B-uniq
              }

-- move this to product
{-# OPTIONS --universe-polymorphism #-}
module Data.Product.NP where

open import Level
open import Data.Product public hiding (∃)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary
open import Relation.Nullary
open import Function
open import Function.Injection using (Injection; module Injection)
open import Relation.Binary.Logical

∃ : ∀ {a b} {A : Set a} → (A → Set b) → Set (a ⊔ b)
∃ = Σ _

first : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} →
          (f : A → B) → A × C → B × C
first f (x , y) = (f x , y)

second : ∀ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} →
           (∀ {x} → P x → Q x) → Σ A P → Σ A Q
second f (x , y) = (x , f y)

second′ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} →
           (B → C) → A × B → A × C
second′ f = second f

syntax ∃ (λ x → e) = ∃[ x ] e

private

  Dec⟦Set⟧ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂}
               (Aᵣ : ⟦Set⟧ aᵣ A₁ A₂)
             → Set _
  Dec⟦Set⟧ Aᵣ = ∀ x₁ x₂ → Dec (Aᵣ x₁ x₂)

  Dec⟦Pred⟧ : ∀ {a₁ a₂ p₁ p₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂}
                (Aᵣ : ⟦Set⟧ aᵣ A₁ A₂)
                {P₁ : Pred p₁ A₁} {P₂ : Pred p₂ A₂} {pᵣ}
              → (Pᵣ : ⟦Pred⟧ pᵣ Aᵣ P₁ P₂) → Set _
  Dec⟦Pred⟧ {A₁ = A₁} {A₂} Aᵣ {P₁} {P₂} Pᵣ = ∀ {x₁ x₂} (xᵣ : Aᵣ x₁ x₂) y₁ y₂ → Dec (Pᵣ xᵣ y₁ y₂) -- Dec⟦Set⟧ Aᵣ ⇒ Dec⟦Set⟧ Pᵣ

record ⟦Σ⟧ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
           {A₁ : Set a₁} {A₂ : Set a₂}
           {B₁ : A₁ → Set b₁}
           {B₂ : A₂ → Set b₂}
           (Aᵣ : A₁ → A₂ → Set aᵣ)
           (Bᵣ : {x₁ : A₁} {x₂ : A₂} (xᵣ : Aᵣ x₁ x₂)
                → B₁ x₁ → B₂ x₂ → Set bᵣ)
           (p₁ : Σ A₁ B₁) (p₂ : Σ A₂ B₂) : Set (aᵣ ⊔ bᵣ) where
  constructor _⟦,⟧_
  field
    ⟦proj₁⟧ : Aᵣ (proj₁ p₁) (proj₁ p₂)
    ⟦proj₂⟧ : Bᵣ ⟦proj₁⟧ (proj₂ p₁) (proj₂ p₂)
open ⟦Σ⟧ public
infixr 4 _⟦,⟧_

syntax ⟦Σ⟧ Aᵣ (λ xᵣ → e) = [ xᵣ ∶ Aᵣ ]×[ e ]

⟦∃⟧ : ∀ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
        {A₁ : Set a₁} {A₂ : Set a₂}
        {Aᵣ : A₁ → A₂ → Set aᵣ}
        {B₁ : A₁ → Set b₁}
        {B₂ : A₂ → Set b₂}
        (Bᵣ : ⟦Pred⟧ bᵣ Aᵣ B₁ B₂)
        (p₁ : Σ A₁ B₁) (p₂ : Σ A₂ B₂) → Set _ -- (aᵣ ⊔ bᵣ)
⟦∃⟧ = ⟦Σ⟧ _

syntax ⟦∃⟧ (λ xᵣ → e) = ⟦∃⟧[ xᵣ ] e

_⟦×⟧_ : ∀ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
          {A₁ : Set a₁} {A₂ : Set a₂}
          {B₁ : Set b₁} {B₂ : Set b₂}
          (Aᵣ : A₁ → A₂ → Set aᵣ)
          (Bᵣ : B₁ → B₂ → Set bᵣ)
          (p₁ : A₁ × B₁) (p₂ : A₂ × B₂) → Set (aᵣ ⊔ bᵣ)
_⟦×⟧_ Aᵣ Bᵣ = ⟦Σ⟧ Aᵣ (λ _ → Bᵣ)

{-
_⟦×⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
          {b₁ b₂ bᵣ} {B₁ : Set b₁} {B₂ : Set b₂} (Bᵣ : B₁ → B₂ → Set bᵣ)
          (p₁ : A₁ × B₁) (p₂ : A₂ × B₂) → Set _
_⟦×⟧_ Aᵣ Bᵣ = λ p₁ p₂ → Aᵣ (proj₁ p₁) (proj₁ p₂) ×
                        Bᵣ (proj₂ p₁) (proj₂ p₂)
-}

{- One can give these two types to ⟦_,_⟧:

⟦_,_⟧' : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ}
       {A₁ : Set a₁} {A₂ : Set a₂}
       {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂}
       {Aᵣ : ⟦Set⟧ aᵣ A₁ A₂}
       {Bᵣ : ⟦Pred⟧ Aᵣ bᵣ B₁ B₂}
       {x₁ x₂ y₁ y₂}
       (xᵣ : Aᵣ x₁ x₂)
       (yᵣ : Bᵣ xᵣ y₁ y₂)
     → ⟦Σ⟧ Aᵣ Bᵣ (x₁ , y₁) (x₂ , y₂)
⟦_,_⟧' = ⟦_,_⟧

⟦_,_⟧'' : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ}
       {A₁ : Set a₁} {A₂ : Set a₂}
       {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂}
       {Aᵣ : ⟦Set⟧ aᵣ A₁ A₂}
       {Bᵣ : ⟦Pred⟧ Aᵣ bᵣ B₁ B₂}
       {p₁ p₂}
       (⟦proj₁⟧ : Aᵣ (proj₁ p₁) (proj₁ p₂))
       (⟦proj₂⟧ : Bᵣ ⟦proj₁⟧ (proj₂ p₁) (proj₂ p₂))
     → ⟦Σ⟧ Aᵣ Bᵣ p₁ p₂
⟦_,_⟧'' = ⟦_,_⟧
-}

dec⟦Σ⟧ : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ A₁ A₂ B₁ B₂}
       {Aᵣ : ⟦Set⟧ {a₁} {a₂} aᵣ A₁ A₂}
       {Bᵣ : ⟦Pred⟧ {b₁} {b₂} bᵣ Aᵣ B₁ B₂}
       (decAᵣ : Dec⟦Set⟧ Aᵣ)
       -- (substAᵣ : ∀ {x y ℓ} {p q} (P : Aᵣ x y → Set ℓ) → P p → P q)
       (uniqAᵣ : ∀ {x y} (p q : Aᵣ x y) → p ≡ q)
       (decBᵣ : Dec⟦Pred⟧ Aᵣ {_} {_} {bᵣ {-BUG: with _ here Agda loops-}} Bᵣ)
     → Dec⟦Set⟧ (⟦Σ⟧ Aᵣ Bᵣ)
dec⟦Σ⟧ {Bᵣ = Bᵣ} decAᵣ uniqAᵣ decBᵣ (x₁ , y₁) (x₂ , y₂) with decAᵣ x₁ x₂
... | no ¬xᵣ = no (¬xᵣ ∘ ⟦proj₁⟧)
... | yes xᵣ with decBᵣ xᵣ y₁ y₂
...           | yes yᵣ = yes (xᵣ ⟦,⟧ yᵣ)
...           | no ¬yᵣ = no (¬yᵣ ∘ f ∘ ⟦proj₂⟧)
  where f : ∀ {xᵣ'} → Bᵣ xᵣ' y₁ y₂ → Bᵣ xᵣ y₁ y₂
        f {xᵣ'} yᵣ rewrite uniqAᵣ xᵣ' xᵣ = yᵣ

module Dec₂ where
  map₂′ : ∀ {p₁ p₂ q} {P₁ : Set p₁} {P₂ : Set p₂} {Q : Set q}
          → (P₁ → P₂ → Q) → (Q → P₁) → (Q → P₂) → Dec P₁ → Dec P₂ → Dec Q
  map₂′ _   π₁  _   (no ¬p₁)  _         = no (¬p₁ ∘ π₁)
  map₂′ _   _   π₂  _         (no ¬p₂)  = no (¬p₂ ∘ π₂)
  map₂′ mk  _   _   (yes p₁)  (yes p₂)  = yes (mk p₁ p₂)

dec⟦×⟧ : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ}
           {A₁ : Set a₁} {A₂ : Set a₂}
           {B₁ : Set b₁} {B₂ : Set b₂}
           {Aᵣ : ⟦Set⟧ aᵣ A₁ A₂}
           {Bᵣ : ⟦Set⟧ bᵣ B₁ B₂}
           (decAᵣ : Dec⟦Set⟧ Aᵣ)
           (decBᵣ : Dec⟦Set⟧ Bᵣ)
         → Dec⟦Set⟧ (Aᵣ ⟦×⟧ Bᵣ)
dec⟦×⟧ decAᵣ decBᵣ (x₁ , y₁) (x₂ , y₂) with decAᵣ x₁ x₂
... | no ¬xᵣ = no (¬xᵣ ∘ ⟦proj₁⟧)
... | yes xᵣ with decBᵣ y₁ y₂
...           | yes yᵣ = yes (xᵣ ⟦,⟧ yᵣ)
...           | no ¬yᵣ = no (¬yᵣ ∘ ⟦proj₂⟧)

Σ,-injective₂ : ∀ {a b} {A : Set a} {B : A → Set b} {x : A} {y z : B x} → ((x , y) ∶ Σ A B) ≡ (x , z) → y ≡ z
Σ,-injective₂ refl = refl

Σ,-injective₁ : ∀ {a b} {A : Set a} {B : A → Set b} {x₁ x₂ : A} {y₁ : B x₁} {y₂ : B x₂} → ((x₁ , y₁) ∶ Σ A B) ≡ (x₂ , y₂) → x₁ ≡ x₂
Σ,-injective₁ refl = refl

proj₁-injective : ∀ {a b} {A : Set a} {B : A → Set b} {x y : Σ A B}
                    (B-uniq : ∀ {z} (p₁ p₂ : B z) → p₁ ≡ p₂)
                  → proj₁ x ≡ proj₁ y → x ≡ y
proj₁-injective {x = (a , p₁)} {y = (_ , p₂)} B-uniq eq rewrite sym eq
  = cong (λ p → (a , p)) (B-uniq p₁ p₂)

proj₂-irrelevance : ∀ {a b} {A : Set a} {B C : A → Set b} {x₁ x₂ : A}
                      {y₁ : B x₁} {y₂ : B x₂} {z₁ : C x₁} {z₂ : C x₂}
                    → (C-uniq : ∀ {z} (p₁ p₂ : C z) → p₁ ≡ p₂)
                    → ((x₁ , y₁) ∶ Σ A B) ≡ (x₂ , y₂)
                    → ((x₁ , z₁) ∶ Σ A C) ≡ (x₂ , z₂)
proj₂-irrelevance C-uniq = proj₁-injective C-uniq ∘ Σ,-injective₁

≟Σ : ∀ {A : Set} {P : A → Set}
       (decA : Decidable {A = A} _≡_)
       (decP : ∀ x → Decidable {A = P x} _≡_)
     → Decidable {A = Σ A P} _≡_
≟Σ decA decP (w₁ , p₁) (w₂ , p₂) with decA w₁ w₂
≟Σ decA decP (w  , p₁) (.w , p₂) | yes refl with decP w p₁ p₂
≟Σ decA decP (w  , p)  (.w , .p) | yes refl | yes refl = yes refl
≟Σ decA decP (w  , p₁) (.w , p₂) | yes refl | no  p≢
    = no (p≢ ∘ Σ,-injective₂)
≟Σ decA decP (w₁ , p₁) (w₂ , p₂) | no w≢ = no (w≢ ∘ cong proj₁)

≟Σ' : ∀ {A : Set} {P : A → Set}
       (decA : Decidable {A = A} _≡_)
       (uniqP : ∀ {x} (p q : P x) → p ≡ q)
     → Decidable {A = Σ A P} _≡_
≟Σ' decA uniqP (w₁ , p₁) (w₂ , p₂) with decA w₁ w₂
≟Σ' decA uniqP (w  , p₁) (.w , p₂) | yes refl
  = yes (cong (λ p → (w , p)) (uniqP p₁ p₂))
≟Σ' decA uniqP (w₁ , p₁) (w₂ , p₂) | no w≢ = no (w≢ ∘ cong proj₁)

proj₁-Injection : ∀ {a b} {A : Set a} {B : A →  Set b}
                  → (∀ {x} (p₁ p₂ : B x) → p₁ ≡ p₂)
                  → Injection (setoid (Σ A B))
                              (setoid A)
proj₁-Injection {B = B} B-uniq
     = record { to        = →-to-⟶ (proj₁ {B = B})
              ; injective = proj₁-injective B-uniq
              }


restructuring the ana proof to avoid redoing all the work of synth.

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = c , ∅ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D with htype-dec τ τ'
    ... | Inl _ = _ , _ , ESAsc2 D
    ... | Inr x = _ , _ , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = _ , _ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = _ , _ , ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = _ , _ , ESAp2 {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = _ , _ , ESAp3 {!!} {!D1!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = e} (ASubsume D x₁) with expandability-synth D
    -- these cases just pass through, but we need to pattern match so we can prove things aren't holes
    expandability-ana {Γ} {c} (ASubsume D x₁)             | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {Γ} {e ·: x} (ASubsume D x₁)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {Γ} {X x} (ASubsume D x₁)           | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {Γ} {·λ x e} (ASubsume D x₁)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {Γ} {·λ x [ x₁ ] e} (ASubsume D x₂) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₂
    expandability-ana {Γ} {e ∘ e₁} (ASubsume D x₁)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    -- the two holes are special-cased
    expandability-ana {Γ} {⦇⦈[ x ]} (ASubsume _ _ )       | _ , _ , _ = _ , _ , _ , EAEHole
    expandability-ana {Γ} {⦇ e ⦈[ x ]} (ASubsume (SNEHole wt) _) | _ , _ , _ = _ , _ , _ , EANEHole (π2( π2 (expandability-synth wt)))
    -- the lambda cases
    expandability-ana (ALam x₁ MAHole wt) with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALamHole x₁ D'
    expandability-ana (ALam x₁ MAArr wt) with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALam x₁ D'

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = c , ∅ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D with htype-dec τ τ'
    ... | Inl _ = _ , _ , ESAsc2 D
    ... | Inr x = _ , _ , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = _ , _ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = _ , _ , ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = _ , _ , ESAp2 {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = _ , _ , ESAp3 {!!} {!D1!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume wt x₁) =  _ , _ , _ , EAEHole
    expandability-ana {e = ⦇ e' ⦈[ x ]} (ASubsume (SNEHole wt) x₁)
      with expandability-synth wt
    ... | d , Δ , D = _ , _ , _ , EANEHole D
    expandability-ana {e = c} (ASubsume SConst x₁) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ())  ESConst x₁
    expandability-ana {e = e ·: x} (ASubsume (SAsc wt) x₂)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D' with htype-dec x τ'
    expandability-ana {Γ} {e ·: .x} (ASubsume (SAsc wt) x₂) | d' , Δ' , x , D' | Inl refl = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESAsc2 D') x₂
    expandability-ana {Γ} {e ·: x} (ASubsume (SAsc wt) x₂) | d' , Δ' , τ' , D' | Inr x₁ = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESAsc1 D' x₁) x₂
    expandability-ana {e = X x} (ASubsume (SVar x₁) x₂) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESVar x₁) x₂
    expandability-ana {e = ·λ x e} (ASubsume () x₁)
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume (SLam x₂ wt) x₃)
      with expandability-synth wt
    ... | d , Δ , D = _ , _ , _ , EASubsume (λ u → λ ()) (λ e' u → λ ()) (ESLam x₂ D) x₃
    expandability-ana {e = e1 ∘ e2} (ASubsume (SAp wt1 MAHole wt2) x₂)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2 = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESAp1 {!!} wt1 {!!} D2) x₂
    expandability-ana {e = e1 ∘ e2} (ASubsume (SAp wt MAArr x₁) x₂) = {!!}
    expandability-ana (ALam x₁ MAHole wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D' = _ , _ , _ , EALamHole x₁ D'
    expandability-ana (ALam x₁ MAArr wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D' = _ , _ , _ , EALam x₁ D'