module Chapter8.Desc.Levitation where

open import Level

open import Data.Unit
open import Data.Product

open import Category.Applicative
open import Category.Applicative.Indexed

open import Relation.Binary.PropositionalEquality

open import Chapter2.Logic
open import Chapter2.IProp

open import Chapter5.Desc
open import Chapter5.Desc.Fixpoint
open import Chapter5.Desc.Lifting
open import Chapter5.Desc.Induction

open import Chapter8.Desc


ψ : ∀{}  Desc   Desc' 
ψ `var = `var'
ψ `1 = `1'
ψ (D  D') = ψ D `×' ψ D'
ψ (D `+ D') = ψ D `+' ψ D'
ψ ( S T) = `Σ' S λ s  ψ (T s)
ψ ( S T) = `Π' S λ s  ψ (T s)

private 
  record ⟨φ_⟩ { : Level}(D : Desc' ) : Set (suc ) where
    constructor return
    field 
      call : Desc 
  open ⟨φ_⟩

  α : ∀{}  [_]^ {k = suc } (DescD )  D  ⟨φ D )   D  ⟨φ  D  )
  α {i = `var` , lift tt} (lift tt) = return `var
  α {i = `1` , lift tt} (lift tt) = return `1
  α {i = `×` , D , D' , lift tt} (ihD , ihD' , lift tt) = return (call ihD  call ihD')
  α {i = `+` , D , D' , lift tt} (ihD , ihD' , lift tt) = return (call ihD `+ call ihD')
  α {i = `Σ` , S , T , lift tt} (ih , lift tt) = return ( S λ s  call (ih (lift s)))
  α {i = `Π` , S , T , lift tt} (ih , lift tt) = return ( S λ s  call (ih (lift s)))

  φh : ∀{}  (D : Desc' )  ⟨φ D 
  φh {} = induction (DescD )  D  ⟨φ D ) α 

φ : ∀{} (D : Desc' )  Desc 
φ D = call (φh D)



⊢ψ∘φ : ∀{} (D : Desc' )   ψ (φ D)  D
⊢ψ∘φ  `var` , lift tt  = pf refl
⊢ψ∘φ  `1` , lift tt  = pf refl
⊢ψ∘φ  `×` , A , B , lift tt  = 
    cong₂  x y   `×` , x , y , lift tt ) <$> ⊢ψ∘φ A  ⊢ψ∘φ B
⊢ψ∘φ  `+` , A , B , lift tt  = 
    cong₂  x y   `+` , x , y , lift tt ) <$> ⊢ψ∘φ A  ⊢ψ∘φ B
⊢ψ∘φ  `Σ` , S , T , lift tt  =
    cong  x   `Σ` , S , x , lift tt ) <$> 
        extensionality  s  ⊢ψ∘φ (T s))
⊢ψ∘φ  `Π` , S , T , lift tt   = 
    cong  x   `Π` , S , x , lift tt ) <$> 
        extensionality  s  ⊢ψ∘φ (T s))


⊢φ∘ψ :  {}(D : Desc )   φ (ψ D)  D
⊢φ∘ψ `var = pf refl
⊢φ∘ψ `1 = pf refl
⊢φ∘ψ (A  B) = cong₂  x y  x  y) <$> ⊢φ∘ψ A  ⊢φ∘ψ B
⊢φ∘ψ (A `+ B) = cong₂  x y  x `+ y) <$> ⊢φ∘ψ A  ⊢φ∘ψ B
⊢φ∘ψ ( S T) = cong  x   S x) <$> 
                    extensionality λ s  ⊢φ∘ψ (T s)
⊢φ∘ψ ( S T) = cong  x   S x) <$> 
                    extensionality λ s  ⊢φ∘ψ (T s)