tree permutations, made easy!

tree permutations, made easy!

module prefect-bintree where

open import Function
open import Data.Nat.NP using (ℕ; zero; suc; 2^_; _+_; module ℕ°)
open import Data.Bool
open import Data.Bits
open import Data.Vec using (Vec; _++_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import Algebra.FunctionProperties

data Tree {a} (A : Set a) : ℕ → Set a where
  leaf : (x : A) → Tree A zero
  fork : ∀ {n} (left right : Tree A n) → Tree A (suc n)

fromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Tree A n
fromFun {zero} f = leaf (f [])
fromFun {suc n} f = fork (fromFun (f ∘ 0∷_)) (fromFun (f ∘ 1∷_))

toFun : ∀ {n a} {A : Set a} → Tree A n → Bits n → A
toFun (leaf x) _ = x
toFun (fork left right) (b ∷ bs) = toFun (if b then right else left) bs

lookup : ∀ {n a} {A : Set a} → Bits n → Tree A n → A
lookup = flip toFun

fold : ∀ {n a} {A : Set a} (op : A → A → A) → Tree A n → A
fold _   (leaf x) = x
fold _·_ (fork t₀ t₁) = fold _·_ t₀ · fold _·_ t₁

search≡fold∘fromFun : ∀ {n a} {A : Set a} op (f : Bits n → A) → search op f ≡ fold op (fromFun f)
search≡fold∘fromFun {zero}  op f = refl
search≡fold∘fromFun {suc n} op f
  rewrite search≡fold∘fromFun op (f ∘ 0∷_)
        | search≡fold∘fromFun op (f ∘ 1∷_) = refl

-- Returns the flat vector of leaves underlying the perfect binary tree.
toVec : ∀ {n a} {A : Set a} → Tree A n → Vec A (2^ n)
toVec (leaf x)     = x ∷ []
toVec (fork t₀ t₁) = toVec t₀ ++ toVec t₁

lookup' : ∀ {m n a} {A : Set a} → Bits m → Tree A (m + n) → Tree A n
lookup' [] t = t
lookup' (b ∷ bs) (fork t t₁) = lookup' bs (if b then t₁ else t)

update' : ∀ {m n a} {A : Set a} → Bits m → Tree A n → Tree A (m + n) → Tree A (m + n)
update' [] val tree = val
update' (b ∷ key) val (fork tree tree₁) = if b then fork tree (update' key val tree₁)
                                               else fork (update' key val tree) tree₁

map : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → Tree A n → Tree B n
map f (leaf x) = leaf (f x)
map f (fork t₀ t₁) = fork (map f t₀) (map f t₁)

open import Relation.Binary
open import Data.Star using (Star; ε; _◅_)

data Swp {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  left : ∀ {n} {left₀ left₁ right : Tree A n} →
         Swp left₀ left₁ →
         Swp (fork left₀ right) (fork left₁ right)
  right : ∀ {n} {left right₀ right₁ : Tree A n} →
         Swp right₀ right₁ →
         Swp (fork left right₀) (fork left right₁)
  swp₁ : ∀ {n} {left right : Tree A n} →
         Swp (fork left right) (fork right left)
  swp₂ : ∀ {n} {t₀₀ t₀₁ t₁₀ t₁₁ : Tree A n} →
         Swp (fork (fork t₀₀ t₀₁) (fork t₁₀ t₁₁)) (fork (fork t₁₁ t₀₁) (fork t₁₀ t₀₀))

Swp★ : ∀ {n a} {A : Set a} (left right : Tree A n) → Set a
Swp★ = Star Swp

Swp-sym : ∀ {n a} {A : Set a} → Symmetric (Swp {A = A} {n})
Swp-sym (left s)  = left (Swp-sym s)
Swp-sym (right s) = right (Swp-sym s)
Swp-sym swp₁      = swp₁
Swp-sym swp₂      = swp₂

data Rot {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  leaf : ∀ x → Rot (leaf x) (leaf x)
  fork : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ left₁ →
         Rot right₀ right₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)
  krof : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ right₁ →
         Rot right₀ left₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)

Rot-refl : ∀ {n a} {A : Set a} → Reflexive (Rot {A = A} {n})
Rot-refl {x = leaf x} = leaf x
Rot-refl {x = fork _ _} = fork Rot-refl Rot-refl

Rot-sym : ∀ {n a} {A : Set a} → Symmetric (Rot {A = A} {n})
Rot-sym (leaf x) = leaf x
Rot-sym (fork p₀ p₁) = fork (Rot-sym p₀) (Rot-sym p₁)
Rot-sym (krof p₀ p₁) = krof (Rot-sym p₁) (Rot-sym p₀)

Rot-trans : ∀ {n a} {A : Set a} → Transitive (Rot {A = A} {n})
Rot-trans (leaf x) q = q
Rot-trans (fork p₀ p₁) (fork q₀ q₁) = fork (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (fork p₀ p₁) (krof q₀ q₁) = krof (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (krof p₀ p₁) (fork q₀ q₁) = krof (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)
Rot-trans (krof p₀ p₁) (krof q₀ q₁) = fork (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)

data SwpOp : ℕ → Set where
  ε : ∀ {n} → SwpOp n

  _⁏_ : ∀ {n} → SwpOp n → SwpOp n → SwpOp n

  first : ∀ {n} → SwpOp n → SwpOp (suc n)

  swp : ∀ {n} → SwpOp (suc n)

  swp-seconds : ∀ {n} → SwpOp (2 + n)

data Perm {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  ε : ∀ {n} {t : Tree A n} → Perm t t

  _⁏_ : ∀ {n} {t u v : Tree A n} → Perm t u → Perm u v → Perm t v

  first : ∀ {n} {tA tB tC : Tree A n} →
         Perm tA tB →
         Perm (fork tA tC) (fork tB tC)

  swp : ∀ {n} {tA tB : Tree A n} →
         Perm (fork tA tB) (fork tB tA)

  swp-seconds : ∀ {n} {tA tB tC tD : Tree A n} →
                 Perm (fork (fork tA tB) (fork tC tD))
                          (fork (fork tA tD) (fork tC tB))

data Perm0↔ {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  ε : ∀ {n} {t : Tree A n} → Perm0↔ t t

  swp : ∀ {n} {tA tB : Tree A n} →
         Perm0↔ (fork tA tB) (fork tB tA)

  first : ∀ {n} {tA tB tC : Tree A n} →
         Perm0↔ tA tB →
         Perm0↔ (fork tA tC) (fork tB tC)

  firsts : ∀ {n} {tA tB tC tD tE tF : Tree A n} →
                 Perm0↔ (fork tA tC) (fork tE tF) →
                 Perm0↔ (fork (fork tA tB) (fork tC tD))
                          (fork (fork tE tB) (fork tF tD))

  extremes : ∀ {n} {tA tB tC tD tE tF : Tree A n} →
                 Perm0↔ (fork tA tD) (fork tE tF) →
                 Perm0↔ (fork (fork tA tB) (fork tC tD))
                          (fork (fork tA tB) (fork tC tF))

-- Star Perm0↔ can then model any permutation

infixr 1 _⁏_

second-perm : ∀ {a} {A : Set a} {n} {left right₀ right₁ : Tree A n} →
           Perm right₀ right₁ →
           Perm (fork left right₀) (fork left right₁)
second-perm f = swp ⁏ first f ⁏ swp

second-swpop : ∀ {n} → SwpOp n → SwpOp (suc n)
second-swpop f = swp ⁏ first f ⁏ swp

<_×_>-perm : ∀ {a} {A : Set a} {n} {left₀ right₀ left₁ right₁ : Tree A n} →
           Perm left₀ left₁ →
           Perm right₀ right₁ →
           Perm (fork left₀ right₀) (fork left₁ right₁)
< f × g >-perm = first f ⁏ second-perm g

swp₂-perm : ∀ {a n} {A : Set a} {t₀₀ t₀₁ t₁₀ t₁₁ : Tree A n} →
          Perm (fork (fork t₀₀ t₀₁) (fork t₁₀ t₁₁)) (fork (fork t₁₁ t₀₁) (fork t₁₀ t₀₀))
swp₂-perm = first swp ⁏ swp-seconds ⁏ first swp

swp₃-perm : ∀ {a n} {A : Set a} {t₀₀ t₀₁ t₁₀ t₁₁ : Tree A n} →
         Perm (fork (fork t₀₀ t₀₁) (fork t₁₀ t₁₁)) (fork (fork t₀₀ t₁₀) (fork t₀₁ t₁₁))
swp₃-perm = second-perm swp ⁏ swp-seconds ⁏ second-perm swp

swp-firsts-perm : ∀ {n a} {A : Set a} {tA tB tC tD : Tree A n} →
                 Perm (fork (fork tA tB) (fork tC tD))
                          (fork (fork tC tB) (fork tA tD))
swp-firsts-perm = < swp × swp >-perm ⁏ swp-seconds ⁏ < swp × swp >-perm

Swp⇒Perm : ∀ {n a} {A : Set a} → Swp {a} {A} {n} ⇒ Perm {n = n}
Swp⇒Perm (left pf) = first (Swp⇒Perm pf)
Swp⇒Perm (right pf) = second-perm (Swp⇒Perm pf)
Swp⇒Perm swp₁ = swp
Swp⇒Perm swp₂ = swp₂-perm

Swp★⇒Perm : ∀ {n a} {A : Set a} → Swp★ {n} {a} {A} ⇒ Perm {n = n}
Swp★⇒Perm ε         = ε
Swp★⇒Perm (x ◅ xs) = Swp⇒Perm x ⁏ Swp★⇒Perm xs

swp-inners : ∀ {n} → SwpOp (2 + n)
swp-inners = second-swpop swp ⁏ swp-seconds ⁏ second-swpop swp

on-extremes : ∀ {n} → SwpOp (1 + n) → SwpOp (2 + n)
on-extremes f = swp-seconds ⁏ first f ⁏ swp-seconds

on-firsts : ∀ {n} → SwpOp (1 + n) → SwpOp (2 + n)
on-firsts f = swp-inners ⁏ first f ⁏ swp-inners

0↔_ : ∀ {m n} → Bits m → SwpOp (m + n)
0↔ [] = ε
0↔ (false{-0-} ∷ p) = first (0↔ p)
0↔ (true{-1-}  ∷ []) = swp
0↔ (true{-1-}  ∷ true {-1-} ∷ p) = on-extremes (0↔ (1b ∷ p))
0↔ (true{-1-}  ∷ false{-0-} ∷ p) = on-firsts   (0↔ (1b ∷ p))

0↔′_ : ∀ {n} → Bits n → SwpOp n
0↔′_ {n} rewrite cong SwpOp (sym (ℕ°.+-comm n 0)) = 0↔_ {n} {0}

[_↔_] : ∀ {m n} (p q : Bits m) → SwpOp (m + n)
[ p ↔ q ] = 0↔ p ⁏ 0↔ q

[_↔′_] : ∀ {n} (p q : Bits n) → SwpOp n
[ p ↔′ q ] = 0↔′ p ⁏ 0↔′ q

_$swp_ : ∀ {n a} {A : Set a} → SwpOp n → Tree A n → Tree A n
ε           $swp t = t
(f ⁏ g)     $swp t = g $swp (f $swp t)
(first f)   $swp (fork t₀ t₁) = fork (f $swp t₀) t₁
swp         $swp (fork t₀ t₁) = fork t₁ t₀
swp-seconds $swp (fork (fork t₀ t₁) (fork t₂ t₃)) = fork (fork t₀ t₃) (fork t₂ t₁)

swpRel : ∀ {n a} {A : Set a} (f : SwpOp n) (t : Tree A n) → Perm t (f $swp t)
swpRel ε           _          = ε
swpRel (f ⁏ g)     _          = swpRel f _ ⁏ swpRel g _
swpRel (first f)   (fork _ _) = first (swpRel f _)
swpRel swp         (fork _ _) = swp
swpRel swp-seconds
 (fork (fork _ _) (fork _ _)) = swp-seconds

[0↔_]-Rel : ∀ {m n a} {A : Set a} (p : Bits m) (t : Tree A (m + n)) → Perm t ((0↔ p) $swp t)
[0↔ p ]-Rel = swpRel (0↔ p)

swpOp' : ∀ {n a} {A : Set a} {t u : Tree A n} → Perm0↔ t u → SwpOp n
swpOp' ε = ε
swpOp' (first f) = first (swpOp' f)
swpOp' swp = swp
swpOp' (firsts f) = on-firsts (swpOp' f)
swpOp' (extremes f) = on-extremes (swpOp' f)

swpOp : ∀ {n a} {A : Set a} {t u : Tree A n} → Perm t u → SwpOp n
swpOp ε = ε
swpOp (f ⁏ g) = swpOp f ⁏  swpOp g
swpOp (first f) = first (swpOp f)
swpOp swp = swp
swpOp swp-seconds = swp-seconds

swpOp-sym : ∀ {n} → SwpOp n → SwpOp n
swpOp-sym ε = ε
swpOp-sym (f ⁏ g) = swpOp-sym g ⁏ swpOp-sym f
swpOp-sym (first f) = first (swpOp-sym f)
swpOp-sym swp = swp
swpOp-sym swp-seconds = swp-seconds

swpOp-sym-involutive : ∀ {n} (f : SwpOp n) → swpOp-sym (swpOp-sym f) ≡ f
swpOp-sym-involutive ε = refl
swpOp-sym-involutive (f ⁏ g) rewrite swpOp-sym-involutive f | swpOp-sym-involutive g = refl
swpOp-sym-involutive (first f) rewrite swpOp-sym-involutive f = refl
swpOp-sym-involutive swp = refl
swpOp-sym-involutive swp-seconds = refl

swpOp-sym-sound : ∀ {n a} {A : Set a} (f : SwpOp n) (t : Tree A n) → swpOp-sym f $swp (f $swp t) ≡ t
swpOp-sym-sound ε t = refl
swpOp-sym-sound (f ⁏ g) t rewrite swpOp-sym-sound g (f $swp t) | swpOp-sym-sound f t = refl
swpOp-sym-sound (first f) (fork t _) rewrite swpOp-sym-sound f t = refl
swpOp-sym-sound swp (fork _ _) = refl
swpOp-sym-sound swp-seconds (fork (fork _ _) (fork _ _)) = refl

module ¬swp-comm where
  data X : Set where
    A B C D E F G H : X
  n : ℕ
  n = 3
  t : Tree X n
  t = fork (fork (fork (leaf A) (leaf B))(fork (leaf C) (leaf D))) (fork (fork (leaf E) (leaf F))(fork (leaf G) (leaf H)))
  f : SwpOp n
  f = swp
  g : SwpOp n
  g = first swp
  pf : f $swp (g $swp t) ≢ g $swp (f $swp t)
  pf ()

swp-leaf : ∀ {a} {A : Set a} (f : SwpOp 0) (x : A) → f $swp (leaf x) ≡ leaf x
swp-leaf ε x = refl
swp-leaf (f ⁏ g) x rewrite swp-leaf f x | swp-leaf g x = refl

swpOp-sound : ∀ {n a} {A : Set a} {t u : Tree A n} (perm : Perm t u) → (swpOp perm $swp t ≡ u)
swpOp-sound ε = refl
swpOp-sound (f ⁏ f₁) rewrite swpOp-sound f | swpOp-sound f₁ = refl
swpOp-sound (first f) rewrite swpOp-sound f = refl
swpOp-sound swp = refl
swpOp-sound swp-seconds = refl

open import Relation.Nullary using (Dec ; yes ; no)
open import Relation.Nullary.Negation

module new-approach where

  open import Data.Empty

  import Function.Inverse as FI
  open FI using (_↔_; module Inverse; _InverseOf_)
  open import Function.Related
  import Function.Equality
  import Relation.Binary.PropositionalEquality as P

  data _∈_ {a}{A : Set a}(x : A) : {n : ℕ} → Tree A n → Set a where
    here  : x ∈ leaf x
    left  : {n : ℕ}{t₁ t₂ : Tree A n} → x ∈ t₁ → x ∈ fork t₁ t₂
    right : {n : ℕ}{t₁ t₂ : Tree A n} → x ∈ t₂ → x ∈ fork t₁ t₂

  toBits : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t : Tree A n} → x ∈ t → Bits n
  toBits here = []
  toBits (left key) = 0b ∷ toBits key
  toBits (right key) = 1b ∷ toBits key

  ∈-lookup : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t : Tree A n}(path : x ∈ t) → lookup (toBits path) t ≡ x
  ∈-lookup here = refl
  ∈-lookup (left path) = ∈-lookup path
  ∈-lookup (right path) = ∈-lookup path

  lookup-∈ : ∀ {a}{A : Set a}{n : ℕ}(key : Bits n)(t : Tree A n) → lookup key t ∈ t
  lookup-∈ [] (leaf x) = here
  lookup-∈ (true ∷ key) (fork tree tree₁) = right (lookup-∈ key tree₁)
  lookup-∈ (false ∷ key) (fork tree tree₁) = left (lookup-∈ key tree)

  _≈_ : ∀ {a}{A : Set a}{n : ℕ} → Tree A n → Tree A n → Set _
  t₁ ≈ t₂ = ∀ x → (x ∈ t₁) ↔ (x ∈ t₂)

  ≈-refl : {a : _}{A : Set a}{n : ℕ}{t : Tree A n} → t ≈ t
  ≈-refl _ = FI.id

  move : ∀ {a}{A : Set a}{n : ℕ}{t s : Tree A n}{x : A} → t ≈ s → x ∈ t → x ∈ s
  move t≈s x∈t = Inverse.to (t≈s _) Function.Equality.⟨$⟩ x∈t

  swap₀ : ∀ {a}{A : Set a}{n : ℕ}(t₁ t₂ : Tree A n) → fork t₁ t₂ ≈ fork t₂ t₁
  swap₀ t₁ t₂ = λ x → record
    { to         = →-to-⟶ swap
    ; from       = →-to-⟶ swap
    ; inverse-of = record { left-inverse-of  = swap-inv
                          ; right-inverse-of = swap-inv }
    } where
       swap : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t₁ t₂ : Tree A n} → x ∈ fork t₁ t₂ → x ∈ fork t₂ t₁
       swap (left path)  = right path
       swap (right path) = left path

       swap-inv : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t₁ t₂ : Tree A n}(p : x ∈ fork t₁ t₂) → swap (swap p) ≡ p
       swap-inv (left p)  = refl
       swap-inv (right p) = refl

  _⟨fork⟩_ : ∀ {a}{A : Set a}{n : ℕ}{t₁ t₂ s₁ s₂ : Tree A n} → t₁ ≈ s₁ → t₂ ≈ s₂ → fork t₁ t₂ ≈ fork s₁ s₂
  (t1≈s1 ⟨fork⟩ t2≈s2) y = record
    { to         = to
    ; from       = from
    ; inverse-of = record { left-inverse-of  = frk-linv
                          ; right-inverse-of = frk-rinv  }
    } where

        frk : ∀ {a}{A : Set a}{n : ℕ}{t₁ t₂ s₁ s₂ : Tree A n}{x : A} → t₁ ≈ s₁ → t₂ ≈ s₂ → x ∈ fork t₁ t₂ → x ∈ fork s₁ s₂
        frk t1≈s1 t2≈s2 (left x∈t1) = left (move t1≈s1 x∈t1)
        frk t1≈s1 t2≈s2 (right x∈t2) = right (move t2≈s2 x∈t2)

        to = →-to-⟶ (frk t1≈s1 t2≈s2)
        from = →-to-⟶ (frk (λ x → FI.sym (t1≈s1 x)) (λ x → FI.sym (t2≈s2 x)))

        open Function.Equality using (_⟨$⟩_)
        open import Function.LeftInverse

        frk-linv : from LeftInverseOf to
        frk-linv (left x) = cong left (_InverseOf_.left-inverse-of (Inverse.inverse-of (t1≈s1 y)) x)
        frk-linv (right x) = cong right (_InverseOf_.left-inverse-of (Inverse.inverse-of (t2≈s2 y)) x)

        frk-rinv : from RightInverseOf to -- ∀ x → to ⟨$⟩ (from ⟨$⟩ x) ≡ x
        frk-rinv (left x) = cong left (_InverseOf_.right-inverse-of (Inverse.inverse-of (t1≈s1 y)) x)
        frk-rinv (right x) = cong right (_InverseOf_.right-inverse-of (Inverse.inverse-of (t2≈s2 y)) x)

  Rot⟶≈ : ∀ {a}{A : Set a}{n : ℕ}{t₁ t₂ : Tree A n} → Rot t₁ t₂ → t₁ ≈ t₂
  Rot⟶≈ (leaf x)        y = FI.id
  Rot⟶≈ (fork rot rot₁) y = (Rot⟶≈ rot ⟨fork⟩ Rot⟶≈ rot₁) y
  Rot⟶≈ (krof {_} {l} {l'} {r} {r'} rot rot₁) y =
        y ∈ fork l r ↔⟨ (Rot⟶≈ rot ⟨fork⟩ Rot⟶≈ rot₁) y ⟩
        y ∈ fork r' l' ↔⟨ swap₀ r' l' y ⟩
        y ∈ fork l' r' ∎
    where open EquationalReasoning

  put : {a : _}{A : Set a}{n : ℕ} → Bits n → A → Tree A n → Tree A n
  put [] val tree = leaf val
  put (x ∷ key) val (fork tree tree₁) = if x then fork tree (put key val tree₁)
                                             else fork (put key val tree) tree₁

  -- move-me
  _∷≢_ : {n : ℕ}{xs ys : Bits n}(x : Bit) → x ∷ xs ≢ x ∷ ys → xs ≢ ys
  _∷≢_ x = contraposition $ cong $ _∷_ x

  ∈-put : {a : _}{A : Set a}{n : ℕ}(p : Bits n){x : A}(t : Tree A n) → x ∈ put p x t
  ∈-put [] t = here
  ∈-put (true ∷ p) (fork t t₁) = right (∈-put p t₁)
  ∈-put (false ∷ p) (fork t t₁) = left (∈-put p t)

  ∈-put-≢  : {a : _}{A : Set a}{n : ℕ}(p : Bits n){x y : A}{t : Tree A n}(path : x ∈ t)
          → p ≢ toBits path → x ∈ put p y t
  ∈-put-≢ [] here neg = ⊥-elim (neg refl)
  ∈-put-≢ (true ∷ p) (left path) neg   = left path
  ∈-put-≢ (false ∷ p) (left path) neg  = left (∈-put-≢ p path (false ∷≢ neg))
  ∈-put-≢ (true ∷ p) (right path) neg  = right (∈-put-≢ p path (true ∷≢ neg))
  ∈-put-≢ (false ∷ p) (right path) neg = right path

  swap : {a : _}{A : Set a}{n : ℕ} → (p₁ p₂ : Bits n) → Tree A n → Tree A n
  swap p₁ p₂ t = put p₁ a₂ (put p₂ a₁ t)
    where
      a₁ = lookup p₁ t
      a₂ = lookup p₂ t

  swap-perm₁ : {a : _}{A : Set a}{n : ℕ}{t : Tree A n}{x : A}(p : x ∈ t) → t ≈ swap (toBits p) (toBits p) t
  swap-perm₁ here         = ≈-refl
  swap-perm₁ (left path)  = swap-perm₁ path ⟨fork⟩ ≈-refl
  swap-perm₁ (right path) = ≈-refl ⟨fork⟩ swap-perm₁ path

  swap-comm : {a : _}{A : Set a}{n : ℕ} (p₁ p₂ : Bits n)(t : Tree A n) → swap p₂ p₁ t ≡ swap p₁ p₂ t
  swap-comm [] [] (leaf x) = refl
  swap-comm (true ∷ p₁) (true ∷ p₂) (fork t t₁) = cong (fork t) (swap-comm p₁ p₂ t₁)
  swap-comm (true ∷ p₁) (false ∷ p₂) (fork t t₁) = refl
  swap-comm (false ∷ p₁) (true ∷ p₂) (fork t t₁) = refl
  swap-comm (false ∷ p₁) (false ∷ p₂) (fork t t₁) = cong (flip fork t₁) (swap-comm p₁ p₂ t)

  swap-perm₂ : {a : _}{A : Set a}{n : ℕ}{t : Tree A n}{x : A}(p' : Bits n)(p : x ∈ t)
             → x ∈ swap (toBits p) p' t
  swap-perm₂ _ here = here
  swap-perm₂ (true ∷ p) (left path) rewrite ∈-lookup path = right (∈-put p _)
  swap-perm₂ (false ∷ p) (left path) = left (swap-perm₂ p path)
  swap-perm₂ (true ∷ p) (right path) = right (swap-perm₂ p path)
  swap-perm₂ (false ∷ p) (right path) rewrite ∈-lookup path = left (∈-put p _)

  swap-perm₃ : {a : _}{A : Set a}{n : ℕ}{t : Tree A n}{x : A}(p₁ p₂ : Bits n)(p : x ∈ t)
              → p₁ ≢ toBits p → p₂ ≢ toBits p → x ∈ swap p₁ p₂ t
  swap-perm₃ [] [] here neg₁ neg₂ = here
  swap-perm₃ (true ∷ p₁) (true ∷ p₂) (left path) neg₁ neg₂   = left path
  swap-perm₃ (true ∷ p₁) (false ∷ p₂) (left path) neg₁ neg₂  = left (∈-put-≢ _ path (false ∷≢ neg₂))
  swap-perm₃ (false ∷ p₁) (true ∷ p₂) (left path) neg₁ neg₂  = left (∈-put-≢ _ path (false ∷≢ neg₁))
  swap-perm₃ (false ∷ p₁) (false ∷ p₂) (left path) neg₁ neg₂ = left
             (swap-perm₃ p₁ p₂ path (false ∷≢ neg₁) (false ∷≢ neg₂))
  swap-perm₃ (true ∷ p₁) (true ∷ p₂) (right path) neg₁ neg₂   = right
             (swap-perm₃ p₁ p₂ path (true ∷≢ neg₁) (true ∷≢ neg₂))
  swap-perm₃ (true ∷ p₁) (false ∷ p₂) (right path) neg₁ neg₂  = right (∈-put-≢ _ path (true ∷≢ neg₁))
  swap-perm₃ (false ∷ p₁) (true ∷ p₂) (right path) neg₁ neg₂  = right (∈-put-≢ _ path (true ∷≢ neg₂))
  swap-perm₃ (false ∷ p₁) (false ∷ p₂) (right path) neg₁ neg₂ = right path

module FoldProp {a} {A : Set a} (_·_ : Op₂ A) (op-comm : Commutative _≡_ _·_) (op-assoc : Associative _≡_ _·_) where

  ⟪_⟫ : ∀ {n} → Tree A n → A
  ⟪_⟫ = fold _·_

  _=[fold]⇒′_ : ∀ {ℓ₁ ℓ₂} → (∀ {m n} → REL (Tree A m) (Tree A n) ℓ₁) → Rel A ℓ₂ → Set _
  -- _∼₀_ =[fold]⇒ _∼₁_ = ∀ {m n} → _∼₀_ {m} {n} =[ fold {n} _·_ ]⇒ _∼₁_
  _∼₀_ =[fold]⇒′ _∼₁_ = ∀ {m n} {t : Tree A m} {u : Tree A n} → t ∼₀ u → ⟪ t ⟫ ∼₁ ⟪ u ⟫

  _=[fold]⇒_ : ∀ {ℓ₁ ℓ₂} → (∀ {n} → Rel (Tree A n) ℓ₁) → Rel A ℓ₂ → Set _
  _∼₀_ =[fold]⇒ _∼₁_ = ∀ {n} → _∼₀_ =[ fold {n} _·_ ]⇒ _∼₁_

  fold-rot : Rot =[fold]⇒ _≡_
  fold-rot (leaf x) = refl
  fold-rot (fork rot rot₁) = cong₂ _·_ (fold-rot rot) (fold-rot rot₁)
  fold-rot (krof rot rot₁) rewrite fold-rot rot | fold-rot rot₁ = op-comm _ _

  -- t ∼ u → fork v t ∼ fork u w

  lem : ∀ x y z t → (x · y) · (z · t) ≡ (t · y) · (z · x)
  lem x y z t = (x · y) · (z · t)
              ≡⟨ op-assoc x y _ ⟩
                x · (y · (z · t))
              ≡⟨ op-comm x _ ⟩
                (y · (z · t)) · x
              ≡⟨ op-assoc y (z · t) _ ⟩
                y · ((z · t) · x)
              ≡⟨ cong (λ u → y · (u · x)) (op-comm z t) ⟩
                y · ((t · z) · x)
              ≡⟨ cong (_·_ y) (op-assoc t z x) ⟩
                y · (t · (z · x))
              ≡⟨ sym (op-assoc y t _) ⟩
                (y · t) · (z · x)
              ≡⟨ cong (λ u → u · (z · x)) (op-comm y t) ⟩
                (t · y) · (z · x)
              ∎
    where open ≡-Reasoning

  fold-swp : Swp =[fold]⇒ _≡_
  fold-swp (left pf) rewrite fold-swp pf = refl
  fold-swp (right pf) rewrite fold-swp pf = refl
  fold-swp swp₁ = op-comm _ _
  fold-swp (swp₂ {_} {t₀₀} {t₀₁} {t₁₀} {t₁₁}) = lem ⟪ t₀₀ ⟫ ⟪ t₀₁ ⟫ ⟪ t₁₀ ⟫ ⟪ t₁₁ ⟫

  fold-swp★ : Swp★ =[fold]⇒ _≡_
  fold-swp★ ε = refl
  fold-swp★ (x ◅ xs) rewrite fold-swp x | fold-swp★ xs = refl

module prefect-bintree where

open import Function
open import Data.Nat.NP using (ℕ; zero; suc; 2^_; _+_)
open import Data.Bool
open import Data.Bits
open import Data.Vec using (Vec; _++_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import Algebra.FunctionProperties

data Tree {a} (A : Set a) : ℕ → Set a where
  leaf : (x : A) → Tree A zero
  fork : ∀ {n} (left right : Tree A n) → Tree A (suc n)

fromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Tree A n
fromFun {zero} f = leaf (f [])
fromFun {suc n} f = fork (fromFun (f ∘ 0∷_)) (fromFun (f ∘ 1∷_))

toFun : ∀ {n a} {A : Set a} → Tree A n → Bits n → A
toFun (leaf x) _ = x
toFun (fork left right) (b ∷ bs) = toFun (if b then right else left) bs

lookup : ∀ {n a} {A : Set a} → Bits n → Tree A n → A
lookup = flip toFun

fold : ∀ {n a} {A : Set a} (op : A → A → A) → Tree A n → A
fold _   (leaf x) = x
fold _·_ (fork t₀ t₁) = fold _·_ t₀ · fold _·_ t₁

search≡fold∘fromFun : ∀ {n a} {A : Set a} op (f : Bits n → A) → search op f ≡ fold op (fromFun f)
search≡fold∘fromFun {zero}  op f = refl
search≡fold∘fromFun {suc n} op f
  rewrite search≡fold∘fromFun op (f ∘ 0∷_)
        | search≡fold∘fromFun op (f ∘ 1∷_) = refl

-- Returns the flat vector of leaves underlying the perfect binary tree.
toVec : ∀ {n a} {A : Set a} → Tree A n → Vec A (2^ n)
toVec (leaf x)     = x ∷ []
toVec (fork t₀ t₁) = toVec t₀ ++ toVec t₁

lookup' : ∀ {m n a} {A : Set a} → Bits m → Tree A (m + n) → Tree A n
lookup' [] t = t
lookup' (b ∷ bs) (fork t t₁) = lookup' bs (if b then t₁ else t)

update' : ∀ {m n a} {A : Set a} → Bits m → Tree A n → Tree A (m + n) → Tree A (m + n)
update' [] val tree = val
update' (b ∷ key) val (fork tree tree₁) = if b then fork tree (update' key val tree₁)
                                               else fork (update' key val tree) tree₁

map : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → Tree A n → Tree B n
map f (leaf x) = leaf (f x)
map f (fork t₀ t₁) = fork (map f t₀) (map f t₁)

open import Relation.Binary
open import Data.Star using (Star; ε; _◅_)

data Swp {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  left : ∀ {n} {left₀ left₁ right : Tree A n} →
         Swp left₀ left₁ →
         Swp (fork left₀ right) (fork left₁ right)
  right : ∀ {n} {left right₀ right₁ : Tree A n} →
         Swp right₀ right₁ →
         Swp (fork left right₀) (fork left right₁)
  swp₁ : ∀ {n} {left right : Tree A n} →
         Swp (fork left right) (fork right left)
  swp₂ : ∀ {n} {t₀₀ t₀₁ t₁₀ t₁₁ : Tree A n} →
         Swp (fork (fork t₀₀ t₀₁) (fork t₁₀ t₁₁)) (fork (fork t₁₁ t₀₁) (fork t₁₀ t₀₀))

Swp★ : ∀ {n a} {A : Set a} (left right : Tree A n) → Set a
Swp★ = Star Swp

Swp-sym : ∀ {n a} {A : Set a} → Symmetric (Swp {A = A} {n})
Swp-sym (left s)  = left (Swp-sym s)
Swp-sym (right s) = right (Swp-sym s)
Swp-sym swp₁      = swp₁
Swp-sym swp₂      = swp₂

data Rot {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  leaf : ∀ x → Rot (leaf x) (leaf x)
  fork : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ left₁ →
         Rot right₀ right₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)
  krof : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ right₁ →
         Rot right₀ left₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)

Rot-refl : ∀ {n a} {A : Set a} → Reflexive (Rot {A = A} {n})
Rot-refl {x = leaf x} = leaf x
Rot-refl {x = fork _ _} = fork Rot-refl Rot-refl

Rot-sym : ∀ {n a} {A : Set a} → Symmetric (Rot {A = A} {n})
Rot-sym (leaf x) = leaf x
Rot-sym (fork p₀ p₁) = fork (Rot-sym p₀) (Rot-sym p₁)
Rot-sym (krof p₀ p₁) = krof (Rot-sym p₁) (Rot-sym p₀)

Rot-trans : ∀ {n a} {A : Set a} → Transitive (Rot {A = A} {n})
Rot-trans (leaf x) q = q
Rot-trans (fork p₀ p₁) (fork q₀ q₁) = fork (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (fork p₀ p₁) (krof q₀ q₁) = krof (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (krof p₀ p₁) (fork q₀ q₁) = krof (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)
Rot-trans (krof p₀ p₁) (krof q₀ q₁) = fork (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)

data AC {a} {A : Set a} : ∀ {m n} (left : Tree A m) (right : Tree A n) → Set a where
  ε : ∀ {n} {t : Tree A n} → AC t t

  _⁏_ : ∀ {m n o} {t : Tree A m} {u : Tree A n} {v : Tree A o} → AC t u → AC u v → AC t v

  first : ∀ {n} {left₀ left₁ right : Tree A n} →
         AC left₀ left₁ →
         AC (fork left₀ right) (fork left₁ right)

  swp : ∀ {n} {left right : Tree A n} →
         AC (fork left right) (fork right left)

  swp₂ : ∀ {n} {t₀₀ t₀₁ t₁₀ t₁₁ : Tree A n} →
         AC (fork (fork t₀₀ t₀₁) (fork t₁₀ t₁₁)) (fork (fork t₁₁ t₀₁) (fork t₁₀ t₀₀))
         {-
  zip : ∀ {m n} {t₀₀ t₀₁ t₁₀ t₁₁ : Tree A m} {u₀ u₁ : Tree A n} →
            AC (fork t₀₀ t₁₁) u₀ →
            AC (fork t₀₁ t₁₀) u₁ →
            AC (fork (fork t₀₀ t₀₁) (fork t₁₀ t₁₁)) (fork u₀ u₁)
            -}

infixr 1 _⁏_

second-AC : ∀ {a} {A : Set a} {n} {left right₀ right₁ : Tree A n} →
           AC right₀ right₁ →
           AC (fork left right₀) (fork left right₁)
second-AC f = swp ⁏ first f ⁏ swp

<_×_>-AC : ∀ {a} {A : Set a} {n} {left₀ right₀ left₁ right₁ : Tree A n} →
           AC left₀ left₁ →
           AC right₀ right₁ →
           AC (fork left₀ right₀) (fork left₁ right₁)
< f × g >-AC = first f ⁏ second-AC g

swp₃-AC : ∀ {a n} {A : Set a} {t₀₀ t₀₁ t₁₀ t₁₁ : Tree A n} →
         AC (fork (fork t₀₀ t₀₁) (fork t₁₀ t₁₁)) (fork (fork t₀₀ t₁₀) (fork t₀₁ t₁₁))
swp₃-AC = < swp × swp >-AC ⁏ swp₂ ⁏ < swp × swp >-AC

Swp⇒AC : ∀ {n a} {A : Set a} → Swp {a} {A} {n} ⇒ AC {n = n}
Swp⇒AC (left pf) = first (Swp⇒AC pf)
Swp⇒AC (right pf) = second-AC (Swp⇒AC pf)
Swp⇒AC swp₁ = swp
Swp⇒AC (swp₂ {t₀₀ = A} {B} {C} {D}) = swp₂ -- zip {!!} {!!} {-first swp ⁏ zip swp ε ⁏ {!!}-}

Swp★⇒AC : ∀ {n a} {A : Set a} → Swp★ {n} {a} {A} ⇒ AC {n = n}
Swp★⇒AC ε         = ε
Swp★⇒AC (x ◅ xs) = Swp⇒AC x ⁏ Swp★⇒AC xs

open import Relation.Nullary using (Dec ; yes ; no)
open import Relation.Nullary.Negation

module new-approach where

  open import Data.Empty

  import Function.Inverse as FI
  open FI using (_↔_; module Inverse; _InverseOf_)
  open import Function.Related
  import Function.Equality
  import Relation.Binary.PropositionalEquality as P

  data _∈_ {a}{A : Set a}(x : A) : {n : ℕ} → Tree A n → Set a where
    here  : x ∈ leaf x
    left  : {n : ℕ}{t₁ t₂ : Tree A n} → x ∈ t₁ → x ∈ fork t₁ t₂
    right : {n : ℕ}{t₁ t₂ : Tree A n} → x ∈ t₂ → x ∈ fork t₁ t₂

  toBits : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t : Tree A n} → x ∈ t → Bits n
  toBits here = []
  toBits (left key) = 0b ∷ toBits key
  toBits (right key) = 1b ∷ toBits key

  ∈-lookup : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t : Tree A n}(path : x ∈ t) → lookup (toBits path) t ≡ x
  ∈-lookup here = refl
  ∈-lookup (left path) = ∈-lookup path
  ∈-lookup (right path) = ∈-lookup path

  lookup-∈ : ∀ {a}{A : Set a}{n : ℕ}(key : Bits n)(t : Tree A n) → lookup key t ∈ t
  lookup-∈ [] (leaf x) = here
  lookup-∈ (true ∷ key) (fork tree tree₁) = right (lookup-∈ key tree₁)
  lookup-∈ (false ∷ key) (fork tree tree₁) = left (lookup-∈ key tree)

  _≈_ : ∀ {a}{A : Set a}{n : ℕ} → Tree A n → Tree A n → Set _
  t₁ ≈ t₂ = ∀ x → (x ∈ t₁) ↔ (x ∈ t₂)

  ≈-refl : {a : _}{A : Set a}{n : ℕ}{t : Tree A n} → t ≈ t
  ≈-refl _ = FI.id

  move : ∀ {a}{A : Set a}{n : ℕ}{t s : Tree A n}{x : A} → t ≈ s → x ∈ t → x ∈ s
  move t≈s x∈t = Inverse.to (t≈s _) Function.Equality.⟨$⟩ x∈t

  swap₀ : ∀ {a}{A : Set a}{n : ℕ}(t₁ t₂ : Tree A n) → fork t₁ t₂ ≈ fork t₂ t₁
  swap₀ t₁ t₂ = λ x → record
    { to         = →-to-⟶ swap
    ; from       = →-to-⟶ swap
    ; inverse-of = record { left-inverse-of  = swap-inv
                          ; right-inverse-of = swap-inv }
    } where
       swap : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t₁ t₂ : Tree A n} → x ∈ fork t₁ t₂ → x ∈ fork t₂ t₁
       swap (left path)  = right path
       swap (right path) = left path

       swap-inv : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t₁ t₂ : Tree A n}(p : x ∈ fork t₁ t₂) → swap (swap p) ≡ p
       swap-inv (left p)  = refl
       swap-inv (right p) = refl

  _⟨fork⟩_ : ∀ {a}{A : Set a}{n : ℕ}{t₁ t₂ s₁ s₂ : Tree A n} → t₁ ≈ s₁ → t₂ ≈ s₂ → fork t₁ t₂ ≈ fork s₁ s₂
  (t1≈s1 ⟨fork⟩ t2≈s2) y = record
    { to         = to
    ; from       = from
    ; inverse-of = record { left-inverse-of  = frk-linv
                          ; right-inverse-of = frk-rinv  }
    } where

        frk : ∀ {a}{A : Set a}{n : ℕ}{t₁ t₂ s₁ s₂ : Tree A n}{x : A} → t₁ ≈ s₁ → t₂ ≈ s₂ → x ∈ fork t₁ t₂ → x ∈ fork s₁ s₂
        frk t1≈s1 t2≈s2 (left x∈t1) = left (move t1≈s1 x∈t1)
        frk t1≈s1 t2≈s2 (right x∈t2) = right (move t2≈s2 x∈t2)

        to = →-to-⟶ (frk t1≈s1 t2≈s2)
        from = →-to-⟶ (frk (λ x → FI.sym (t1≈s1 x)) (λ x → FI.sym (t2≈s2 x)))

        open Function.Equality using (_⟨$⟩_)
        open import Function.LeftInverse

        frk-linv : from LeftInverseOf to
        frk-linv (left x) = cong left (_InverseOf_.left-inverse-of (Inverse.inverse-of (t1≈s1 y)) x)
        frk-linv (right x) = cong right (_InverseOf_.left-inverse-of (Inverse.inverse-of (t2≈s2 y)) x)

        frk-rinv : from RightInverseOf to -- ∀ x → to ⟨$⟩ (from ⟨$⟩ x) ≡ x
        frk-rinv (left x) = cong left (_InverseOf_.right-inverse-of (Inverse.inverse-of (t1≈s1 y)) x)
        frk-rinv (right x) = cong right (_InverseOf_.right-inverse-of (Inverse.inverse-of (t2≈s2 y)) x)

  Rot⟶≈ : ∀ {a}{A : Set a}{n : ℕ}{t₁ t₂ : Tree A n} → Rot t₁ t₂ → t₁ ≈ t₂
  Rot⟶≈ (leaf x)        y = FI.id
  Rot⟶≈ (fork rot rot₁) y = (Rot⟶≈ rot ⟨fork⟩ Rot⟶≈ rot₁) y
  Rot⟶≈ (krof {_} {l} {l'} {r} {r'} rot rot₁) y =
        y ∈ fork l r ↔⟨ (Rot⟶≈ rot ⟨fork⟩ Rot⟶≈ rot₁) y ⟩
        y ∈ fork r' l' ↔⟨ swap₀ r' l' y ⟩
        y ∈ fork l' r' ∎
    where open EquationalReasoning

  put : {a : _}{A : Set a}{n : ℕ} → Bits n → A → Tree A n → Tree A n
  put [] val tree = leaf val
  put (x ∷ key) val (fork tree tree₁) = if x then fork tree (put key val tree₁)
                                             else fork (put key val tree) tree₁

  -- move-me
  _∷≢_ : {n : ℕ}{xs ys : Bits n}(x : Bit) → x ∷ xs ≢ x ∷ ys → xs ≢ ys
  _∷≢_ x = contraposition $ cong $ _∷_ x

  ∈-put : {a : _}{A : Set a}{n : ℕ}(p : Bits n){x : A}(t : Tree A n) → x ∈ put p x t
  ∈-put [] t = here
  ∈-put (true ∷ p) (fork t t₁) = right (∈-put p t₁)
  ∈-put (false ∷ p) (fork t t₁) = left (∈-put p t)

  ∈-put-≢  : {a : _}{A : Set a}{n : ℕ}(p : Bits n){x y : A}{t : Tree A n}(path : x ∈ t)
          → p ≢ toBits path → x ∈ put p y t
  ∈-put-≢ [] here neg = ⊥-elim (neg refl)
  ∈-put-≢ (true ∷ p) (left path) neg   = left path
  ∈-put-≢ (false ∷ p) (left path) neg  = left (∈-put-≢ p path (false ∷≢ neg))
  ∈-put-≢ (true ∷ p) (right path) neg  = right (∈-put-≢ p path (true ∷≢ neg))
  ∈-put-≢ (false ∷ p) (right path) neg = right path

  swap : {a : _}{A : Set a}{n : ℕ} → (p₁ p₂ : Bits n) → Tree A n → Tree A n
  swap p₁ p₂ t = put p₁ a₂ (put p₂ a₁ t)
    where
      a₁ = lookup p₁ t
      a₂ = lookup p₂ t

  swap-perm₁ : {a : _}{A : Set a}{n : ℕ}{t : Tree A n}{x : A}(p : x ∈ t) → t ≈ swap (toBits p) (toBits p) t
  swap-perm₁ here         = ≈-refl
  swap-perm₁ (left path)  = swap-perm₁ path ⟨fork⟩ ≈-refl
  swap-perm₁ (right path) = ≈-refl ⟨fork⟩ swap-perm₁ path

  swap-comm : {a : _}{A : Set a}{n : ℕ} (p₁ p₂ : Bits n)(t : Tree A n) → swap p₂ p₁ t ≡ swap p₁ p₂ t
  swap-comm [] [] (leaf x) = refl
  swap-comm (true ∷ p₁) (true ∷ p₂) (fork t t₁) = cong (fork t) (swap-comm p₁ p₂ t₁)
  swap-comm (true ∷ p₁) (false ∷ p₂) (fork t t₁) = refl
  swap-comm (false ∷ p₁) (true ∷ p₂) (fork t t₁) = refl
  swap-comm (false ∷ p₁) (false ∷ p₂) (fork t t₁) = cong (flip fork t₁) (swap-comm p₁ p₂ t)

  swap-perm₂ : {a : _}{A : Set a}{n : ℕ}{t : Tree A n}{x : A}(p' : Bits n)(p : x ∈ t)
             → x ∈ swap (toBits p) p' t
  swap-perm₂ _ here = here
  swap-perm₂ (true ∷ p) (left path) rewrite ∈-lookup path = right (∈-put p _)
  swap-perm₂ (false ∷ p) (left path) = left (swap-perm₂ p path)
  swap-perm₂ (true ∷ p) (right path) = right (swap-perm₂ p path)
  swap-perm₂ (false ∷ p) (right path) rewrite ∈-lookup path = left (∈-put p _)

  swap-perm₃ : {a : _}{A : Set a}{n : ℕ}{t : Tree A n}{x : A}(p₁ p₂ : Bits n)(p : x ∈ t)
              → p₁ ≢ toBits p → p₂ ≢ toBits p → x ∈ swap p₁ p₂ t
  swap-perm₃ [] [] here neg₁ neg₂ = here
  swap-perm₃ (true ∷ p₁) (true ∷ p₂) (left path) neg₁ neg₂   = left path
  swap-perm₃ (true ∷ p₁) (false ∷ p₂) (left path) neg₁ neg₂  = left (∈-put-≢ _ path (false ∷≢ neg₂))
  swap-perm₃ (false ∷ p₁) (true ∷ p₂) (left path) neg₁ neg₂  = left (∈-put-≢ _ path (false ∷≢ neg₁))
  swap-perm₃ (false ∷ p₁) (false ∷ p₂) (left path) neg₁ neg₂ = left
             (swap-perm₃ p₁ p₂ path (false ∷≢ neg₁) (false ∷≢ neg₂))
  swap-perm₃ (true ∷ p₁) (true ∷ p₂) (right path) neg₁ neg₂   = right
             (swap-perm₃ p₁ p₂ path (true ∷≢ neg₁) (true ∷≢ neg₂))
  swap-perm₃ (true ∷ p₁) (false ∷ p₂) (right path) neg₁ neg₂  = right (∈-put-≢ _ path (true ∷≢ neg₁))
  swap-perm₃ (false ∷ p₁) (true ∷ p₂) (right path) neg₁ neg₂  = right (∈-put-≢ _ path (true ∷≢ neg₂))
  swap-perm₃ (false ∷ p₁) (false ∷ p₂) (right path) neg₁ neg₂ = right path

module FoldProp {a} {A : Set a} (_·_ : Op₂ A) (op-comm : Commutative _≡_ _·_) (op-assoc : Associative _≡_ _·_) where

  ⟪_⟫ : ∀ {n} → Tree A n → A
  ⟪_⟫ = fold _·_

  _=[fold]⇒′_ : ∀ {ℓ₁ ℓ₂} → (∀ {m n} → REL (Tree A m) (Tree A n) ℓ₁) → Rel A ℓ₂ → Set _
  -- _∼₀_ =[fold]⇒ _∼₁_ = ∀ {m n} → _∼₀_ {m} {n} =[ fold {n} _·_ ]⇒ _∼₁_
  _∼₀_ =[fold]⇒′ _∼₁_ = ∀ {m n} {t : Tree A m} {u : Tree A n} → t ∼₀ u → ⟪ t ⟫ ∼₁ ⟪ u ⟫

  _=[fold]⇒_ : ∀ {ℓ₁ ℓ₂} → (∀ {n} → Rel (Tree A n) ℓ₁) → Rel A ℓ₂ → Set _
  _∼₀_ =[fold]⇒ _∼₁_ = ∀ {n} → _∼₀_ =[ fold {n} _·_ ]⇒ _∼₁_

  fold-rot : Rot =[fold]⇒ _≡_
  fold-rot (leaf x) = refl
  fold-rot (fork rot rot₁) = cong₂ _·_ (fold-rot rot) (fold-rot rot₁)
  fold-rot (krof rot rot₁) rewrite fold-rot rot | fold-rot rot₁ = op-comm _ _

  -- t ∼ u → fork v t ∼ fork u w

  lem : ∀ x y z t → (x · y) · (z · t) ≡ (t · y) · (z · x)
  lem x y z t = (x · y) · (z · t)
              ≡⟨ op-assoc x y _ ⟩
                x · (y · (z · t))
              ≡⟨ op-comm x _ ⟩
                (y · (z · t)) · x
              ≡⟨ op-assoc y (z · t) _ ⟩
                y · ((z · t) · x)
              ≡⟨ cong (λ u → y · (u · x)) (op-comm z t) ⟩
                y · ((t · z) · x)
              ≡⟨ cong (_·_ y) (op-assoc t z x) ⟩
                y · (t · (z · x))
              ≡⟨ sym (op-assoc y t _) ⟩
                (y · t) · (z · x)
              ≡⟨ cong (λ u → u · (z · x)) (op-comm y t) ⟩
                (t · y) · (z · x)
              ∎
    where open ≡-Reasoning

  fold-swp : Swp =[fold]⇒ _≡_
  fold-swp (left pf) rewrite fold-swp pf = refl
  fold-swp (right pf) rewrite fold-swp pf = refl
  fold-swp swp₁ = op-comm _ _
  fold-swp (swp₂ {_} {t₀₀} {t₀₁} {t₁₀} {t₁₁}) = lem ⟪ t₀₀ ⟫ ⟪ t₀₁ ⟫ ⟪ t₁₀ ⟫ ⟪ t₁₁ ⟫

  fold-swp★ : Swp★ =[fold]⇒ _≡_
  fold-swp★ ε = refl
  fold-swp★ (x ◅ xs) rewrite fold-swp x | fold-swp★ xs = refl


IDesc example: rework Hutton shaver with a more traditional context

 {-# OPTIONS --type-in-type #-}

module IDescTT where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Sigma and friends
--****************

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A : Set)(B : Set) -> Set
A * B = Sigma A \_ -> B

fst : {A : Set}{B : A -> Set} -> Sigma A B -> A
fst (a , _) = a

snd : {A : Set}{B : A -> Set} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero : Set where
data Unit  : Set where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ (A : Set)(B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

subst : forall {x y} -> x == y -> x -> y
subst refl x = x

cong : {A B : Set}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {A B C : Set}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

postulate
  reflFun : {A B : Set}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--****************
-- Meta-language
--****************

-- Note that we could define Nat, Bool, and the related operations in
-- IDesc. But it is awful to code with them, in Agda.

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Bool : Set where
  true : Bool
  false : Bool

plus : Nat -> Nat -> Nat
plus ze n' = n'
plus (su n) n' = su (plus n n')

le : Nat -> Nat -> Bool
le ze _ = true
le (su _) ze = false
le (su n) (su n') = le n n'

--********************************************
-- Desc code
--********************************************

data IDesc (I : Set) : Set where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

[|_|] : {I : Set} -> IDesc I -> (I -> Set) -> Set
[| var i |] P = P i
[| const X |] P = X
[| prod D D' |] P = [| D |] P * [| D' |] P
[| sigma S T |] P = Sigma S (\s -> [| T s |] P)
[| pi S T |] P = (s : S) -> [| T s |] P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {I : Set}(R : I -> IDesc I)(i : I) : Set where
  con : [| R i |] (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: All
--********************************************

All : {I : Set}(D : IDesc I)(P : I -> Set) -> [| D |] P -> IDesc (Sigma I P)
All (var i)     P x        = var (i , x)
All (const X)   P x        = const Unit
All (prod D D') P (d , d') = prod (All D P d) (All D' P d')
All (sigma S T) P (a , b)  = All (T a) P b
All (pi S T)    P f        = pi S (\s -> All (T s) P (f s))

all : {I : Set}(D : IDesc I)(X : I -> Set)
      (R : Sigma I X -> Set)(P : (x : Sigma I X) -> R x) ->
      (xs : [| D |] X) -> [| All D X xs |] R
all (var i) X R P x = P (i , x)
all (const K) X R P k = Void
all (prod D D') X R P (x , y) = ( all D X R P x , all D' X R P y )
all (sigma S T) X R P (a , b) = all (T a) X R P b
all (pi S T) X R P f = \a -> all (T a) X R P (f a)

--********************************************
-- Elimination principle: induction
--********************************************

-- One would like to write the following:

{-
indI : {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
indI {I} R P m i (con xs) = m i xs (all (R i) (IMu R) P induct xs)
  where induct : (x : Sigma I (IMu R)) -> P x
        induct (i , xs) = indI R P m i xs
-}

-- But the termination-checker complains, so here we go
-- inductive-recursive:

module Elim {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs ))
       where

  mutual
    indI : (i : I)(x : IMu R i) -> P (i , x)
    indI i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : [| D |] (IMu R)) ->
           [| All D (IMu R) xs |] P
    hyps (var i) x = indI i x
    hyps (const X) x = Void
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

indI : {I : Set}
       (R : I -> IDesc I)
       (P : Sigma I (IMu R) -> Set)
       (m : (i : I)
            (xs : [| R i |] (IMu R))
            (hs : [| All (R i) (IMu R) xs |] P) ->
            P ( i , con xs)) ->
       (i : I)(x : IMu R i) -> P ( i , x )
indI = Elim.indI

--********************************************
-- Examples
--********************************************

--****************
-- Nat
--****************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> IDesc Unit
natCases Ze = const Unit
natCases Suc = var Void

NatD : Unit -> IDesc Unit
NatD Void = sigma NatConst  natCases

Natd : Unit -> Set
Natd x = IMu NatD x

zed : Natd Void
zed = con (Ze , Void)

sud : Natd Void -> Natd Void
sud n = con (Su , n)

--****************
-- Desc
--****************

data DescDConst : Set where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : Set -> DescDConst -> IDesc Unit
descDChoice I lvar = const I
descDChoice _ lconst = const Set
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma Set (\S -> pi S (\s -> var Void))
descDChoice _ lsigma = sigma Set (\S -> pi S (\s -> var Void))

descD : (I : Set) -> IDesc Unit
descD I = sigma DescDConst (descDChoice I)

IDescl0 : (I : Set) -> Unit -> Set
IDescl0 I = IMu (\_ -> descD I)

IDescl : (I : Set) -> Set
IDescl I = IDescl0 I _

varl : {I : Set}(i : I) -> IDescl I
varl i = con (lvar ,  i)

constl : {I : Set}(X : Set) -> IDescl I
constl X = con (lconst , X)

prodl : {I : Set}(D D' : IDescl I) -> IDescl I
prodl D D' = con (lprod , (D , D'))

pil : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
pil S T = con (lpi , ( S , T))

sigmal : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
sigmal S T = con (lsigma , ( S , T))

--****************
-- Vec (constraints)
--****************

data VecConst : Set where
  Vnil : VecConst
  Vcons : VecConst

vecDChoice : Set -> Nat -> VecConst -> IDesc Nat
vecDChoice X n Vnil = const (n == ze)
vecDChoice X n Vcons = sigma Nat (\m -> prod (var m) (const (n == su m)))

vecD : Set -> Nat -> IDesc Nat
vecD X n = sigma VecConst (vecDChoice X n)

vec : Set -> Nat -> Set
vec X n = IMu (vecD X) n

--****************
-- Vec (de-tagged, forced)
--****************

data VecConst2 : Nat -> Set where
  Vnil : VecConst2 ze
  Vcons : {n : Nat} -> VecConst2 (su n)

vecDChoice2 : Set -> (n : Nat) -> VecConst2 n -> IDesc Nat
vecDChoice2 X ze Vnil = const Unit
vecDChoice2 X (su n) Vcons = prod (const X) (var n)

vecD2 : Set -> Nat -> IDesc Nat
vecD2 X n = sigma (VecConst2 n) (vecDChoice2 X n)

vec2 : Set -> Nat -> Set
vec2 X n = IMu (vecD2 X) n

--****************
-- Fin (de-tagged)
--****************

data FinConst : Nat -> Set where
  Fz : {n : Nat} -> FinConst (su n)
  Fs : {n : Nat} -> FinConst (su n)

finDChoice : (n : Nat) -> FinConst n -> IDesc Nat
finDChoice ze ()
finDChoice (su n) Fz = const Unit
finDChoice (su n) Fs = var n

finD : Nat -> IDesc Nat
finD n = sigma (FinConst n) (finDChoice n)

fin : Nat -> Set
fin n = IMu finD n

--********************************************
-- Enumerations (hard-coded)
--********************************************

-- Unlike in Desc.agda, we don't carry the levitation of finite sets
-- here. We hard-code them and manipulate with standard Agda
-- machinery. Both presentation are isomorph but, in Agda, the coded
-- one quickly gets unusable.

data EnumU : Set where
  nilE : EnumU
  consE : EnumU -> EnumU

data EnumT : (e : EnumU) -> Set where
  EZe : {e : EnumU} -> EnumT (consE e)
  ESu : {e : EnumU} -> EnumT e -> EnumT (consE e)

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi nilE P = Unit
spi (consE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : EnumU)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nilE P b ()
switch (consE e) P b EZe = fst b
switch (consE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n

_++_ : EnumU -> EnumU -> EnumU
nilE ++ e' = e'
(consE e) ++ e' = consE (e ++ e')

-- A special switch, for tagged descriptions. Switching on a
-- concatenation of finite sets:
sswitch : (e : EnumU)(e' : EnumU)(P : Set)
       (b : spi e (\_ -> P))(b' : spi e' (\_ -> P))(x : EnumT (e ++ e')) -> P
sswitch nilE nilE P b b' ()
sswitch nilE (consE e') P b b' EZe = fst b'
sswitch nilE (consE e') P b b' (ESu n) = sswitch nilE e' P b (snd b') n
sswitch (consE e) e' P b b' EZe = fst b
sswitch (consE e) e' P b b' (ESu n) = sswitch e e' P (snd b) b' n

--********************************************
-- Tagged indexed description
--********************************************

FixMenu : Set -> Set
FixMenu I = Sigma EnumU (\e -> (i : I) -> spi e (\_ -> IDesc I))

SensitiveMenu : Set -> Set
SensitiveMenu I = Sigma (I -> EnumU) (\F -> (i : I) -> spi (F i) (\_ -> IDesc I))

TagIDesc : Set -> Set
TagIDesc I = FixMenu I * SensitiveMenu I

toIDesc : (I : Set) -> TagIDesc I -> (I -> IDesc I)
toIDesc I ((E , ED) , (F , FD)) i = sigma (EnumT (E ++ F i))
                                          (\x -> sswitch E (F i) (IDesc I) (ED i) (FD i) x)

--********************************************
-- Catamorphism
--********************************************

cata : (I : Set)
       (R : I -> IDesc I)
       (T : I -> Set) ->
       ((i : I) -> [| R i |] T -> T i) ->
       (i : I) -> IMu R i -> T i
cata I R T phi i x = indI R (\it -> T (fst it)) (\i xs ms -> phi i (replace (R i) T xs ms)) i x
  where replace : (D : IDesc I)(T : I -> Set)
                  (xs : [| D |] (IMu R))
                  (ms : [| All D (IMu R) xs |] (\it -> T (fst it))) ->
                  [| D |] T
        replace (var i) T x y = y
        replace (const Z) T z z' = z
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Hutton's razor
--********************************************

--********************************
-- Types code
--********************************

data Type : Set where
  nat : Type
  bool : Type

--********************************
-- Typed expressions
--********************************

-- Fix menu:
exprFixMenu : (Type -> Set) -> FixMenu Type
exprFixMenu constt = ( consE (consE nilE) ,
                       \ty -> (const (constt ty),                        -- Val t
                              (prod (var bool) (prod (var ty) (var ty)), -- if b then t1 else t2
                               Void)))

-- Indexed menu:
choiceMenu : Type -> EnumU
choiceMenu nat = consE nilE
choiceMenu bool = consE nilE

choiceDessert : (ty : Type) -> spi (choiceMenu ty) (\ _ -> IDesc Type)
choiceDessert nat = (prod (var nat) (var nat) , Void)
choiceDessert bool = (prod (var nat) (var nat) , Void )

exprSensitiveMenu : SensitiveMenu Type
exprSensitiveMenu = ( choiceMenu ,  choiceDessert )

-- Expression:
expr : (Type -> Set) -> TagIDesc Type
expr constt = exprFixMenu constt , exprSensitiveMenu

exprIDesc : (Type -> Set) -> ((Type -> Set) -> TagIDesc Type) -> (Type -> IDesc Type)
exprIDesc constt D = toIDesc Type  (D constt)

--********************************
-- Closed terms
--********************************

Val : Type -> Set
Val nat = Nat
Val bool = Bool

closeTerm : Type -> IDesc Type
closeTerm = exprIDesc Val expr

--********************************
-- Closed term evaluation
--********************************

eval : (ty : Type) -> IMu closeTerm ty -> Val ty
eval ty term = cata Type closeTerm Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm ty |] Val -> Val ty
              evalOneStep _ (EZe , t) = t
              evalOneStep _ ((ESu EZe) , (true , ( x , _))) = x
              evalOneStep _ ((ESu EZe) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu EZe)) , (x , y)) = plus x y
              evalOneStep nat ((ESu (ESu (ESu ()))) , t)
              evalOneStep bool ((ESu (ESu EZe)) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu ()))) , _)

