{-# OPTIONS --type-in-type #-} module Chapter3.IDesc.Levitation {I : Set} where open import Data.Unit open import Data.Product open import Relation.Binary.PropositionalEquality open import Chapter1.Logic open import Chapter1.IProp open import Chapter2.IDesc open import Chapter2.IDesc.Fixpoint open import Chapter2.IDesc.Lifting open import Chapter2.IDesc.Induction open import Chapter3.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₁ where constructor return field call : IDesc I open ⟨φ_⟩ α : [ IDescD I ]^ (λ D → ⟨φ D ⟩) ⇒ (λ D → ⟨φ ⟨ proj₂ D ⟩ ⟩) α {_ , `var` , i , tt} tt = return (`var i) α {_ , `1` , tt} tt = return `1 α {_ , `×` , D , D' , tt} (ihD , ihD' , tt) = return (call ihD `× call ihD') α {_ , `σ` , n , T , tt} (ih , tt) = return (`σ n λ k → call (ih k)) α {_ , `Σ` , S , T , tt} (ih , tt) = return (`Σ S λ s → call (ih s)) α {_ , `Π` , S , T , tt} (ih , tt) = return (`Π S λ s → call (ih 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) postulate ⊢ψ∘φ : ∀ (D : IDesc' I) → ⊢ ψ (φ D) ≡ D ⊢φ∘ψ : ∀ (D : IDesc I) → ⊢ φ (ψ D) ≡ D