module Chapter11.Lift.Examples.Head
(A : Set)
where
open import Level hiding (zero ; suc)
open import Data.Unit
open import Data.Fin hiding (fold ; lift)
open import Data.Product
open import Chapter2.Logic
open import Chapter6.IDesc
open import Chapter6.IDesc.Fixpoint
open import Chapter6.IDesc.InitialAlgebra
open import Chapter6.IDesc.Examples.Bool
open import Chapter6.IDesc.Examples.Nat
open import Chapter10.Ornament
open import Chapter10.Ornament.Examples.List
open import Chapter10.Ornament.Examples.Maybe
open import Chapter11.Functions
open import Chapter11.FunOrnament
open import Chapter11.Patch
open import Chapter11.Lift.Fold
open import Chapter11.Lift.Constructor
typeIsSuc : Type _
typeIsSuc = μ NatD [ tt ]→ μ BoolD [ tt ]× `⊤
α : Alg NatD (λ _ → Bool × Lift ⊤)
α {tt} (zero , lift tt) = false , lift tt
α {tt} (suc zero , _) = true , lift tt
α {tt} (suc (suc ()) , _)
isSuc : ⟦ typeIsSuc ⟧Type
isSuc = fold NatD α
typeHead : FunctionOrn typeIsSuc
typeHead = μ⁺ ListO A [ inv tt ]→
μ⁺ MaybeO A [ inv tt ]× `⊤
αL : AlgLift (ListO A) α (μ⁺ MaybeO A [ inv tt ]× `⊤)
αL {tt , ⟨ zero , lift tt ⟩} xs = liftConstructor (MaybeO A) (lift tt) (lift tt) (lift tt)
αL {tt , ⟨ suc zero , n ⟩} ((a , _) , xs) = liftConstructor ((MaybeO A)) (a , lift tt) (lift tt) (lift tt)
αL {tt , ⟨ suc (suc ()) , _ ⟩} _
vhead : Patch isSuc typeHead
vhead = liftAlg (ListO A) {T⁺ = μ⁺ MaybeO A [ inv tt ]× `⊤} α (λ {i} → αL {i})
open import Chapter11.Patch.Apply
head : ⟦ typeHead ⟧FunctionOrn
head = patch typeHead isSuc vhead