Skip to content

[ add ] Choudhury and Fiore's alternative definition of Permutation for Setoids #2726

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 14 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
139 changes: 139 additions & 0 deletions src/Data/List/Relation/Binary/Permutation/Algorithmic.agda
Original file line number Diff line number Diff line change
@@ -0,0 +1,139 @@
-------------------------------------------------------------------------------
-- The Agda standard library
--
-- A alternative definition for the permutation relation using setoid equality
-- Based on Choudhury and Fiore, "Free Commutative Monoids in HoTT" (MFPS, 2022)
-- Constructor `_⋎_` below is rule (3), directly after the proof of Theorem 6.3,
-- and appears as rule `commrel` of their earlier presentation at (HoTT, 2019),
-- "The finite-multiset construction in HoTT".
-------------------------------------------------------------------------------

{-# OPTIONS --cubical-compatible --safe #-}

open import Relation.Binary.Bundles using (Setoid)

module Data.List.Relation.Binary.Permutation.Algorithmic
{s ℓ} (S : Setoid s ℓ) where

open import Data.List.Base using (List; []; _∷_; length)
open import Data.List.Properties using (++-identityʳ)
open import Data.Nat.Base using (ℕ; suc)
open import Data.Nat.Properties using (suc-injective)
open import Level using (_⊔_)
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)

open import Data.List.Relation.Binary.Equality.Setoid S as ≋
using (_≋_; []; _∷_; ≋-refl)

open Setoid S
renaming (Carrier to A; refl to ≈-refl; sym to ≈-sym; trans to ≈-trans)

private
variable
a b c d : A
as bs cs ds : List A
n : ℕ


-------------------------------------------------------------------------------
-- Definition

infix 4 _∼_
infix 5 _⋎_ _⋎[_]_

data _∼_ : List A → List A → Set (s ⊔ ℓ) where
[] : [] ∼ []
_∷_ : a ≈ b → as ∼ bs → a ∷ as ∼ b ∷ bs
_⋎_ : as ∼ b ∷ cs → a ∷ cs ∼ bs → a ∷ as ∼ b ∷ bs

-- smart constructor for prefix congruence

_≡∷_ : ∀ c → as ∼ bs → c ∷ as ∼ c ∷ bs
_≡∷_ c = ≈-refl ∷_

-- pattern synonym to allow naming the 'middle' term
pattern _⋎[_]_ {as} {b} {a} {bs} as∼b∷cs cs a∷cs∼bs
= _⋎_ {as} {b} {cs = cs} {a} {bs} as∼b∷cs a∷cs∼bs

-------------------------------------------------------------------------------
-- Properties

∼-reflexive : as ≋ bs → as ∼ bs
∼-reflexive [] = []
∼-reflexive (a≈b ∷ as∼bs) = a≈b ∷ ∼-reflexive as∼bs

∼-refl : ∀ as → as ∼ as
∼-refl _ = ∼-reflexive ≋-refl

∼-sym : as ∼ bs → bs ∼ as
∼-sym [] = []
∼-sym (a≈b ∷ as∼bs) = ≈-sym a≈b ∷ ∼-sym as∼bs
∼-sym (as∼b∷cs ⋎ a∷cs∼bs) = ∼-sym a∷cs∼bs ⋎ ∼-sym as∼b∷cs

≋∘∼⇒∼ : as ≋ bs → bs ∼ cs → as ∼ cs
≋∘∼⇒∼ [] [] = []
≋∘∼⇒∼ (a≈b ∷ as≋bs) (b≈c ∷ bs∼cs) = ≈-trans a≈b b≈c ∷ ≋∘∼⇒∼ as≋bs bs∼cs
≋∘∼⇒∼ (a≈b ∷ as≋bs) (bs∼c∷ds ⋎ b∷ds∼cs) =
≋∘∼⇒∼ as≋bs bs∼c∷ds ⋎ ≋∘∼⇒∼ (a≈b ∷ ≋-refl) b∷ds∼cs

