open import Level

module Chapter8.IDesc.Levitation 
         { k : Level}
         {I : Set k}
       where

open import Level
  renaming ( zero to zeroL
           ; suc to sucL )
open import Data.Unit
open import Data.Product

open import Category.Applicative

open import Relation.Binary.PropositionalEquality

open import Chapter2.Logic
open import Chapter2.IProp

open import Chapter6.IDesc
open import Chapter6.IDesc.Fixpoint
open import Chapter6.IDesc.Lifting
open import Chapter6.IDesc.Induction

open import Chapter8.IDesc


ψ : IDesc  I  IDesc'  I
ψ (`var i) = `var' i
ψ `1 = `1'
ψ (D  D') = ψ D `×' ψ D'
ψ ( n T) = `σ' n λ k  ψ (T k)
ψ ( S T) = `Σ' S λ s  ψ (T s)
ψ ( S T) = `Π' S λ s  ψ (T s)

private 
  record ⟨φ_⟩ (D : IDesc'  I) : Set (k  (sucL )) where
    constructor return
    field 
      call : IDesc  I
  open ⟨φ_⟩

  α : [ IDescD  I ]^  D  ⟨φ D )   D  ⟨φ  proj₂ D  )
  α {_ , `var` , (lift i) , lift tt} (lift tt) = return (`var i)
  α {_ , `1` , lift tt} (lift tt) = return `1
  α {_ , `×` , D , D' , (lift tt)} (ihD , ihD' , lift tt) = return (call ihD  call ihD')
  α {_ , `σ` , lift n , T , lift tt} (ih , lift tt) = return ( n λ k  call (ih (lift k)))
  α {_ , `Σ` , lift S , T , lift tt} (ih , lift tt) = return ( S λ s  call (ih (lift (lift s))))
  α {_ , `Π` , lift S , T , lift tt} (ih , lift tt) = return ( S λ s  call (ih (lift (lift s))))

  φh : (D : IDesc'  I)  ⟨φ D 
  φh = induction (IDescD  I)  D  ⟨φ D )  {i}{xs}  α {i , xs})

φ : (D : IDesc'  I)  IDesc  I
φ D = call (φh D)

⊢ψ∘φ :  (D : IDesc'  I)   ψ (φ D)  D
⊢ψ∘φ  `var` , i , lift tt  = pf refl
⊢ψ∘φ  `1` , lift tt  = pf refl
⊢ψ∘φ  `×` , A , B , lift tt  = 
  cong₂  x y   `×` , x , y , lift {= k  sucL } tt ) <$> ⊢ψ∘φ A  ⊢ψ∘φ B 
⊢ψ∘φ  `σ` , E , T , lift tt  = 
  cong  x   `σ` , E , x , lift {= k  sucL } tt ) <$> 
         extensionality  e  ⊢ψ∘φ (T e))
⊢ψ∘φ  `Σ` , S , T , lift tt  = 
    cong  x   `Σ` , S , x , lift {= k  sucL } tt ) <$> 
         extensionality  s  ⊢ψ∘φ (T s))
⊢ψ∘φ  `Π` , S , T , lift tt  = 
    cong  x   `Π` , S , x , lift {= k  sucL } tt ) <$> 
         extensionality  s  ⊢ψ∘φ (T s))


⊢φ∘ψ :  (D : IDesc  I)   φ (ψ D)  D
⊢φ∘ψ (`var i) = pf refl
⊢φ∘ψ `1 = pf refl
⊢φ∘ψ (A  B) = cong₂  x y  x  y) <$> ⊢φ∘ψ A  ⊢φ∘ψ B 
⊢φ∘ψ ( E T) = cong  x   E x) <$> extensionality λ e  ⊢φ∘ψ (T e)
⊢φ∘ψ ( S T) = cong  x   S x) <$> extensionality λ s  ⊢φ∘ψ (T s)
⊢φ∘ψ ( S T) = cong  x   S x) <$> extensionality λ s  ⊢φ∘ψ (T s)