--********************************************
-- Free monad construction
--********************************************

_**_ : {I : Set} (R : TagIDesc I)(X : I -> Set) -> TagIDesc I
((E , ED) , FFD) ** X = ((( consE E ,  \ i -> ( const (X i) , ED i ))) , FFD)

--********************************************
-- Substitution
--********************************************

apply : {I : Set}
        (R : TagIDesc I)(X Y : I -> Set) ->
        ((i : I) -> X i -> IMu (toIDesc I (R ** Y)) i) ->
        (i : I) ->
        [| toIDesc I (R ** X) i |] (IMu (toIDesc I (R ** Y))) ->
        IMu (toIDesc I (R ** Y)) i
apply (( E , ED) , (F , FD)) X Y sig i (EZe , x) = sig i x
apply (( E , ED) , (F , FD)) X Y sig i (ESu n , t) = con (ESu n , t)

substI : {I : Set} (X Y : I -> Set)(R : TagIDesc I)
         (sigma : (i : I) -> X i -> IMu (toIDesc I (R ** Y)) i)
         (i : I)(D : IMu (toIDesc I (R ** X)) i) ->
         IMu (toIDesc I (R ** Y)) i
substI {I} X Y R sig i term = cata I (toIDesc I (R ** X)) (IMu (toIDesc I (R ** Y))) (apply R X Y sig) i term

