Prove most of commutativity by relying on in-dec.

The "no" case still needs to be dismissed, but that can probably
be done by some lemma about keys in maps.

Signed-off-by: Danila Fedorin <danila.fedorin@gmail.com>
This commit is contained in:
Danila Fedorin 2023-07-28 00:05:41 -07:00
parent 77b8b6fad9
commit 4033a1b33d

View File

@ -69,6 +69,28 @@ private module _ where
ListAB-functional {l = _ xs } (push _ uxs) (there k,v∈xs) (there k,v'∈xs) = ListAB-functional {l = _ xs } (push _ uxs) (there k,v∈xs) (there k,v'∈xs) =
ListAB-functional uxs k,v∈xs k,v'∈xs ListAB-functional uxs k,v∈xs k,v'∈xs
∈k-dec : (k : A) (l : List (A × B)) Dec (k keys l)
∈k-dec k [] = no (λ ())
∈k-dec k ((k' , v) xs)
with (≡-dec-A k k')
... | yes k≡k' = yes (here k≡k')
... | no k≢k' with (∈k-dec k xs)
... | yes k∈kxs = yes (there k∈kxs)
... | no k∉kxs = no witness
where
witness : ¬ k keys ((k' , v) xs)
witness (here k≡k') = k≢k' k≡k'
witness (there k∈kxs) = k∉kxs k∈kxs
∈-cong : {c d} {C : Set c} {D : Set d} {c : C} {l : List C}
(f : C D) c l f c map f l
∈-cong f (here c≡c') = here (cong f c≡c')
∈-cong f (there c∈xs) = there (∈-cong f c∈xs)
locate : {k : A} {l : List (A × B)} k keys l Σ B (λ v (k , v) l)
locate {k} {(k' , v) xs} (here k≡k') rewrite k≡k' = (v , here refl)
locate {k} {(k' , v) xs} (there k∈kxs) = let (v , k,v∈xs) = locate k∈kxs in (v , there k,v∈xs)
private module ImplRelation (_≈_ : B B Set b) where private module ImplRelation (_≈_ : B B Set b) where
open MemProp using (_∈_) open MemProp using (_∈_)
@ -117,28 +139,6 @@ private module ImplInsert (f : B → B → B) where
... | no _ = cong (λ xs' k' xs') ... | no _ = cong (λ xs' k' xs')
(insert-keys-∉ k v xs (λ k∈kxs k∉kl (there k∈kxs))) (insert-keys-∉ k v xs (λ k∈kxs k∉kl (there k∈kxs)))
∈k-dec : (k : A) (l : List (A × B)) Dec (k ∈k l)
∈k-dec k [] = no (λ ())
∈k-dec k ((k' , v) xs)
with (≡-dec-A k k')
... | yes k≡k' = yes (here k≡k')
... | no k≢k' with (∈k-dec k xs)
... | yes k∈kxs = yes (there k∈kxs)
... | no k∉kxs = no witness
where
witness : ¬ k ∈k ((k' , v) xs)
witness (here k≡k') = k≢k' k≡k'
witness (there k∈kxs) = k∉kxs k∈kxs
∈-cong : {c d} {C : Set c} {D : Set d} {c : C} {l : List C}
(f : C D) c l f c map f l
∈-cong f (here c≡c') = here (cong f c≡c')
∈-cong f (there c∈xs) = there (∈-cong f c∈xs)
locate : {k : A} {l : List (A × B)} k ∈k l Σ B (λ v (k , v) l)
locate {k} {(k' , v) xs} (here k≡k') rewrite k≡k' = (v , here refl)
locate {k} {(k' , v) xs} (there k∈kxs) = let (v , k,v∈xs) = locate k∈kxs in (v , there k,v∈xs)
insert-preserves-Unique : (k : A) (v : B) (l : List (A × B)) insert-preserves-Unique : (k : A) (v : B) (l : List (A × B))
Unique (keys l) Unique (keys (insert k v l)) Unique (keys l) Unique (keys (insert k v l))
insert-preserves-Unique k v l u insert-preserves-Unique k v l u
@ -304,7 +304,6 @@ module _ (f : B → B → B) where
(in v₂ k∉kl₁ k,v₂∈l₂ , merge-preserves-keys₁ k v₂ l₁ l₂ k∉kl₁ k,v₂∈l₂) (in v₂ k∉kl₁ k,v₂∈l₂ , merge-preserves-keys₁ k v₂ l₁ l₂ k∉kl₁ k,v₂∈l₂)
... | no k∉kl₁ | no k∉kl₂ = absurd (merge-preserves-∉ k l₁ l₂ k∉kl₁ k∉kl₂ k∈km₁m₂) ... | no k∉kl₁ | no k∉kl₂ = absurd (merge-preserves-∉ k l₁ l₂ k∉kl₁ k∉kl₂ k∈km₁m₂)
module _ (_≈_ : B B Set b) where module _ (_≈_ : B B Set b) where
open ImplRelation _≈_ renaming (subset to subset-impl) open ImplRelation _≈_ renaming (subset to subset-impl)
@ -313,3 +312,31 @@ module _ (_≈_ : B → B → Set b) where
lift : Map Map Set (a b) lift : Map Map Set (a b)
lift m₁ m₂ = subset m₁ m₂ × subset m₂ m₁ lift m₁ m₂ = subset m₁ m₂ × subset m₂ m₁
module _ (f : B B B) where
module _ (f-comm : (b₁ b₂ : B) f b₁ b₂ f b₂ b₁) where
merge-comm : forall (m₁ m₂ : Map) lift (_≡_) (merge f m₁ m₂) (merge f m₂ m₁)
merge-comm m₁ m₂ = (merge-comm-subset m₁ m₂ , merge-comm-subset m₂ m₁)
where
merge-comm-subset : (m₁ m₂ : Map) subset (_≡_) (merge f m₁ m₂) (merge f m₂ m₁)
merge-comm-subset m₁ m₂ k v k,v∈m₁m₂
with ∈k-dec k (proj₁ (merge f m₂ m₁) )
... | no k∉km₂m₁ = {!!}
... | yes k∈km₂m₁ with merge-provenance f m₁ m₂ k (∈-cong proj₁ k,v∈m₁m₂) | merge-provenance f m₂ m₁ k k∈km₂m₁
... | (both v₁ v₂ v₁∈m₁ v₂∈m₂ , v₁v₂∈m₁m₂) | (both v₂' v₁' v₂'∈m₂ v₁'∈m₁ , v₂'v₁'∈m₂m₁)
rewrite Map-functional {m = merge f m₁ m₂} k,v∈m₁m₂ v₁v₂∈m₁m₂
rewrite Map-functional {m = m₁} v₁∈m₁ v₁'∈m₁
rewrite Map-functional {m = m₂} v₂∈m₂ v₂'∈m₂ = (f v₂' v₁' , (f-comm v₁' v₂' , v₂'v₁'∈m₂m₁))
... | (in v₁ v₁∈m₁ _ , v₁∈m₁m₂) | (in v₁' _ v₁'∈m₁ , v₁'∈m₂m₁)
rewrite Map-functional {m = merge f m₁ m₂} k,v∈m₁m₂ v₁∈m₁m₂ =
(v₁' , (Map-functional {m = m₁} v₁∈m₁ v₁'∈m₁ , v₁'∈m₂m₁))
... | (in v₂ _ v₂∈m₂ , v₂∈m₁m₂) | (in v₂' v₂'∈m₂ _ , v₂'∈m₂m₁)
rewrite Map-functional {m = merge f m₁ m₂} k,v∈m₁m₂ v₂∈m₁m₂ =
(v₂' , (Map-functional {m = m₂} v₂∈m₂ v₂'∈m₂ , v₂'∈m₂m₁))
-- The rest of the cases are to be dismissed.
... | (both v₁ v₂ v₁∈m₁ v₂∈m₂ , _) | (in v₂' v₂'∈m₂ k∉km₁ , _) = absurd (k∉km₁ (∈-cong proj₁ v₁∈m₁))
... | (both v₁ v₂ v₁∈m₁ v₂∈m₂ , _) | (in v₁' k∉km₂ v₁'∈m₁ , _) = absurd (k∉km₂ (∈-cong proj₁ v₂∈m₂))
... | (in v₁ v₁∈m₁ k∉km₂ , _) | (both v₂' v₁' v₂'∈m₂ v₁'∈m₁ , _) = absurd (k∉km₂ (∈-cong proj₁ v₂'∈m₂))
... | (in v₁ v₁∈m₁ k∉km₂ , _) | (in v₂' v₂'∈m₂ k∉km₁ , _) = absurd (k∉km₂ (∈-cong proj₁ v₂'∈m₂))
... | (in v₂ k∉km₁ v₂∈m₂ , v₂∈m₁m₂) | (both v₂' v₁' v₂'∈m₂ v₁'∈m₁ , _) = absurd (k∉km₁ (∈-cong proj₁ v₁'∈m₁))
... | (in v₂ k∉km₁ v₂∈m₂ , v₂∈m₁m₂) | (in v₁' _ v₁'∈m₁ , v₁'∈m₂m₁) = absurd (k∉km₁ (∈-cong proj₁ v₁'∈m₁))