∼∘≋⇒∼ : as ∼ bs → bs ≋ cs → as ∼ cs
∼∘≋⇒∼ [] [] = []
∼∘≋⇒∼ (a≈b ∷ as∼bs) (b≈c ∷ bs≋cs) = ≈-trans a≈b b≈c ∷ ∼∘≋⇒∼ as∼bs bs≋cs
∼∘≋⇒∼ (as∼b∷cs ⋎ a∷cs∼bs) (b≈d ∷ bs≋ds) =
∼∘≋⇒∼ as∼b∷cs (b≈d ∷ ≋-refl) ⋎ ∼∘≋⇒∼ a∷cs∼bs bs≋ds

∼-length : as ∼ bs → length as ≡ length bs
∼-length [] = ≡.refl
∼-length (a≈b ∷ as∼bs) = ≡.cong suc (∼-length as∼bs)
∼-length (as∼b∷cs ⋎ a∷cs∼bs) = ≡.cong suc (≡.trans (∼-length as∼b∷cs) (∼-length a∷cs∼bs))

∼-trans : as ∼ bs → bs ∼ cs → as ∼ cs
∼-trans = lemma ≡.refl
where
lemma : n ≡ length bs → as ∼ bs → bs ∼ cs → as ∼ cs

-- easy base case for bs = [], eq: 0 ≡ 0
lemma _ [] [] = []

-- fiddly step case for bs = b ∷ bs, where eq : suc n ≡ suc (length bs)
-- hence suc-injective eq : n ≡ length bs

lemma {n = suc n} eq (a≈b ∷ as∼bs) (b≈c ∷ bs∼cs)
= ≈-trans a≈b b≈c ∷ lemma (suc-injective eq) as∼bs bs∼cs

lemma {n = suc n} eq (a≈b ∷ as∼bs) (bs∼c∷ys ⋎ b∷ys∼cs)
= ≋∘∼⇒∼ (a≈b ∷ ≋-refl) (lemma (suc-injective eq) as∼bs bs∼c∷ys ⋎ b∷ys∼cs)

lemma {n = suc n} eq (as∼b∷xs ⋎ a∷xs∼bs) (a≈b ∷ bs∼cs)
= ∼∘≋⇒∼ (as∼b∷xs ⋎ lemma (suc-injective eq) a∷xs∼bs bs∼cs) (a≈b ∷ ≋-refl)

lemma {n = suc n} {bs = b ∷ bs} {as = a ∷ as} {cs = c ∷ cs} eq
(as∼b∷xs ⋎[ xs ] a∷xs∼bs) (bs∼c∷ys ⋎[ ys ] b∷ys∼cs) = a∷as∼c∷cs
where
n≡∣bs∣ : n ≡ length bs
n≡∣bs∣ = suc-injective eq

n≡∣b∷xs∣ : n ≡ length (b ∷ xs)
n≡∣b∷xs∣ = ≡.trans n≡∣bs∣ (≡.sym (∼-length a∷xs∼bs))

n≡∣b∷ys∣ : n ≡ length (b ∷ ys)
n≡∣b∷ys∣ = ≡.trans n≡∣bs∣ (∼-length bs∼c∷ys)

a∷as∼c∷cs : a ∷ as ∼ c ∷ cs
a∷as∼c∷cs with lemma n≡∣bs∣ a∷xs∼bs bs∼c∷ys
... | a≈c ∷ xs∼ys = a≈c ∷ as∼cs
where
as∼cs : as ∼ cs
as∼cs = lemma n≡∣b∷xs∣ as∼b∷xs
(lemma n≡∣b∷ys∣ (b ≡∷ xs∼ys) b∷ys∼cs)
... | xs∼c∷zs ⋎[ zs ] a∷zs∼ys
= lemma n≡∣b∷xs∣ as∼b∷xs b∷xs∼c∷b∷zs
⋎[ b ∷ zs ]
lemma n≡∣b∷ys∣ a∷b∷zs∼b∷ys b∷ys∼cs
where
b∷zs∼b∷zs : b ∷ zs ∼ b ∷ zs
b∷zs∼b∷zs = ∼-refl (b ∷ zs)
b∷xs∼c∷b∷zs : b ∷ xs ∼ c ∷ (b ∷ zs)
b∷xs∼c∷b∷zs = xs∼c∷zs ⋎[ zs ] b∷zs∼b∷zs
a∷b∷zs∼b∷ys : a ∷ (b ∷ zs) ∼ b ∷ ys
a∷b∷zs∼b∷ys = b∷zs∼b∷zs ⋎[ zs ] a∷zs∼ys
Original file line number Diff line number Diff line change
@@ -0,0 +1,84 @@
-------------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of the `Algorithmic` definition of the permutation relation.
-------------------------------------------------------------------------------