--********************************************
-- Hutton's razor is free monad
--********************************************

exprFreeFixMenu : FixMenu Type
exprFreeFixMenu = ( consE nilE ,
                    \ty -> (prod (var bool) (prod (var ty) (var ty)),
                           Void))

choiceFreeMenu : Type -> EnumU
choiceFreeMenu nat = consE nilE
choiceFreeMenu bool = consE nilE

choiceFreeDessert : (ty : Type) -> spi (choiceFreeMenu ty) (\ _ -> IDesc Type)
choiceFreeDessert nat = (prod (var nat) (var nat) , Void)
choiceFreeDessert bool = (prod (var nat) (var nat) , Void )

exprFreeSensitiveMenu : SensitiveMenu Type
exprFreeSensitiveMenu = ( choiceFreeMenu ,  choiceFreeDessert )

exprFree : TagIDesc Type
exprFree = exprFreeFixMenu , exprFreeSensitiveMenu

exprFreeC : (Type -> Set) -> TagIDesc Type
exprFreeC X = exprFree ** X

closeTerm' : Type -> IDesc Type
closeTerm' = toIDesc Type (exprFree ** Val)

--********************************
-- Closed term' evaluation
--********************************

eval' : {ty : Type} -> IMu closeTerm' ty -> Val ty
eval' {ty} term = cata Type closeTerm' Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm' ty |] Val -> Val ty
              evalOneStep _ (EZe , t) = t
              evalOneStep _ ((ESu EZe) , (true , ( x , _))) = x
              evalOneStep _ ((ESu EZe) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu EZe)) , (x , y)) = plus x y
              evalOneStep nat ((ESu (ESu (ESu ()))) , t)
              evalOneStep bool ((ESu (ESu EZe)) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu ()))) , _)

