116 lines
5.2 KiB
Plaintext
116 lines
5.2 KiB
Plaintext
{-# OPTIONS --cubical --safe --exact-split #-}
|
||
|
||
Definition taken from https://drops.dagstuhl.de/opus/volltexte/2023/18395/pdf/LIPIcs-ITP-2023-20.pdf
|
||
module Cubical.Structures.Set.CMon.PList where
|
||
|
||
open import Cubical.Core.Everything
|
||
open import Cubical.Foundations.Everything
|
||
open import Cubical.Data.List as L
|
||
|
||
import Cubical.Structures.Set.Mon.Desc as M
|
||
import Cubical.Structures.Set.Mon.List as LM
|
||
import Cubical.Structures.Set.CMon.Desc as M
|
||
import Cubical.Structures.Free as F
|
||
open import Cubical.Structures.Sig
|
||
open import Cubical.Structures.Str public
|
||
open import Cubical.Structures.Tree
|
||
open import Cubical.Structures.Eq
|
||
open import Cubical.Structures.Arity hiding (_/_)
|
||
open import Cubical.Structures.Set.CMon.QFreeMon
|
||
|
||
data Perm {ℓ : Level} {A : Type ℓ} : List A -> List A -> Type ℓ where
|
||
perm-refl : ∀ {xs} -> Perm xs xs
|
||
perm-swap : ∀ {x y xs ys zs} -> Perm (xs ++ x ∷ y ∷ ys) zs -> Perm (xs ++ y ∷ x ∷ ys) zs
|
||
|
||
private
|
||
variable
|
||
ℓ ℓ₁ ℓ₂ : Level
|
||
A B : Type ℓ
|
||
|
||
infixr 30 _∙ₚ_
|
||
_∙ₚ_ : ∀ {xs ys zs} -> Perm xs ys -> Perm ys zs -> Perm {A = A} xs zs
|
||
perm-refl ∙ₚ q = q
|
||
(perm-swap p) ∙ₚ q = perm-swap (p ∙ₚ q)
|
||
|
||
perm-sym : ∀ {xs ys} -> Perm xs ys -> Perm {A = A} ys xs
|
||
perm-sym perm-refl = perm-refl
|
||
perm-sym (perm-swap p) = perm-sym p ∙ₚ perm-swap perm-refl
|
||
|
||
perm-subst : ∀ {xs ys} -> xs ≡ ys -> Perm {A = A} xs ys
|
||
perm-subst {xs = xs} p = subst (Perm xs) p perm-refl
|
||
|
||
perm-∷ : ∀ {x xs ys} -> Perm xs ys -> Perm {A = A} (x ∷ xs) (x ∷ ys)
|
||
perm-∷ perm-refl = perm-refl
|
||
perm-∷ {x = x} (perm-swap {xs = xs} p) = perm-swap {xs = x ∷ xs} (perm-∷ p)
|
||
|
||
perm-prepend : (xs : List A) {ys zs : List A} -> Perm ys zs -> Perm (xs ++ ys) (xs ++ zs)
|
||
perm-prepend [] p = p
|
||
perm-prepend (x ∷ xs) p = perm-∷ (perm-prepend xs p)
|
||
|
||
perm-append : ∀ {xs ys} -> Perm xs ys -> (zs : List A) -> Perm (xs ++ zs) (ys ++ zs)
|
||
perm-append perm-refl _ = perm-refl
|
||
perm-append (perm-swap {xs = xs} p) _ =
|
||
perm-subst (++-assoc xs _ _) ∙ₚ perm-swap (perm-subst (sym (++-assoc xs _ _)) ∙ₚ perm-append p _)
|
||
|
||
perm-movehead : (x : A) (xs : List A) {ys : List A} -> Perm (x ∷ xs ++ ys) (xs ++ x ∷ ys)
|
||
perm-movehead x [] = perm-refl
|
||
perm-movehead x (y ∷ xs) = perm-swap {xs = []} (perm-∷ (perm-movehead x xs))
|
||
|
||
⊕-commₚ : (xs ys : List A) -> Perm (xs ++ ys) (ys ++ xs)
|
||
⊕-commₚ xs [] = perm-subst (++-unit-r xs)
|
||
⊕-commₚ xs (y ∷ ys) = perm-sym (perm-movehead y xs {ys = ys}) ∙ₚ perm-∷ (⊕-commₚ xs ys)
|
||
|
||
module _ {ℓA ℓB} {A : Type ℓA} {𝔜 : struct ℓB M.MonSig} {isSet𝔜 : isSet (𝔜 .car)} (𝔜-cmon : 𝔜 ⊨ M.CMonSEq) (f : A -> 𝔜 .car) where
|
||
module 𝔜 = M.CMonSEq 𝔜 𝔜-cmon
|
||
|
||
f♯-hom = LM.Free.♯-isMonHom isSet𝔜 (M.cmonSatMon 𝔜-cmon) f
|
||
|
||
f♯ : List A -> 𝔜 .car
|
||
f♯ = f♯-hom .fst
|
||
|
||
f♯-++ : ∀ xs ys -> f♯ (xs ++ ys) ≡ f♯ xs 𝔜.⊕ f♯ ys
|
||
f♯-++ xs ys =
|
||
f♯ (xs ++ ys) ≡⟨ sym ((f♯-hom .snd) M.`⊕ (lookup (xs ∷ ys ∷ []))) ⟩
|
||
𝔜 .alg (M.`⊕ , (λ w -> f♯ (lookup (xs ∷ ys ∷ []) w))) ≡⟨ 𝔜.⊕-eta (lookup (xs ∷ ys ∷ [])) f♯ ⟩
|
||
_ ∎
|
||
|
||
f♯-swap : ∀ {x y : A} (xs ys : List A) -> f♯ (xs ++ x ∷ y ∷ ys) ≡ f♯ (xs ++ y ∷ x ∷ ys)
|
||
f♯-swap {x} {y} [] ys =
|
||
f♯ ((L.[ x ] ++ L.[ y ]) ++ ys) ≡⟨ f♯-++ (L.[ x ] ++ L.[ y ]) ys ⟩
|
||
f♯ (L.[ x ] ++ L.[ y ]) 𝔜.⊕ f♯ ys ≡⟨ cong (𝔜._⊕ f♯ ys) (f♯-++ L.[ x ] L.[ y ]) ⟩
|
||
(f♯ L.[ x ] 𝔜.⊕ f♯ L.[ y ]) 𝔜.⊕ f♯ ys ≡⟨ cong (𝔜._⊕ f♯ ys) (𝔜.comm _ _) ⟩
|
||
(f♯ L.[ y ] 𝔜.⊕ f♯ L.[ x ]) 𝔜.⊕ f♯ ys ≡⟨ cong (𝔜._⊕ f♯ ys) (sym (f♯-++ L.[ y ] L.[ x ])) ⟩
|
||
f♯ (L.[ y ] ++ L.[ x ]) 𝔜.⊕ f♯ ys ≡⟨ sym (f♯-++ (L.[ y ] ++ L.[ x ]) ys) ⟩
|
||
f♯ ((L.[ y ] ++ L.[ x ]) ++ ys) ∎
|
||
f♯-swap {x} {y} (a ∷ as) ys =
|
||
f♯ (L.[ a ] ++ (as ++ x ∷ y ∷ ys)) ≡⟨ f♯-++ L.[ a ] (as ++ x ∷ y ∷ ys) ⟩
|
||
f♯ L.[ a ] 𝔜.⊕ f♯ (as ++ x ∷ y ∷ ys) ≡⟨ cong (f♯ L.[ a ] 𝔜.⊕_) (f♯-swap as ys) ⟩
|
||
f♯ L.[ a ] 𝔜.⊕ f♯ (as ++ y ∷ x ∷ ys) ≡⟨ sym (f♯-++ L.[ a ] (as ++ y ∷ x ∷ ys)) ⟩
|
||
f♯ (L.[ a ] ++ (as ++ y ∷ x ∷ ys)) ≡⟨⟩
|
||
f♯ ((a ∷ as) ++ y ∷ x ∷ ys) ∎
|
||
|
||
perm-resp-f♯ : {a b : List A} -> Perm a b -> f♯ a ≡ f♯ b
|
||
perm-resp-f♯ perm-refl = refl
|
||
perm-resp-f♯ (perm-swap {xs = xs} {ys = ys} p) = f♯-swap xs ys ∙ perm-resp-f♯ p
|
||
|
||
module _ {ℓ} (A : Type ℓ) where
|
||
open import Cubical.Relation.Binary
|
||
module P = BinaryRelation {A = List A} Perm
|
||
open isPermRel
|
||
|
||
isPermRelPerm : isPermRel LM.listDef (Perm {A = A})
|
||
P.isEquivRel.reflexive (isEquivRel isPermRelPerm) _ = perm-refl
|
||
P.isEquivRel.symmetric (isEquivRel isPermRelPerm) _ _ = perm-sym
|
||
P.isEquivRel.transitive (isEquivRel isPermRelPerm) _ _ _ = _∙ₚ_
|
||
isCongruence isPermRelPerm {a} {b} {c} {d} p q = perm-prepend a q ∙ₚ perm-append p d
|
||
isCommutative isPermRelPerm {a} {b} = ⊕-commₚ a b
|
||
resp-♯ isPermRelPerm {isSet𝔜 = isSet𝔜} 𝔜-cmon f p = perm-resp-f♯ {isSet𝔜 = isSet𝔜} 𝔜-cmon f p
|
||
|
||
PermRel : PermRelation LM.listDef A
|
||
PermRel = Perm , isPermRelPerm
|
||
|
||
module PListDef = F.Definition M.MonSig M.CMonEqSig M.CMonSEq
|
||
|
||
plistFreeDef : ∀ {ℓ} -> PListDef.Free ℓ ℓ 2
|
||
plistFreeDef = qFreeMonDef (PermRel _)
|