{-# OPTIONS --cubical-compatible --safe #-}

open import Relation.Binary.Bundles using (Setoid)

module Data.List.Relation.Binary.Permutation.Algorithmic.Properties
{s ℓ} (S : Setoid s ℓ) where

open import Data.List.Base using (List; []; _∷_; _++_)
open import Data.List.Properties using (++-identityʳ)
import Relation.Binary.PropositionalEquality as ≡
using (sym)

open import Data.List.Relation.Binary.Equality.Setoid S as ≋
using (≋-reflexive)
open import Data.List.Relation.Binary.Permutation.Algorithmic S
open import Data.List.Relation.Binary.Permutation.Setoid S as ↭
using (_↭_; ↭-refl; ↭-prep; ↭-swap; ↭-trans)

open Setoid S
renaming (Carrier to A; refl to ≈-refl; sym to ≈-sym; trans to ≈-trans)

private
variable
a b c d : A
as bs cs ds : List A


-------------------------------------------------------------------------------
-- Properties

∼-swap : a ≈ c → b ≈ d → cs ∼ ds → a ∷ b ∷ cs ∼ d ∷ c ∷ ds
∼-swap a≈c b≈d cs≈ds = (b≈d ∷ cs≈ds) ⋎ (a≈c ∷ ∼-refl _)

∼-swap-++ : (as bs : List A) → as ++ bs ∼ bs ++ as
∼-swap-++ [] bs = ∼-reflexive (≋-reflexive (≡.sym (++-identityʳ bs)))
∼-swap-++ (a ∷ as) bs = lemma bs (∼-swap-++ as bs)
where
lemma : ∀ bs → cs ∼ bs ++ as → a ∷ cs ∼ bs ++ a ∷ as
lemma [] cs∼as
= a ≡∷ cs∼as
lemma (b ∷ bs) (a≈b ∷ cs∼bs++as)
= (a≈b ∷ ∼-refl _) ⋎ lemma bs cs∼bs++as
lemma (b ∷ bs) (cs∼b∷ds ⋎ a∷ds∼bs++as)
= (cs∼b∷ds ⋎ (∼-refl _)) ⋎ (lemma bs a∷ds∼bs++as)

∼-congʳ : ∀ cs → as ∼ bs → cs ++ as ∼ cs ++ bs
∼-congʳ {as = as} {bs = bs} cs as∼bs = lemma cs
where
lemma : ∀ cs → cs ++ as ∼ cs ++ bs
lemma [] = as∼bs
lemma (c ∷ cs) = c ≡∷ lemma cs

∼-congˡ : as ∼ bs → ∀ cs → as ++ cs ∼ bs ++ cs
∼-congˡ as∼bs cs = lemma as∼bs
where
lemma : as ∼ bs → as ++ cs ∼ bs ++ cs
lemma [] = ∼-refl cs
lemma (a≈b ∷ as∼bs) = a≈b ∷ lemma as∼bs
lemma (as∼b∷xs ⋎ bs∼a∷xs) = lemma as∼b∷xs ⋎ lemma bs∼a∷xs

∼-cong : as ∼ bs → cs ∼ ds → as ++ cs ∼ bs ++ ds
∼-cong as∼bs cs∼ds = ∼-trans (∼-congˡ as∼bs _) (∼-congʳ _ cs∼ds)

-------------------------------------------------------------------------------
-- Equivalence with `Setoid` definition _↭_

↭⇒∼ : as ↭ bs → as ∼ bs
↭⇒∼ (↭.refl as≋bs) = ∼-reflexive as≋bs
↭⇒∼ (↭.prep a≈b as∼bs) = a≈b ∷ ↭⇒∼ as∼bs
↭⇒∼ (↭.swap a≈c b≈d cs∼ds) = ∼-swap a≈c b≈d (↭⇒∼ cs∼ds)
↭⇒∼ (↭.trans as∼bs bs∼cs) = ∼-trans (↭⇒∼ as∼bs) (↭⇒∼ bs∼cs)

∼⇒↭ : as ∼ bs → as ↭ bs
∼⇒↭ [] = ↭.↭-refl
∼⇒↭ (a≈b ∷ as∼bs) = ↭.prep a≈b (∼⇒↭ as∼bs)
∼⇒↭ (as∼b∷cs ⋎ a∷cs∼bs) = ↭-trans (↭-prep _ (∼⇒↭ as∼b∷cs))
(↭-trans (↭-swap _ _ ↭-refl)
(↭-prep _ (∼⇒↭ a∷cs∼bs)))
104 changes: 104 additions & 0 deletions src/Data/List/Relation/Binary/Permutation/Declarative.agda
Original file line number Diff line number Diff line change
@@ -0,0 +1,104 @@
-------------------------------------------------------------------------------
-- The Agda standard library
--
-- A declarative definition of the permutation relation,
-- as the least congruence making `_++_` commutative
-------------------------------------------------------------------------------

{-# OPTIONS --cubical-compatible --safe #-}

open import Relation.Binary.Bundles using (Setoid)

module Data.List.Relation.Binary.Permutation.Declarative
{s ℓ} (S : Setoid s ℓ) where

open import Data.List.Base using (List; []; _∷_; [_]; _++_)
open import Data.List.Properties using (++-identityʳ)
open import Function.Base using (id; _∘_)
open import Level using (_⊔_)
import Relation.Binary.PropositionalEquality as ≡ using (sym)

open import Data.List.Relation.Binary.Equality.Setoid S as ≋
using (_≋_; []; _∷_; ≋-refl; ≋-reflexive)

open Setoid S
renaming (Carrier to A; refl to ≈-refl; sym to ≈-sym; trans to ≈-trans)

private
variable
a b c d : A
as bs cs ds : List A


-------------------------------------------------------------------------------
-- Definition

infix 4 _∼_

data _∼_ : List A → List A → Set (s ⊔ ℓ) where
[] : [] ∼ []
_∷_ : a ≈ b → as ∼ bs → a ∷ as ∼ b ∷ bs
trans : as ∼ bs → bs ∼ cs → as ∼ cs
_++ᵒ_ : ∀ as bs → as ++ bs ∼ bs ++ as

-- smart constructor for prefix congruence

_≡∷_ : ∀ c → as ∼ bs → c ∷ as ∼ c ∷ bs
_≡∷_ c = ≈-refl ∷_

-------------------------------------------------------------------------------
-- Basic properties and smart constructors

∼-reflexive : as ≋ bs → as ∼ bs
∼-reflexive [] = []
∼-reflexive (a≈b ∷ as∼bs) = a≈b ∷ ∼-reflexive as∼bs

∼-refl : ∀ as → as ∼ as
∼-refl _ = ∼-reflexive ≋-refl

∼-sym : as ∼ bs → bs ∼ as
∼-sym [] = []
∼-sym (a≈b ∷ as∼bs) = ≈-sym a≈b ∷ ∼-sym as∼bs
∼-sym (trans as∼cs cs∼bs) = trans (∼-sym cs∼bs) (∼-sym as∼cs)
∼-sym (as ++ᵒ bs) = bs ++ᵒ as

-- smart constructor for trans

∼-trans : as ∼ bs → bs ∼ cs → as ∼ cs
∼-trans [] = id
∼-trans (trans as∼bs bs∼cs) = ∼-trans as∼bs ∘ ∼-trans bs∼cs
∼-trans as∼bs = trans as∼bs

-- smart constructor for swap

∼-swap-++ : (as bs : List A) → as ++ bs ∼ bs ++ as
∼-swap-++ [] bs = ∼-reflexive (≋-reflexive (≡.sym (++-identityʳ bs)))
∼-swap-++ as@(_ ∷ _) [] = ∼-reflexive (≋-reflexive (++-identityʳ as))
∼-swap-++ as@(_ ∷ _) bs@(_ ∷ _) = as ++ᵒ bs

∼-congʳ : as ∼ bs → cs ++ as ∼ cs ++ bs
∼-congʳ {as = as} {bs = bs} {cs = cs} as∼bs = lemma cs
where
lemma : ∀ cs → cs ++ as ∼ cs ++ bs
lemma [] = as∼bs
lemma (c ∷ cs) = c ≡∷ lemma cs

∼-congˡ : as ∼ bs → as ++ cs ∼ bs ++ cs
∼-congˡ {as = as} {bs = bs} {cs = cs} as∼bs =
∼-trans (∼-swap-++ as cs) (∼-trans (∼-congʳ as∼bs) (∼-swap-++ cs bs))

∼-cong : as ∼ bs → cs ∼ ds → as ++ cs ∼ bs ++ ds
∼-cong as∼bs cs∼ds = ∼-trans (∼-congˡ as∼bs) (∼-congʳ cs∼ds)

-- smart constructor for generalised swap

infix 5 _∼-⋎_

_∼-⋎_ : as ∼ b ∷ cs → a ∷ cs ∼ bs → a ∷ as ∼ b ∷ bs
_∼-⋎_ {b = b} {a = a} as∼b∷cs a∷cs∼bs =
trans (a ≡∷ as∼b∷cs) (∼-trans (∼-congˡ ([ a ] ++ᵒ [ b ])) (b ≡∷ a∷cs∼bs))

⋎-syntax : ∀ cs → as ∼ b ∷ cs → a ∷ cs ∼ bs → a ∷ as ∼ b ∷ bs
⋎-syntax cs = _∼-⋎_ {cs = cs}

syntax ⋎-syntax cs as∼b∷cs a∷cs∼bs = as∼b∷cs ∼-⋎[ cs ] a∷cs∼bs
Original file line number Diff line number Diff line change
@@ -0,0 +1,65 @@
-------------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of declarative definition of permutation
-------------------------------------------------------------------------------

{-# OPTIONS --cubical-compatible --safe #-}

open import Relation.Binary.Bundles using (Setoid)

module Data.List.Relation.Binary.Permutation.Declarative.Properties
{s ℓ} (S : Setoid s ℓ) where

open import Data.List.Base using (List; []; _∷_; length; _++_)
open import Data.List.Properties using (length-++)
open import Data.Nat.Base using (suc; _+_)
open import Data.Nat.Properties using (+-comm)
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)
open import Relation.Binary.PropositionalEquality.Properties as ≡
using (module ≡-Reasoning)

open import Data.List.Relation.Binary.Permutation.Algorithmic S
using ([]; _∷_; _⋎_)
renaming (_∼_ to _∼ₐ_; ∼-trans to ∼ₐ-trans)
open import Data.List.Relation.Binary.Permutation.Algorithmic.Properties S
using ()
renaming (∼-swap-++ to ∼ₐ-swap-++)
open import Data.List.Relation.Binary.Permutation.Declarative S

open Setoid S
using ()
renaming (Carrier to A)

private
variable
as bs : List A


-------------------------------------------------------------------------------
-- Properties

∼-length : as ∼ bs → length as ≡ length bs
∼-length [] = ≡.refl
∼-length (a≈b ∷ as∼bs) = ≡.cong suc (∼-length as∼bs)
∼-length (trans as∼cs cs∼bs) = ≡.trans (∼-length as∼cs) (∼-length cs∼bs)
∼-length (as ++ᵒ bs) = begin
length (as ++ bs) ≡⟨ length-++ as ⟩
length as + length bs ≡⟨ +-comm (length as) (length bs) ⟩
length bs + length as ≡⟨ length-++ bs ⟨
length (bs ++ as) ∎
where open ≡-Reasoning

-------------------------------------------------------------------------------
-- Equivalence with `Algorithmic` definition of _∼_

∼ₐ⇒∼ : as ∼ₐ bs → as ∼ bs
∼ₐ⇒∼ [] = []
∼ₐ⇒∼ (a≈b ∷ as∼bs) = a≈b ∷ ∼ₐ⇒∼ as∼bs
∼ₐ⇒∼ (as∼b∷cs ⋎ a∷cs∼bs) = ∼ₐ⇒∼ as∼b∷cs ∼-⋎ ∼ₐ⇒∼ a∷cs∼bs

∼⇒∼ₐ : as ∼ bs → as ∼ₐ bs
∼⇒∼ₐ [] = []
∼⇒∼ₐ (a≈b ∷ as∼bs) = a≈b ∷ ∼⇒∼ₐ as∼bs
∼⇒∼ₐ (trans as∼cs cs∼bs) = ∼ₐ-trans (∼⇒∼ₐ as∼cs) (∼⇒∼ₐ cs∼bs)
∼⇒∼ₐ (as ++ᵒ bs) = ∼ₐ-swap-++ as bs