--********************************
-- Open terms
--********************************

data Vec (A : Set) : Nat -> Set where
   vnil : Vec A ze
   vcons : {n : Nat} -> A -> Vec A n -> Vec A (su n)

data Fin : Nat -> Set where
  fze : {n : Nat} -> Fin (su n)
  fsu : {n : Nat} -> Fin n -> Fin (su n)

Context : Nat -> Set
Context n = Vec (Sigma Type (\ty -> IMu closeTerm' ty)) n

typeAt : {n : Nat}(c : Context n) -> Fin n -> Type
typeAt {ze} c ()
typeAt {.(su n)} (vcons x xs) (fze {n}) = fst x
typeAt {.(su n)} (vcons x xs) (fsu {n} y) = typeAt xs y

lookup : {n : Nat}(c : Context n)(i : Fin n) -> IMu closeTerm' (typeAt c i)
lookup {ze} c ()
lookup {su _} (vcons x _) fze = snd x
lookup {su _} (vcons _ xs) (fsu y) = lookup xs y

Var : {n : Nat} -> Context n -> Type -> Set
Var {n} c ty = Sigma (Fin n) (\i -> typeAt c i == ty)

openTerm : {n : Nat} -> Context n -> Type -> IDesc Type
openTerm c = toIDesc Type (exprFree ** (\ty -> Val ty + Var c ty))

--********************************
-- Evaluation of open terms
--********************************

discharge : {n : Nat}
             {context : Context n}
             (ty : Type) ->
             (Val ty + Var context ty) ->
             IMu closeTerm' ty
discharge ty (l value) = con (EZe , value)
discharge {n} {c} ty (r variable) = subst (cong (IMu closeTerm') (snd variable)) (lookup c (fst variable))

substExpr : {n : Nat}
             {ty : Type}
             (context : Context n)
             (sigma : (ty : Type) ->
                      (Val ty + Var context ty) ->
                      IMu closeTerm' ty) ->
             IMu (openTerm context) ty ->
             IMu closeTerm' ty
substExpr {n} {ty} c sig term =
    substI (\ty -> Val ty + Var c ty) Val exprFree sig ty term

evalOpen : {n : Nat}{ty : Type}
           (context : Context n) ->
           IMu (openTerm context) ty ->
           Val ty
evalOpen context tm = eval' (substExpr context discharge tm)

--********************************
-- Tests
--********************************

-- V 0 :-> true, V 1 :-> 2
testContext : Context _
testContext = vcons (bool , con (EZe , true )) (vcons (nat , con (EZe , su (su ze)) ) vnil)

-- V 1
test1 : IMu (openTerm testContext) nat
test1 = con (EZe , r ( fsu fze , refl ) )

testSubst1 : IMu closeTerm' nat
testSubst1 = substExpr testContext
                       discharge
                       test1
-- = 2
testEval1 : Val nat
testEval1 = evalOpen testContext test1

-- add 1 (V 1)
test2 : IMu (openTerm testContext) nat
test2 = con (ESu (ESu EZe) , (con (EZe , l (su ze)) , con ( EZe , r (fsu fze , refl) )) )

testSubst2 : IMu closeTerm' nat
testSubst2 = substExpr testContext
                        discharge
                        test2

-- = 3
testEval2 : Val nat
testEval2 = evalOpen testContext test2

-- if (V 0) then (V 1) else 0
test3 : IMu (openTerm testContext) nat
test3 = con (ESu EZe , (con (EZe , r (fze , refl)) ,
                       (con (EZe , r (fsu fze , refl)) ,
                        con (EZe , l ze))))

testSubst3 : IMu closeTerm' nat
testSubst3 = substExpr testContext
                       discharge
                       test3

-- = 2
testEval3 : Val nat
testEval3 = evalOpen testContext test3

 {-# OPTIONS --type-in-type #-}

module IDescTT where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Sigma and friends
--****************

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A : Set)(B : Set) -> Set
A * B = Sigma A \_ -> B

fst : {A : Set}{B : A -> Set} -> Sigma A B -> A
fst (a , _) = a

snd : {A : Set}{B : A -> Set} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero : Set where
data Unit  : Set where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ (A : Set)(B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

cong : {A B : Set}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {A B C : Set}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

postulate
  reflFun : {A B : Set}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--****************
-- Meta-language
--****************

-- Note that we could define Nat, Bool, and the related operations in
-- IDesc. But it is awful to code with them, in Agda.

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Bool : Set where
  true : Bool
  false : Bool

plus : Nat -> Nat -> Nat
plus ze n' = n'
plus (su n) n' = su (plus n n')

le : Nat -> Nat -> Bool
le ze _ = true
le (su _) ze = false
le (su n) (su n') = le n n'

--********************************************
-- Desc code
--********************************************

data IDesc (I : Set) : Set where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

[|_|] : {I : Set} -> IDesc I -> (I -> Set) -> Set
[| var i |] P = P i
[| const X |] P = X
[| prod D D' |] P = [| D |] P * [| D' |] P
[| sigma S T |] P = Sigma S (\s -> [| T s |] P)
[| pi S T |] P = (s : S) -> [| T s |] P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {I : Set}(R : I -> IDesc I)(i : I) : Set where
  con : [| R i |] (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: All
--********************************************

All : {I : Set}(D : IDesc I)(P : I -> Set) -> [| D |] P -> IDesc (Sigma I P)
All (var i)     P x        = var (i , x)
All (const X)   P x        = const Unit
All (prod D D') P (d , d') = prod (All D P d) (All D' P d')
All (sigma S T) P (a , b)  = All (T a) P b
All (pi S T)    P f        = pi S (\s -> All (T s) P (f s))

all : {I : Set}(D : IDesc I)(X : I -> Set)
      (R : Sigma I X -> Set)(P : (x : Sigma I X) -> R x) ->
      (xs : [| D |] X) -> [| All D X xs |] R
all (var i) X R P x = P (i , x)
all (const K) X R P k = Void
all (prod D D') X R P (x , y) = ( all D X R P x , all D' X R P y )
all (sigma S T) X R P (a , b) = all (T a) X R P b
all (pi S T) X R P f = \a -> all (T a) X R P (f a)

--********************************************
-- Elimination principle: induction
--********************************************

-- One would like to write the following:

{-
indI : {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
indI {I} R P m i (con xs) = m i xs (all (R i) (IMu R) P induct xs)
  where induct : (x : Sigma I (IMu R)) -> P x
        induct (i , xs) = indI R P m i xs
-}

-- But the termination-checker complains, so here we go
-- inductive-recursive:

module Elim {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs ))
       where

  mutual
    indI : (i : I)(x : IMu R i) -> P (i , x)
    indI i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : [| D |] (IMu R)) ->
           [| All D (IMu R) xs |] P
    hyps (var i) x = indI i x
    hyps (const X) x = Void
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

indI : {I : Set}
       (R : I -> IDesc I)
       (P : Sigma I (IMu R) -> Set)
       (m : (i : I)
            (xs : [| R i |] (IMu R))
            (hs : [| All (R i) (IMu R) xs |] P) ->
            P ( i , con xs)) ->
       (i : I)(x : IMu R i) -> P ( i , x )
indI = Elim.indI

--********************************************
-- Examples
--********************************************

--****************
-- Nat
--****************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> IDesc Unit
natCases Ze = const Unit
natCases Suc = var Void

NatD : Unit -> IDesc Unit
NatD Void = sigma NatConst  natCases

Natd : Unit -> Set
Natd x = IMu NatD x

zed : Natd Void
zed = con (Ze , Void)

sud : Natd Void -> Natd Void
sud n = con (Su , n)

--****************
-- Desc
--****************

data DescDConst : Set where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : Set -> DescDConst -> IDesc Unit
descDChoice I lvar = const I
descDChoice _ lconst = const Set
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma Set (\S -> pi S (\s -> var Void))
descDChoice _ lsigma = sigma Set (\S -> pi S (\s -> var Void))

descD : (I : Set) -> IDesc Unit
descD I = sigma DescDConst (descDChoice I)

IDescl0 : (I : Set) -> Unit -> Set
IDescl0 I = IMu (\_ -> descD I)

IDescl : (I : Set) -> Set
IDescl I = IDescl0 I _

varl : {I : Set}(i : I) -> IDescl I
varl i = con (lvar ,  i)

constl : {I : Set}(X : Set) -> IDescl I
constl X = con (lconst , X)

prodl : {I : Set}(D D' : IDescl I) -> IDescl I
prodl D D' = con (lprod , (D , D'))

pil : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
pil S T = con (lpi , ( S , T))

sigmal : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
sigmal S T = con (lsigma , ( S , T))

--****************
-- Vec (constraints)
--****************

data VecConst : Set where
  Vnil : VecConst
  Vcons : VecConst

vecDChoice : Set -> Nat -> VecConst -> IDesc Nat
vecDChoice X n Vnil = const (n == ze)
vecDChoice X n Vcons = sigma Nat (\m -> prod (var m) (const (n == su m)))

vecD : Set -> Nat -> IDesc Nat
vecD X n = sigma VecConst (vecDChoice X n)

vec : Set -> Nat -> Set
vec X n = IMu (vecD X) n

--****************
-- Vec (de-tagged, forced)
--****************

data VecConst2 : Nat -> Set where
  Vnil : VecConst2 ze
  Vcons : {n : Nat} -> VecConst2 (su n)

vecDChoice2 : Set -> (n : Nat) -> VecConst2 n -> IDesc Nat
vecDChoice2 X ze Vnil = const Unit
vecDChoice2 X (su n) Vcons = prod (const X) (var n)

vecD2 : Set -> Nat -> IDesc Nat
vecD2 X n = sigma (VecConst2 n) (vecDChoice2 X n)

vec2 : Set -> Nat -> Set
vec2 X n = IMu (vecD2 X) n

--****************
-- Fin (de-tagged)
--****************

data FinConst : Nat -> Set where
  Fz : {n : Nat} -> FinConst (su n)
  Fs : {n : Nat} -> FinConst (su n)

finDChoice : (n : Nat) -> FinConst n -> IDesc Nat
finDChoice ze ()
finDChoice (su n) Fz = const Unit
finDChoice (su n) Fs = var n

finD : Nat -> IDesc Nat
finD n = sigma (FinConst n) (finDChoice n)

fin : Nat -> Set
fin n = IMu finD n

--********************************************
-- Enumerations (hard-coded)
--********************************************

-- Unlike in Desc.agda, we don't carry the levitation of finite sets
-- here. We hard-code them and manipulate with standard Agda
-- machinery. Both presentation are isomorph but, in Agda, the coded
-- one quickly gets unusable.

data EnumU : Set where
  nilE : EnumU
  consE : EnumU -> EnumU

data EnumT : (e : EnumU) -> Set where
  EZe : {e : EnumU} -> EnumT (consE e)
  ESu : {e : EnumU} -> EnumT e -> EnumT (consE e)

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi nilE P = Unit
spi (consE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : EnumU)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nilE P b ()
switch (consE e) P b EZe = fst b
switch (consE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n

_++_ : EnumU -> EnumU -> EnumU
nilE ++ e' = e'
(consE e) ++ e' = consE (e ++ e')

-- A special switch, for tagged descriptions. Switching on a
-- concatenation of finite sets:
sswitch : (e : EnumU)(e' : EnumU)(P : Set)
       (b : spi e (\_ -> P))(b' : spi e' (\_ -> P))(x : EnumT (e ++ e')) -> P
sswitch nilE nilE P b b' ()
sswitch nilE (consE e') P b b' EZe = fst b'
sswitch nilE (consE e') P b b' (ESu n) = sswitch nilE e' P b (snd b') n
sswitch (consE e) e' P b b' EZe = fst b
sswitch (consE e) e' P b b' (ESu n) = sswitch e e' P (snd b) b' n

--********************************************
-- Tagged indexed description
--********************************************

FixMenu : Set -> Set
FixMenu I = Sigma EnumU (\e -> (i : I) -> spi e (\_ -> IDesc I))

SensitiveMenu : Set -> Set
SensitiveMenu I = Sigma (I -> EnumU) (\F -> (i : I) -> spi (F i) (\_ -> IDesc I))

TagIDesc : Set -> Set
TagIDesc I = FixMenu I * SensitiveMenu I

toIDesc : (I : Set) -> TagIDesc I -> (I -> IDesc I)
toIDesc I ((E , ED) , (F , FD)) i = sigma (EnumT (E ++ F i))
                                          (\x -> sswitch E (F i) (IDesc I) (ED i) (FD i) x)

--********************************************
-- Catamorphism
--********************************************

cata : (I : Set)
       (R : I -> IDesc I)
       (T : I -> Set) ->
       ((i : I) -> [| R i |] T -> T i) ->
       (i : I) -> IMu R i -> T i
cata I R T phi i x = indI R (\it -> T (fst it)) (\i xs ms -> phi i (replace (R i) T xs ms)) i x
  where replace : (D : IDesc I)(T : I -> Set)
                  (xs : [| D |] (IMu R))
                  (ms : [| All D (IMu R) xs |] (\it -> T (fst it))) ->
                  [| D |] T
        replace (var i) T x y = y
        replace (const Z) T z z' = z
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Hutton's razor
--********************************************

--********************************
-- Types code
--********************************

data Type : Set where
  nat : Type
  bool : Type

--********************************
-- Typed expressions
--********************************

exprFixMenu : (Type -> Set) -> FixMenu Type
exprFixMenu constt = ( consE (consE nilE) ,
                       \ty -> (const (constt ty),
                              (prod (var bool) (prod (var ty) (var ty)),
                               Void)))

choiceMenu : Type -> EnumU
choiceMenu nat = consE nilE
choiceMenu bool = consE nilE

choiceDessert : (ty : Type) -> spi (choiceMenu ty) (\ _ -> IDesc Type)
choiceDessert nat = (prod (var nat) (var nat) , Void)
choiceDessert bool = (prod (var nat) (var nat) , Void )

exprSensitiveMenu : SensitiveMenu Type
exprSensitiveMenu = ( choiceMenu ,  choiceDessert )

expr : (Type -> Set) -> TagIDesc Type
expr constt = exprFixMenu constt , exprSensitiveMenu

exprIDesc : (Type -> Set) -> ((Type -> Set) -> TagIDesc Type) -> (Type -> IDesc Type)
exprIDesc constt D = toIDesc Type  (D constt)

--********************************
-- Closed terms
--********************************

Val : Type -> Set
Val nat = Nat
Val bool = Bool

closeTerm : Type -> IDesc Type
closeTerm = exprIDesc Val expr

--********************************
-- Closed term evaluation
--********************************

eval : (ty : Type) -> IMu closeTerm ty -> Val ty
eval ty term = cata Type closeTerm Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm ty |] Val -> Val ty
              evalOneStep _ (EZe , t) = t
              evalOneStep _ ((ESu EZe) , (true , ( x , _))) = x
              evalOneStep _ ((ESu EZe) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu EZe)) , (x , y)) = plus x y
              evalOneStep nat ((ESu (ESu (ESu ()))) , t)
              evalOneStep bool ((ESu (ESu EZe)) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu ()))) , _)

--********************************
-- Open terms
--********************************

Var : EnumU -> Type -> Set
Var dom _ = EnumT dom

openTerm : EnumU -> Type -> IDesc Type
openTerm dom = exprIDesc (\ty -> Val ty + Var dom ty) expr

--********************************
-- Evaluation of open terms
--********************************

discharge : (ty : Type)
          (vars : EnumU)
          (context : spi vars (\_ -> IMu closeTerm ty)) ->
          (Val ty + Var vars ty) ->
          IMu closeTerm ty
discharge ty vars context (l value) = con ( EZe , value )
discharge ty vars context (r variable) = switch vars (\_ -> IMu closeTerm ty) context variable

--********************************************
-- Free monad construction
--********************************************

_**_ : {I : Set} (R : TagIDesc I)(X : I -> Set) -> TagIDesc I
((E , ED) , FFD) ** X = ((( consE E ,  \ i -> ( const (X i) , ED i ))) , FFD)

--********************************************
-- Substitution
--********************************************

apply : {I : Set}
        (R : TagIDesc I)(X Y : I -> Set) ->
        ((i : I) -> X i -> IMu (toIDesc I (R ** Y)) i) ->
        (i : I) ->
        [| toIDesc I (R ** X) i |] (IMu (toIDesc I (R ** Y))) ->
        IMu (toIDesc I (R ** Y)) i
apply (( E , ED) , (F , FD)) X Y sig i (EZe , x) = sig i x
apply (( E , ED) , (F , FD)) X Y sig i (ESu n , t) = con (ESu n , t)

substI : {I : Set} (X Y : I -> Set)(R : TagIDesc I)
         (sigma : (i : I) -> X i -> IMu (toIDesc I (R ** Y)) i)
         (i : I)(D : IMu (toIDesc I (R ** X)) i) ->
         IMu (toIDesc I (R ** Y)) i
substI {I} X Y R sig i term = cata I (toIDesc I (R ** X)) (IMu (toIDesc I (R ** Y))) (apply R X Y sig) i term

--********************************************
-- Hutton's razor is free monad
--********************************************

exprFreeFixMenu : FixMenu Type
exprFreeFixMenu = ( consE nilE ,
                    \ty -> (prod (var bool) (prod (var ty) (var ty)),
                           Void))

choiceFreeMenu : Type -> EnumU
choiceFreeMenu nat = consE nilE
choiceFreeMenu bool = consE nilE

choiceFreeDessert : (ty : Type) -> spi (choiceFreeMenu ty) (\ _ -> IDesc Type)
choiceFreeDessert nat = (prod (var nat) (var nat) , Void)
choiceFreeDessert bool = (prod (var nat) (var nat) , Void )

exprFreeSensitiveMenu : SensitiveMenu Type
exprFreeSensitiveMenu = ( choiceFreeMenu ,  choiceFreeDessert )

exprFree : TagIDesc Type
exprFree = exprFreeFixMenu , exprFreeSensitiveMenu

exprFreeC : (Type -> Set) -> TagIDesc Type
exprFreeC X = exprFree ** X

closeTerm' : Type -> IDesc Type
closeTerm' = toIDesc Type (exprFree ** Val)

openTerm' : EnumU -> Type -> IDesc Type
openTerm' dom = toIDesc Type (exprFree ** (\ty -> Val ty + Var dom ty))

--********************************
-- Evaluation of open terms'
--********************************

discharge' : (ty : Type)
            (vars : EnumU)
            (context : spi vars (\_ -> IMu closeTerm' ty)) ->
            (Val ty + Var vars ty) ->
            IMu closeTerm' ty
discharge' ty vars context (l value) = con (EZe , value)
discharge' ty vars context (r variable) = switch vars (\_ -> IMu closeTerm' ty) context variable

chooseDom : (ty : Type)(domNat domBool : EnumU) -> EnumU
chooseDom nat domNat _ = domNat
chooseDom bool _ domBool = domBool

chooseGamma : (ty : Type)
              (dom : EnumU)
              (gammaNat : spi dom (\_ -> IMu closeTerm' nat))
              (gammaBool : spi dom (\_ -> IMu closeTerm' bool)) ->
              spi dom (\_ -> IMu closeTerm' ty)
chooseGamma nat dom gammaNat gammaBool = gammaNat
chooseGamma bool dom gammaNat gammaBool = gammaBool

substExpr : (dom : EnumU)
            (gammaNat : spi dom (\_ -> IMu closeTerm' nat))
            (gammaBool : spi dom (\_ -> IMu closeTerm' bool))
            (sigma : (dom : EnumU)
                     (gammaNat : spi dom (\_ -> IMu closeTerm' nat))
                     (gammaBool : spi dom (\_ -> IMu closeTerm' bool))
                     (ty : Type) ->
                     (Val ty + Var dom ty) ->
                     IMu closeTerm' ty)
            (ty : Type) ->
            IMu (openTerm' dom) ty ->
            IMu closeTerm' ty
substExpr dom gammaNat gammaBool sig ty term =
    substI (\ty -> Val ty + Var dom ty)
           Val
           exprFree
           (sig dom gammaNat gammaBool)
           ty
           term

sigmaExpr : (dom : EnumU)
            (gammaNat : spi dom (\_ -> IMu closeTerm' nat))
            (gammaBool : spi dom (\_ -> IMu closeTerm' bool))
            (ty : Type) ->
            (Val ty + Var dom ty) ->
            IMu closeTerm' ty
sigmaExpr dom gammaNat gammaBool ty v =
    discharge' ty
               dom
               (chooseGamma ty dom gammaNat gammaBool)
               v

test : IMu (openTerm' (consE (consE nilE))) nat ->
       IMu closeTerm' nat
test term = substExpr (consE (consE nilE))
                      ( con ( EZe , ze ) , ( con (EZe , su ze ) , Void ))
                      ( con ( EZe , true ) , ( con ( EZe , false ) , Void ))
                      sigmaExpr nat term


agda/derivation.agda: progress on Δ-term

Implement Δ-term on applications, assuming the availability of a nabla
metafunction (which we expect to be implemented using a term
constructor, but who knows).

Old-commit-hash: 803596156f6f88a497e4f039116e047d66aedf3c

module derivation where

open import lambda

-- CHANGE TYPES

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₂
Δ-Type bool = {!!}

apply : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app apply (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x        )  (     f                 x        )
apply {bool} = {!!}

compose : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ Δ-Type τ ⇒ Δ-Type τ)
compose {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app (compose {τ₂}) (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λdg. λx.           compose (     df                       x         ) (     dg                x      )
compose {bool} = {!!}

nil : ∀ {τ Γ} → Term Γ (Δ-Type τ)
nil {τ₁ ⇒ τ₂} =
    abs (nil {τ₂})
 -- λx. nil
nil {bool} = {!!}

-- Hey, apply is α-equivalent to compose, what's going on?
-- Oh, and `Δ-Type` is the identity function?

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = τ • Δ-Type τ • Δ-Context Γ

-- CHANGE VARIABLES

-- changes 'x' to 'dx'

rename : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
rename this = that this
rename (that x) = that (that (rename x))

adaptVar : ∀  {τ} Γ₁ Γ₂ → Var (Γ₁ ⋎ Γ₂) τ → Var (Γ₁ ⋎ Δ-Context Γ₂) τ
adaptVar ∅ (τ₂ • Γ₂) this = this
adaptVar ∅ (τ₂ • Γ₂) (that x) = that (that (adaptVar ∅ Γ₂ x))
adaptVar (τ₁ • Γ₁) Γ₂ this = this
adaptVar (τ₁ • Γ₁) Γ₂ (that x) = that (adaptVar Γ₁ Γ₂ x)

adapt : ∀ {τ} Γ₁ Γ₂ → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) τ
adapt {τ₁ ⇒ τ₂} Γ₁ Γ₂ (abs t) = abs (adapt (τ₁ • Γ₁) Γ₂ t)
adapt Γ₁ Γ₂ (app t₁ t₂) = app (adapt Γ₁ Γ₂ t₁) (adapt Γ₁ Γ₂ t₂)
adapt Γ₁ Γ₂ (var t) = var (adaptVar Γ₁ Γ₂ t)
adapt Γ₁ Γ₂ true = true
adapt Γ₁ Γ₂ false = false
adapt Γ₁ Γ₂ (cond tc t₁ t₂) = cond (adapt Γ₁ Γ₂ tc) (adapt Γ₁ Γ₂ t₁) (adapt Γ₁ Γ₂ t₂)

-- changes 'x' to 'nil' (if internally bound) or 'dx' (if externally bound)

Δ-var : ∀ {Γ₁ Γ₂ τ} → Var (Γ₁ ⋎ Γ₂) τ → Term (Δ-Context Γ₂) (Δ-Type τ)
Δ-var {∅} x = var (rename x)
Δ-var {τ • Γ} this = nil {τ}
Δ-var {τ • Γ} (that x) = Δ-var {Γ} x

-- Note: this should be the derivative with respect to the first variable.
nabla : ∀ {Γ τ₁ τ₂} → (t₀ : Term Γ (τ₁ ⇒ τ₂)) → Term Γ (τ₁ ⇒ Δ-Type τ₁ ⇒ Δ-Type τ₂)
nabla = {!!}

-- CHANGE TERMS
Δ-term : ∀ {Γ₁ Γ₂ τ} → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) (Δ-Type τ)
Δ-term {Γ} (abs {τ₁ = τ} t) = abs (Δ-term {τ • Γ} t)

Δ-term {Γ₁} {Γ₂} {τ} (app t₁ t₂) = app (app (compose {τ}) (app (Δ-term {Γ₁} t₁) (adapt Γ₁ Γ₂ t₂)))
  (app (adapt Γ₁ Γ₂ (app (nabla {Γ₁ ⋎ Γ₂} t₁) t₂)) (Δ-term {Γ₁} {Γ₂} t₂))

Δ-term {Γ} (var x) = weaken {∅} {Γ} (Δ-var {Γ} x)
Δ-term {Γ} true = {!!}
Δ-term {Γ} false = {!!}
Δ-term {Γ} (cond t₁ t₂ t₃) = {!!}

module derivation where

open import lambda

-- CHANGE TYPES

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₂
Δ-Type bool = {!!}

apply : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app apply (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x        )  (     f                 x        )
apply {bool} = {!!}

compose : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ Δ-Type τ ⇒ Δ-Type τ)
compose {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app (compose {τ₂}) (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λdg. λx.           compose (     df                       x         ) (     dg                x      )
compose {bool} = {!!}

nil : ∀ {τ Γ} → Term Γ (Δ-Type τ)
nil {τ₁ ⇒ τ₂} =
    abs (nil {τ₂})
 -- λx. nil
nil {bool} = {!!}

-- Hey, apply is α-equivalent to compose, what's going on?
-- Oh, and `Δ-Type` is the identity function?

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = τ • Δ-Type τ • Δ-Context Γ

-- CHANGE VARIABLES

-- changes 'x' to 'dx'

rename : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
rename this = that this
rename (that x) = that (that (rename x))

-- changes 'x' to 'nil' (if internally bound) or 'dx' (if externally bound)

Δ-var : ∀ {Γ₁ Γ₂ τ} → Var (Γ₁ ⋎ Γ₂) τ → Term (Δ-Context Γ₂) (Δ-Type τ)
Δ-var {∅} x = var (rename x)
Δ-var {τ • Γ} this = nil {τ}
Δ-var {τ • Γ} (that x) = Δ-var {Γ} x

-- CHANGE TERMS

Δ-term : ∀ {Γ₁ Γ₂ τ} → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) (Δ-Type τ)
Δ-term {Γ} (abs {τ₁ = τ} t) = abs (Δ-term {τ • Γ} t)
Δ-term {Γ} (app t₁ t₂) = {!!}
Δ-term {Γ} (var x) = weaken {∅} {Γ} (Δ-var {Γ} x)
Δ-term {Γ} true = {!!}
Δ-term {Γ} false = {!!}
Δ-term {Γ} (cond t₁ t₂ t₃) = {!!}


Added setoid for FOTC.

Added setoid for FOTC.

------------------------------------------------------------------------------
-- Using setoids for formalizing FOTC
------------------------------------------------------------------------------

{-# OPTIONS --no-positivity-check #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

{-

From Peter emails:

At that time I was considering an inductive data type D and an
inductively defined equality on D. But I think what we are doing now
is better.

For =: The reason is that with the propositional identity we have
identity elimination which lets us replace equals by equals. We cannot
do that in general if we have setoid equality.

For D: the reason why I prefer to postulate D is that we have no use
for the inductive structure of D, and this inductive structure would
make e g 0 + 0 different from 0. So in that case we need setoid
equality.

-}

-- References:
--
-- • Gilles Barthe, Venanzio Capretta, and Olivier Pons. Setoids in
--   type theory. Journal of Functional Programming, 13(2):261–293,
--   2003.

module FOTC where

module Aczel-CA where
  -- From Peter's slides
  -- http://www.cse.chalmers.se/~peterd/slides/Amagasaki.pdf

  -- We add 3 to the fixities of the standard library.
  infixl 9 _·_  -- The symbol is '\cdot'.
  infix 7  _≐_

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- The setoid equality.
  data _≐_ : D → D → Set where
    refl  : ∀ {x} → x ≐ x
    sym   : ∀ {x y} → x ≐ y → y ≐ x
    trans : ∀ {x y z} → x ≐ y → y ≐ z → x ≐ z
    cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≐ x₂ → y₁ ≐ y₂ → x₁ · y₁ ≐ x₂ · y₂
    K-eq  : ∀ x y → K · x · y ≐ x
    S-eq  : ∀ x y z → S · x · y · z ≐ x · z · (y · z)

  -- The identity type.
  data _≡_ (x : D) : D → Set where
    refl : x ≡ x

  ----------------------------------------------------------------------------
  -- 14 May 2012: Using the inductive structure we cannot prove
  --
  -- K · x · y ≡ x,
  --
  -- we need the setoid equality.
  -- K-eq : ∀ {x y} → (K · x · y) ≡ x

  ----------------------------------------------------------------------------
  -- 14 May 2012. We cannot define the identity elimination using the
  -- setoid equality.
  --
  -- Adapted from Peter's email:

  -- Given
  postulate subst : (A : D → Set) → ∀ {x y} → x ≐ y → A x → A y

  -- we can proof

  ≐→≡ : ∀ {x y} → x ≐ y → x ≡ y
  ≐→≡ {x} h = subst (λ z → x ≡ z) h refl

  -- but this doesn't hold because "x ≡ y" (propositional equality)
  -- means identical expressions. We do NOT have K · x · y ≡ x.
  --
  -- The point is that ≐ is a non-trivial equivalence relation, and
  -- not all properties preserve it. However, all properties are
  -- preserved by ≡.

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

module FOTC where

  infixl 9 _·_  -- The symbol is '\cdot'.
  infix 7  _≐_

  data D : Set where
    _·_ : D → D → D
    lam fix : (D → D) → D
    true false if zero succ pred iszero : D

  -- The setoid equality.
  data _≐_ : D → D → Set where
    refl     : ∀ {x} → x ≐ x
    sym      : ∀ {x y} → x ≐ y → y ≐ x
    trans    : ∀ {x y z} → x ≐ y → y ≐ z → x ≐ z
    if-true  : ∀ d₁ d₂ → if · true · d₁ · d₂ ≐ d₁
    if-false : ∀ d₁ d₂ → if · false · d₁ · d₂ ≐ d₂
    pred-0   : pred · zero ≐ zero
    pred-S   : ∀ n → pred · (succ · n) ≐ n
    iszero-0 : iszero · zero ≐ true
    iszero-S : ∀ n → iszero · (succ · n) ≐ false
    beta     : ∀ f a → lam f · a ≐ f a
    fix-eq   : ∀ f → fix f ≐ f (fix f)

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

module LeibnizEquality where

  infix 7 _≡_

  data D : Set where
    _·_ : D → D → D
    lam fix : (D → D) → D
    true false if zero succ pred iszero : D

  -- (Barthe et al. 2003, p. 262) use the Leibniz equality when
  -- they talk about setoids.

  -- Using the Leibniz equality (adapted from
  -- Agda/examples/lib/Logic/Leibniz.agda)

  _≡_ : D → D → Set₁
  x ≡ y = (A : D → Set) → A x → A y

  -- we can prove the setoids properties

  refl : ∀ x → x ≡ x
  refl x A Ax = Ax

  sym : ∀ {x y} → x ≡ y → y ≡ x
  sym {x} h A Ay = h (λ z → A z → A x) (λ Ax → Ax) Ay

  trans : ∀ x y z → x ≡ y → y ≡ z → x ≡ z
  trans x y z h₁ h₂ A Ax = h₂ A (h₁ A Ax)

  -- and the identity elimination

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A x≡y = x≡y A

  -- and the congruency

  cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≡ x₂ → y₁ ≡ y₂ → x₁ · y₁ ≡ x₂ · y₂
  cong {x₁} {x₂} {y₁} {y₂} h₁ h₂ A Ax₁x₂ =
    h₂ (λ z → A (x₂ · z)) (h₁ (λ z → A (z · y₁)) Ax₁x₂)

------------------------------------------------------------------------------
-- Using setoids for formalizing the FOTC
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

{-

From Peter emails:

At that time I was considering an inductive data type D and an
inductively defined equality on D. But I think what we are doing now
is better.

For =: The reason is that with the propositional identity we have
identity elimination which lets us replace equals by equals. We cannot
do that in general if we have setoid equality.

For D: the reason why I prefer to postulate D is that we have no use
for the inductive structure of D, and this inductive structure would
make e g 0 + 0 different from 0. So in that case we need setoid
equality.

-}

module FOTC where

-- References:
--
-- • Gilles Barthe, Venanzio Capretta, and Olivier Pons. Setoids in
--   type theory. Journal of Functional Programming, 13(2):261–293,
--   2003.

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

module Setoid where

  -- From Peter's slides
  -- http://www.cse.chalmers.se/~peterd/slides/Amagasaki.pdf

  -- We add 3 to the fixities of the standard library.
  infixl 9 _·_  -- The symbol is '\cdot'.
  infix 7  _≐_

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- The setoid equality.
  data _≐_ : D → D → Set where
    refl  : ∀ x →                                       x ≐ x
    sym   : ∀ {x y} → x ≐ y →                           y ≐ x
    trans : ∀ {x y z} → x ≐ y → y ≐ z →                 x ≐ z
    cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≐ x₂ → y₁ ≐ y₂ → x₁ · y₁ ≐ x₂ · y₂
    Kax   : ∀ x y →                            K · x · y  ≐ x
    Sax   : ∀ x y z →                      S · x · y · z  ≐ x · z · (y · z)

  -- The identity type.
  data _≡_ (x : D) : D → Set where
    refl : x ≡ x

  ----------------------------------------------------------------------------
  -- 14 May 2012: Using the inductive structure we cannot prove
  --
  -- K · x · y ≡ x,
  --
  -- we need the setoid equality.
  -- K-eq : ∀ {x y} → (K · x · y) ≡ x

  ----------------------------------------------------------------------------
  -- 14 May 2012. We cannot define the identity elimination using the
  -- setoid equality.
  --
  -- Adapted from Peter's email:

  -- Given
  postulate subst : (A : D → Set) → ∀ x y → x ≐ y → A x → A y

  -- you can get the instance

  subst-aux : ∀ x y → x ≐ y → x ≡ x → x ≡ y
  subst-aux x y h₁ h₂ = subst A x y h₁ refl
    where A : D → Set
          A z = x ≡ z

  -- hence you can prove

  thm : ∀ {x y} → x ≐ y → x ≡ y
  thm {x} {y} h = subst-aux x y h refl

  -- but this doesn't hold because "x ≡ y" (propositional equality)
  -- means identical expressions. We do NOT have K · x · y ≡ x.
  --
  -- The point is that ≐ is a non-trivial equivalence relation, and
  -- not all properties preserve it. However, all properties are
  -- preserved by ≡.

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

module LeibnizEquality where

  infix 7 _≡_

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- (Barthe et al. 2003, p. 262) use the Leibniz equality when
  -- they talk about setoids.

  -- Using the Leibniz equality (adapted from
  -- Agda/examples/lib/Logic/Leibniz.agda)

  _≡_ : D → D → Set₁
  x ≡ y = (A : D → Set) → A x → A y

  -- we can prove the setoids properties

  refl : ∀ x → x ≡ x
  refl x A Ax = Ax

  sym : ∀ {x y} → x ≡ y → y ≡ x
  sym {x} h A Ay = h (λ z → A z → A x) (λ Ax → Ax) Ay

  trans : ∀ x y z → x ≡ y → y ≡ z → x ≡ z
  trans x y z h₁ h₂ A Ax = h₂ A (h₁ A Ax)

  -- and the identity elimination

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A x≡y = x≡y A

  -- and the congruency

  cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≡ x₂ → y₁ ≡ y₂ → x₁ · y₁ ≡ x₂ · y₂
  cong {x₁} {x₂} {y₁} {y₂} h₁ h₂ A Ax₁x₂ =
    h₂ (λ z → A (x₂ · z)) (h₁ (λ z → A (z · y₁)) Ax₁x₂)


Reported issue #11.

Reported issue #11.


Desc stratified model: fresh start

Desc stratified model: fresh start

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {l : Level}{A : Set l}(x : A) : A -> Set l where
  refl : x == x

cong : {l : Level}{A B : Set l}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l : Level}{A B C : Set l}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

-- Intensionally extensional
postulate
  reflFun : {l : Level}{A B : Set l}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc (l : Level)(I : Set l) : Set (suc l) where
  var : I -> IDesc l I
  const : Set l -> IDesc l I
  prod : IDesc l I -> IDesc l I -> IDesc l I
  sigma : (S : Set l) -> (S -> IDesc l I) -> IDesc l I
  pi : (S : Set l) -> (S -> IDesc l I) -> IDesc l I

--********************************************
-- Desc interpretation
--********************************************

desc : (l : Level)(I : Set l) -> IDesc l I -> (I -> Set l) -> Set l
desc _ I (var i) P = P i
desc _ I (const X) P = X
desc x I (prod D D') P = desc x I D P * desc x I D' P
desc x I (sigma S T) P = Sigma S (\s -> desc x I (T s) P)
desc x I (pi S T) P = (s : S) -> desc x I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu (l : Level)(I : Set l)(R : I -> IDesc l I)(i : I) : Set l where
  con : desc l I (R i) (\j -> IMu l I R j) -> IMu l I R i

--********************************************
-- Predicate: Box
--********************************************

box : (l : Level)(I : Set l)(D : IDesc l I)(P : I -> Set l) -> desc l I D P -> IDesc l (Sigma I P)
box _ I (var i)     P x        = var (i , x)
box _ I (const X)   P x        = const X
box x I (prod D D') P (d , d') = prod (box x I D P d) (box x I D' P d')
box x I (sigma S T) P (a , b)  = box x I (T a) P b
box x I (pi S T)    P f        = pi S (\s -> box x I (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim (l : Level)
            (I : Set l)
            (R : I -> IDesc l I)
            (P : Sigma I (IMu l I R) -> Set l)
            (m : (i : I)
                 (xs : desc l I (R i) (IMu l I R))
                 (hs : desc l (Sigma I (IMu l I R)) (box l I (R i) (IMu l I R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu l I R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc l I) ->
           (xs : desc l I D (IMu l I R)) ->
           desc l (Sigma I (IMu l I R)) (box l I D (IMu l I R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : (l : Level)
            (I : Set l)
            (R : I -> IDesc l I)
            (P : Sigma I (IMu l I R) -> Set l)
            (m : (i : I)
                 (xs : desc l I (R i) (IMu l I R))
                 (hs : desc l (Sigma I (IMu l I R)) (box l I (R i) (IMu l I R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu l I R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst (l : Level) : Set l where
  lvar   : DescDConst l
  lconst : DescDConst l
  lprod  : DescDConst l
  lpi    : DescDConst l
  lsigma : DescDConst l

descDChoice : (l : Level) -> Set l -> DescDConst (suc l) -> IDesc (suc l) Unit
descDChoice _ I lvar = const (lift I)
descDChoice x _ lconst = const (Set x)
descDChoice _ _ lprod = prod (var Void) (var Void)
descDChoice x _ lpi = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))
descDChoice x _ lsigma = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))

descD : (l : Level)(I : Set l) -> IDesc (suc l) Unit
descD x I = sigma (DescDConst (suc x)) (descDChoice x I)

IDescl : (l : Level)(I : Set l) -> Set (suc l)
IDescl x I = IMu (suc x) Unit (\_ -> descD x I) Void

varl : (l : Level)(I : Set l)(i : I) -> IDescl l I
varl x I i = con (lv , lifter i)
     where lv : DescDConst (suc x)
           lv = lvar

constl : (l : Level)(I : Set l)(X : Set l) -> IDescl l I
constl x I X = con (lc , X)
       where lc : DescDConst (suc x)
             lc = lconst

prodl : (l : Level)(I : Set l)(D D' : IDescl l I) -> IDescl l I
prodl x I D D' = con (lp , (D , D'))
      where lp : DescDConst (suc x)
            lp = lprod

pil : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
pil x I S T = con (lp , ( S , Tl))
    where lp : DescDConst (suc x)
          lp = lpi
          Tl : Lifted S -> IDescl x I
          Tl (lifter s) = T s

sigmal : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
sigmal x I S T = con (ls , ( S , Tl))
       where ls : DescDConst (suc x)
             ls = lsigma
             Tl : Lifted S -> IDescl x I
             Tl (lifter s) = T s

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

data IDesc (l : Level)(I : Set l) : Set (suc l) where
  var : I -> IDesc l I
  const : Set l -> IDesc l I
  prod : IDesc l I -> IDesc l I -> IDesc l I
  sigma : (S : Set l) -> (S -> IDesc l I) -> IDesc l I
  pi : (S : Set l) -> (S -> IDesc l I) -> IDesc l I

--********************************************
-- Desc interpretation
--********************************************

desc : (l : Level)(I : Set l) -> IDesc l I -> (I -> Set l) -> Set l
desc _ I (var i) P = P i
desc _ I (const X) P = X
desc x I (prod D D') P = desc x I D P * desc x I D' P
desc x I (sigma S T) P = Sigma S (\s -> desc x I (T s) P)
desc x I (pi S T) P = (s : S) -> desc x I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu (l : Level)(I : Set l)(R : I -> IDesc l I)(i : I) : Set l where
  con : desc l I (R i) (\j -> IMu l I R j) -> IMu l I R i

--********************************************
-- Predicate: Box
--********************************************

box : (l : Level)(I : Set l)(D : IDesc l I)(P : I -> Set l) -> desc l I D P -> IDesc l (Sigma I P)
box _ I (var i)     P x        = var (i , x)
box _ I (const X)   P x        = const X
box x I (prod D D') P (d , d') = prod (box x I D P d) (box x I D' P d')
box x I (sigma S T) P (a , b)  = box x I (T a) P b
box x I (pi S T)    P f        = pi S (\s -> box x I (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim (l : Level)
            (I : Set l)
            (R : I -> IDesc l I)
            (P : Sigma I (IMu l I R) -> Set l)
            (m : (i : I)
                 (xs : desc l I (R i) (IMu l I R))
                 (hs : desc l (Sigma I (IMu l I R)) (box l I (R i) (IMu l I R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu l I R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc l I) ->
           (xs : desc l I D (IMu l I R)) ->
           desc l (Sigma I (IMu l I R)) (box l I D (IMu l I R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : (l : Level)
            (I : Set l)
            (R : I -> IDesc l I)
            (P : Sigma I (IMu l I R) -> Set l)
            (m : (i : I)
                 (xs : desc l I (R i) (IMu l I R))
                 (hs : desc l (Sigma I (IMu l I R)) (box l I (R i) (IMu l I R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu l I R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- List
--********************************************

data ListDConst (l : Level) : Set l where
  cnil : ListDConst l
  ccons : ListDConst l

listDChoice : (l : Level) -> Set l -> ListDConst l -> IDesc l Unit
listDChoice x X cnil = const Unit
listDChoice x X ccons = sigma X (\_ -> var Void)

listD : (l : Level) -> Set l -> IDesc l Unit
listD x X = sigma (ListDConst x) (listDChoice x X)

list : (l : Level) -> Set l -> Set l
list x X = IMu x Unit (\_ -> listD x X) Void

--********************************************
-- DescD
--********************************************

data DescDConst (l : Level) : Set l where
  lvar   : DescDConst l
  lconst : DescDConst l
  lprod  : DescDConst l
  lpi    : DescDConst l
  lsigma : DescDConst l

descDChoice : (l : Level) -> Set l -> DescDConst (suc l) -> IDesc (suc l) Unit
descDChoice _ I lvar = const (lift I)
descDChoice x _ lconst = const (Set x)
descDChoice _ _ lprod = prod (var Void) (var Void)
descDChoice x _ lpi = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))
descDChoice x _ lsigma = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))

descD : (l : Level)(I : Set l) -> IDesc (suc l) Unit
descD x I = sigma (DescDConst (suc x)) (descDChoice x I)

IDescl : (l : Level)(I : Set l) -> Set (suc l)
IDescl x I = IMu (suc x) Unit (\_ -> descD x I) Void

varl : (l : Level)(I : Set l)(i : I) -> IDescl l I
varl x I i = con (lv , lifter i)
     where lv : DescDConst (suc x)
           lv = lvar

constl : (l : Level)(I : Set l)(X : Set l) -> IDescl l I
constl x I X = con (lc , X)
       where lc : DescDConst (suc x)
             lc = lconst

prodl : (l : Level)(I : Set l)(D D' : IDescl l I) -> IDescl l I
prodl x I D D' = con (lp , (D , D'))
      where lp : DescDConst (suc x)
            lp = lprod

pil : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
pil x I S T = con (lp , ( S , Tl))
    where lp : DescDConst (suc x)
          lp = lpi
          Tl : Lifted S -> IDescl x I
          Tl (lifter s) = T s

sigmal : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
sigmal x I S T = con (ls , ( S , Tl))
       where ls : DescDConst (suc x)
             ls = lsigma
             Tl : Lifted S -> IDescl x I
             Tl (lifter s) = T s