Saturday, 20 February 2016

-- When I was reading about descriptions ([1]), I was wondering whether
-- there is an encoding that is not that powerful, but simple, straightforward
-- and allows to encode a vast amount of data types among with their elimination principles
-- (the containers approach ([2]) doesn't allow this in an intensional type theory [3]).
-- I'll describe such encoding.
openimportLevelrenaming(zero to lzero; suc to lsuc)openimportFunctionopenimportRelation.Binary.PropositionalEqualityopenimportData.Nat.Baserenaming(_⊔_ to _⊔ℕ_)openimportData.ProductopenimportData.List.Baseinfixr5 _∷₁_
-- `List₁ B xs` contains a `B x` for each `x` in `xs`.
-- It's the same `All` from `Data.List.All`, but lies in `Set β` rather than `Set (α ⊔ β)`.
dataList₁{αβ}{A:Setα}(B:A->Setβ):ListA->Setβwhere[]₁:List₁B[]_∷₁_:∀{xxs}->Bx->List₁Bxs->List₁B(x∷xs)-- And here is the encoding.
Over:∀{ι}->Setι->∀α->Set(ι⊔lsucα)OverIα=ListI->I->SetαrecordRose{ια}{I:Setι}(F:OverIα)j:Set(ι⊔α)whereinductiveconstructornodefield{is}:ListIcons:Fisjchilds:List₁(RoseF)is-- `Over` describes all possible constructors of a data type and
-- `Rose` ties the knot and connects these constructors together.
-- `Rose` is able to express inductive families and that's why there is the `I` --
-- it's the type of the indices of a data type.
-- `Over` contains all information about a data type being described
-- except for inductive occurrences, which are reflected to the type level
-- by storing their indices in `List I`. The final `I` in
-- Over I α = List I -> I -> Set α
-- is for the index that a constructor produces.
-- Here is how it looks for vectors:
moduleVecwheredataVecF{α}(A:Setα):Overℕαwhere-- The first constructor for `Vec` (`[]ᵥ`) doesn't contain any data
-- and it produces the index `0`.
Nil:VecFA[]0-- The second constructor for `Vec` (`_∷ᵥ_`) contains an `A` and
-- an inductive occurrence of `Vec`. It produces the index `suc n`
-- where `n` is the index of the inductive occurrence.
-- Hence we put `n` into the list of indices of inductive occurrences and return `suc n`.
Cons:∀{n}->A->VecFA(n∷[])(sucn)-- `Vec` then is
Vec:∀{α}->Setα->ℕ->SetαVecAn=Rose(VecFA)n-- Let's look again at the definition of `Rose`:
-- record Rose {ι α} {I : Set ι} (F : Over I α) j : Set (ι ⊔ α) where
-- inductive
-- constructor node
-- field
-- {is} : List I
-- cons : F is j
-- childs : List₁ (Rose F) is
-- `j` is an index of an inhabitant of a data type.
-- `is` is a list of indices of inductive occurrences.
-- `cons` is a constructor of this data type.
-- `childs` is a list of `Rose F i` for each `i` in `is`,
-- i.e. a list that actually contains inductive occurrences (finally).
-- Recall the definition of `Cons`:
-- `Cons : ∀ {n} -> A -> VecF A (n ∷ []) (suc n)`
-- When we write `node (Cons x)` `is` gets unified with `_n ∷ []` and
-- `j` gets unified with `suc _n` for a fresh meta `_n`.
-- Thus, `childs` has type `List₁ (Vec A) (_n ∷ [])`,
-- i.e. there is exactly one child -- `Vec A n`.
-- So here are the constructors:
-- []ᵥ : ∀ {α} {A : Set α} -> Vec A 0
-- []ᵥ = node Nil []₁
-- _∷ᵥ_ : ∀ {n α} {A : Set α} -> A -> Vec A n -> Vec A (suc n)
-- x ∷ᵥ xs = node (Cons x) (xs ∷₁ []₁)
-- But for convenience we'll define them as pattern synonyms instead
pattern[]ᵥ=nodeNil[]₁pattern_∷ᵥ_xxs=node(Consx)(xs∷₁[]₁)-- And guess what, we have literally the same eliminator as for the usual `Vec`:
elimVec:∀{απ}{A:Setα}{n}->(P:∀{n}->VecAn->Setπ)->(∀{n}{xs:VecAn}x->Pxs->P(x∷ᵥxs))->P[]ᵥ->(xs:VecAn)->PxselimVecPfz[]ᵥ=zelimVecPfz(x∷ᵥxs)=fx(elimVecPfzxs)-- So we basically don't need it -- we can use pattern matching directly, e.g.:
vmap:∀{nαβ}{A:Setα}{B:Setβ}->(A->B)->VecAn->VecBnvmapf[]ᵥ=[]ᵥvmapf(x∷ᵥxs)=fx∷ᵥvmapfxsvhead:∀{nα}{A:Setα}->VecA(sucn)->Avhead(x∷ᵥxs)=xmoduleAnEliminatorwhere-- We can of course define an eliminator of `Rose`.
-- But let's define an eliminator for something simpler first.
dataTree{α}(A:Setα):Setαwherebranch:A->List(TreeA)->TreeA-- An eliminator is an induction principle and an induction hypothesis
-- sounds like "`P` holds, if it holds at every inductive position".
-- To say "`P` holds for a list `xs` of inductive occurrences" we write `List₁ P xs`.
-- Here is the eliminator:
elimTree:∀{απ}{A:Setα}->(P:TreeA->Setπ)->(∀{ts}x->List₁Pts->P(branchxts))->∀t->PtelimTreePf(branchxts)=fx(elimTreests)whereelimTrees:∀ts->List₁PtselimTrees[]=[]₁elimTrees(t∷ts)=elimTreePft∷₁elimTreests-- `Rose` is basically the same thing as `Tree`, but there is `List₁` instead of `List`.
-- All we need is to define `List₂` over `List₁` in the same manner as `List₁` over `List` before.
dataList₂{αβγ}{A:Setα}{B:A->Setβ}(C:∀{x}->Bx->Setγ):∀{xs}->List₁Bxs->Setγwhere[]₂:List₂C[]₁_∷₂_:∀{xxs}{y:Bx}{ys:List₁Bxs}->Cy->List₂Cys->List₂C(y∷₁ys)lmap₂:∀{αβγ}{A:Setα}{B:A->Setβ}{C:∀{x}->Bx->Setγ}{xs}->(∀{x}->(y:Bx)->Cy)->(ys:List₁Bxs)->List₂Cyslmap₂g[]₁=[]₂lmap₂g(y∷₁ys)=gy∷₂lmap₂gys{-#TERMINATING#-}elimRose:∀{ιαπ}{I:Setι}{F:OverIα}{j}->(P:∀{j}->RoseFj->Setπ)->(∀{isjcs}->(c:Fisj)->List₂Pcs->P(nodeccs))->(r:RoseFj)->PrelimRosePf(nodeccs)=fc(lmap₂(elimRosePf)cs)-- We could get rid of the `{-# TERMINATING #-}` pragma by inlining `lmap₂' and
-- defining `elimRose` mutually with `elimRoses` as in the case of `Tree`, but I hate this.
-- As an example, let's define an eliminator for `Vec` in terms of `elimRose`.
openVecelimVec′:∀{απ}{A:Setα}{n}->(P:∀{n}->VecAn->Setπ)->(∀{n}{xs:VecAn}x->Pxs->P(x∷ᵥxs))->P[]ᵥ->(xs:VecAn)->PxselimVec′{A =A}Pfz=elimRosePhwhereh:∀{isjcs}->(c:VecFAisj)->List₂Pcs->P(nodeccs)hNil[]₂=zh(Consx)(xs∷₂[]₂)=fxxs-- Not super nice, but works.
-- A recursor is similar:
unmap₁:∀{αβγ}{A:Setα}{B:A->Setβ}{C:Setγ}{xs}->(∀{x}->Bx->C)->List₁Bxs->ListCunmap₁g[]₁=[]unmap₁g(y∷₁ys)=gy∷unmap₁gys{-#TERMINATING#-}foldRose:∀{ιαπ}{I:Setι}{F:OverIα}{j}{P:Setπ}->(∀{isj}->Fisj->ListP->P)->RoseFj->PfoldRosef(nodeccs)=fc(unmap₁(foldRosef)cs)-- We can define a generic `depth` function that returns the depth of any `Rose`.
depth:∀{ια}{I:Setι}{F:OverIα}{j}->RoseFj->ℕdepth=foldRose(λ_->foldr(_⊔ℕ_∘suc)0)-- A simple test:
vec-depth:∀{nα}{A:Setα}->(xs:VecAn)->depthxs≡nvec-depth[]ᵥ=reflvec-depth(x∷ᵥxs)=congsuc(vec-depthxs)-- One restriction is that we can't describe data types in which an inductive position occurs
-- to the right of the arrow in a parameter of a constructor (like e.g. in `W`).
-- This is fixable: I wrote a library that deals with Observational Type Theory,
-- `W` is expressible there and has the usual induction principle.
-- Here it is: https://github.com/effectfully/OTT/blob/master/Data/W.agda
-- An extended example: simply typed lambda calculus.
moduleSTLCwhereinfixr6 _⇒_
infixl5 _▻_
infix3 _∈_ _⊢_
infixr4 vs_
infixr0 ƛ_
infixl6 _·_
dataType:Setwherenat:Type_⇒_:Type->Type->Type⟦_⟧:Type->Set⟦nat⟧=ℕ⟦σ⇒τ⟧=⟦σ⟧->⟦τ⟧dataCon:Setwhereε:Con_▻_:Con->Type->Condata_∈_σ:Con->Setwherevz:∀{Γ}->σ∈Γ▻σvs_:∀{Γτ}->σ∈Γ->σ∈Γ▻τdataEnv:Con->Setwhere∅:Envε_▷_:∀{Γσ}->EnvΓ->⟦σ⟧->Env(Γ▻σ)lookupᵉ:∀{Γσ}->σ∈Γ->EnvΓ->⟦σ⟧lookupᵉvz(ρ▷x)=xlookupᵉ(vsv)(ρ▷x)=lookupᵉvρdataTermF:Over(Con×Type)lzerowherePure:∀{Γσ}->⟦σ⟧->TermF[](Γ,σ)Var:∀{Γσ}->σ∈Γ->TermF[](Γ,σ)Lam:∀{Γστ}->TermF((Γ▻σ,τ)∷[])(Γ,σ⇒τ)App:∀{Γστ}->TermF((Γ,σ⇒τ)∷(Γ,σ)∷[])(Γ,τ)Z:∀{Γ}->TermF[](Γ,nat)S:∀{Γ}->TermF((Γ,nat)∷[])(Γ,nat)Fold:∀{Γσ}->TermF((Γ,σ⇒σ)∷(Γ,σ)∷(Γ,nat)∷[])(Γ,σ)_⊢_:Con->Type->SetΓ⊢σ=RoseTermF(Γ,σ)Term⁺:Type->SetTerm⁺σ=∀{Γ}->Γ⊢σTerm⁽⁾:Type->SetTerm⁽⁾σ=ε⊢σpatternpurex=node(Purex)[]₁patternvarv=node(Varv)[]₁patternƛ_b=nodeLam(b∷₁[]₁)pattern_·_fx=nodeApp(f∷₁x∷₁[]₁)patternz=nodeZ[]₁patternsn=nodeS(n∷₁[]₁)patterntfoldfxn=nodeFold(f∷₁x∷₁n∷₁[]₁)⟦_⟧ᵥ:∀{Γσ}->Γ⊢σ->EnvΓ->⟦σ⟧⟦purex⟧ᵥρ=x⟦varv⟧ᵥρ=lookupᵉvρ⟦ƛb⟧ᵥρ=λx->⟦b⟧ᵥ(ρ▷x)⟦f·x⟧ᵥρ=⟦f⟧ᵥρ(⟦x⟧ᵥρ)⟦z⟧ᵥρ=0⟦sn⟧ᵥρ=suc(⟦n⟧ᵥρ)⟦tfoldfxn⟧ᵥρ=fold(⟦x⟧ᵥρ)(⟦f⟧ᵥρ)(⟦n⟧ᵥρ)eval:∀{σ}->Term⁽⁾σ->⟦σ⟧evalt=⟦t⟧ᵥ∅A:∀{στ}->Term⁺((σ⇒τ)⇒σ⇒τ)A=ƛƛvar(vsvz)·varvztest:∀{στ}->eval(A{σ}{τ})≡_$_test=reflmoduleReferenceswhere-- [1] "The Gentle Art of Levitation"
-- James Chapman, Pierre-Evariste Dagand, Conor McBride, Peter Morris
-- http://jmchapman.github.io/papers/levitation.pdf
-- [2] "Indexed Containers"
-- Thorsten Altenkirch, Neil Ghani, Peter Hancock, Conor McBride, Peter Morris
-- http://www.cs.nott.ac.uk/~psztxa/publ/jcont.pdf
-- [3] "W-types: good news and bad news"
-- Conor McBride
-- http://mazzo.li/epilogue/index.html%3Fp=324.html