91 lines
3.5 KiB
Plaintext
91 lines
3.5 KiB
Plaintext
{-# OPTIONS --cubical --safe --exact-split #-}
|
||
|
||
module Cubical.Structures.Arity where
|
||
|
||
import Cubical.Data.Empty as ⊥
|
||
open import Cubical.Foundations.Everything
|
||
open import Cubical.Data.Fin public renaming (Fin to Arity)
|
||
open import Cubical.Data.Fin.Recursive public using (rec)
|
||
open import Cubical.Data.Nat
|
||
open import Cubical.Data.Nat.Order
|
||
open import Cubical.Data.List
|
||
open import Cubical.Data.Sigma
|
||
|
||
private
|
||
variable
|
||
ℓ : Level
|
||
A B : Type ℓ
|
||
k : ℕ
|
||
|
||
ftwo : Arity (suc (suc (suc k)))
|
||
ftwo = fsuc fone
|
||
|
||
lookup : ∀ (xs : List A) -> Arity (length xs) -> A
|
||
lookup [] num = ⊥.rec (¬Fin0 num)
|
||
lookup (x ∷ xs) (zero , prf) = x
|
||
lookup (x ∷ xs) (suc num , prf) = lookup xs (num , pred-≤-pred prf)
|
||
|
||
tabulate : ∀ n -> (Arity n -> A) -> List A
|
||
tabulate zero ^a = []
|
||
tabulate (suc n) ^a = ^a fzero ∷ tabulate n (^a ∘ fsuc)
|
||
|
||
length-tabulate : ∀ n -> (^a : Arity n → A) -> length (tabulate n ^a) ≡ n
|
||
length-tabulate zero ^a = refl
|
||
length-tabulate (suc n) ^a = cong suc (length-tabulate n (^a ∘ fsuc))
|
||
|
||
tabulate-lookup : ∀ (xs : List A) -> tabulate (length xs) (lookup xs) ≡ xs
|
||
tabulate-lookup [] = refl
|
||
tabulate-lookup (x ∷ xs) =
|
||
_ ≡⟨ cong (λ z -> x ∷ tabulate (length xs) z) (funExt λ _ -> cong (lookup xs) (Σ≡Prop (λ _ -> isProp≤) refl)) ⟩
|
||
_ ≡⟨ cong (x ∷_) (tabulate-lookup xs) ⟩
|
||
_ ∎
|
||
|
||
arity-n≡m : ∀ {n m} -> (a : Arity n) -> (b : Arity m) -> (p : n ≡ m) -> a .fst ≡ b .fst -> PathP (λ i -> Arity (p i)) a b
|
||
arity-n≡m (v , a) (w , b) p q = ΣPathP (q , toPathP (isProp≤ _ _))
|
||
|
||
lookup-tabulate : ∀ n (^a : Arity n -> A) -> PathP (λ i -> (Arity (length-tabulate n ^a i) -> A)) (lookup (tabulate n ^a)) ^a
|
||
lookup-tabulate zero ^a = funExt (⊥.rec ∘ ¬Fin0)
|
||
lookup-tabulate (suc n) ^a = toPathP (funExt lemma) i (zero , p) = ^a (0 , toPathP {A = λ j -> 0 < suc (length-tabulate n (^a ∘ fsuc) (~ j))} {! !} i) toPathP (sym (transport-filler _ _) ∙ cong ^a (Σ≡Prop (λ _ -> isProp≤) refl)) i suc-≤-suc (zero-≤ {n = n}) toPathP {x = suc-≤-suc (zero-≤ {n = n})} {! !} i
|
||
where
|
||
lemma : _
|
||
lemma (zero , p) = sym (transport-filler _ _) ∙ cong ^a (Σ≡Prop (λ _ -> isProp≤) refl)
|
||
TODO: Cleanup this mess
|
||
lemma (suc w , p) =
|
||
_ ≡⟨ sym (transport-filler _ _) ⟩
|
||
_ ≡⟨ congP (λ i f -> f (arity-n≡m (w ,
|
||
pred-≤-pred
|
||
(transp
|
||
(λ i → suc w < suc (length-tabulate n (λ x → ^a (fsuc x)) (~ i)))
|
||
i0 p)) (w , pred-≤-pred p) (length-tabulate n (^a ∘ fsuc)) refl i)) (lookup-tabulate n (^a ∘ fsuc)) ⟩
|
||
_ ≡⟨ cong ^a (Σ≡Prop (λ _ -> isProp≤) refl) ⟩
|
||
_ ∎
|
||
|
||
lookup2≡i : ∀ (i : Arity 2 -> A) -> lookup (i fzero ∷ i fone ∷ []) ≡ i
|
||
lookup2≡i i = funExt lemma
|
||
where
|
||
lemma : _
|
||
lemma (zero , p) = cong i (Σ≡Prop (λ _ -> isProp≤) refl)
|
||
lemma (suc zero , p) = cong i (Σ≡Prop (λ _ -> isProp≤) refl)
|
||
lemma (suc (suc n) , p) = ⊥.rec (¬m+n<m {m = 2} p)
|
||
|
||
◼ : Arity 0 -> A
|
||
◼ = ⊥.rec ∘ ¬Fin0
|
||
|
||
infixr 30 _▸_
|
||
|
||
_▸_ : ∀ {n} -> A -> (Arity n -> A) -> Arity (suc n) -> A
|
||
_▸_ {n = zero} x f i = x
|
||
_▸_ {n = suc n} x f i = lookup (x ∷ tabulate (suc n) f) (subst Arity (congS (suc ∘ suc) (sym (length-tabulate n (f ∘ fsuc)))) i)
|
||
|
||
⟪⟫ : Arity 0 -> A
|
||
⟪⟫ = lookup []
|
||
|
||
⟪_⟫ : (a : A) -> Arity 1 -> A
|
||
⟪ a ⟫ = lookup [ a ]
|
||
|
||
⟪_⨾_⟫ : (a b : A) -> Arity 2 -> A
|
||
⟪ a ⨾ b ⟫ = lookup (a ∷ b ∷ [])
|
||
|
||
⟪_⨾_⨾_⟫ : (a b c : A) -> Arity 3 -> A
|
||
⟪ a ⨾ b ⨾ c ⟫ = lookup (a ∷ b ∷ c ∷ [])
|
||
|