diff --git a/README.md b/README.md index 73621631..a3d056c8 100644 --- a/README.md +++ b/README.md @@ -130,6 +130,14 @@ Details on the features implemented in Vatras, including tutorials for integrati The PhD thesis presents a refined and extended version of our OOPSLA'24 paper in chapter 3. In the thesis, we extended the discussion on existing variability languages to better reflect and compare their assumptions on the underlying object language and their varying semantic domains. Consequently, we also extended our formal framework and case study to also study differences in semantic domains. We also refined the notation to better align with the Agda code and to avoid some minor ambiguities. +### On the Succinctness of Languages for Static Variability + +[![Thesis](https://img.shields.io/badge/Thesis-PDF-purple)](https://doi.org/10.18725/OPARU-59127) + +> Benjamin Moosherr. _On the Succinctness of Languages for Static Variability_. Master Thesis, University of Ulm, November 2025. Reviewed by Matthias Tichy and Thomas Thüm. Supervised by Paul Maximilian Bittner. + +This master thesis extends Vatras by a succinctness relation. Succinctness expresses how the size of expressions must change when translated using a variability language compiler. Hence, succinctness allows us to differentiate between variability languages which have equal semantic expressiveness but whose translation results in combinatorial explosion. + ### On the Expressive Power of Languages for Static Variability (OOPSLA'24) [![Preprint](https://img.shields.io/badge/OOPSLA'24-Preprint-purple)](https://github.com/SoftVarE-Group/Papers/raw/main/2024/2024-OOPSLA-Bittner.pdf) diff --git a/src/Vatras/Data/IndexedSet.lagda.md b/src/Vatras/Data/IndexedSet.lagda.md index cdac5f3e..dd0528db 100644 --- a/src/Vatras/Data/IndexedSet.lagda.md +++ b/src/Vatras/Data/IndexedSet.lagda.md @@ -882,3 +882,15 @@ re-index {_≈ᵃ_ = _≈ᵃ_} rename M rename-is-surjective ≈ᵃ-refl ≈ᵇ- , re-indexʳ {_≈ᵃ_ = _≈ᵃ_} rename M rename-is-surjective ≈ᵃ-refl ≈ᵇ-sym M-is-congruent ``` +### Ungrouped Properties + +```agda +module _ where + open import Data.Nat as ℕ using (ℕ) + open import Data.Fin as Fin using (Fin) + open import Data.List using (lookup; tabulate) + + tabulate⁺ : ∀ {j} {J : Set j} {n : ℕ} {A : IndexedSet (Fin n)} {B : IndexedSet J} → A ⊆ B → lookup (tabulate A) ⊆ B + tabulate⁺ {n = ℕ.suc n} x Fin.zero = x Fin.zero + tabulate⁺ {n = ℕ.suc n} x (Fin.suc i) = tabulate⁺ (x ∘ Fin.suc) i +``` diff --git a/src/Vatras/Framework/Definitions.agda b/src/Vatras/Framework/Definitions.agda index c54dfa09..d536425f 100644 --- a/src/Vatras/Framework/Definitions.agda +++ b/src/Vatras/Framework/Definitions.agda @@ -1,9 +1,12 @@ module Vatras.Framework.Definitions where open import Data.Maybe using (Maybe; just) +open import Data.Nat as ℕ using (ℕ; zero) open import Data.Product using (_×_; Σ; Σ-syntax; proj₁; proj₂) renaming (_,_ to _and_) +import Data.Product.Properties as Product +open import Data.String as String using (String) open import Data.Unit using (⊤; tt) public -open import Function using (id; _∘_) +open import Function using (id; _∘_; const) open import Relation.Binary.PropositionalEquality as Eq using (_≡_; _≗_; refl) open import Relation.Binary using (DecidableEquality) open import Relation.Nullary.Negation using (¬_) @@ -20,12 +23,14 @@ the core definitions because it is quite reasonable. Any actual data we can think of to plug in here (e.g., strings, tokens or nodes of an abstract syntax tree) can be checked for equality. -} -𝔸 : Set₁ -𝔸 = Σ Set DecidableEquality - --- retrieve the set of atoms from an atom type 𝔸 -atoms : 𝔸 → Set -atoms = proj₁ +record 𝔸 : Set₁ where + -- We do not actually need eta equality in Vatras and it does break a proof when enabled (no idea why). + no-eta-equality + field + atoms : Set + atomsEqual? : DecidableEquality atoms + atomSize : atoms → ℕ +open 𝔸 public {-| Variant Language. @@ -63,14 +68,39 @@ and hence expressions are parameterized in the type of this atomic data. 𝔼 = 𝔸 → Set₁ -- some default atoms -module _ where - open import Data.String using (String; _≟_) - - STRING : 𝔸 - STRING = String and _≟_ +{-| +String artifacts. +Equality is defined character wise +and size is measured by length (in characters not bytes). +-} +STRING : 𝔸 +STRING = record + { atoms = String + ; atomsEqual? = String._≟_ + ; atomSize = String.length + } -module _ where - open import Data.Nat using (ℕ; _≟_) +{-| +Pairs of natural numbers as artifacts. +The first element in the pair is treated as an identifier +whereas the second element determines the size of the artifact. +Both elements of the pair are tested for equality. +-} +NAT : 𝔸 +NAT = record + { atoms = ℕ × ℕ + ; atomsEqual? = Product.≡-dec ℕ._≟_ ℕ._≟_ + ; atomSize = proj₂ + } - NAT : 𝔸 - NAT = ℕ and _≟_ +{-| +Natural number artifacts. +Each number is treated as a separate artifact. +The size of all artifacts is zero. +-} +NAT' : 𝔸 +NAT' = record + { atoms = ℕ + ; atomsEqual? = ℕ._≟_ + ; atomSize = const zero + } diff --git a/src/Vatras/Framework/Variants.agda b/src/Vatras/Framework/Variants.agda index 3e910f8d..470bbce8 100644 --- a/src/Vatras/Framework/Variants.agda +++ b/src/Vatras/Framework/Variants.agda @@ -7,7 +7,7 @@ module Vatras.Framework.Variants where open import Data.List using (List; []; _∷_; map) open import Data.Maybe using (nothing; just) -open import Data.Product using (_,_; proj₁; proj₂) +open import Data.Product using (_×_; _,_; proj₁; proj₂) open import Data.String using (String; _++_; intersperse) open import Data.Unit using (⊤; tt) open import Relation.Binary.PropositionalEquality as Eq using (_≡_; _≗_; refl) @@ -16,7 +16,7 @@ open Eq.≡-Reasoning open import Function using (id; _∘_; flip) open import Size using (Size; ↑_; ∞) -open import Vatras.Framework.Definitions using (𝕍; 𝔸; atoms) +open import Vatras.Framework.Definitions using (𝕍; 𝔸; atoms; atomsEqual?) open import Vatras.Framework.VariabilityLanguage open import Vatras.Framework.Compiler using (LanguageCompiler) open LanguageCompiler @@ -77,11 +77,17 @@ GrulerVL = Variant-is-VL GrulerVariant RoseVL : VariabilityLanguage (Rose ∞) RoseVL = Variant-is-VL (Rose ∞) +{-| +Lemma to conclude that the child lists of two equal rose trees must be equal as well. +-} +Rose-injective : ∀ {A : 𝔸} {a₁ a₂ : atoms A} {cs₁ cs₂ : List (Rose ∞ A)} → a₁ -< cs₁ >- ≡ a₂ -< cs₂ >- → (a₁ ≡ a₂) × (cs₁ ≡ cs₂) +Rose-injective refl = refl , refl + {-| Lemma to conclude that the child lists of two equal rose trees must be equal as well. -} children-equality : ∀ {A : 𝔸} {a₁ a₂ : atoms A} {cs₁ cs₂ : List (Rose ∞ A)} → a₁ -< cs₁ >- ≡ a₂ -< cs₂ >- → cs₁ ≡ cs₂ -children-equality refl = refl +children-equality = proj₂ ∘ Rose-injective {-| Show function for rose trees. @@ -149,6 +155,6 @@ open import Data.Bool using (Bool; true) open import Data.Bool.ListAction using (or) has-atom : ∀ {A i} → atoms A → Rose i A → Bool -has-atom {A , _≟_} a (b -< cs >-) with a ≟ b +has-atom {A} a (b -< cs >-) with atomsEqual? A a b ... | yes refl = true ... | no x = or (map (has-atom b) cs) diff --git a/src/Vatras/Lang/2CC/Encode.agda b/src/Vatras/Lang/2CC/Encode.agda new file mode 100644 index 00000000..7367e0f6 --- /dev/null +++ b/src/Vatras/Lang/2CC/Encode.agda @@ -0,0 +1,58 @@ +open import Vatras.Framework.Definitions using (𝔽) +module Vatras.Lang.2CC.Encode {Dimension : 𝔽} where + +open import Data.List as List using (List; []; _∷_) + +open import Size using (∞) +open import Data.Bool using (false) +open import Data.Unit using (⊤; tt) +open import Data.List.Properties using (map-∘; map-id; map-cong) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl) + +open import Vatras.Data.EqIndexedSet using (_≅[_][_]_; irrelevant-index-≅) +open import Vatras.Framework.Variants as V using (Rose; Variant-is-VL; VariantEncoder) +open import Vatras.Framework.Relation.Function using (_⇔_; to; from) +open import Vatras.Framework.VariabilityLanguage using (Semantics; Config) +open import Vatras.Lang.2CC Dimension + +encode : ∀ {i} {A} → Rose i A → 2CC ∞ A +encode (a V.-< cs >-) = a -< List.map encode cs >- + +confs : ⊤ ⇔ Config 2CCL +confs = record + { to = λ where tt _ → false + ; from = λ _ → tt + } + +2cc-encode-idemp : ∀ {A} (v : Rose ∞ A) → (c : Configuration) → ⟦ encode v ⟧ c ≡ v +2cc-encode-idemp {A} v@(a V.-< cs >-) c = + begin + ⟦ encode v ⟧ c + ≡⟨⟩ + a V.-< List.map (λ x → ⟦ x ⟧ c) (List.map encode cs) >- + ≡⟨ Eq.cong (a V.-<_>-) (map-∘ cs) ⟨ + a V.-< List.map (λ x → ⟦ encode x ⟧ c) cs >- + ≡⟨ Eq.cong (a V.-<_>-) (go cs) ⟩ + v + ∎ + where + open Eq.≡-Reasoning + + go : (cs' : List (Rose ∞ A)) → List.map (λ c' → ⟦ encode c' ⟧ c) cs' ≡ cs' + go [] = refl + go (c' ∷ cs') = Eq.cong₂ _∷_ (2cc-encode-idemp c' c) (go cs') + +preserves : ∀ {A} → (v : Rose ∞ A) + → Semantics (Variant-is-VL (Rose ∞)) v ≅[ to confs ][ from confs ] ⟦ encode v ⟧ +preserves {A} v = irrelevant-index-≅ v + (λ { tt → refl }) + (2cc-encode-idemp v) + (to confs) + (from confs) + +encoder : VariantEncoder (Rose ∞) 2CCL +encoder = record + { compile = encode + ; config-compiler = λ _ → confs + ; preserves = preserves + } diff --git a/src/Vatras/Lang/2CC/FixedArtifactLength.agda b/src/Vatras/Lang/2CC/FixedArtifactLength.agda new file mode 100644 index 00000000..f7c8e223 --- /dev/null +++ b/src/Vatras/Lang/2CC/FixedArtifactLength.agda @@ -0,0 +1,142 @@ +{-| +This module shows that artifacts of choice calculus expressions have a fixed number of children. +Afterwards, we introduce some more usable lemmas on top og this insight. +-} +open import Vatras.Framework.Definitions using (𝔽; 𝔸; atoms) +module Vatras.Lang.2CC.FixedArtifactLength (Dimension : 𝔽) (A : 𝔸) where + +open import Data.Bool using (true; false) +open import Data.Empty using (⊥-elim) +open import Data.List as List using (List; []; _∷_; _++_) +import Data.List.Properties as List +open import Data.List.Relation.Ternary.Interleaving.Propositional using (Interleaving; []; consˡ; consʳ) +open import Data.List.Relation.Unary.All as All using (All; []; _∷_) +import Data.List.Relation.Unary.All.Properties +open import Data.List.Relation.Unary.AllPairs as AllPairs using (AllPairs; []; _∷_) +open import Data.Nat as ℕ using (ℕ; suc; _+_; _∸_; _*_; _≤_; z≤n; s≤s; _≥_) +import Data.Nat.Properties as ℕ +open import Data.Product using (_×_; _,_; proj₂; ∃-syntax) +open import Function using (_∘_; const) +open import Relation.Binary.PropositionalEquality as Eq using (refl; _≡_; _≢_) +open import Size using (Size; ∞) + +import Vatras.Util.List as List +open import Vatras.Data.EqIndexedSet using (_∈_; _⊆_) +open import Vatras.Framework.Variants using (Rose; children-equality) +open import Vatras.Lang.2CC Dimension using (2CC; _⟨_,_⟩; _-<_>-; ⟦_⟧) +open import Vatras.Lang.2CC.ReflectsVariantSize using (reflectsVariantSize) +open import Vatras.Succinctness.Sizes using (sizeRose; size2CC) + +_≉_ : Rose ∞ A → Rose ∞ A → Set +(a₁ Rose.-< cs₁ >-) ≉ (a₂ Rose.-< cs₂ >-) = List.length cs₁ ≢ List.length cs₂ + +{-| +The key insight of this module: +Given a choice calculus expression with an artifact at the root, +all expressed variants must have the same number of children. +-} +fixedChildCount : ∀ {i} + → {a₁ : atoms A} {cs₁ : List (Rose ∞ A)} + → {a₂ : atoms A} {cs₂ : List (2CC i A)} + → (a₁ Rose.-< cs₁ >-) ∈ ⟦ a₂ -< cs₂ >- ⟧ + → List.length cs₁ ≡ List.length cs₂ +fixedChildCount {cs₁ = cs₁} {cs₂ = cs₂} (c , v≡e) = + List.length cs₁ + ≡⟨ Eq.cong List.length (children-equality v≡e) ⟩ + List.length (List.map (λ e → ⟦ e ⟧ c) cs₂) + ≡⟨ List.length-map (λ e → ⟦ e ⟧ c) cs₂ ⟩ + List.length cs₂ + ∎ + where + open Eq.≡-Reasoning + +{-| +We can partition a list of variants +on whether we can choose the left or right alternative of a choice +in order to configure each variant. +-} +partition : ∀ {i : Size} + → (D : Dimension) (c₁ c₂ : 2CC i A) + → (vs : List (Rose ∞ A)) + → AllPairs _≉_ vs + → All (_∈ ⟦ D 2CC.⟨ c₁ , c₂ ⟩ ⟧) vs + → ∃[ vs₁ ] ∃[ vs₂ ] + Interleaving vs₁ vs₂ vs + × All (_∈ ⟦ c₁ ⟧) vs₁ + × All (_∈ ⟦ c₂ ⟧) vs₂ +partition D c₁ c₂ [] unique-vs vs⊆e = [] , [] , [] , [] , [] +partition D c₁ c₂ (v ∷ vs) (v∉vs ∷ unique-vs) ((c , v≡e) ∷ vs⊆e) + with partition D c₁ c₂ vs unique-vs vs⊆e +... | vs₁ , vs₂ , partition , vs₁⊆e , vs₂⊆e + with c D +... | true = v ∷ vs₁ , vs₂ , consˡ partition , (c , v≡e) ∷ vs₁⊆e , vs₂⊆e +... | false = vs₁ , v ∷ vs₂ , consʳ partition , vs₁⊆e , (c , v≡e) ∷ vs₂⊆e + +{-| +Gives a lower bound on the size of a choice calculus expression +given that it expresses a number of variants with pairwise different child count. +-} +sum≤size2CC : ∀ {i : Size} + → (e : 2CC i A) + → (vs : List (Rose ∞ A)) + → AllPairs (_≉_) vs + → All (_∈ ⟦ e ⟧) vs + → List.sum (List.map sizeRose vs) ≤ size2CC e +sum≤size2CC (a -< cs >-) [] unique-vs vs⊆e = z≤n +sum≤size2CC (a -< cs >-) (v ∷ []) unique-vs (v∈e ∷ []) = + begin + List.sum (List.map sizeRose (v ∷ [])) + ≡⟨⟩ + sizeRose v + 0 + ≡⟨ ℕ.+-identityʳ (sizeRose v) ⟩ + sizeRose v + ≤⟨ reflectsVariantSize v (a -< cs >-) v∈e ⟩ + size2CC (a -< cs >-) + ∎ + where + open ℕ.≤-Reasoning +sum≤size2CC (a -< cs >-) ((a₁ Rose.-< cs₁ >-) ∷ (a₂ Rose.-< cs₂ >-) ∷ vs) ((v₁≢v₂ ∷ v₁∉vs) ∷ unique-vs) (v₁∈e ∷ v₂∈e ∷ vs⊆e) = + ⊥-elim (v₁≢v₂ (Eq.trans (fixedChildCount v₁∈e) (Eq.sym (fixedChildCount v₂∈e)))) +sum≤size2CC (D ⟨ c₁ , c₂ ⟩) vs unique-vs vs⊆e with partition D c₁ c₂ vs unique-vs vs⊆e +... | vs₁ , vs₂ , partition , vs₁⊆c₁ , vs₂⊆c₂ = + begin + List.sum (List.map sizeRose vs) + ≡⟨ List.sum-Interleaving (List.map-Interleaving partition) ⟨ + List.sum (List.map sizeRose vs₁) + List.sum (List.map sizeRose vs₂) + ≤⟨ ℕ.+-mono-≤ (sum≤size2CC c₁ vs₁ (List.AllPairs-resp-⊆ (List.Interleaving⇒Sublistˡ partition) unique-vs) vs₁⊆c₁) (sum≤size2CC c₂ vs₂ (List.AllPairs-resp-⊆ (List.Interleaving⇒Sublistʳ partition) unique-vs) vs₂⊆c₂) ⟩ + size2CC c₁ + size2CC c₂ + <⟨ ℕ.n<1+n (size2CC c₁ + size2CC c₂) ⟩ + size2CC (D ⟨ c₁ , c₂ ⟩) + ∎ + where + open ℕ.≤-Reasoning + +{-| +Gives a lower bound on the size of a choice calculus expression +given that it expresses a number of variants with pairwise different child count. +In contrast to `sum≤size2CC`, this lemma is a simplified special case +which makes use of a lower bound on the variant size. +-} +different-children-counts : + ∀ {i : Size} + → (n : ℕ) + → (e : 2CC i A) + → (vs : List (Rose ∞ A)) + → All (_∈ ⟦ e ⟧) vs + → All (λ v → sizeRose v ≥ n) vs + → AllPairs _≉_ vs + → size2CC e ≥ List.length vs * n +different-children-counts n e vs vs⊆e vs≥n unique-vs = + begin + List.length vs * n + ≡⟨ List.sum-replicate (List.length vs) n ⟨ + List.sum (List.replicate (List.length vs) n) + ≡⟨ Eq.cong List.sum (List.map-const n vs) ⟨ + List.sum (List.map (const n) vs) + ≤⟨ List.sum-map-≤-with∈ vs (λ v v∈vs → All.lookup vs≥n v∈vs) ⟩ + List.sum (List.map sizeRose vs) + ≤⟨ sum≤size2CC e vs unique-vs (vs⊆e) ⟩ + size2CC e + ∎ + where + open ℕ.≤-Reasoning diff --git a/src/Vatras/Lang/2CC/ReflectsVariantSize.agda b/src/Vatras/Lang/2CC/ReflectsVariantSize.agda new file mode 100644 index 00000000..7037eb53 --- /dev/null +++ b/src/Vatras/Lang/2CC/ReflectsVariantSize.agda @@ -0,0 +1,75 @@ +open import Vatras.Framework.Definitions using (𝔽; 𝔸; atomSize) +module Vatras.Lang.2CC.ReflectsVariantSize {Dimension : 𝔽} {A : 𝔸} where + +open import Data.Bool using (true; false) +open import Data.List as List using (List; []; _∷_) +import Data.List.Properties as List +open import Data.Nat using (suc; _+_; _≤_; s≤s) +import Data.Nat.Properties as ℕ +open import Data.Product using (_,_; proj₁; proj₂) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_) +open import Size using (Size; ∞) + +open import Vatras.Data.EqIndexedSet using (_∈_) +open import Vatras.Framework.Variants using (Rose; Rose-injective) +open import Vatras.Lang.2CC Dimension using (2CC; _⟨_,_⟩; _-<_>-; ⟦_⟧) +open import Vatras.Succinctness.Sizes using (sizeRose; size2CC) + +reflectsVariantSize : ∀ {i : Size} + → (v : Rose ∞ A) + → (e : 2CC i A) + → v ∈ ⟦ e ⟧ + → sizeRose v ≤ size2CC e +reflectsVariantSize v (D ⟨ l , r ⟩) (config , v≡e) with config D +reflectsVariantSize v (D ⟨ l , r ⟩) (config , v≡e) | true = + begin + sizeRose v + ≤⟨ reflectsVariantSize v l (config , v≡e) ⟩ + size2CC l + <⟨ ℕ.n<1+n (size2CC l) ⟩ + suc (size2CC l) + ≤⟨ s≤s (ℕ.m≤m+n (size2CC l) (size2CC r)) ⟩ + suc (size2CC l + size2CC r) + ≡⟨⟩ + size2CC (D ⟨ l , r ⟩) + ∎ + where + open ℕ.≤-Reasoning +reflectsVariantSize v (D ⟨ l , r ⟩) (config , v≡e) | false = + begin + sizeRose v + ≤⟨ reflectsVariantSize v r (config , v≡e) ⟩ + size2CC r + <⟨ ℕ.n<1+n (size2CC r) ⟩ + suc (size2CC r) + ≤⟨ s≤s (ℕ.m≤n+m (size2CC r) (size2CC l)) ⟩ + suc (size2CC l + size2CC r) + ≡⟨⟩ + size2CC (D ⟨ l , r ⟩) + ∎ + where + open ℕ.≤-Reasoning +reflectsVariantSize (a Rose.-< cs >-) (a' -< cs' >-) (config , v≡e) = + begin + sizeRose (a Rose.-< cs >-) + ≡⟨⟩ + suc (atomSize A a + List.sum (List.map sizeRose cs)) + ≤⟨ s≤s (ℕ.+-monoʳ-≤ (atomSize A a) (go cs cs' (proj₂ (Rose-injective v≡e)))) ⟩ + suc (atomSize A a + List.sum (List.map size2CC cs')) + ≡⟨⟩ + size2CC (a -< cs' >-) + ≡⟨ Eq.cong (λ x → size2CC (x -< cs' >-)) (proj₁ (Rose-injective v≡e)) ⟩ + size2CC (a' -< cs' >-) + ∎ + where + open ℕ.≤-Reasoning + + go : ∀ {i : Size} + → (cs : List (Rose ∞ A)) (cs' : List (2CC i A)) + → cs ≡ List.map (λ c → ⟦ c ⟧ config) cs' + → List.sum (List.map sizeRose cs) ≤ List.sum (List.map size2CC cs') + go [] [] cs≡cs' = ℕ.≤-refl + go (c ∷ cs) (c' ∷ cs') cs≡cs' = + ℕ.+-mono-≤ + (reflectsVariantSize c c' (config , List.∷-injectiveˡ cs≡cs')) + (go cs cs' (List.∷-injectiveʳ cs≡cs')) diff --git a/src/Vatras/Lang/2CC/Show.agda b/src/Vatras/Lang/2CC/Show.agda index 3001463c..880abb35 100644 --- a/src/Vatras/Lang/2CC/Show.agda +++ b/src/Vatras/Lang/2CC/Show.agda @@ -9,12 +9,12 @@ open import Data.List as List using ([]; _∷_) open import Vatras.Show.Lines open import Vatras.Lang.2CC Dimension using (2CC; _⟨_,_⟩; _-<_>-) -show : ∀ {i} → 2CC i (String , String._≟_) → String +show : ∀ {i} → 2CC i STRING → String show (a -< [] >-) = a show (a -< es@(_ ∷ _) >-) = a ++ "-<" ++ (String.intersperse ", " (List.map show es)) ++ ">-" show (D ⟨ l , r ⟩) = show-D D ++ "⟨" ++ (show l) ++ ", " ++ (show r) ++ "⟩" -pretty : ∀ {i : Size} → 2CC i (String , String._≟_) → Lines +pretty : ∀ {i : Size} → 2CC i STRING → Lines pretty (a -< [] >-) = > a pretty (a -< es@(_ ∷ _) >-) = do > a ++ "-<" diff --git a/src/Vatras/Lang/All.agda b/src/Vatras/Lang/All.agda index 9ff65145..bfcc50bf 100644 --- a/src/Vatras/Lang/All.agda +++ b/src/Vatras/Lang/All.agda @@ -22,6 +22,7 @@ import Vatras.Lang.OC import Vatras.Lang.FST import Vatras.Lang.Gruler import Vatras.Lang.VT +import Vatras.Lang.PropOC open import Data.Empty.Polymorphic using (⊥) open import Vatras.Util.Nat.AtLeast using (ℕ≥) @@ -95,3 +96,8 @@ module VT where open Vatras.Lang.VT using (VT; UnrootedVT; VTL; Configuration) public module _ {F : 𝔽} where open Vatras.Lang.VT F hiding (VT; UnrootedVT; VTL; Configuration) public + +module PropOC where + open Vatras.Lang.PropOC using (PropOC; PropOCL; WFPropOC; WFPropOCL; Configuration) public + module _ {F : 𝔽} where + open Vatras.Lang.PropOC F hiding (PropOC; PropOCL; WFPropOC; WFPropOCL; Configuration) public diff --git a/src/Vatras/Lang/All/Fixed.agda b/src/Vatras/Lang/All/Fixed.agda index 8a910b1a..5bd3bd03 100644 --- a/src/Vatras/Lang/All/Fixed.agda +++ b/src/Vatras/Lang/All/Fixed.agda @@ -15,6 +15,7 @@ import Vatras.Lang.OC import Vatras.Lang.FST import Vatras.Lang.Gruler import Vatras.Lang.VT +import Vatras.Lang.PropOC module VariantList = Vatras.Lang.VariantList V module CCC = Vatras.Lang.CCC F @@ -31,3 +32,4 @@ module OC = Vatras.Lang.OC F module FST = Vatras.Lang.FST F module Gruler = Vatras.Lang.Gruler F module VT = Vatras.Lang.VT F +module PropOC = Vatras.Lang.PropOC F diff --git a/src/Vatras/Lang/CCC/Show.agda b/src/Vatras/Lang/CCC/Show.agda index dd3c1d75..475b07a7 100644 --- a/src/Vatras/Lang/CCC/Show.agda +++ b/src/Vatras/Lang/CCC/Show.agda @@ -1,4 +1,4 @@ -open import Vatras.Framework.Definitions using (𝔽) +open import Vatras.Framework.Definitions using (𝔽; STRING) module Vatras.Lang.CCC.Show {Dimension : 𝔽} where open import Size using (Size) @@ -10,12 +10,12 @@ open import Data.String as String using (String; _++_) open import Vatras.Show.Lines hiding (map) open import Vatras.Lang.CCC Dimension using (CCC; _-<_>-; _⟨_⟩) -show : ∀ {i} → (Dimension → String) → CCC i (String , String._≟_) → String +show : ∀ {i} → (Dimension → String) → CCC i STRING → String show _ (a -< [] >-) = a show show-D (a -< es@(_ ∷ _) >- ) = a ++ "-<" ++ (List.foldl _++_ "" (List.map (show show-D) es)) ++ ">-" show show-D (D ⟨ es ⟩) = show-D D ++ "⟨" ++ (String.intersperse ", " (List⁺.toList (List⁺.map (show show-D) es))) ++ "⟩" -pretty : ∀ {i : Size} → (Dimension → String) → CCC i (String , String._≟_) → Lines +pretty : ∀ {i : Size} → (Dimension → String) → CCC i STRING → Lines pretty show-D (a -< [] >-) = > a pretty show-D (a -< es@(_ ∷ _) >-) = do > a ++ "-<" diff --git a/src/Vatras/Lang/CCC/Util.agda b/src/Vatras/Lang/CCC/Util.agda index 501d5db1..3f635084 100644 --- a/src/Vatras/Lang/CCC/Util.agda +++ b/src/Vatras/Lang/CCC/Util.agda @@ -1,8 +1,8 @@ -open import Vatras.Framework.Definitions using (𝔽; 𝔸) +open import Vatras.Framework.Definitions using (𝔽; 𝔸; atoms) module Vatras.Lang.CCC.Util {Dimension : 𝔽} where -open import Size using (Size) -open import Data.List as List using (List; _∷_) +open import Size using (Size; ∞) +open import Data.List as List using (List; []; _∷_) import Data.List.NonEmpty as List⁺ open import Vatras.Lang.CCC Dimension using (CCC; _-<_>-; _⟨_⟩) @@ -11,3 +11,6 @@ open import Vatras.Lang.CCC Dimension using (CCC; _-<_>-; _⟨_⟩) dims : ∀ {i : Size} {A : 𝔸} → CCC i A → List Dimension dims (_ -< es >-) = List.concatMap dims es dims (D ⟨ es ⟩) = D ∷ List.concatMap dims (List⁺.toList es) + +leaf : {A : 𝔸} → atoms A → CCC ∞ A +leaf a = a -< [] >- diff --git a/src/Vatras/Lang/FST.lagda.md b/src/Vatras/Lang/FST.lagda.md index aec5a8b1..751732ca 100644 --- a/src/Vatras/Lang/FST.lagda.md +++ b/src/Vatras/Lang/FST.lagda.md @@ -34,7 +34,6 @@ open import Vatras.Framework.Composition.FeatureAlgebra open import Vatras.Framework.VariabilityLanguage open import Vatras.Util.Function using (cong-app₂) -open import Vatras.Util.List using (++-tail) ``` ## Basic Definitions @@ -56,7 +55,7 @@ module Impose (AtomSet : 𝔸) where private A = atoms AtomSet - _≟_ = proj₂ AtomSet + _≟_ = atomsEqual? AtomSet fst-leaf : A → FSTA ∞ fst-leaf = rose-leaf @@ -385,7 +384,7 @@ We now prove some useful properties of the above statements. ⊕-strangers ls [] _ _ rewrite ++-identityʳ ls = refl ⊕-strangers ls (r ∷ rs) (r∉rs ∷ u-rs) (r∉ls ∷ d-ls-rs) -- Goal: (ls ⊙ r) ⊕ rs ≡ ls ++ r ∷ rs - rewrite (Eq.sym (++-tail r rs ls)) + rewrite (Eq.sym (List.∷ʳ-++ ls r rs)) -- Goal: (ls ⊙ r) ⊕ rs ≡ (ls ++ r ∷ []) ++ rs rewrite ⊙-stranger r ls r∉ls -- Goal: (ls ++ r ∷ []) ⊕ rs ≡ (ls ++ r ∷ []) ++ rs diff --git a/src/Vatras/Lang/FST/Composition.agda b/src/Vatras/Lang/FST/Composition.agda new file mode 100644 index 00000000..4fc83406 --- /dev/null +++ b/src/Vatras/Lang/FST/Composition.agda @@ -0,0 +1,37 @@ +open import Vatras.Framework.Definitions using (𝔽; 𝔸) +module Vatras.Lang.FST.Composition (F : 𝔽) (A : 𝔸) where + +open import Data.List as List using (List; []; _∷_; _++_) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl) + +import Vatras.Util.List as List +import Vatras.Lang.FST +open Vatras.Lang.FST.Impose F A + +⊛-all-unique + : (fs : List FSF) + → Unique (List.concatMap forget-uniqueness fs) + → forget-uniqueness (⊛-all fs) ≡ List.concatMap forget-uniqueness fs +⊛-all-unique [] unique-fs = refl +⊛-all-unique (f ∷ fs) unique-fs = + forget-uniqueness (⊛-all (f ∷ fs)) + ≡⟨⟩ + forget-uniqueness f ⊕ forget-uniqueness (⊛-all fs) + ≡⟨ Eq.cong (forget-uniqueness f ⊕_) (⊛-all-unique fs (List.AllPairs-++⁻ʳ (forget-uniqueness f) unique-fs)) ⟩ + forget-uniqueness f ⊕ List.concatMap forget-uniqueness fs + ≡⟨ ⊕-strangers + (forget-uniqueness f) + (List.concatMap forget-uniqueness fs) + (List.AllPairs-++⁻ʳ (forget-uniqueness f) unique-fs) + (List.AllAll-comm + (List.concatMap forget-uniqueness fs) + (forget-uniqueness f) + ≉-sym + (List.AllPairs⇒AllAll (forget-uniqueness f) (List.concatMap forget-uniqueness fs) unique-fs)) + ⟩ + forget-uniqueness f ++ List.concatMap forget-uniqueness fs + ≡⟨⟩ + List.concatMap forget-uniqueness (f ∷ fs) + ∎ + where + open Eq.≡-Reasoning diff --git a/src/Vatras/Lang/FST/IncompleteOnRose.lagda.md b/src/Vatras/Lang/FST/IncompleteOnRose.lagda.md index 6d818946..905cc5c2 100644 --- a/src/Vatras/Lang/FST/IncompleteOnRose.lagda.md +++ b/src/Vatras/Lang/FST/IncompleteOnRose.lagda.md @@ -1,5 +1,5 @@ ``` -open import Vatras.Framework.Definitions using (𝔽; 𝔸; atoms) +open import Vatras.Framework.Definitions using (𝔽; 𝔸; NAT') module Vatras.Lang.FST.IncompleteOnRose {F : 𝔽} where open import Size using (Size; ∞) @@ -24,16 +24,16 @@ open import Data.Nat as ℕ using (ℕ; zero; suc) open import Vatras.Framework.VariantGenerator using (VariantGenerator) open import Vatras.Framework.Properties.Completeness using (Incomplete) -variant-0 = rose-leaf {A = (ℕ , ℕ._≟_)} 0 -variant-1 = rose-leaf {A = (ℕ , ℕ._≟_)} 1 +variant-0 = rose-leaf {A = NAT'} 0 +variant-1 = rose-leaf {A = NAT'} 1 -variants-0-and-1 : VariantGenerator (Rose ∞) (ℕ , ℕ._≟_) 1 +variants-0-and-1 : VariantGenerator (Rose ∞) NAT' 1 variants-0-and-1 zero = variant-0 variants-0-and-1 (suc zero) = variant-1 does-not-describe-variants-0-and-1 : ∀ {i : Size} - → (e : Impose.SPL (ℕ , ℕ._≟_)) + → (e : Impose.SPL NAT') → ∃[ c ] (variant-0 ≡ ⟦ e ⟧ c) → ∄[ c ] (variant-1 ≡ ⟦ e ⟧ c) does-not-describe-variants-0-and-1 (zero Impose.◀ features) _ () diff --git a/src/Vatras/Lang/FST/NoCoreFeature.agda b/src/Vatras/Lang/FST/NoCoreFeature.agda new file mode 100644 index 00000000..8420fc2d --- /dev/null +++ b/src/Vatras/Lang/FST/NoCoreFeature.agda @@ -0,0 +1,76 @@ +{-| +Proof that feature structure trees do not contain a core feature. +In other words: Every feature structure tree contains a variant that has no children. +Hence, feature structure trees are incomplete +(they cannot encode a variant set that does not contain a variant without children). +-} + +open import Vatras.Framework.Definitions using (𝔽; NAT') +module Vatras.Lang.FST.NoCoreFeature {F : 𝔽} where + +open import Data.Bool using (true; false) +open import Data.Fin using (zero) +open import Data.List using ([]; _∷_) +open import Data.Nat as ℕ using (ℕ) +open import Data.Product as Prod using (_,_; proj₂; Σ-syntax) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl) +open import Relation.Nullary.Negation using (¬_) +open import Size using (∞) + +open import Vatras.Data.EqIndexedSet using (_≅_; ≅-sym) +open import Vatras.Framework.Variants using (Rose; Rose-injective) +open import Vatras.Framework.VariantGenerator using (VariantGenerator) +open import Vatras.Framework.Properties.Completeness using (Incomplete) +import Vatras.Lang.FST as FST + +open FST.Impose F NAT' + +{-| +A variant that has at least one child. +-} +variant : Rose ∞ NAT' +variant = 0 Rose.-< 0 Rose.-< [] >- ∷ [] >- + +{-| +A variant set that does not contain the variant that has no children. +-} +variantGenerator : VariantGenerator (Rose ∞) NAT' 0 +variantGenerator zero = variant + +{-| +The configuration `λ f → false` results in no selected features. +-} +select-false : ∀ features → select (λ f → false) features ≡ [] +select-false [] = refl +select-false (feature ∷ features) = select-false features + +{-| +Every feature structure tree contains a variant without children. +-} +lemma : ∀ (e : SPL) → Σ[ a ∈ ℕ ] ⟦ e ⟧ (λ f → false) ≡ a Rose.-< [] >- +lemma (a ◀ features) = a , ( + begin + ⟦ a ◀ features ⟧ (λ f → false) + ≡⟨⟩ + a Rose.-< forget-uniqueness (⊛-all (select (λ f → false) features)) >- + ≡⟨ Eq.cong (λ x → a Rose.-< forget-uniqueness (⊛-all x) >-) (select-false features) ⟩ + a Rose.-< forget-uniqueness (⊛-all []) >- + ≡⟨⟩ + a Rose.-< [] >- + ∎) + where + open Eq.≡-Reasoning + +{-| +The variant set `variantGenerator` cannot be expressed by a feature structure tree. +-} +does-not-describe-variant : ¬ (Σ[ e ∈ SPL ] (⟦ e ⟧ ≅ variantGenerator)) +does-not-describe-variant (e , variant⊆e , e⊆variant) with variant⊆e (λ f → false) | lemma e +does-not-describe-variant (e , variant⊆e , e⊆variant) | zero , e≡variant | a , e≡empty with Eq.trans (Eq.sym (proj₂ (Rose-injective e≡variant))) (proj₂ (Rose-injective e≡empty)) +does-not-describe-variant (e , variant⊆e , e⊆variant) | zero , e≡variant | a , e≡empty | () + +{-| +Due to `does-not-describe-variant`, feature structure trees are incomplete. +-} +FST-is-incomplete : Incomplete (Rose ∞) (FST.FSTL F) +FST-is-incomplete complete = does-not-describe-variant (Prod.map₂ (≅-sym) (complete variantGenerator)) diff --git a/src/Vatras/Lang/FST/Util.agda b/src/Vatras/Lang/FST/Util.agda new file mode 100644 index 00000000..2667feb5 --- /dev/null +++ b/src/Vatras/Lang/FST/Util.agda @@ -0,0 +1,19 @@ +open import Vatras.Framework.Definitions using (𝔽; 𝔸; atoms) +module Vatras.Lang.FST.Util (F : 𝔽) (A : 𝔸) where + +open import Data.Bool using (true; false) +open import Data.List as List using ([]; _∷_) +open import Function using (_∘_) +open import Relation.Binary.PropositionalEquality as Eq using (_≗_; refl) + +import Vatras.Lang.FST +open Vatras.Lang.FST F using (Configuration) +open Vatras.Lang.FST.Impose F A using (select; impl; name; _::_) + +select≗filter + : (config : Configuration) + → select config ≗ List.map impl ∘ List.filterᵇ (config ∘ name) +select≗filter config [] = refl +select≗filter config ((name :: impl) ∷ fs) with config name +select≗filter config ((name :: impl) ∷ fs) | true = Eq.cong (impl ∷_) (select≗filter config fs) +select≗filter config ((name :: impl) ∷ fs) | false = select≗filter config fs diff --git a/src/Vatras/Lang/NCC/Show.agda b/src/Vatras/Lang/NCC/Show.agda index 7b0a1c22..30d9ca3d 100644 --- a/src/Vatras/Lang/NCC/Show.agda +++ b/src/Vatras/Lang/NCC/Show.agda @@ -1,5 +1,5 @@ open import Data.String as String using (String; _++_) -open import Vatras.Framework.Definitions using (𝔽) +open import Vatras.Framework.Definitions using (𝔽; STRING) open import Vatras.Util.Nat.AtLeast using (ℕ≥) module Vatras.Lang.NCC.Show {Dimension : 𝔽} {n : ℕ≥ 2} (show-D : Dimension → String) where @@ -11,13 +11,13 @@ open import Data.Product using (_,_) open import Vatras.Show.Lines open import Vatras.Lang.NCC Dimension n using (NCC; _⟨_⟩; _-<_>-) -show : ∀ {i} → NCC i (String , String._≟_) → String +show : ∀ {i} → NCC i STRING → String show (a -< [] >-) = a show (a -< es@(_ ∷ _) >-) = a ++ "-<" ++ (String.intersperse ", " (List.map show es)) ++ ">-" show (D ⟨ cs ⟩) = show-D D ++ "⟨" ++ (String.intersperse ", " (List.map show (Vec.toList cs))) ++ "⟩" -pretty : ∀ {i : Size} → NCC i (String , String._≟_) → Lines +pretty : ∀ {i : Size} → NCC i STRING → Lines pretty (a -< [] >-) = > a pretty (a -< es@(_ ∷ _) >-) = do > a ++ "-<" diff --git a/src/Vatras/Lang/OC/Alternative.agda b/src/Vatras/Lang/OC/Alternative.agda index e0745192..8b202957 100644 --- a/src/Vatras/Lang/OC/Alternative.agda +++ b/src/Vatras/Lang/OC/Alternative.agda @@ -3,7 +3,7 @@ This module proves that option calculus cannot encode alternatives, at the example of natural numbers as the atom set. The proof is restricted to variants with alternatives at their root. -} -open import Vatras.Framework.Definitions using (𝔽; 𝔸; atoms) +open import Vatras.Framework.Definitions using (𝔽; NAT') module Vatras.Lang.OC.Alternative {F : 𝔽} where open import Data.List using (List; []; _∷_) @@ -20,11 +20,8 @@ open import Vatras.Lang.OC F as OC using (WFOC; Root) open import Vatras.Lang.OC.Util using (all-oc) open import Vatras.Lang.OC.Subtree using (Subtree; subtrees; subtreeₒ-recurse) -A : 𝔸 -A = ℕ , _≟_ - cannotEncodeAlternative : - (e : WFOC ∞ A) + (e : WFOC ∞ NAT') → (∃[ c ] zero -< rose-leaf zero ∷ [] >- ≡ OC.⟦ e ⟧ c) → (∃[ c ] zero -< rose-leaf (suc zero) ∷ [] >- ≡ OC.⟦ e ⟧ c) → (zero -< [] >- ≡ OC.⟦ e ⟧ (all-oc false)) @@ -32,14 +29,14 @@ cannotEncodeAlternative : ⊎ Subtree (zero -< rose-leaf (suc zero) ∷ rose-leaf zero ∷ [] >-) (OC.⟦ e ⟧ (all-oc true)) cannotEncodeAlternative e@(Root zero cs) p₁ p₂ p₃ = Sum.map subtrees subtrees (mergeSubtrees' (sublist p₁) (sublist p₂)) where - sublist : ∀ {a : atoms A} {v : Rose ∞ A} → (∃[ c ] a -< v ∷ [] >- ≡ OC.⟦ e ⟧ c) → Sublist Subtree (v ∷ []) (OC.⟦ cs ⟧ₒ-recurse (all-oc true)) + sublist : ∀ {a : ℕ} {v : Rose ∞ NAT'} → (∃[ c ] a -< v ∷ [] >- ≡ OC.⟦ e ⟧ c) → Sublist Subtree (v ∷ []) (OC.⟦ cs ⟧ₒ-recurse (all-oc true)) sublist (c₁ , p₁) = Eq.subst (λ cs' → Sublist Subtree cs' (OC.⟦ cs ⟧ₒ-recurse (all-oc true))) (children-equality (Eq.sym p₁)) (subtreeₒ-recurse cs c₁ (all-oc true) (λ f p → refl)) - mergeSubtrees' : ∀ {cs : List (Rose ∞ A)} + mergeSubtrees' : ∀ {cs : List (Rose ∞ NAT')} → Sublist Subtree (rose-leaf zero ∷ []) cs → Sublist Subtree (rose-leaf (suc zero) ∷ []) cs → Sublist Subtree (rose-leaf zero ∷ rose-leaf (suc zero) ∷ []) cs diff --git a/src/Vatras/Lang/OC/IncompleteOnRose.lagda.md b/src/Vatras/Lang/OC/IncompleteOnRose.lagda.md index 83068f57..3360fc58 100644 --- a/src/Vatras/Lang/OC/IncompleteOnRose.lagda.md +++ b/src/Vatras/Lang/OC/IncompleteOnRose.lagda.md @@ -1,5 +1,5 @@ ```agda -open import Vatras.Framework.Definitions using (𝔽) +open import Vatras.Framework.Definitions using (𝔽; NAT') module Vatras.Lang.OC.IncompleteOnRose {Option : 𝔽} where open import Size using (Size; ∞) @@ -9,7 +9,7 @@ open import Data.Product using (_,_; ∃-syntax; ∄-syntax) open import Relation.Binary.PropositionalEquality using (_≡_) open import Vatras.Framework.Variants using (Rose; rose-leaf) -open import Vatras.Framework.VariantGenerator (Rose ∞) (ℕ , ℕ._≟_) using (VariantGenerator) +open import Vatras.Framework.VariantGenerator (Rose ∞) NAT' open import Vatras.Framework.Properties.Completeness (Rose ∞) using (Incomplete) open import Vatras.Lang.OC Option using (WFOC; Root; ⟦_⟧; WFOCL) ``` @@ -18,8 +18,8 @@ We prove incompleteness by showing that there exists at least one set of variant In particular, any set of variants that includes two entirely distinct variants cannot be expressed because options cannot encode constraints such as alternatives in choice calculus. As our counter example, we use the set `{0, 1}` as our variants: ```agda -variant-0 = rose-leaf {A = (ℕ , ℕ._≟_)} 0 -variant-1 = rose-leaf {A = (ℕ , ℕ._≟_)} 1 +variant-0 = rose-leaf {A = NAT'} 0 +variant-1 = rose-leaf {A = NAT'} 1 variants-0-and-1 : VariantGenerator 1 variants-0-and-1 zero = variant-0 @@ -34,7 +34,7 @@ So we show that given an expression `e`, a proof that `e` can be configured to ` ```agda does-not-describe-variants-0-and-1 : ∀ {i : Size} - → (e : WFOC i (ℕ , ℕ._≟_)) + → (e : WFOC i NAT') → ∃[ c ] (variant-0 ≡ ⟦ e ⟧ c) → ∄[ c ] (variant-1 ≡ ⟦ e ⟧ c) -- If e has 0 as root, it may be configured to 0 but never to 1. diff --git a/src/Vatras/Lang/OC/Show.agda b/src/Vatras/Lang/OC/Show.agda index b53dea98..491348ec 100644 --- a/src/Vatras/Lang/OC/Show.agda +++ b/src/Vatras/Lang/OC/Show.agda @@ -1,4 +1,4 @@ -open import Vatras.Framework.Definitions using (𝔽) +open import Vatras.Framework.Definitions using (𝔽; STRING) open import Data.String as String using (String; _++_) module Vatras.Lang.OC.Show {Option : 𝔽} (print-opt : Option → String) where @@ -10,15 +10,15 @@ open import Data.List as List using ([]; _∷_) open import Vatras.Show.Lines hiding (map) open import Vatras.Lang.OC Option using (OC; _❲_❳; _-<_>-; WFOC; forgetWF) -show-oc : ∀ {i : Size} → OC i (String , String._≟_) → String +show-oc : ∀ {i : Size} → OC i STRING → String show-oc (s -< [] >-) = s show-oc (s -< es@(_ ∷ _) >-) = s ++ "-<" ++ (String.intersperse ", " (List.map show-oc es)) ++ ">-" show-oc (O ❲ e ❳) = print-opt O ++ "❲" ++ show-oc e ++ "❳" -show-wfoc : ∀ {i : Size} → WFOC i (String , String._≟_) → String +show-wfoc : ∀ {i : Size} → WFOC i STRING → String show-wfoc = show-oc ∘ forgetWF -pretty-oc : ∀ {i : Size} → OC i (String , String._≟_) → Lines +pretty-oc : ∀ {i : Size} → OC i STRING → Lines pretty-oc (s -< [] >-) = > s pretty-oc (s -< es@(_ ∷ _) >-) = do > s ++ "-<" @@ -30,5 +30,5 @@ pretty-oc (O ❲ e ❳) = do indent 2 (pretty-oc e) > "❳" -pretty-wfoc : ∀ {i : Size} → WFOC i (String , String._≟_) → Lines +pretty-wfoc : ∀ {i : Size} → WFOC i STRING → Lines pretty-wfoc = pretty-oc ∘ forgetWF diff --git a/src/Vatras/Lang/PropOC.agda b/src/Vatras/Lang/PropOC.agda new file mode 100644 index 00000000..83fc3e77 --- /dev/null +++ b/src/Vatras/Lang/PropOC.agda @@ -0,0 +1,42 @@ +{-| +A specialization of option calculus with propositional formulas as dimensions. +The semantics is adapted in order to evaluate the propositional formulas. +Hence, the configuration consists of an `Assignment` of variables to `Bool`. +-} +open import Vatras.Framework.Definitions using (𝔽; ℂ; 𝔼) + +module Vatras.Lang.PropOC (F : 𝔽) where + +open import Data.List using (List) +open import Data.Maybe using (Maybe) +open import Function using (_∘_; flip) +open import Size using (Size; ∞) + +open import Vatras.Data.Prop using (Prop; Assignment; eval) +open import Vatras.Framework.Variants as V using (Rose) +open import Vatras.Framework.VariabilityLanguage using (VariabilityLanguage; ⟪_,_,_⟫; 𝔼-Semantics) +open import Vatras.Lang.OC (Prop F) as OC + public + using (Root; _-<_>-; _❲_❳) + renaming + ( OC to PropOC + ; WFOC to WFPropOC + ) + +Configuration : ℂ +Configuration = Assignment F + +⟦_⟧ₒ-recurse : ∀ {i} → 𝔼-Semantics (List ∘ Rose ∞) Configuration (List ∘ PropOC i) +⟦ e ⟧ₒ-recurse c = OC.⟦ e ⟧ₒ-recurse (flip eval c) + +⟦_⟧ₒ : ∀ {i : Size} → 𝔼-Semantics (Maybe ∘ Rose ∞) Configuration (PropOC i) +⟦ e ⟧ₒ c = OC.⟦ e ⟧ₒ (flip eval c) + +⟦_⟧ : ∀ {i : Size} → 𝔼-Semantics (Rose ∞) Configuration (WFPropOC i) +⟦ e ⟧ c = OC.⟦ e ⟧ (flip eval c) + +PropOCL : ∀ {i : Size} → VariabilityLanguage (Maybe ∘ Rose ∞) +PropOCL {i} = ⟪ PropOC i , Configuration , ⟦_⟧ₒ ⟫ + +WFPropOCL : {i : Size} → VariabilityLanguage (Rose ∞) +WFPropOCL {i} = ⟪ WFPropOC i , Configuration , ⟦_⟧ ⟫ diff --git a/src/Vatras/Succinctness/DefinitionEquivalence.agda b/src/Vatras/Succinctness/DefinitionEquivalence.agda new file mode 100644 index 00000000..e50db5bc --- /dev/null +++ b/src/Vatras/Succinctness/DefinitionEquivalence.agda @@ -0,0 +1,94 @@ +open import Vatras.Framework.Definitions using (𝔸; 𝕍) +module Vatras.Succinctness.DefinitionEquivalence (V : 𝕍) where + +open import Data.Empty using (⊥-elim) +open import Data.Product as Product using (_×_; _,_; proj₁; proj₂; Σ-syntax; ∃-syntax; ∄-syntax) +open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _≤_; _<_; _≤?_) +import Data.Nat.Properties as ℕ +open import Relation.Binary.PropositionalEquality as Eq using (_≡_) +open import Relation.Nullary.Decidable using (yes; no) + +open import Vatras.Data.EqIndexedSet using (≅-refl; ≅-sym; ≅-trans) +open import Vatras.Framework.VariabilityLanguage using (Expression) +open import Vatras.Framework.Relation.Expression V using (_,_⊢_≣_) +open import Vatras.Succinctness.Sizes using (SizedLang; Lang; size) +open import Vatras.Succinctness.DesignedDefinition V using (minimalExpression; design) +open import Vatras.Succinctness.ProofDefinition V using (_≤ₛ[_]_) + +simplification→design + : (f : ℕ → ℕ) + → (VL₁ VL₂ : SizedLang V) + → VL₁ ≤ₛ[ f ] VL₂ + → design f VL₁ VL₂ +simplification→design f VL₁ VL₂ (m , simplification) .proj₁ = m +simplification→design f VL₁ VL₂ (m , simplification) .proj₂ A e₁ e₂ e₁≅e₂ e₁-minimal e₂-minimal + with simplification A e₂ (e₁ , ≅-sym e₁≅e₂) +... | e₁' , e₁'≅e₂ , e₁'≤e₂ + = ℕ.≤-trans (e₁-minimal e₁' (≅-trans e₁≅e₂ (≅-sym e₁'≅e₂))) e₁'≤e₂ + +open import Axiom.ExcludedMiddle +module Classical (excludedMiddle : ∀ {ℓ} → ExcludedMiddle ℓ) where + + ∃minimalExpression + : {A : 𝔸} + → (VL : SizedLang V) + → (e : Expression (Lang VL) A) + → Σ[ e' ∈ Expression (Lang VL) A ] (Lang VL , Lang VL ⊢ e ≣ e') × minimalExpression VL e' + ∃minimalExpression {A} VL e = go (size VL e) zero (Eq.sym (ℕ.*-identityˡ (size VL e))) λ where () + where + open ℕ.≤-Reasoning + + go + : (m n : ℕ) + → size VL e ≡ m + n + → (∄[ e' ] (Lang VL , Lang VL ⊢ e ≣ e') × size VL e' < n) + → Σ[ e' ∈ Expression (Lang VL) A ] (Lang VL , Lang VL ⊢ e ≣ e') × minimalExpression VL e' + go zero n size≡m+n ∄smaller = e , ≅-refl , isMinimal + where + isMinimal : (e' : Expression (Lang VL) A) → Lang VL , Lang VL ⊢ e ≣ e' → size VL e ≤ size VL e' + isMinimal e' e≅e' with size VL e ≤? size VL e' + isMinimal e' e≅e' | yes e≤e' = e≤e' + isMinimal e' e≅e' | no e≰e' = ⊥-elim (∄smaller (e' , e≅e' , ( + begin-strict + size VL e' + <⟨ ℕ.≰⇒> e≰e' ⟩ + size VL e + ≡⟨ size≡m+n ⟩ + n + ∎))) + go (suc m) n size≡m+n ∄smaller with excludedMiddle {P = ∃[ e' ] (Lang VL , Lang VL ⊢ e ≣ e') × size VL e' < suc n} + go (suc m) n size≡m+n ∄smaller | no ∄e' e'≰e'' ⟩ + size VL e' + ≤⟨ ℕ.≤-pred e'≤e ⟩ + n + ∎))) + + design→simplification + : (f : ℕ → ℕ) + → (∀ n m → n ≤ m → f n ≤ f m) + → (VL₁ VL₂ : SizedLang V) + → design f VL₁ VL₂ + → VL₁ ≤ₛ[ f ] VL₂ + design→simplification f f-monotone VL₁ VL₂ (m , design) .proj₁ = m + design→simplification f f-monotone VL₁ VL₂ (m , design) .proj₂ A e₂ (e₁ , e₂≅e₁) + with ∃minimalExpression VL₁ e₁ | ∃minimalExpression VL₂ e₂ + ... | e₁' , e₁≅e₁' , e₁'-minimal | e₂' , e₂≅e₂' , e₂'-minimal + = e₁' , ≅-sym (≅-trans e₂≅e₁ e₁≅e₁') , ( + begin + size VL₁ e₁' + ≤⟨ design A e₁' e₂' (≅-trans (≅-sym (≅-trans e₂≅e₁ e₁≅e₁')) e₂≅e₂') e₁'-minimal e₂'-minimal ⟩ + m * f (size VL₂ e₂') + ≤⟨ ℕ.*-monoʳ-≤ m (f-monotone (size VL₂ e₂') (size VL₂ e₂) (e₂'-minimal e₂ (≅-sym e₂≅e₂'))) ⟩ + m * f (size VL₂ e₂) + ∎) + where + open ℕ.≤-Reasoning diff --git a/src/Vatras/Succinctness/DesignedDefinition.agda b/src/Vatras/Succinctness/DesignedDefinition.agda new file mode 100644 index 00000000..9b7f6035 --- /dev/null +++ b/src/Vatras/Succinctness/DesignedDefinition.agda @@ -0,0 +1,37 @@ +open import Vatras.Framework.Definitions using (𝔸; 𝕍) +module Vatras.Succinctness.DesignedDefinition (V : 𝕍) where + +open import Data.Product using (Σ-syntax) +open import Data.Nat using (ℕ; _≤_; _*_) +open import Function using (id) + +open import Vatras.Framework.VariabilityLanguage using (Expression) +open import Vatras.Framework.Relation.Expression V using (_,_⊢_≣_) +open import Vatras.Succinctness.Sizes using (SizedLang; Lang; size) + +minimalExpression + : {A : 𝔸} (VL : SizedLang V) + → Expression (Lang VL) A + → Set _ +minimalExpression {A} VL e = + ∀ (e' : Expression (Lang VL) A) (e≅e' : Lang VL , Lang VL ⊢ e ≣ e') + → size VL e ≤ size VL e' + +design + : (f : ℕ → ℕ) + → (VL₁ VL₂ : SizedLang V) + → Set _ +design f VL₁ VL₂ = + Σ[ m ∈ ℕ ] + ∀ (A : 𝔸) + (e₁ : Expression (Lang VL₁) A) + (e₂ : Expression (Lang VL₂) A) + → Lang VL₁ , Lang VL₂ ⊢ e₁ ≣ e₂ + → minimalExpression VL₁ e₁ + → minimalExpression VL₂ e₂ + → size VL₁ e₁ ≤ m * f (size VL₂ e₂) + +relation + : (VL₁ VL₂ : SizedLang V) + → Set _ +relation = design id diff --git a/src/Vatras/Succinctness/ProofDefinition.agda b/src/Vatras/Succinctness/ProofDefinition.agda new file mode 100644 index 00000000..d0914900 --- /dev/null +++ b/src/Vatras/Succinctness/ProofDefinition.agda @@ -0,0 +1,514 @@ +open import Vatras.Framework.Definitions using (𝔸; 𝕍) +module Vatras.Succinctness.ProofDefinition (V : 𝕍) where + +import Axiom.ExcludedMiddle +import Axiom.DoubleNegationElimination +open import Data.Empty using (⊥-elim) +open import Data.Nat as ℕ using (ℕ; _≤_; _>_; _*_) +import Data.Nat.Properties as ℕ +open import Data.Product as Product using (_×_; _,_; Σ-syntax; proj₁; proj₂) +open import Function using (id; _∘_) +open import Relation.Binary using (_Preserves_⟶_) +import Relation.Binary.PropositionalEquality as Eq +open import Relation.Binary.Structures using (IsEquivalence; IsPreorder; IsPartialOrder; IsStrictPartialOrder) +open import Relation.Nullary.Decidable using (yes; no) +open import Relation.Nullary.Negation using (¬_; ¬∃⟶∀¬) +open import Relation.Unary using (_∈_) + +open import Vatras.Data.EqIndexedSet using (≅-refl; ≅-sym; ≅-trans; ≅→≅[]; ⊆-index) +open import Vatras.Util.Big-O using (𝒪[_]) +open Vatras.Util.Big-O.Examples using (n∈𝒪[n]) +open import Vatras.Framework.Relation.Expression V using (_,_⊢_≣_) +open import Vatras.Framework.Relation.Expressiveness V using (_≽_; _≋_; ≽-trans; ≋-refl; ≋-sym; ≋-trans) +open import Vatras.Framework.VariabilityLanguage using (VariabilityLanguage; Expression) +open import Vatras.Framework.Compiler using (LanguageCompiler) +open import Vatras.Succinctness.Sizes using (SizedLang; Lang; size) + +translatable + : (L₁ L₂ : SizedLang V) + → {A : 𝔸} + → (e₁ : Expression (Lang L₁) A) + → Set _ +translatable L₁ L₂ {A} e₁ = + Σ[ e₂ ∈ Expression (Lang L₂) A ] + Lang L₁ , Lang L₂ ⊢ e₁ ≣ e₂ + +_≤ₛ[_]_ + : (L₁ : SizedLang V) + → (f : ℕ → ℕ) + → (L₂ : SizedLang V) + → Set _ +L₁ ≤ₛ[ f ] L₂ = + Σ[ n ∈ ℕ ] + ∀ (A : 𝔸) → + ∀ (e₂ : Expression (Lang L₂) A) + → translatable L₂ L₁ e₂ + → Σ[ e₁ ∈ Expression (Lang L₁) A ] + Lang L₁ , Lang L₂ ⊢ e₁ ≣ e₂ + × size L₁ e₁ ≤ n * f (size L₂ e₂) + +_≰ₛ[_]_ + : (L₁ : SizedLang V) + → (f : ℕ → ℕ) + → (L₂ : SizedLang V) + → Set _ +L₁ ≰ₛ[ f ] L₂ = + ∀ (n : ℕ) → + Σ[ A ∈ 𝔸 ] + Σ[ e₂ ∈ Expression (Lang L₂) A ] + translatable L₂ L₁ e₂ + × ∀ (e₁ : Expression (Lang L₁) A) + → Lang L₁ , Lang L₂ ⊢ e₁ ≣ e₂ + → size L₁ e₁ > n * f (size L₂ e₂) + + +≤ₛ[]-growthFactor : {L₁ L₂ : SizedLang V} (f : ℕ → ℕ) → L₁ ≤ₛ[ f ] L₂ → ℕ +≤ₛ[]-growthFactor f = proj₁ + +at-least-linear : (ℕ → ℕ) → Set +at-least-linear f = id ∈ 𝒪[ f ] + +monotonic : (ℕ → ℕ) → Set +monotonic f = f Preserves _≤_ ⟶ _≤_ + + +≤ₛ[]-refl : {L : SizedLang V} {f : ℕ → ℕ} → at-least-linear f → L ≤ₛ[ f ] L +≤ₛ[]-refl {L} (n , id≤f) = n , λ A e e-translatable → e , ≅-refl , id≤f (size L e) + +≤ₛ[]-transitive + : {L₁ L₂ L₃ : SizedLang V} + → (f g : ℕ → ℕ) + → monotonic f + → Lang L₁ ≽ Lang L₂ + → Lang L₂ ≽ Lang L₃ + → L₁ ≤ₛ[ f ] L₂ + → (L₂≤ₛL₃ : L₂ ≤ₛ[ g ] L₃) + → L₁ ≤ₛ[ (λ n → f (≤ₛ[]-growthFactor g L₂≤ₛL₃ * g n)) ] L₃ +≤ₛ[]-transitive {L₁} {L₂} {L₃} f g f-monotone L₁≽L₂ L₂≽L₃ (n₁ , L₂→L₁) (n₂ , L₃→L₂) .proj₁ = n₁ +≤ₛ[]-transitive {L₁} {L₂} {L₃} f g f-monotone L₁≽L₂ L₂≽L₃ (n₁ , L₂→L₁) (n₂ , L₃→L₂) .proj₂ A e₃ e₃-translatable with L₃→L₂ A e₃ (L₂≽L₃ e₃) +≤ₛ[]-transitive {L₁} {L₂} {L₃} f g f-monotone L₁≽L₂ L₂≽L₃ (n₁ , L₂→L₁) (n₂ , L₃→L₂) .proj₂ A e₃ e₃-translatable | e₂ , e₂≅e₃ , e₁≤e₂ with L₂→L₁ A e₂ (L₁≽L₂ e₂) +≤ₛ[]-transitive {L₁} {L₂} {L₃} f g f-monotone L₁≽L₂ L₂≽L₃ (n₁ , L₂→L₁) (n₂ , L₃→L₂) .proj₂ A e₃ e₃-translatable | e₂ , e₂≅e₃ , e₂≤e₃ | e₁ , e₁≅e₂ , e₁≤e₂ + = e₁ , ≅-trans e₁≅e₂ e₂≅e₃ , + (begin + size L₁ e₁ + ≤⟨ e₁≤e₂ ⟩ + n₁ * f (size L₂ e₂) + ≤⟨ ℕ.*-monoʳ-≤ n₁ (f-monotone e₂≤e₃) ⟩ + n₁ * f (n₂ * g (size L₃ e₃)) + ∎) + where + open ℕ.≤-Reasoning + + +_≤ₛ_ : SizedLang V → SizedLang V → Set₁ +L₁ ≤ₛ L₂ = L₁ ≤ₛ[ id ] L₂ + +_=ₛ_ : SizedLang V → SizedLang V → Set₁ +L₁ =ₛ L₂ = L₁ ≤ₛ L₂ × L₂ ≤ₛ L₁ + +_≰ₛ_ : SizedLang V → SizedLang V → Set₁ +L₁ ≰ₛ L₂ = L₁ ≰ₛ[ id ] L₂ + +_<ₛ_ : SizedLang V → SizedLang V → Set₁ +L₁ <ₛ L₂ = L₁ ≤ₛ L₂ × L₂ ≰ₛ L₁ + + +≤ₛ-refl : {L : SizedLang V} → L ≤ₛ L +≤ₛ-refl = ≤ₛ[]-refl n∈𝒪[n] + +≤ₛ-reflexive : {L₁ L₂ : SizedLang V} → L₁ =ₛ L₂ → L₁ ≤ₛ L₂ +≤ₛ-reflexive (L₁≤ₛL₂ , L₂≤ₛL₁) = L₁≤ₛL₂ + +≤ₛ-transitive : {L₁ L₂ L₃ : SizedLang V} → + Lang L₁ ≽ Lang L₂ + → Lang L₂ ≽ Lang L₃ + → L₁ ≤ₛ L₂ + → L₂ ≤ₛ L₃ + → L₁ ≤ₛ L₃ +≤ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₂≽L₃ (n₁ , L₂→L₁) (n₂ , L₃→L₂) .proj₁ = n₁ * n₂ +≤ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₂≽L₃ (n₁ , L₂→L₁) (n₂ , L₃→L₂) .proj₂ A e₃ e₃-translatable with L₃→L₂ A e₃ (L₂≽L₃ e₃) +≤ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₂≽L₃ (n₁ , L₂→L₁) (n₂ , L₃→L₂) .proj₂ A e₃ e₃-translatable | e₂ , e₂≅e₃ , e₁≤e₂ with L₂→L₁ A e₂ (L₁≽L₂ e₂) +≤ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₂≽L₃ (n₁ , L₂→L₁) (n₂ , L₃→L₂) .proj₂ A e₃ e₃-translatable | e₂ , e₂≅e₃ , e₂≤e₃ | e₁ , e₁≅e₂ , e₁≤e₂ + = e₁ , ≅-trans e₁≅e₂ e₂≅e₃ , + (begin + size L₁ e₁ + ≤⟨ e₁≤e₂ ⟩ + n₁ * size L₂ e₂ + ≤⟨ ℕ.*-monoʳ-≤ n₁ e₂≤e₃ ⟩ + n₁ * (n₂ * size L₃ e₃) + ≡⟨ ℕ.*-assoc n₁ n₂ (size L₃ e₃) ⟨ + n₁ * n₂ * size L₃ e₃ + ∎) + where + open ℕ.≤-Reasoning + +≤ₛ-antisymmetric : {L₁ L₂ : SizedLang V} → L₁ ≤ₛ L₂ → L₂ ≤ₛ L₁ → L₁ =ₛ L₂ +≤ₛ-antisymmetric L₁≤ₛL₂ L₂≤ₛL₁ = L₁≤ₛL₂ , L₂≤ₛL₁ + + +=ₛ-reflexive : {L : SizedLang V} → L =ₛ L +=ₛ-reflexive = ≤ₛ-refl , ≤ₛ-refl + +=ₛ-symmetric : {L₁ L₂ : SizedLang V} → L₁ =ₛ L₂ → L₂ =ₛ L₁ +=ₛ-symmetric (L₁≤ₛL₂ , L₂≤ₛL₁) = L₂≤ₛL₁ , L₁≤ₛL₂ + +=ₛ-transitive : {L₁ L₂ L₃ : SizedLang V} → Lang L₁ ≋ Lang L₂ → Lang L₂ ≋ Lang L₃ → L₁ =ₛ L₂ → L₂ =ₛ L₃ → L₁ =ₛ L₃ +=ₛ-transitive (L₁≽L₂ , L₂≽L₁) (L₂≽L₃ , L₃≽L₂) (L₁≤ₛL₂ , L₂≤ₛL₁) (L₂≤ₛL₃ , L₃≤ₛL₂) = ≤ₛ-transitive L₁≽L₂ L₂≽L₃ L₁≤ₛL₂ L₂≤ₛL₃ , ≤ₛ-transitive L₃≽L₂ L₂≽L₁ L₃≤ₛL₂ L₂≤ₛL₁ + +<ₛ→≤ₛ : {L₁ L₂ : SizedLang V} → L₁ <ₛ L₂ → L₁ ≤ₛ L₂ +<ₛ→≤ₛ (L₁≤ₛL₂ , L₂≰ₛL₁) = L₁≤ₛL₂ + +≤ₛ-≱ₛ-transitive : + ∀ {L₁ L₂ L₃ : SizedLang V} + → Lang L₁ ≽ Lang L₂ + → L₁ ≤ₛ L₂ + → L₃ ≰ₛ L₂ + → L₃ ≰ₛ L₁ +≤ₛ-≱ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₁≤ₛL₂@(m , L₂→L₁) L₃≰ₛL₂ n with L₃≰ₛL₂ (n * m) +≤ₛ-≱ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₁≤ₛL₂@(m , L₂→L₁) L₃≰ₛL₂ n | A , e₂ , (e₃ , e₂≅e₃) , e₂< with L₂→L₁ A e₂ (L₁≽L₂ e₂) +≤ₛ-≱ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₁≤ₛL₂@(m , L₂→L₁) L₃≰ₛL₂ n | A , e₂ , (e₃ , e₂≅e₃) , e₂< | e₁ , e₁≅e₂ , e₁≤e₂ + = A , e₁ , (e₃ , ≅-trans e₁≅e₂ e₂≅e₃) , λ e₃' e₃≅e₁ → + begin-strict + n * size L₁ e₁ + ≤⟨ ℕ.*-monoʳ-≤ n e₁≤e₂ ⟩ + n * (m * size L₂ e₂) + ≡⟨ ℕ.*-assoc n m (size L₂ e₂) ⟨ + n * m * size L₂ e₂ + <⟨ e₂< e₃' (≅-trans e₃≅e₁ e₁≅e₂) ⟩ + size L₃ e₃' + ∎ + where + open ℕ.≤-Reasoning + +≤ₛ-<ₛ-transitive : {L₁ L₂ L₃ : SizedLang V} → Lang L₁ ≽ Lang L₂ → Lang L₂ ≽ Lang L₃ → L₁ ≤ₛ L₂ → L₂ <ₛ L₃ → L₁ <ₛ L₃ +≤ₛ-<ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₂≽L₃ L₁≤ₛL₂ (L₂≤ₛL₃ , L₃≰ₛL₂) .proj₁ = ≤ₛ-transitive L₁≽L₂ L₂≽L₃ L₁≤ₛL₂ L₂≤ₛL₃ +≤ₛ-<ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₂≽L₃ L₁≤ₛL₂ (L₂≤ₛL₃ , L₃≰ₛL₂) .proj₂ = ≤ₛ-≱ₛ-transitive L₁≽L₂ L₁≤ₛL₂ L₃≰ₛL₂ + +≱ₛ-≤ₛ-transitive : + ∀ {L₁ L₂ L₃ : SizedLang V} + → Lang L₂ ≋ Lang L₃ + → L₂ ≰ₛ L₁ + → L₂ ≤ₛ L₃ + → L₃ ≰ₛ L₁ +≱ₛ-≤ₛ-transitive {L₁} {L₂} {L₃} (L₂≽L₃ , L₃≽L₂) L₂≰ₛL₁ L₂≤ₛL₃@(m , L₃→L₂) n with L₂≰ₛL₁ (m * n) +≱ₛ-≤ₛ-transitive {L₁} {L₂} {L₃} (L₂≽L₃ , L₃≽L₂) L₂≰ₛL₁ L₂≤ₛL₃@(m , L₃→L₂) n | A , e₁ , (e₂ , e₁≅e₂) , e₁< + = A , e₁ , Product.map₂ (≅-trans e₁≅e₂) (L₃≽L₂ e₂) , go + where + go : (e₃ : Expression (Lang L₃) A) → Lang L₃ , Lang L₁ ⊢ e₃ ≣ e₁ → size L₃ e₃ > n * size L₁ e₁ + go e₃ e₃≅e₁ with L₃→L₂ A e₃ (L₂≽L₃ e₃) + go e₃ e₃≅e₁ | e₂ , e₂≅e₃ , e₂≤e₃ = + begin-strict + n * size L₁ e₁ + <⟨ ℕ.*-cancelˡ-< m (n * size L₁ e₁) (size L₃ e₃) + (begin-strict + m * (n * size L₁ e₁) + ≡⟨ ℕ.*-assoc m n (size L₁ e₁) ⟨ + m * n * size L₁ e₁ + <⟨ e₁< e₂ (≅-trans e₂≅e₃ e₃≅e₁) ⟩ + size L₂ e₂ + ≤⟨ e₂≤e₃ ⟩ + m * size L₃ e₃ + ∎) + ⟩ + size L₃ e₃ + ∎ + where + open ℕ.≤-Reasoning + +<ₛ-≤ₛ-transitive : {L₁ L₂ L₃ : SizedLang V} → Lang L₁ ≽ Lang L₂ → Lang L₂ ≋ Lang L₃ → L₁ <ₛ L₂ → L₂ ≤ₛ L₃ → L₁ <ₛ L₃ +<ₛ-≤ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₂≋L₃@(L₂≽L₃ , _) (L₁≤ₛL₂ , L₂≰ₛL₁) L₂≤ₛL₃ .proj₁ = ≤ₛ-transitive L₁≽L₂ L₂≽L₃ L₁≤ₛL₂ L₂≤ₛL₃ +<ₛ-≤ₛ-transitive {L₁} {L₂} {L₃} L₁≽L₂ L₂≋L₃@(L₂≽L₃ , _) (L₁≤ₛL₂ , L₂≰ₛL₁) L₂≤ₛL₃ .proj₂ = ≱ₛ-≤ₛ-transitive L₂≋L₃ L₂≰ₛL₁ L₂≤ₛL₃ + +<ₛ-transitive : {L₁ L₂ L₃ : SizedLang V} → Lang L₁ ≽ Lang L₂ → Lang L₂ ≋ Lang L₃ → L₁ <ₛ L₂ → L₂ <ₛ L₃ → L₁ <ₛ L₃ +<ₛ-transitive L₁≽L₂ L₂≋L₃ L₁<ₛL₂ L₂<ₛL₃ = <ₛ-≤ₛ-transitive L₁≽L₂ L₂≋L₃ L₁<ₛL₂ (<ₛ→≤ₛ L₂<ₛL₃) + +<ₛ-irreflexive : {L₁ L₂ : SizedLang V} → L₁ =ₛ L₂ → ¬ (L₁ <ₛ L₂) +<ₛ-irreflexive {L₁} {L₂} (L₁≤ₛL₂ , (n , L₁→L₂)) (L₁≤ₛL₂' , L₂≰ₛL₁) with L₂≰ₛL₁ n +<ₛ-irreflexive {L₁} {L₂} (L₁≤ₛL₂ , (n , L₁→L₂)) (L₁≤ₛL₂' , L₂≰ₛL₁) | A , e₁ , e₁-translatable , e₂< with L₁→L₂ A e₁ e₁-translatable +<ₛ-irreflexive {L₁} {L₂} (L₁≤ₛL₂ , (n , L₁→L₂)) (L₁≤ₛL₂' , L₂≰ₛL₁) | A , e₁ , e₁-translatable , e₁< | e₂ , e₁≅e₂ , e₂≤e₁ = ℕ.n≮n (size L₂ e₂) (ℕ.≤-trans (ℕ.s≤s e₂≤e₁) (e₁< e₂ e₁≅e₂)) + +<ₛ-Respectsʳ : {L₁ L₂ L₃ : SizedLang V} → Lang L₁ ≋ Lang L₂ → Lang L₂ ≋ Lang L₃ → L₂ =ₛ L₃ → L₁ <ₛ L₂ → L₁ <ₛ L₃ +<ₛ-Respectsʳ {L₁} {L₂} {L₃} (L₁≽L₂ , L₂≽L₁) (L₂≽L₃ , L₃≽L₂) (L₂≤ₛL₃@(m , L₃→L₂) , L₃≤ₛL₂) (L₁≤ₛL₂ , L₂≰ₛL₁) .proj₁ = ≤ₛ-transitive L₁≽L₂ L₂≽L₃ L₁≤ₛL₂ L₂≤ₛL₃ +<ₛ-Respectsʳ {L₁} {L₂} {L₃} (L₁≽L₂ , L₂≽L₁) (L₂≽L₃ , L₃≽L₂) (L₂≤ₛL₃@(m , L₃→L₂) , L₃≤ₛL₂) (L₁≤ₛL₂ , L₂≰ₛL₁) .proj₂ n with L₂≰ₛL₁ (m * n) +<ₛ-Respectsʳ {L₁} {L₂} {L₃} (L₁≽L₂ , L₂≽L₁) (L₂≽L₃ , L₃≽L₂) (L₂≤ₛL₃@(m , L₃→L₂) , L₃≤ₛL₂) (L₁≤ₛL₂ , L₂≰ₛL₁) .proj₂ n | A , e₁ , e₁-translatable , e₁< + = A , e₁ , (≽-trans L₃≽L₂ L₂≽L₁) e₁ , go + where + go : (e₃ : Expression (Lang L₃) A) → Lang L₃ , Lang L₁ ⊢ e₃ ≣ e₁ → size L₃ e₃ > n * size L₁ e₁ + go e₃ e₃≅e₁ with L₃→L₂ A e₃ (L₂≽L₃ e₃) + go e₃ e₃≅e₁ | e₂ , e₂≅e₃ , e₂≤e₃ = ℕ.*-cancelˡ-< m (n * size L₁ e₁) (size L₃ e₃) + (begin-strict + m * (n * size L₁ e₁) + ≡⟨ ℕ.*-assoc m n (size L₁ e₁) ⟨ + m * n * size L₁ e₁ + <⟨ ℕ.≤-trans (e₁< e₂ (≅-trans e₂≅e₃ e₃≅e₁)) e₂≤e₃ ⟩ + m * size L₃ e₃ + ∎) + where + open ℕ.≤-Reasoning + +<ₛ-Respectsˡ : {L₁ L₂ L₃ : SizedLang V} → Lang L₃ ≋ Lang L₂ → Lang L₂ ≋ Lang L₁ → L₂ =ₛ L₃ → L₂ <ₛ L₁ → L₃ <ₛ L₁ +<ₛ-Respectsˡ {L₁} {L₂} {L₃} (L₃≽L₂ , L₂≽L₃) (L₂≽L₁ , L₁≽L₂) (L₂≤ₛL₃ , L₃≤ₛL₂@(m , L₂→L₃)) (L₂≤ₛL₁ , L₁≰ₛL₂) .proj₁ = ≤ₛ-transitive L₃≽L₂ L₂≽L₁ L₃≤ₛL₂ L₂≤ₛL₁ +<ₛ-Respectsˡ {L₁} {L₂} {L₃} (L₃≽L₂ , L₂≽L₃) (L₂≽L₁ , L₁≽L₂) (L₂≤ₛL₃ , L₃≤ₛL₂@(m , L₂→L₃)) (L₂≤ₛL₁ , L₁≰ₛL₂) .proj₂ n with L₁≰ₛL₂ (m * n) +<ₛ-Respectsˡ {L₁} {L₂} {L₃} (L₃≽L₂ , L₂≽L₃) (L₂≽L₁ , L₁≽L₂) (L₂≤ₛL₃ , L₃≤ₛL₂@(m , L₂→L₃)) (L₂≤ₛL₁ , L₁≰ₛL₂) .proj₂ n | A , e₂ , e₂-translatable , e₂< with L₂→L₃ A e₂ (L₃≽L₂ e₂) +<ₛ-Respectsˡ {L₁} {L₂} {L₃} (L₃≽L₂ , L₂≽L₃) (L₂≽L₁ , L₁≽L₂) (L₂≤ₛL₃ , L₃≤ₛL₂@(m , L₂→L₃)) (L₂≤ₛL₁ , L₁≰ₛL₂) .proj₂ n | A , e₂ , e₂-translatable , e₂< | e₃ , e₃≅e₂ , e₃≤e₂ + = A , e₃ , (≽-trans L₁≽L₂ L₂≽L₃) e₃ , go + where + go : (e₁ : Expression (Lang L₁) A) → Lang L₁ , Lang L₃ ⊢ e₁ ≣ e₃ → size L₁ e₁ > n * size L₃ e₃ + go e₁ e₁≅e₃ = + begin-strict + n * size L₃ e₃ + ≤⟨ ℕ.*-monoʳ-≤ n e₃≤e₂ ⟩ + n * (m * size L₂ e₂) + ≡⟨ ℕ.*-assoc n m (size L₂ e₂) ⟨ + n * m * size L₂ e₂ + ≡⟨ Eq.cong (_* size L₂ e₂) (ℕ.*-comm n m) ⟩ + m * n * size L₂ e₂ + <⟨ e₂< e₁ (≅-trans e₁≅e₃ e₃≅e₂) ⟩ + size L₁ e₁ + ∎ + where + open ℕ.≤-Reasoning + + +_<ₛ[_]_ + : (L₁ : SizedLang V) + → (f : ℕ → ℕ) + → (L₂ : SizedLang V) + → Set _ +L₁ <ₛ[ f ] L₂ = L₁ ≤ₛ L₂ × L₂ ≰ₛ[ f ] L₁ + +<ₛ[]-growthFactor : {L₁ L₂ : SizedLang V} (f : ℕ → ℕ) → L₁ <ₛ[ f ] L₂ → ℕ +<ₛ[]-growthFactor f = proj₁ ∘ proj₁ + +≤ₛ[]-<ₛ[]-transitive + : {L₁ L₂ L₃ : SizedLang V} + → (f : ℕ → ℕ) + → monotonic f + → Lang L₁ ≽ Lang L₂ + → Lang L₂ ≋ Lang L₃ + → (L₁≤ₛL₂ : L₁ ≤ₛ L₂) + → L₂ <ₛ[ (λ n → f (≤ₛ[]-growthFactor id L₁≤ₛL₂ * n)) ] L₃ + → L₁ <ₛ[ f ] L₃ +≤ₛ[]-<ₛ[]-transitive {L₁} {L₂} {L₃} f f-monotone L₁≽L₂ (L₂≽L₃ , L₃≽L₂) L₁≤ₛL₂@(m , L₂→L₁) (L₂≤ₛL₃ , L₃≰ₛL₂) .proj₁ = ≤ₛ-transitive L₁≽L₂ L₂≽L₃ L₁≤ₛL₂ L₂≤ₛL₃ +≤ₛ[]-<ₛ[]-transitive {L₁} {L₂} {L₃} f f-monotone L₁≽L₂ L₂≽L₃ L₁≤ₛL₂@(m , L₂→L₁) (L₂≤ₛL₃ , L₃≰ₛL₂) .proj₂ n with L₃≰ₛL₂ n +≤ₛ[]-<ₛ[]-transitive {L₁} {L₂} {L₃} f f-monotone L₁≽L₂ L₂≽L₃ L₁≤ₛL₂@(m , L₂→L₁) (L₂≤ₛL₃ , L₃≰ₛL₂) .proj₂ n | A , e₂ , (e₃ , e₂≅e₃) , e₂< with L₂→L₁ A e₂ (L₁≽L₂ e₂) +≤ₛ[]-<ₛ[]-transitive {L₁} {L₂} {L₃} f f-monotone L₁≽L₂ L₂≽L₃ L₁≤ₛL₂@(m , L₂→L₁) (L₂≤ₛL₃ , L₃≰ₛL₂) .proj₂ n | A , e₂ , (e₃ , e₂≅e₃) , e₂< | e₁ , e₁≅e₂ , e₁≤e₂ + = A , e₁ , (e₃ , ≅-trans e₁≅e₂ e₂≅e₃) , λ e₃' e₃≅e₁ → + begin-strict + n * f (size L₁ e₁) + ≤⟨ ℕ.*-monoʳ-≤ n (f-monotone (e₁≤e₂)) ⟩ + n * f (m * size L₂ e₂) + <⟨ e₂< e₃' (≅-trans e₃≅e₁ e₁≅e₂) ⟩ + size L₃ e₃' + ∎ + where + open ℕ.≤-Reasoning + +<ₛ[]-≤ₛ[]-transitive + : {L₁ L₂ L₃ : SizedLang V} + → (f : ℕ → ℕ) + → Lang L₁ ≽ Lang L₂ + → Lang L₂ ≋ Lang L₃ + → L₁ <ₛ[ f ] L₂ + → L₂ ≤ₛ L₃ + → L₁ <ₛ[ f ] L₃ +<ₛ[]-≤ₛ[]-transitive {L₁} {L₂} {L₃} f L₁≽L₂ (L₂≽L₃ , L₃≽L₂) (L₁≤ₛL₂ , L₂≰ₛL₁) L₂≤ₛL₃@(m , L₃→L₂) .proj₁ = ≤ₛ-transitive L₁≽L₂ L₂≽L₃ L₁≤ₛL₂ L₂≤ₛL₃ +<ₛ[]-≤ₛ[]-transitive {L₁} {L₂} {L₃} f L₁≽L₂ (L₂≽L₃ , L₃≽L₂) (L₁≤ₛL₂ , L₂≰ₛL₁) L₂≤ₛL₃@(m , L₃→L₂) .proj₂ n with L₂≰ₛL₁ (m * n) +<ₛ[]-≤ₛ[]-transitive {L₁} {L₂} {L₃} f L₁≽L₂ (L₂≽L₃ , L₃≽L₂) (L₁≤ₛL₂ , L₂≰ₛL₁) L₂≤ₛL₃@(m , L₃→L₂) .proj₂ n | A , e₁ , (e₂ , e₁≅e₂) , e₁< + = A , e₁ , Product.map₂ (≅-trans e₁≅e₂) (L₃≽L₂ e₂) , go + where + go : (e₃ : Expression (Lang L₃) A) → Lang L₃ , Lang L₁ ⊢ e₃ ≣ e₁ → size L₃ e₃ > n * f (size L₁ e₁) + go e₃ e₃≅e₁ with L₃→L₂ A e₃ (L₂≽L₃ e₃) + go e₃ e₃≅e₁ | e₂ , e₂≅e₃ , e₂≤e₃ = + begin-strict + n * f (size L₁ e₁) + <⟨ ℕ.*-cancelˡ-< m (n * f (size L₁ e₁)) (size L₃ e₃) + (begin-strict + m * (n * f (size L₁ e₁)) + ≡⟨ ℕ.*-assoc m n (f (size L₁ e₁)) ⟨ + m * n * f (size L₁ e₁) + <⟨ e₁< e₂ (≅-trans e₂≅e₃ e₃≅e₁) ⟩ + size L₂ e₂ + ≤⟨ e₂≤e₃ ⟩ + m * size L₃ e₃ + ∎) + ⟩ + size L₃ e₃ + ∎ + where + open ℕ.≤-Reasoning + + +_=ₛ'_ : SizedLang V → SizedLang V → Set₁ +L₁ =ₛ' L₂ = Lang L₁ ≋ Lang L₂ × L₁ ≤ₛ L₂ × L₂ ≤ₛ L₁ + +_≤ₛ'_ : SizedLang V → SizedLang V → Set₁ +L₁ ≤ₛ' L₂ = Lang L₁ ≽ Lang L₂ × L₁ ≤ₛ[ id ] L₂ + +_<ₛ'_ : SizedLang V → SizedLang V → Set₁ +L₁ <ₛ' L₂ = Lang L₁ ≋ Lang L₂ × L₁ ≤ₛ L₂ × L₂ ≰ₛ L₁ + +=ₛ'-IsEquivalence : IsEquivalence _=ₛ'_ +=ₛ'-IsEquivalence = record + { refl = ≋-refl , =ₛ-reflexive + ; sym = Product.map ≋-sym =ₛ-symmetric + ; trans = λ (L₁≋L₂ , L₁=ₛL₂) (L₂≋L₃ , L₂=ₛL₃) → ≋-trans L₁≋L₂ L₂≋L₃ , =ₛ-transitive L₁≋L₂ L₂≋L₃ L₁=ₛL₂ L₂=ₛL₃ + } + +≤ₛ'-IsPreOrder : IsPreorder _=ₛ'_ _≤ₛ'_ +≤ₛ'-IsPreOrder = record + { isEquivalence = =ₛ'-IsEquivalence + ; reflexive = λ ((L₁≽L₂ , L₂≽L₁) , L₁≤ₛL₂) → L₁≽L₂ , ≤ₛ-reflexive L₁≤ₛL₂ + ; trans = λ (L₁≽L₂ , L₁≤ₛL₂) (L₂≽L₃ , L₂≤ₛL₃) → ≽-trans L₁≽L₂ L₂≽L₃ , ≤ₛ-transitive L₁≽L₂ L₂≽L₃ L₁≤ₛL₂ L₂≤ₛL₃ + } + +≤ₛ'-IsPartialOrder : IsPartialOrder _=ₛ'_ _≤ₛ'_ +≤ₛ'-IsPartialOrder = record + { isPreorder = ≤ₛ'-IsPreOrder + ; antisym = λ (L₁≽L₂ , L₁≤ₛL₂) (L₂≽L₁ , L₂≤ₛL₁) → (L₁≽L₂ , L₂≽L₁) , ≤ₛ-antisymmetric L₁≤ₛL₂ L₂≤ₛL₁ + } + +<ₛ'-IsStrictPartialOrder : IsStrictPartialOrder _=ₛ'_ _<ₛ'_ +<ₛ'-IsStrictPartialOrder = record + { isEquivalence = =ₛ'-IsEquivalence + ; trans = λ (L₁≋L₂@(L₁≽L₂ , L₂≽L₁) , L₁≤ₛL₂) (L₂≋L₃ , L₂≤ₛL₃) → ≋-trans L₁≋L₂ L₂≋L₃ , <ₛ-transitive L₁≽L₂ L₂≋L₃ L₁≤ₛL₂ L₂≤ₛL₃ + ; irrefl = λ (L₁≋L₂ , L₁=ₛL₂) (L₁≋L₂ , L₁<ₛL₂) → <ₛ-irreflexive L₁=ₛL₂ L₁<ₛL₂ + ; <-resp-≈ = + (λ (L₂≋L₃ , L₂=ₛL₃) (L₁≋L₂ , L₁<ₛL₂) → ≋-trans L₁≋L₂ L₂≋L₃ , <ₛ-Respectsʳ L₁≋L₂ L₂≋L₃ L₂=ₛL₃ L₁<ₛL₂) + , (λ (L₁≋L₂ , L₁=ₛL₂) (L₁≋L₃ , L₁<ₛL₃) → ≋-trans (≋-sym L₁≋L₂) L₁≋L₃ , <ₛ-Respectsˡ (≋-sym L₁≋L₂) L₁≋L₃ L₁=ₛL₂ L₁<ₛL₃) + } + + +=ₛ'→=ₛ : {L₁ L₂ : SizedLang V} → L₁ =ₛ' L₂ → L₁ =ₛ L₂ +=ₛ'→=ₛ = proj₂ + +≤ₛ'→≤ₛ : {L₁ L₂ : SizedLang V} → L₁ =ₛ' L₂ → L₁ =ₛ L₂ +≤ₛ'→≤ₛ = proj₂ + +<ₛ'→<ₛ : {L₁ L₂ : SizedLang V} → L₁ =ₛ' L₂ → L₁ =ₛ L₂ +<ₛ'→<ₛ = proj₂ + + +≰[]→¬≤[] : {L₁ L₂ : SizedLang V} (f : ℕ → ℕ) → L₁ ≰ₛ[ f ] L₂ → ¬ (L₁ ≤ₛ[ f ] L₂) +≰[]→¬≤[] {L₁} {L₂} f L₁≰ₛL₂ (n , L₁→L₂) with L₁≰ₛL₂ n +≰[]→¬≤[] {L₁} {L₂} f L₁≰ₛL₂ (n , L₁→L₂) | A , e₂ , e₂-translatable , e₂< with L₁→L₂ A e₂ e₂-translatable +≰[]→¬≤[] {L₁} {L₂} f L₁≰ₛL₂ (n , L₁→L₂) | A , e₂ , e₂-translatable , e₂< | e₁ , e₂≅e₁ , e₁≤e₂ = ℕ.n≮n (size L₁ e₁) (ℕ.≤-trans (ℕ.s≤s e₁≤e₂) (e₂< e₁ e₂≅e₁)) + +≤[]→¬≰[] : {L₁ L₂ : SizedLang V} (f : ℕ → ℕ) → L₁ ≤ₛ[ f ] L₂ → ¬ (L₁ ≰ₛ[ f ] L₂) +≤[]→¬≰[] {L₁} {L₂} f (n , L₂→L₁) L₂≰ₛL₁ with L₂≰ₛL₁ n +≤[]→¬≰[] {L₁} {L₂} f (n , L₂→L₁) L₂≰ₛL₁ | A , e₂ , e₂-translatable , e₂< with L₂→L₁ A e₂ e₂-translatable +≤[]→¬≰[] {L₁} {L₂} f (n , L₂→L₁) L₂≰ₛL₁ | A , e₂ , e₂-translatable , e₂< | e₁ , e₂≅e₁ , e₁≤e₂ = ℕ.n≮n (n * f (size L₂ e₂)) (ℕ.≤-trans (e₂< e₁ e₂≅e₁) e₁≤e₂) + +≰→¬= : {L₁ L₂ : SizedLang V} → L₁ ≰ₛ L₂ → ¬ (L₁ =ₛ L₂) +≰→¬= L₁≰ₛL₂ (L₁≤ₛL₂ , L₂≤ₛL₁) = ≰[]→¬≤[] id L₁≰ₛL₂ L₁≤ₛL₂ + +≤[]→Compiler : {L₁ L₂ : SizedLang V} (f : ℕ → ℕ) → Lang L₁ ≽ Lang L₂ → L₁ ≤ₛ[ f ] L₂ → LanguageCompiler (Lang L₂) (Lang L₁) +≤[]→Compiler f L₁≽L₂ (n , L₂→L₁) = record + { compile = λ {A} e₂ → proj₁ (L₂→L₁ A e₂ (L₁≽L₂ e₂)) + ; config-compiler = λ {A} e₂ → record + { to = ⊆-index (proj₂ (proj₁ (proj₂ (L₂→L₁ A e₂ (L₁≽L₂ e₂))))) + ; from = ⊆-index (proj₁ (proj₁ (proj₂ (L₂→L₁ A e₂ (L₁≽L₂ e₂))))) + } + ; preserves = λ {A} e₂ → ≅→≅[] (≅-sym (proj₁ (proj₂ (L₂→L₁ A e₂ (L₁≽L₂ e₂))))) + } + +≤ₛ[]-weakening : ∀ {L₁ L₂ : SizedLang V} {f g : ℕ → ℕ} → f ∈ 𝒪[ g ] → L₁ ≤ₛ[ f ] L₂ → L₁ ≤ₛ[ g ] L₂ +≤ₛ[]-weakening {L₁} {L₂} {f} {g} (m , f≤g) (n , L₂→L₁) .proj₁ = n * m +≤ₛ[]-weakening {L₁} {L₂} {f} {g} (m , f≤g) (n , L₂→L₁) .proj₂ A e₂ e₂-translatable with L₂→L₁ A e₂ e₂-translatable +≤ₛ[]-weakening {L₁} {L₂} {f} {g} (m , f≤g) (n , L₂→L₁) .proj₂ A e₂ e₂-translatable | e₁ , e₁≅e₂ , e₂≤e₁ = e₁ , e₁≅e₂ , ( + begin + size L₁ e₁ + ≤⟨ e₂≤e₁ ⟩ + n * f (size L₂ e₂) + ≤⟨ ℕ.*-monoʳ-≤ n (f≤g (size L₂ e₂)) ⟩ + n * (m * g (size L₂ e₂)) + ≡⟨ ℕ.*-assoc n m (g (size L₂ e₂)) ⟨ + n * m * g (size L₂ e₂) + ∎) + where + open ℕ.≤-Reasoning + +≰ₛ[]-strengthening : ∀ {L₁ L₂ : SizedLang V} {f g : ℕ → ℕ} → f ∈ 𝒪[ g ] → L₁ ≰ₛ[ g ] L₂ → L₁ ≰ₛ[ f ] L₂ +≰ₛ[]-strengthening {L₁} {L₂} {f} {g} (m , f≤g) L₁≰ₛL₂ n with L₁≰ₛL₂ (n * m) +... | A , e₂ , e₂-translatable , >e₂ = A , e₂ , e₂-translatable , λ e₁ e₁≅e₂ → + begin-strict + n * f (size L₂ e₂) + ≤⟨ ℕ.*-monoʳ-≤ n (f≤g (size L₂ e₂)) ⟩ + n * (m * g (size L₂ e₂)) + ≡⟨ ℕ.*-assoc n m (g (size L₂ e₂)) ⟨ + (n * m) * g (size L₂ e₂) + <⟨ >e₂ e₁ e₁≅e₂ ⟩ + size L₁ e₁ + ∎ + where + open ℕ.≤-Reasoning + +proportionalSize : ∀ {ℓ} {L : 𝔸 → Set ℓ} → ({A : 𝔸} → L A → ℕ) → ({A : 𝔸} → L A → ℕ) → Set _ +proportionalSize {L = L} s₁ s₂ = + Σ[ n ∈ ℕ ] + Σ[ m ∈ ℕ ] + ∀ {A : 𝔸} + → (e : L A) + → s₁ e ≤ n * s₂ e + × s₂ e ≤ m * s₁ e + +sizeDefinitionIndependence : + ∀ (L₁ L₂ : VariabilityLanguage V) + → (s₁ s₂ : ∀ {A : 𝔸} → Expression L₁ A → ℕ) + → (s₃ s₄ : ∀ {A : 𝔸} → Expression L₂ A → ℕ) + → proportionalSize {L = Expression L₁} s₁ s₂ + → proportionalSize {L = Expression L₂} s₃ s₄ + → record {Lang = L₁; size = s₁} ≤ₛ record {Lang = L₂; size = s₃} + → record {Lang = L₁; size = s₂} ≤ₛ record {Lang = L₂; size = s₄} +sizeDefinitionIndependence L₁ L₂ s₁ s₂ s₃ s₄ (n₁ , m₁ , s₁=s₂) (n₂ , m₂ , s₃=s₄) (k , L₂→L₁) .proj₁ = m₁ * k * n₂ +sizeDefinitionIndependence L₁ L₂ s₁ s₂ s₃ s₄ (n₁ , m₁ , s₁=s₂) (n₂ , m₂ , s₃=s₄) (k , L₂→L₁) .proj₂ A e₂ e₂-translatable + with L₂→L₁ A e₂ e₂-translatable +... | e₁ , e₁≅e₂ , e₁≤e₂ + with s₁=s₂ e₁ +... | s₁≤s₂ , s₂≤s₁ + with s₃=s₄ e₂ +... | s₃≤s₄ , s₄≤s₃ + = e₁ , e₁≅e₂ , ( + begin + s₂ e₁ + ≤⟨ s₂≤s₁ ⟩ + m₁ * s₁ e₁ + ≤⟨ ℕ.*-monoʳ-≤ m₁ e₁≤e₂ ⟩ + m₁ * (k * s₃ e₂) + ≡⟨ ℕ.*-assoc m₁ k (s₃ e₂) ⟨ + m₁ * k * s₃ e₂ + ≤⟨ ℕ.*-monoʳ-≤ (m₁ * k) s₃≤s₄ ⟩ + m₁ * k * (n₂ * s₄ e₂) + ≡⟨ ℕ.*-assoc (m₁ * k) n₂ (s₄ e₂) ⟨ + m₁ * k * n₂ * s₄ e₂ + ∎) + where + open ℕ.≤-Reasoning + +open Axiom.ExcludedMiddle using (ExcludedMiddle) +open Axiom.DoubleNegationElimination using (em⇒dne) +module Classical (excludedMiddle : ∀ {ℓ} → ExcludedMiddle ℓ) where + ¬∀→∃¬ : ∀ {ℓ₁ ℓ₂} {A : Set ℓ₁} {P : A → Set ℓ₂} → ¬ (∀ (a : A) → P a) → Σ[ a ∈ A ] ¬ P a + ¬∀→∃¬ {A = A} {P = P} ¬∀P with excludedMiddle {P = Σ[ a ∈ A ] ¬ P a} + ¬∀→∃¬ {A = A} {P = P} ¬∀P | yes ∃P = ∃P + ¬∀→∃¬ {A = A} {P = P} ¬∀P | no ∄P = ⊥-elim (¬∀P (λ a → em⇒dne excludedMiddle (¬∃⟶∀¬ ∄P a))) + + map-∀ : ∀ {ℓ₁ ℓ₂ ℓ₃} {A : Set ℓ₁} {P : A → Set ℓ₂} {Q : A → Set ℓ₃} + → (∀ {a} → P a → Q a) → (∀ (a : A) → P a) → (∀ (a : A) → Q a) + map-∀ f ∀P a = f (∀P a) + + map-Σ : ∀ {ℓ₁ ℓ₂ ℓ₃} {A : Set ℓ₁} {P : A → Set ℓ₂} {Q : A → Set ℓ₃} + → (∀ {a} → P a → Q a) → Σ[ a ∈ A ] P a → Σ[ a ∈ A ] Q a + map-Σ f (a , Pa) = a , f Pa + + ¬∀→∃ : ∀ {ℓ₁ ℓ₂ ℓ₃} {A : Set ℓ₁} {P : A → Set ℓ₂} {Q : A → Set ℓ₃} → (∀ {a : A} → ¬ P a → Q a) → ¬ (∀ (a : A) → P a) → Σ[ a ∈ A ] Q a + ¬∀→∃ f P = map-Σ f (¬∀→∃¬ P) + + ¬∃→∀ : ∀ {ℓ₁ ℓ₂ ℓ₃} {A : Set ℓ₁} {P : A → Set ℓ₂} {Q : A → Set ℓ₃} → (∀ {a : A} → ¬ P a → Q a) → ¬ (Σ[ a ∈ A ] P a) → ∀ (a : A) → Q a + ¬∃→∀ f P = map-∀ f (¬∃⟶∀¬ P) + + ¬≤ₛ[]→≰ₛ[] : {L₁ L₂ : SizedLang V} (f : ℕ → ℕ) → ¬ (L₁ ≤ₛ[ f ] L₂) → L₁ ≰ₛ[ f ] L₂ + ¬≤ₛ[]→≰ₛ[] f = ¬∃→∀ (¬∀→∃ (¬∀→∃ (¬∀→∃ (¬∃→∀ (¬∃→∀ ℕ.≰⇒>))))) + + ¬≰[]→≤[] : {L₁ L₂ : SizedLang V} (f : ℕ → ℕ) → ¬ (L₁ ≰ₛ[ f ] L₂) → L₁ ≤ₛ[ f ] L₂ + ¬≰[]→≤[] f = ¬∀→∃ (¬∃→∀ (¬∃→∀ (¬∃→∀ (¬∀→∃ (¬∀→∃ ℕ.≮⇒≥))))) diff --git a/src/Vatras/Succinctness/Reflection.agda b/src/Vatras/Succinctness/Reflection.agda new file mode 100644 index 00000000..d65e8f3d --- /dev/null +++ b/src/Vatras/Succinctness/Reflection.agda @@ -0,0 +1,239 @@ +module Vatras.Succinctness.Reflection where + +open import Data.Product using (_×_; _,_; Σ-syntax; map₁; uncurry; proj₁; proj₂; map₂) +open import Data.Sum using (_⊎_) +open import Data.Nat as ℕ hiding (_≡ᵇ_) +import Data.Nat.Properties as ℕ +open import Level renaming (zero to lzero; suc to lsuc) +open import Data.Bool +open import Data.Unit +open import Data.Maybe as Maybe using (maybe; is-just) +open import Data.List +open import Data.List.NonEmpty as List⁺ using (List⁺; _∷_) +import Data.List.Effectful +import Data.Nat.Show as ℕ +open import Data.String as S using (String) +import Effect.Monad.Identity +open import Function +open import Relation.Binary.PropositionalEquality +open import Size +open import Reflection +open import Reflection.AST +open import Reflection.AST.Argument as Argument hiding (map) +open import Reflection.AST.Argument.Information +open import Reflection.AST.Argument.Visibility +open import Reflection.AST.Name +open import Reflection.AST.Term +open import Reflection.AST.Pattern +open import Reflection.AST.Show +import Reflection.AST.Traversal +open import Reflection.TCM.Syntax +import Reflection.TCM.Effectful as TCM +open Data.List.Effectful.TraversableM (TCM.monad {lzero}) + +open import Vatras.Framework.Definitions + +module SizeByReflection where + private + infixr 1 _=<<_ + _=<<_ : ∀ {a} {b} {A : Set a} {B : Set b} → (B → TC A) → TC B → TC A + _=<<_ = flip bindTC + + hide : ∀ {a} {A : Set a} → Arg A → Arg A + hide (arg (arg-info _ m) a) = arg (arg-info hidden m) a + + getDataDefinition : Name → TC (ℕ × List Name) + getDataDefinition n = go =<< getDefinition n + where + go : Definition → TC (ℕ × List Name) + go (data-type arity constructors) = pure (arity , constructors) + go _ = typeError (strErr "The given name \"" ∷ nameErr n ∷ strErr "\" must be a data type" ∷ []) + + deconstructFunctionType : Type → List (String × Arg Type) × Type + deconstructFunctionType (pi argType (abs n resultType)) = map₁ ((n , argType) ∷_) (deconstructFunctionType resultType) + deconstructFunctionType rest = [] , rest + + getArgs : Name → TC (List (String × Arg Type) × Type) + getArgs functionName = deconstructFunctionType <$> getType functionName + + mapWithIndex : ∀ {a b} {A : Set a} {B : Set b} → (ℕ → A → B) → List A → List B + mapWithIndex {A = A} {B = B} f xs = go (length xs) xs + where + go : ℕ → List A → List B + go zero xs = [] + go (suc i) [] = [] + go (suc i) (x ∷ xs) = f i x ∷ go i xs + + withIndex : ∀ {a} {A : Set a} → List A → List (ℕ × A) + withIndex = mapWithIndex (_,_) + + withIndexReverse : ∀ {a} {A : Set a} → List A → List (ℕ × A) + withIndexReverse xs = zip (upTo (length xs)) xs + + mapWithIndexReverse : ∀ {a b} {A : Set a} {B : Set b} → (ℕ → A → B) → List A → List B + mapWithIndexReverse f xs = zipWith f (upTo (length xs)) xs + + removeIndices : ∀ {a} {A : Set a} → List ℕ → List A → List A + removeIndices {A = A} is = go zero + where + go : ℕ → List A → List A + go i [] = [] + go i (x ∷ xs) = if is-just (findᵇ (ℕ._≡ᵇ_ i) is) then go (suc i) xs else x ∷ go (suc i) xs + + module _ where + open Effect.Monad.Identity + open Reflection.AST.Traversal applicative + + fixVarsTerm : (ℕ → ℕ) → Term → Term + fixVarsTerm f = runIdentity ∘ traverseTerm (record defaultActions { onVar = λ _ i → mkIdentity (f i) }) (0 , []) + + fixVarsArgTerm : (ℕ → ℕ) → Arg Term → Arg Term + fixVarsArgTerm f (arg info term) = arg info (runIdentity (traverseTerm (record defaultActions { onVar = λ _ i → mkIdentity (f i) }) (0 , []) term)) + + fixVarsPats : (ℕ → ℕ) → List (Arg Pattern) → List (Arg Pattern) + fixVarsPats f = runIdentity ∘ traversePats (record defaultActions { onVar = λ _ i → mkIdentity (f i) }) (0 , []) + + handleRecursiveArgs : Name → (List (Arg Term) → Term) → List (ℕ × ℕ) → List (ℕ × Arg Term) → TC (List Term) + handleRecursiveArgs n sizeFun sizeFuns [] = pure [] + handleRecursiveArgs n sizeFun sizeFuns ((i , arg _ (def n' args)) ∷ as) with n ≡ᵇ n' + -- handle recursion + handleRecursiveArgs n sizeFun sizeFuns ((i , arg _ (def n' args)) ∷ as) | true = do + is <- handleRecursiveArgs n sizeFun sizeFuns as + pure (sizeFun (var i [] ⟨∷⟩ []) ∷ is) + -- handle atoms + handleRecursiveArgs n sizeFun sizeFuns ((i , arg _ (def (quote atoms) (arg _ (var Ai []) ∷ []))) ∷ as) | false = do + is <- handleRecursiveArgs n sizeFun sizeFuns as + pure (def (quote atomSize) (var (suc Ai + length as) [] ⟨∷⟩ var i [] ⟨∷⟩ []) ∷ is) + -- special case List(⁺) (for now) + handleRecursiveArgs n sizeFun sizeFuns ((i , arg _ (def n' (_ ∷ arg _ (def n'' _) ∷ []))) ∷ as) | false = do + is <- handleRecursiveArgs n sizeFun sizeFuns as + if quote List ≡ᵇ n' ∧ n ≡ᵇ n'' + then pure (def (quote sum) (def (quote map) (sizeFun [] ⟨∷⟩ var i [] ⟨∷⟩ []) ⟨∷⟩ []) ∷ is) + else if quote List⁺ ≡ᵇ n' ∧ n ≡ᵇ n'' + then pure (def (quote sum) (def (quote map) (sizeFun [] ⟨∷⟩ def (quote List⁺.toList) (var i [] ⟨∷⟩ []) ⟨∷⟩ []) ⟨∷⟩ []) ∷ is) + else pure is + handleRecursiveArgs n sizeFun sizeFuns ((i , arg _ (def n' args)) ∷ as) | false = handleRecursiveArgs n sizeFun sizeFuns as + -- handle size functions + handleRecursiveArgs n sizeFun sizeFuns ((i , arg _ (var j args)) ∷ as) = do + is <- handleRecursiveArgs n sizeFun sizeFuns as + maybe + (λ (_ , i') → pure (var i' (var i [] ⟨∷⟩ []) ∷ is)) + (pure is) + (findᵇ (λ (j' , _) → j' ℕ.≡ᵇ j + i) sizeFuns) + handleRecursiveArgs n sizeFun sizeFuns ((i , arg _ _) ∷ as) = handleRecursiveArgs n sizeFun sizeFuns as + + typeArguments : Type → TC (List (Arg Term)) + typeArguments (def f args) = pure args + typeArguments term = typeError (strErr "typeArguments got " ∷ termErr term ∷ []) + + appendArguments : Term → List (Arg Term) → TC Term + appendArguments (var i args) args' = pure (var i (args ++ args')) + appendArguments (con c args) args' = pure (con c (args ++ args')) + appendArguments (def f args) args' = pure (def f (args ++ args')) + appendArguments term args' = typeError (strErr "Cannot add arguments to " ∷ termErr term ∷ []) + + sizeFunType : String → Type → Term → TC Type + sizeFunType n type shape = do + args , _ <- deconstructFunctionType <$> normalise type -- TODO type can contain free variables + type <- appendArguments (fixVarsTerm (_+ length args) shape) (mapWithIndex (λ where i (n , arg info _) → arg info (var i [])) args) + pure (foldr + (λ (n , a) t → pi (hide a) (abs n t)) + (pi + (vArg type) + (abs n (def (quote ℕ) []))) + args) + + sizeType : Name → List ℕ → TC Type + sizeType n unsizedArgs = do + args , _ <- getArgs n + + let langType = vArg (def n (mapWithIndex (λ where i (_ , arg info _) → arg info (var (i + length args ∸ length unsizedArgs) [])) args)) + let expr→ℕ = pi langType (abs "expr" (def (quote ℕ) [])) + + sizeFuns→expr→ℕ <- foldr + (λ where (i , (n , arg info a)) t' → do + t <- t' + sizeFun <- sizeFunType n a (var i []) + pure (pi (vArg sizeFun) (abs (n S.++ "-size") t))) + (pure expr→ℕ) + (removeIndices unsizedArgs (withIndex args)) + + pure (foldr + (λ (n , a) t → pi (hide a) (abs n t)) + sizeFuns→expr→ℕ + args) + + sizeClause : Name → Name → ℕ → List ℕ → Name → TC Clause + sizeClause typeName sizeFunctionName arity unsizedArgs c = do + -- type arguments + targs , _ <- getArgs typeName + + -- constructor arguments + cargs , cResultType <- getArgs c + cResultArgs <- typeArguments cResultType + + let numSizeFuns = length targs ∸ length unsizedArgs + sizeFunTypes <- mapM + (λ where (funTypeI , (argName , arg _ argType) , arg _ argShape) → do + funType <- sizeFunType argName argType argShape + pure (argName S.++ "-size" , vArg funType)) + (withIndexReverse (removeIndices unsizedArgs (zip targs cResultArgs))) + + let argsPats = applyUpTo (λ argI → hArg (var (length cargs ∸ suc argI + numSizeFuns))) arity + let indiciesPats = fixVarsPats (_+ numSizeFuns) (map (λ where (arg _ a) → hArg (dot a)) (drop arity cResultArgs)) + let sizeFunPats = applyDownFrom (λ sizeFunI → vArg (var sizeFunI)) numSizeFuns + let cargsPats = con c (mapWithIndex (λ where cargI (_ , arg info _) → arg info (var (cargI + numSizeFuns))) (drop arity cargs)) ⟨∷⟩ [] + + sizeOperands <- sequenceM (mapWithIndex + (λ where + funI (arg _ (var typeI [])) → pure (typeI , funI) + funI (arg _ term) → typeError (strErr "Cannot yet apply size functions to specialized indicies" ∷ [])) + (removeIndices unsizedArgs cResultArgs)) + recursiveSize <- handleRecursiveArgs + typeName + (λ args → def sizeFunctionName (applyDownFrom (λ i → vArg (var i [])) numSizeFuns ++ args)) + sizeOperands + (mapWithIndex (λ where argI (_ , argType) → argI + numSizeFuns , argType) cargs) + + pure (clause + (cargs + ++ sizeFunTypes) + (argsPats + ++ indiciesPats + ++ sizeFunPats + ++ cargsPats) + (con (quote suc) + (foldl (λ acc t → + def (quote _+_) (vArg acc ∷ vArg t ∷ [])) + (quoteTerm zero) + recursiveSize + ⟨∷⟩ []))) + + generateSize : Name → Name → List ℕ → TC ⊤ + generateSize lang fun unsizedArgs = do + declareDef (vArg fun) =<< sizeType lang unsizedArgs + arity , constructors <- getDataDefinition lang + defineFun fun =<< mapM (sizeClause lang fun arity unsizedArgs) constructors + +import Vatras.Framework.Variants as V +open import Vatras.Lang.All + +unquoteDecl CCC-size = SizeByReflection.generateSize (quote CCC.CCC) CCC-size (0 ∷ 1 ∷ 2 ∷ []) +unquoteDecl 2CC-size = SizeByReflection.generateSize (quote 2CC.2CC) 2CC-size (0 ∷ 1 ∷ 2 ∷ []) +unquoteDecl OC-size = SizeByReflection.generateSize (quote OC.OC) OC-size (0 ∷ 1 ∷ 2 ∷ []) +unquoteDecl ADT-size = SizeByReflection.generateSize (quote ADT.ADT) ADT-size (0 ∷ 2 ∷ []) + +_ : CCC-size {String} {_} {NAT} ((0 , 0) CCC.-< (1 , 1) CCC.-< [] >- ∷ "A" CCC.⟨ (2 , 2) CCC.-< [] >- ∷ (3 , 3) CCC.-< (4 , 4) CCC.-< [] >- ∷ [] >- ∷ [] ⟩ ∷ [] >-) ≡ 16 +_ = refl + +_ : 2CC-size {String} {_} {NAT} ((0 , 0) 2CC.-< (1 , 1) 2CC.-< [] >- ∷ "A" 2CC.⟨ (2 , 2) 2CC.-< [] >- , (3 , 3) 2CC.-< (4 , 4) 2CC.-< [] >- ∷ [] >- ⟩ ∷ [] >-) ≡ 16 +_ = refl + +_ : OC-size {String} {_} {NAT} ((0 , 0) OC.-< (1 , 1) OC.-< [] >- ∷ "A" OC.❲ (3 , 3) OC.-< "B" OC.❲ (4 , 4) OC.-< [] >- ❳ ∷ [] >- ❳ ∷ [] >-) ≡ 14 +_ = refl + +sizeRose : ∀ {i : Size} {A : 𝔸} → V.Rose i A → ℕ +sizeRose {A = A} (a V.-< cs >-) = suc (atomSize A a + sum (map sizeRose cs)) + +_ : ADT-size {String} {V.Rose ∞} {NAT} sizeRose ("A" ADT.⟨ ADT.leaf ((1 , 1) V.-< [] >-) , "B" ADT.⟨ ADT.leaf ((2 , 2) V.-< [] >-) , ADT.leaf ((3 , 3) V.-< (4 , 4) V.-< [] >- ∷ [] >-) ⟩ ⟩) ≡ 19 +_ = refl diff --git a/src/Vatras/Succinctness/Relations/2CC-; 2CCL) +open ADT using (ADT; _⟨_,_⟩; leaf; ADTL) + +e₁-cs : ℕ → ℕ → List (2CC ∞ NAT') +e₁-cs zero D = [] +e₁-cs (suc n) D = f D ⟨ 0 -< [] >- , 1 -< [] >- ⟩ ∷ e₁-cs n (suc D) + +e₁ : ℕ → 2CC ∞ NAT' +e₁ n = 0 -< e₁-cs n zero >- + +size-e₁-cs : ∀ n D → List.sum (List.map size2CC (e₁-cs n D)) ≡ n * 3 +size-e₁-cs zero D = refl +size-e₁-cs (suc n) D = Eq.cong (3 +_) (size-e₁-cs n (suc D)) + +size-e₁ : ∀ n → size2CC (e₁ n) ≡ 1 + n * 3 +size-e₁ n = Eq.cong suc (size-e₁-cs n zero) + +variants-cs : ∀ n → Vec Bool n → List (Rose ∞ NAT') +variants-cs zero [] = [] +variants-cs (suc n) (b ∷ bs) = (if b then 0 else 1) Rose.-< [] >- ∷ variants-cs n bs + +variants : ∀ n → Vec Bool n → Rose ∞ NAT' +variants n bs = 0 Rose.-< variants-cs n bs >- + +variants-cs-injective : ∀ n bs₁ bs₂ → variants-cs n bs₁ ≡ variants-cs n bs₂ → bs₁ ≡ bs₂ +variants-cs-injective zero [] [] refl = refl +variants-cs-injective (suc n) (false ∷ bs₁) (false ∷ bs₂) eq = Eq.cong (false ∷_) (variants-cs-injective n bs₁ bs₂ (List.∷-injectiveʳ eq)) +variants-cs-injective (suc n) (true ∷ bs₁) (true ∷ bs₂) eq = Eq.cong (true ∷_) (variants-cs-injective n bs₁ bs₂ (List.∷-injectiveʳ eq)) + +variants-injective : ∀ n {bs₁} {bs₂} → variants n bs₁ ≡ variants n bs₂ → bs₁ ≡ bs₂ +variants-injective n {bs₁} {bs₂} x = variants-cs-injective n bs₁ bs₂ (proj₂ (Rose-injective x)) + +enumerate-binary : ∀ n → List⁺ (Vec Bool n) +enumerate-binary zero = [] ∷ [] +enumerate-binary (suc n) = List⁺.map (true ∷_) (enumerate-binary n) ⁺++⁺ List⁺.map (false ∷_) (enumerate-binary n) + +length-enumerate-binary : ∀ n → List⁺.length (enumerate-binary n) ≡ 2 ^ n +length-enumerate-binary zero = refl +length-enumerate-binary (suc n) = + List⁺.length (enumerate-binary (suc n)) + ≡⟨⟩ + List⁺.length (List⁺.map (true ∷_) (enumerate-binary n) ⁺++⁺ List⁺.map (false ∷_) (enumerate-binary n)) + ≡⟨ List⁺.length-⁺++⁺ (List⁺.map (true ∷_) (enumerate-binary n)) (List⁺.map (false ∷_) (enumerate-binary n)) ⟩ + List⁺.length (List⁺.map (true ∷_) (enumerate-binary n)) + List⁺.length (List⁺.map (false ∷_) (enumerate-binary n)) + ≡⟨ Eq.cong₂ _+_ (List⁺.length-map (true ∷_) (enumerate-binary n)) (List⁺.length-map (false ∷_) (enumerate-binary n)) ⟩ + List⁺.length (enumerate-binary n) + List⁺.length (enumerate-binary n) + ≡⟨ Eq.cong (λ x → x + x) (length-enumerate-binary n) ⟩ + 2 ^ n + 2 ^ n + ≡⟨ Eq.cong (2 ^ n +_) (ℕ.*-identityˡ (2 ^ n)) ⟨ + 2 * 2 ^ n + ≡⟨⟩ + 2 ^ suc n + ∎ + where + open Eq.≡-Reasoning + +enumerate-binary-unique : ∀ n → Unique (List⁺.toList (enumerate-binary n)) +enumerate-binary-unique zero = [] ∷ [] +enumerate-binary-unique (suc n) = Unique.++⁺ + (Unique.map⁺ Vec.∷-injectiveʳ (enumerate-binary-unique n)) + (Unique.map⁺ Vec.∷-injectiveʳ (enumerate-binary-unique n)) + (λ where (a , b) → true≢false (lemma a) (lemma b)) + where + lemma : ∀ {v : Vec Bool (suc n)} → {b : Bool} → v List.∈ List.map (b ∷_) (List⁺.toList (enumerate-binary n)) → Vec.head v ≡ b + lemma {v = b ∷ vs} p = Vec.∷-injectiveˡ (proj₂ (Any.satisfied (Any.map⁻ p))) + +simple-drop : ∀ {a} {A : Set a} (n : ℕ) {m : ℕ} → Vec A (n + m) → Vec A m +simple-drop zero xs = xs +simple-drop (suc n) (x ∷ xs) = simple-drop n xs + +simple-drop-tail : + ∀ {a} {A : Set a} {n k : ℕ} + → (D : ℕ) (xs : Vec A n) (y : A) (zs : Vec A k) + → (n≡D+m : n ≡ D + suc k) + → (n≡D+m' : n ≡ suc D + k) + → simple-drop D (Vec.cast n≡D+m xs) ≡ y ∷ zs + → simple-drop (suc D) (Vec.cast n≡D+m' xs) ≡ zs +simple-drop-tail zero (x ∷ xs) y zs n≡D+m n≡D+m' h = Vec.∷-injectiveʳ h +simple-drop-tail (suc D) (x ∷ xs) y zs n≡D+m n≡D+m' h = simple-drop-tail D xs y zs (ℕ.suc-injective n≡D+m) (ℕ.suc-injective n≡D+m') h + +cast-is-id : ∀ {a} {A : Set a} {n : ℕ} (v : Vec A n) → Vec.cast refl v ≡ v +cast-is-id [] = refl +cast-is-id (x ∷ xs) = Eq.cong (x ∷_) (cast-is-id xs) + +variants⊆e₁ : ∀ n → variants n ⊆ 2CC.⟦ e₁ n ⟧ +variants⊆e₁ n bs = config n bs , Eq.cong (0 Rose.-<_>-) (go n bs zero refl (cast-is-id bs)) + where + config' : ∀ (n m : ℕ) → Vec Bool n → 2CC.Configuration + config' zero m [] d = false + config' (suc n) m (b ∷ bs) d with f m == d + config' (suc n) m (b ∷ bs) d | yes f-m≡d = b + config' (suc n) m (b ∷ bs) d | no f-m≡d = config' n (suc m) bs d + + config : ∀ n → Vec Bool n → 2CC.Configuration + config n bs d = config' n zero bs d + + config-lemma : + ∀ m b (bs' : Vec Bool m) D + → (n≡D+m : n ≡ D + suc m) + → simple-drop D (Vec.cast n≡D+m bs) ≡ b ∷ bs' + → config' n zero bs (f D) ≡ b + config-lemma m b bs' D n≡D+m x = go n zero bs D D b bs' (Eq.sym (ℕ.+-identityʳ D)) n≡D+m x + where + go : + ∀ n m bs D k {x : ℕ} b' (bs' : Vec Bool x) + → D ≡ k + m + → (n≡k+x : n ≡ k + suc x) + → simple-drop k (Vec.cast n≡k+x bs) ≡ b' ∷ bs' + → config' n m bs (f D) ≡ b' + go zero m [] D k b' bs' D≡k+m n≡k+x h = ⊥-elim (ℕ.n≮0 (ℕ.≤-trans (ℕ.m≤n+m (suc _) k) (ℕ.≤-reflexive (Eq.sym n≡k+x)))) + go (suc n) m (b ∷ bs) D zero b' bs' D≡k+m n≡k+x h rewrite ℕ.suc-injective n≡k+x rewrite D≡k+m with f m == f m + go (suc n) m (b ∷ bs) D zero b' bs' D≡k+m n≡k+x h | yes refl = Vec.∷-injectiveˡ h + go (suc n) m (b ∷ bs) D zero b' bs' D≡k+m n≡k+x h | no f-m≢f-m = ⊥-elim (f-m≢f-m refl) + go (suc n) m (b ∷ bs) D (suc k) b' bs' D≡k+m n≡k+x h with f m == f D + go (suc n) m (b ∷ bs) D (suc k) b' bs' D≡k+m n≡k+x h | yes f-m≡f-D = ⊥-elim (f-injective (ℕ.<⇒≢ (ℕ.≤-<-trans (ℕ.m≤n+m m k) (ℕ.<-≤-trans (ℕ.n<1+n (k + m)) (ℕ.≤-reflexive (Eq.sym D≡k+m))))) f-m≡f-D) + go (suc n) m (b ∷ bs) D (suc k) b' bs' D≡k+m (n≡k+x) h | no f-m≢f-D = go n (suc m) bs D k b' bs' (Eq.trans D≡k+m (Eq.sym (ℕ.+-suc k m))) (ℕ.suc-injective n≡k+x) h + + go : ∀ (m : ℕ) (bs' : Vec Bool m) (D : ℕ) → (n≡D+m : n ≡ D + m) → simple-drop D (Vec.cast n≡D+m bs) ≡ bs' + → variants-cs m bs' ≡ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m D) + go zero [] D n≡D+m y = refl + go (suc m) (true ∷ bs') D n≡D+m y = + variants-cs (suc m) (true ∷ bs') + ≡⟨⟩ + 0 Rose.-< [] >- ∷ variants-cs m bs' + ≡⟨ Eq.cong ((0 Rose.-< [] >-) ∷_) (go m bs' (suc D) (Eq.trans n≡D+m (ℕ.+-suc D m)) (simple-drop-tail D bs true bs' n≡D+m (Eq.trans n≡D+m (ℕ.+-suc D m)) y)) ⟩ + 0 Rose.-< [] >- ∷ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m (suc D)) + ≡⟨⟩ + (if true then 0 Rose.-< [] >- else 1 Rose.-< [] >-) ∷ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m (suc D)) + ≡⟨ Eq.cong (λ x → (if x then 0 Rose.-< [] >- else 1 Rose.-< [] >-) ∷ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m (suc D))) (config-lemma m true bs' D n≡D+m y) ⟨ + (if config n bs (f D) then 0 Rose.-< [] >- else 1 Rose.-< [] >-) ∷ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m (suc D)) + ≡⟨⟩ + 2CC.⟦ f D ⟨ 0 -< [] >- , 1 -< [] >- ⟩ ⟧ (config n bs) ∷ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m (suc D)) + ≡⟨⟩ + List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs (suc m) D) + ∎ + where open Eq.≡-Reasoning + go (suc m) (false ∷ bs') D n≡D+m y = + variants-cs (suc m) (false ∷ bs') + ≡⟨⟩ + 1 Rose.-< [] >- ∷ variants-cs m bs' + ≡⟨ Eq.cong ((1 Rose.-< [] >-) ∷_) (go m bs' (suc D) (Eq.trans n≡D+m (ℕ.+-suc D m)) (simple-drop-tail D bs false bs' n≡D+m (Eq.trans n≡D+m (ℕ.+-suc D m)) y)) ⟩ + 1 Rose.-< [] >- ∷ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m (suc D)) + ≡⟨⟩ + (if false then 0 Rose.-< [] >- else 1 Rose.-< [] >-) ∷ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m (suc D)) + ≡⟨ Eq.cong (λ x → (if x then 0 Rose.-< [] >- else 1 Rose.-< [] >-) ∷ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m (suc D))) (config-lemma m false bs' D n≡D+m y) ⟨ + (if config n bs (f D) then 0 Rose.-< [] >- else 1 Rose.-< [] >-) ∷ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m (suc D)) + ≡⟨⟩ + 2CC.⟦ f D ⟨ 0 -< [] >- , 1 -< [] >- ⟩ ⟧ (config n bs) ∷ List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs m (suc D)) + ≡⟨⟩ + List.map (λ e → 2CC.⟦ e ⟧ (config n bs)) (e₁-cs (suc m) D) + ∎ + where open Eq.≡-Reasoning + +partition-choice-variants : + ∀ (D : F) + → (l r : ADT NAT') + → (vs : List (Rose ∞ NAT')) + → Unique vs + → List.lookup vs ⊆ ADT.⟦ D ⟨ l , r ⟩ ⟧ + → Σ[ vs₁ ∈ List (Rose ∞ NAT') ] + Σ[ vs₂ ∈ List (Rose ∞ NAT') ] + Interleaving vs₁ vs₂ vs + × Unique vs₁ + × Unique vs₂ + × List.lookup vs₁ ⊆ ADT.⟦ l ⟧ + × List.lookup vs₂ ⊆ ADT.⟦ r ⟧ +partition-choice-variants D l r [] unique-vs vs⊆adt = [] , [] , [] , [] , [] , (λ where ()) , (λ where ()) +partition-choice-variants D l r (v ∷ vs) (v∉vs ∷ unique-vs) vs⊆adt + with partition-choice-variants D l r vs unique-vs (vs⊆adt ∘ suc) +... | vs₁ , vs₂ , is-interleaving , unique-vs₁ , unique-vs₂ , vs₁⊆l , vs₂⊆r + with vs⊆adt zero +... | config , v∈adt + with config D +... | true = v ∷ vs₁ , vs₂ , consˡ is-interleaving , List.All-Interleavingₗ is-interleaving v∉vs ∷ unique-vs₁ , unique-vs₂ , (λ where + zero → config , v∈adt + (suc n) → vs₁⊆l n) , vs₂⊆r +... | false = vs₁ , v ∷ vs₂ , consʳ is-interleaving , unique-vs₁ , List.All-Interleavingᵣ is-interleaving v∉vs ∷ unique-vs₂ , vs₁⊆l , (λ where + zero → config , v∈adt + (suc n) → vs₂⊆r n) + +minimal-adt-size : + ∀ (adt : ADT NAT') + → (vs : List (Rose ∞ NAT')) + → Unique vs + → List.lookup vs ⊆ ADT.⟦ adt ⟧ + → List.sum (List.map sizeRose vs) ≤ sizeADT sizeRose adt +minimal-adt-size (leaf v) [] unique-vs vs⊆adt = z≤n +minimal-adt-size (leaf v) (v' ∷ []) unique-vs vs⊆adt with proj₂ (vs⊆adt zero) +minimal-adt-size (leaf v) (v ∷ []) unique-vs vs⊆adt | refl = + begin + List.sum (List.map sizeRose (v ∷ [])) + ≡⟨⟩ + sizeRose v + 0 + ≡⟨ ℕ.+-identityʳ (sizeRose v) ⟩ + sizeRose v + <⟨ ℕ.≤-refl ⟩ + suc (sizeRose v) + ∎ + where + open ℕ.≤-Reasoning +minimal-adt-size (leaf v) (v₁ ∷ v₂ ∷ vs) ((v₁≢v₂ ∷ v₁∉vs) ∷ unique-vs) vs⊆adt = ⊥-elim (v₁≢v₂ (Eq.trans (proj₂ (vs⊆adt zero)) (Eq.sym (proj₂ (vs⊆adt (suc zero)))))) +minimal-adt-size (D ⟨ l , r ⟩) vs unique-vs vs⊆adt with partition-choice-variants D l r vs unique-vs vs⊆adt +minimal-adt-size (D ⟨ l , r ⟩) vs unique-vs vs⊆adt | vs₁ , vs₂ , is-interleaving , unique-vs₁ , unique-vs₂ , vs₁⊆l , vs₂⊆r = + begin + List.sum (List.map sizeRose vs) + ≡⟨ List.sum-Interleaving (List.map-Interleaving is-interleaving) ⟨ + List.sum (List.map sizeRose vs₁) + List.sum (List.map sizeRose vs₂) + ≤⟨ ℕ.+-mono-≤ (minimal-adt-size l vs₁ unique-vs₁ vs₁⊆l) (minimal-adt-size r vs₂ unique-vs₂ vs₂⊆r) ⟩ + sizeADT sizeRose l + sizeADT sizeRose r + <⟨ ℕ.≤-refl ⟩ + suc (sizeADT sizeRose l + sizeADT sizeRose r) + ≡⟨⟩ + sizeADT sizeRose (D ⟨ l , r ⟩) + ∎ + where + open ℕ.≤-Reasoning + +13*n^2<16^n : ∀ n → 13 * (n * n) < 16 ^ n +13*n^2<16^n zero = s≤s z≤n +13*n^2<16^n (suc zero) = ℕ.+-monoʳ-≤ 14 z≤n +13*n^2<16^n (suc (suc n)) = go (suc n) + where + open ℕ.≤-Reasoning + + go : ∀ n → {{ℕ.NonZero n}} → 13 * ((1 + n) * (1 + n)) < 16 ^ (1 + n) + go n = + begin-strict + 13 * ((1 + n) * (1 + n)) + ≤⟨ ℕ.*-monoʳ-≤ 13 ( + begin + (1 + n) * (1 + n) + ≡⟨⟩ + 1 + n + n * (1 + n) + ≡⟨ Eq.cong (λ x → 1 + n + x) (ℕ.*-distribˡ-+ n 1 n) ⟩ + 1 + n + (n * 1 + n * n) + ≡⟨ Eq.cong (λ x → 1 + n + (x + n * n)) (ℕ.*-identityʳ n) ⟩ + 1 + n + (n + n * n) + ≡⟨ Eq.cong (λ x → 1 + x) (ℕ.+-assoc n n (n * n)) ⟨ + 1 + (n + n + n * n) + ≤⟨ ℕ.+-monoˡ-≤ (n + n + n * n) (ℕ.m≤n*m 1 n) ⟩ + (n * 1) + (n + n + n * n) + ≡⟨ Eq.cong (_+ (n + n + n * n)) (ℕ.*-identityʳ n) ⟩ + n + (n + n + n * n) + ≡⟨ ℕ.+-assoc n (n + n) (n * n) ⟨ + n + (n + n) + n * n + ≡⟨ Eq.cong (λ x → n + (n + x) + n * n) (ℕ.+-identityʳ n) ⟨ + n + (n + (n + 0)) + n * n + ≡⟨⟩ + 3 * n + n * n + ≤⟨ ℕ.+-monoˡ-≤ (n * n) (ℕ.*-monoʳ-≤ 3 (ℕ.m≤m*n n n)) ⟩ + 3 * (n * n) + n * n + ≡⟨ ℕ.+-comm (3 * (n * n)) (n * n) ⟩ + n * n + 3 * (n * n) + ≡⟨⟩ + 4 * (n * n) + ∎ + )⟩ + 13 * (4 * (n * n)) + ≤⟨ ℕ.*-monoˡ-≤ (4 * (n * n)) (ℕ.+-monoʳ-≤ 13 (z≤n {3})) ⟩ + 16 * (4 * (n * n)) + ≤⟨ ℕ.*-monoʳ-≤ 16 (ℕ.*-monoˡ-≤ (n * n) (ℕ.+-monoʳ-≤ 4 (z≤n {9}))) ⟩ + 16 * (13 * (n * n)) + <⟨ ℕ.*-monoʳ-< 16 (13*n^2<16^n n) ⟩ + 16 * 16 ^ n + ≡⟨⟩ + 16 ^ (1 + n) + ∎ + +sizeRose-variants-cs : ∀ n bs → List.sum (List.map sizeRose (variants-cs n bs)) ≡ n +sizeRose-variants-cs zero [] = refl +sizeRose-variants-cs (suc n) (b ∷ bs) = Eq.cong suc (sizeRose-variants-cs n bs) + +sizeRose-variants : ∀ n bs → sizeRose (variants n bs) ≡ suc n +sizeRose-variants n bs = Eq.cong suc (sizeRose-variants-cs n bs) + +sizeRose∈variants : + ∀ (n : ℕ) + → (v : Rose ∞ NAT') + → v List.∈ List.map (variants n) (List⁺.toList (enumerate-binary n)) + → suc n ≡ sizeRose v +sizeRose∈variants n v p with (Any.satisfied (Any.map⁻ p)) +sizeRose∈variants n v p | bs , v≡variants-bs = + suc n + ≡⟨ sizeRose-variants n bs ⟨ + sizeRose (variants n bs) + ≡⟨ Eq.cong sizeRose v≡variants-bs ⟨ + sizeRose v + ∎ + where + open Eq.≡-Reasoning + +lookup≡find-or-last : + ∀ {a} {A : Set a} (xs : List⁺ A) (i : Fin (List⁺.length xs)) + → List.lookup (List⁺.toList xs) i + ≡ find-or-last (Fin.toℕ i) xs +lookup≡find-or-last (x ∷ []) zero = refl +lookup≡find-or-last (x₁ ∷ x₂ ∷ xs) zero = refl +lookup≡find-or-last (x₁ ∷ x₂ ∷ xs) (suc i) = lookup≡find-or-last (x₂ ∷ xs) i + +lookup-enumerate-binary⊆ : + ∀ {i} {I : Set i} {a} {A : Set a} {n : ℕ} {M : Vec Bool n → A} {N : I → A} + → M ⊆ N + → List.lookup (List.map M (List⁺.toList (enumerate-binary n))) ⊆ N +lookup-enumerate-binary⊆ {n = zero} M⊆N zero = M⊆N [] +lookup-enumerate-binary⊆ {I = I} {A = A} {n = suc n} {M = M} {N} M⊆N i with Fin.toℕ i -nonZero (ℕ.m^n>0 2 m)}} (ℕ.*-monoʳ-< n (ℕ.≤-refl {3})) ⟩ + n * 3 * 2 ^ m + ≡⟨ Eq.cong (_* 2 ^ m) (ℕ.*-comm n 3) ⟩ + 3 * n * 2 ^ m + ≡⟨⟩ + m * 2 ^ m + ≤⟨ ℕ.*-monoˡ-≤ (2 ^ m) (ℕ.n≤1+n m) ⟩ + suc m * 2 ^ m + ≡⟨ Eq.cong (suc m *_) (length-enumerate-binary m) ⟨ + suc m * List⁺.length (enumerate-binary m) + ≡⟨ Eq.cong (suc m *_) ((List⁺.length-map (variants m)) (enumerate-binary m)) ⟨ + suc m * List⁺.length (List⁺.map (variants m) (enumerate-binary m)) + ≡⟨ List.sum-map-const (suc m) (List.map (variants m) (List⁺.toList (enumerate-binary m))) ⟨ + List.sum (List.map (const (suc m)) (List.map (variants m) (List⁺.toList (enumerate-binary m)))) + ≡⟨ Eq.cong List.sum (List.map-cong-with∈ (List.map (variants m) (List⁺.toList (enumerate-binary m))) (sizeRose∈variants m)) ⟩ + List.sum (List.map sizeRose (List.map (variants m) (List⁺.toList (enumerate-binary m)))) + ≤⟨ minimal-adt-size e₂ (List.map (variants m) (List⁺.toList (enumerate-binary m))) (Unique.map⁺ (variants-injective m) (enumerate-binary-unique m)) (⊆-trans (lookup-enumerate-binary⊆ (variants⊆e₁ m)) e₁⊆e₂) ⟩ + sizeADT sizeRose e₂ + ∎ + where + open ℕ.≤-Reasoning + n = suc k + m = 3 * n + +ADT≰2CC : SizedADT F (Rose ∞) sizeRose ≰ₛ[ (λ n → 2 ^ (n / 3)) ] Sized2CC F +ADT≰2CC n = NAT' , e₁ (3 * n) , ADT≽2CC (e₁ (3 * n)) , lemma n + +2^n≥n : ∀ n → n ≤ 15 * 2 ^ (n / 3) +2^n≥n n with n ≤? 15 +2^n≥n n | yes n≤15 = + begin + n + ≤⟨ n≤15 ⟩ + 15 + ≤⟨ ℕ.m≤m*n 15 (2 ^ (n / 3)) {{ℕ.>-nonZero (ℕ.m^n>0 2 (n / 3))}} ⟩ + 15 * 2 ^ (n / 3) + ∎ + where + open ℕ.≤-Reasoning +2^n≥n n | no n≰15 = + begin + n + ≤⟨ All.wfRec <-wellFounded _ (λ n → 16 ≤ n → n ≤ 2 ^ (n / 3)) go n (ℕ.≰⇒> n≰15) ⟩ + 2 ^ (n / 3) + ≤⟨ ℕ.m≤n*m (2 ^ (n / 3)) 15 ⟩ + 15 * 2 ^ (n / 3) + ∎ + where + open ℕ.≤-Reasoning + + lemma' : ∀ n → 16 ≤ n → 2 ^ 5 * 2 ^ ((n ∸ 15) / 3) ≤ 2 ^ (n / 3) + lemma' n 16≤n = + begin + 2 ^ 5 * 2 ^ ((n ∸ 15) / 3) + ≡⟨ ℕ.^-distribˡ-+-* 2 5 ((n ∸ 15) / 3) ⟨ + 2 ^ (5 + (n ∸ 15) / 3) + ≡⟨ Eq.cong (2 ^_) (ℕ.+-distrib-/ 15 (n ∸ 15) (ℕ.m%n0 2 ((n ∸ 15) / 3)) ⟩ + 2 ^ 5 * 2 ^ ((n ∸ 15) / 3) + ≤⟨ lemma' n 16≤n ⟩ + 2 ^ (n / 3) + ∎ + where + open ℕ.≤-Reasoning + go n rec 16≤n | no n≰30 = + begin + n + ≤⟨ ℕ.m≤n+m n 16 ⟩ + 16 + n + ≡⟨⟩ + 32 + n ∸ 16 + ≡⟨ ℕ.+-∸-assoc 32 16≤n ⟩ + 32 + (n ∸ 16) + ≤⟨ ℕ.+-monoʳ-≤ 32 (ℕ.m≤n*m (n ∸ 16) 32) ⟩ + 32 + 32 * (n ∸ 16) + ≡⟨ ℕ.*-suc 32 (n ∸ 16) ⟨ + 32 * suc (n ∸ 16) + ≡⟨ Eq.cong (32 *_) {n ∸ 15} {suc (n ∸ 16)} (ℕ.+-∸-assoc 1 16≤n) ⟨ + 32 * (n ∸ 15) + ≡⟨⟩ + 2 ^ 5 * (n ∸ 15) + ≤⟨ ℕ.*-monoʳ-≤ (2 ^ 5) (rec {n ∸ 15} ( + begin-strict + n ∸ 15 + <⟨ ℕ.∸-monoʳ-< {n} {15} {0} (s≤s (z≤n {14})) (ℕ.≤-trans (ℕ.n≤1+n 15) 16≤n) ⟩ + n + ∎) (ℕ.∸-monoˡ-≤ 15 (ℕ.≰⇒> n≰30))) + ⟩ + 2 ^ 5 * 2 ^ ((n ∸ 15) / 3) + ≤⟨ lemma' n 16≤n ⟩ + 2 ^ (n / 3) + ∎ + where + open ℕ.≤-Reasoning + +id∈𝒪[exponential] : id ∈ 𝒪[ (λ n → 2 ^ (n / 3)) ] +id∈𝒪[exponential] .proj₁ = 15 +id∈𝒪[exponential] .proj₂ n = 2^n≥n n + +2CC-) = + begin + size2CC (rename f (a 2CC.2CC.-< cs >-)) + ≡⟨⟩ + size2CC (a 2CC.2CC.-< List.map (rename f) cs >-) + ≡⟨⟩ + suc (atomSize A a + List.sum (List.map size2CC (List.map (rename f) cs))) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + List.sum x)) (List.map-∘ cs) ⟨ + suc (atomSize A a + List.sum (List.map (size2CC ∘ rename f) cs)) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + List.sum x)) (List.map-cong rename-preserves-size2CC cs) ⟩ + suc (atomSize A a + List.sum (List.map size2CC cs)) + ≡⟨⟩ + size2CC (a 2CC.2CC.-< cs >-) + ∎ + where + open Eq.≡-Reasoning + rename-preserves-size2CC (D 2CC.2CC.⟨ l , r ⟩) = + begin + size2CC (rename f (D 2CC.2CC.⟨ l , r ⟩)) + ≡⟨⟩ + suc (size2CC (rename f l) + size2CC (rename f r)) + ≡⟨ Eq.cong suc (Eq.cong₂ _+_ (rename-preserves-size2CC l) (rename-preserves-size2CC r)) ⟩ + suc (size2CC l + size2CC r) + ≡⟨⟩ + size2CC (D 2CC.2CC.⟨ l , r ⟩) + ∎ + where + open Eq.≡-Reasoning + + 2CC≤2CC : Sized2CC F₁ ≤ₛ Sized2CC F₂ + 2CC≤2CC = 1 , λ A e e-translatable → + rename f e + , ≅[]→≅ (rename-preserves f f⁻¹ f⁻¹∘f≗id e) + , ℕ.≤-reflexive (Eq.trans (rename-preserves-size2CC e) (Eq.sym (ℕ.+-identityʳ (size2CC e)))) + +2CC=2CC : ∀ {F₁ F₂ : 𝔽} + → (f : F₂ → F₁) + → (f⁻¹ : F₁ → F₂) + → f⁻¹ ∘ f ≗ id + → f ∘ f⁻¹ ≗ id + → Sized2CC F₁ =ₛ Sized2CC F₂ +2CC=2CC f f⁻¹ f⁻¹∘f≗id f∘f⁻¹≗id = 2CC≤2CC f f⁻¹ f⁻¹∘f≗id , 2CC≤2CC f⁻¹ f f∘f⁻¹≗id + +2CC→NCC-preserves-size : ∀ {i : Size} {A : 𝔸} {F : 𝔽} + → (e : 2CC.2CC F i A) + → sizeNCC (sucs zero) (2CC→NCC e) ≡ size2CC e +2CC→NCC-preserves-size {A = A} {F = F} (a 2CC.2CC.-< cs >-) = + begin + sizeNCC (sucs zero) (2CC→NCC (a 2CC.2CC.-< cs >-)) + ≡⟨⟩ + sizeNCC (sucs zero) (a NCC.NCC.-< List.map 2CC→NCC cs >-) + ≡⟨⟩ + suc (atomSize A a + List.sum (List.map (sizeNCC (sucs zero)) (List.map 2CC→NCC cs))) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + List.sum x)) (List.map-∘ cs) ⟨ + suc (atomSize A a + List.sum (List.map (sizeNCC (sucs zero) ∘ 2CC→NCC) cs)) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + List.sum x)) (List.map-cong 2CC→NCC-preserves-size cs) ⟩ + suc (atomSize A a + List.sum (List.map size2CC cs)) + ≡⟨⟩ + size2CC (a 2CC.2CC.-< cs >-) + ∎ + where + open Eq.≡-Reasoning +2CC→NCC-preserves-size {F = F} (D 2CC.2CC.⟨ l , r ⟩) = + begin + sizeNCC (sucs zero) (2CC→NCC (D 2CC.2CC.⟨ l , r ⟩)) + ≡⟨⟩ + sizeNCC (sucs zero) (D NCC.NCC.⟨ 2CC→NCC l ∷ 2CC→NCC r ∷ [] ⟩) + ≡⟨⟩ + suc (Vec.sum (Vec.map (sizeNCC (sucs zero)) (2CC→NCC l ∷ 2CC→NCC r ∷ []))) + ≡⟨⟩ + suc (sizeNCC (sucs zero) (2CC→NCC l) + (sizeNCC (sucs zero) (2CC→NCC r) + 0)) + ≡⟨ Eq.cong (λ x → suc (sizeNCC (sucs zero) (2CC→NCC l) + x)) (ℕ.+-identityʳ (sizeNCC (sucs zero) (2CC→NCC r))) ⟩ + suc (sizeNCC (sucs zero) (2CC→NCC l) + sizeNCC (sucs zero) (2CC→NCC r)) + ≡⟨ Eq.cong suc (Eq.cong₂ _+_ (2CC→NCC-preserves-size l) (2CC→NCC-preserves-size r)) ⟩ + suc (size2CC l + size2CC r) + ≡⟨⟩ + size2CC (D 2CC.2CC.⟨ l , r ⟩) + ∎ + where + open Eq.≡-Reasoning + +NCC→2CC-preserves-size : ∀ {i : Size} {A : 𝔸} {F : 𝔽} + → (e : NCC.NCC F (sucs zero) i A) + → size2CC (NCC→2CC e) ≡ sizeNCC (sucs zero) e +NCC→2CC-preserves-size {A = A} {F = F} (a NCC.NCC.-< cs >-) = + begin + size2CC (NCC→2CC (a NCC.NCC.-< cs >-)) + ≡⟨⟩ + size2CC (a 2CC.2CC.-< List.map NCC→2CC cs >-) + ≡⟨⟩ + suc (atomSize A a + List.sum (List.map size2CC (List.map NCC→2CC cs))) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + List.sum x)) (List.map-∘ cs) ⟨ + suc (atomSize A a + List.sum (List.map (size2CC ∘ NCC→2CC) cs)) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + List.sum x)) (List.map-cong NCC→2CC-preserves-size cs) ⟩ + suc (atomSize A a + List.sum (List.map (sizeNCC (sucs zero)) cs)) + ≡⟨⟩ + sizeNCC (sucs zero) (a NCC.NCC.-< cs >-) + ∎ + where + open Eq.≡-Reasoning +NCC→2CC-preserves-size {F = F} (D NCC.NCC.⟨ c₁ ∷ c₂ ∷ [] ⟩) = + begin + size2CC (NCC→2CC (D NCC.NCC.⟨ c₁ ∷ c₂ ∷ [] ⟩)) + ≡⟨⟩ + size2CC (D 2CC.2CC.⟨ NCC→2CC c₁ , NCC→2CC c₂ ⟩) + ≡⟨⟩ + suc (size2CC (NCC→2CC c₁) + size2CC (NCC→2CC c₂)) + ≡⟨ Eq.cong suc (Eq.cong₂ _+_ (NCC→2CC-preserves-size c₁) (NCC→2CC-preserves-size c₂)) ⟩ + suc (sizeNCC (sucs zero) c₁ + sizeNCC (sucs zero) c₂) + ≡⟨ Eq.cong (λ x → suc (sizeNCC (sucs zero) c₁) + x) (ℕ.+-identityʳ (sizeNCC (sucs zero) c₂)) ⟨ + suc (sizeNCC (sucs zero) c₁ + (sizeNCC (sucs zero) c₂ + 0)) + ≡⟨⟩ + suc (Vec.sum (Vec.map (sizeNCC (sucs zero)) (c₁ ∷ c₂ ∷ []))) + ≡⟨⟩ + sizeNCC (sucs zero) (D NCC.NCC.⟨ c₁ ∷ c₂ ∷ [] ⟩) + ∎ + where + open Eq.≡-Reasoning + +NCC=2CC : ∀ {F : 𝔽} + → SizedNCC F (sucs zero) =ₛ Sized2CC F +NCC=2CC {F} = + (1 , λ A e e-translatable → 2CC→NCC e , ≅[]→≅ (2CC→NCC-preserves e) , ℕ.≤-reflexive (Eq.trans (2CC→NCC-preserves-size e) (Eq.sym (ℕ.+-identityʳ (size2CC e))))) + , (1 , λ A e e-translatable → NCC→2CC e , ≅[]→≅ (NCC→2CC-preserves e) , ℕ.≤-reflexive (Eq.trans (NCC→2CC-preserves-size e) (Eq.sym (ℕ.+-identityʳ (sizeNCC (sucs zero) e))))) diff --git a/src/Vatras/Succinctness/Relations/2CC=CCC.agda b/src/Vatras/Succinctness/Relations/2CC=CCC.agda new file mode 100644 index 00000000..5d9fb26c --- /dev/null +++ b/src/Vatras/Succinctness/Relations/2CC=CCC.agda @@ -0,0 +1,32 @@ +open import Vatras.Framework.Definitions using (𝔽; 𝔸) +module Vatras.Succinctness.Relations.2CC=CCC (F : 𝔽) where + +open import Data.Nat using (ℕ; zero) +open import Data.Product using (_×_; _,_; proj₁) +open import Function using (_∘_; id) +open import Relation.Binary.PropositionalEquality using (_≗_) +open import Size using (∞) + +open import Vatras.Util.Nat.AtLeast using (sucs) +open import Vatras.Framework.Variants using (Rose) +open import Vatras.Lang.All.Fixed F (Rose ∞) +open import Vatras.Succinctness.ProofDefinition (Rose ∞) using (_=ₛ_; ≤ₛ-transitive) +open import Vatras.Succinctness.Sizes using (Sized2CC; SizedCCC) +open import Vatras.Succinctness.Relations.2CC=2CC using (2CC=2CC; NCC=2CC) +open import Vatras.Succinctness.Relations.2CC≤CCC F using (2CC≤CCC) +open import Vatras.Succinctness.Relations.CCC≤NCC F using (CCC≤NCC) + +open import Vatras.Translation.Lang.Transitive.CCC-to-2CC using (2CC≽CCC) +open import Vatras.Translation.Lang.2CC.Rename using (2CC-rename≽2CC) +open import Vatras.Translation.Lang.NCC-to-CCC using (CCC≽NCC) +open import Vatras.Translation.Lang.2CC-to-NCC using (NCC≽2CC) + +2CC=CCC : + ∀ (f : F × ℕ → F) + → (f⁻¹ : F → F × ℕ) + → f⁻¹ ∘ f ≗ id + → f ∘ f⁻¹ ≗ id + → Sized2CC F =ₛ SizedCCC F +2CC=CCC f f⁻¹ f⁻¹∘f≗id f∘f⁻¹≗id = + ≤ₛ-transitive (2CC-rename≽2CC f f⁻¹ f⁻¹∘f≗id) 2CC≽CCC (proj₁ (2CC=2CC f f⁻¹ f⁻¹∘f≗id f∘f⁻¹≗id)) 2CC≤CCC + , ≤ₛ-transitive (CCC≽NCC (sucs zero)) (NCC≽2CC (sucs zero)) (CCC≤NCC (sucs zero)) (proj₁ NCC=2CC) diff --git "a/src/Vatras/Succinctness/Relations/2CC\342\211\244ADT.agda" "b/src/Vatras/Succinctness/Relations/2CC\342\211\244ADT.agda" new file mode 100644 index 00000000..d6fd39d7 --- /dev/null +++ "b/src/Vatras/Succinctness/Relations/2CC\342\211\244ADT.agda" @@ -0,0 +1,63 @@ +open import Vatras.Framework.Definitions using (𝔽; 𝔸; atoms; atomSize) +module Vatras.Succinctness.Relations.2CC≤ADT (F : 𝔽) where + +open import Data.Nat using (suc; _≤_; s≤s; _+_) +import Data.Nat.Properties as ℕ +import Data.List as List +import Data.List.Properties as List +open import Data.Product using (_,_) +open import Function using (_∘_) +import Relation.Binary.PropositionalEquality as Eq +open import Size using (Size; ∞) + +open import Vatras.Data.EqIndexedSet using (≅-sym; ≅[]→≅) +open import Vatras.Framework.Variants using (Rose) +import Vatras.Util.List as List +open import Vatras.Lang.All.Fixed F (Rose ∞) +open import Vatras.Translation.Lang.2CC.Rename using (2CC-rename) +open import Vatras.Framework.Compiler using (LanguageCompiler) +open import Vatras.Translation.LanguageMap using (ADT→2CC) +open import Vatras.Succinctness.ProofDefinition (Rose ∞) using (_≤ₛ_) +open import Vatras.Succinctness.Sizes using (sizeRose; Sized2CC; size2CC; SizedADT; sizeADT) +open import Vatras.Lang.2CC.Encode using (encode; encoder) + +ADT→2CC' : LanguageCompiler ADT.ADTL 2CC.2CCL +ADT→2CC' = ADT→2CC encoder + +lemma2 : ∀ {i : Size} {A : 𝔸} (v : Rose i A) → size2CC (encode v) ≤ sizeRose v +lemma2 {A = A} (a Rose.-< cs >-) = + begin + size2CC (encode (a Rose.-< cs >-)) + ≡⟨⟩ + size2CC (a 2CC.2CC.-< List.map encode cs >-) + ≡⟨⟩ + suc (atomSize A a + List.sum (List.map size2CC (List.map encode cs))) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + List.sum x)) (List.map-∘ cs) ⟨ + suc (atomSize A a + List.sum (List.map (size2CC ∘ encode) cs)) + ≤⟨ s≤s (ℕ.+-monoʳ-≤ (atomSize A a) (List.sum-map-≤ (size2CC ∘ encode) sizeRose cs lemma2)) ⟩ + suc (atomSize A a + List.sum (List.map sizeRose cs)) + ≡⟨⟩ + sizeRose (a Rose.-< cs >-) + ∎ + where + open ℕ.≤-Reasoning + +lemma : ∀ {A : 𝔸} → (adt : ADT.ADT A) → size2CC (LanguageCompiler.compile ADT→2CC' adt) ≤ sizeADT sizeRose adt +lemma (ADT.ADT.leaf v) = ℕ.m≤n⇒m≤1+n (lemma2 v) +lemma (D ADT.ADT.⟨ l , r ⟩) = + begin + size2CC (LanguageCompiler.compile ADT→2CC' (D ADT.ADT.⟨ l , r ⟩)) + ≡⟨⟩ + size2CC (D 2CC.2CC.⟨ LanguageCompiler.compile ADT→2CC' l , LanguageCompiler.compile ADT→2CC' r ⟩) + ≡⟨⟩ + suc (size2CC (LanguageCompiler.compile ADT→2CC' l) + size2CC (LanguageCompiler.compile ADT→2CC' r)) + ≤⟨ s≤s (ℕ.+-monoˡ-≤ (size2CC (LanguageCompiler.compile ADT→2CC' r)) (lemma l)) ⟩ + suc (sizeADT sizeRose l + size2CC (LanguageCompiler.compile ADT→2CC' r)) + ≤⟨ s≤s (ℕ.+-monoʳ-≤ (sizeADT sizeRose l) (lemma r)) ⟩ + suc (sizeADT sizeRose l + sizeADT sizeRose r) + ∎ + where + open ℕ.≤-Reasoning + +2CC≤ADT : Sized2CC F ≤ₛ SizedADT F (Rose ∞) sizeRose +2CC≤ADT = 1 , λ A adt adt-translatable → LanguageCompiler.compile ADT→2CC' adt , ≅-sym (≅[]→≅ (LanguageCompiler.preserves ADT→2CC' adt)) , Eq.subst (size2CC (LanguageCompiler.compile ADT→2CC' adt )≤_) (Eq.sym (ℕ.+-identityʳ (sizeADT sizeRose adt))) (lemma adt) diff --git "a/src/Vatras/Succinctness/Relations/2CC\342\211\244CCC.agda" "b/src/Vatras/Succinctness/Relations/2CC\342\211\244CCC.agda" new file mode 100644 index 00000000..4fc63a17 --- /dev/null +++ "b/src/Vatras/Succinctness/Relations/2CC\342\211\244CCC.agda" @@ -0,0 +1,462 @@ +open import Vatras.Framework.Definitions using (𝔽; 𝔸; atoms; atomSize) +open import Vatras.Util.Nat.AtLeast as ℕ≥ using (ℕ≥; sucs) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; _≢_) +open import Data.Nat as ℕ using (ℕ; zero; suc; pred; _≤_; z≤n; s≤s; _<_; _>_; _+_; _∸_; _*_; _0) + +>⇒¬≤ᵇ : ∀ {m n : ℕ} → m > n → Bool.T (Bool.not (m ≤ᵇ n)) +>⇒¬≤ᵇ (s≤s z≤n) = tt +>⇒¬≤ᵇ (s≤s (s≤s m>n)) = >⇒¬≤ᵇ (s≤s m>n) + +conf : CCC.Configuration F → 2CC.Configuration (F × ℕ) +conf config (f , n) = config f ≤ᵇ n + +fnoc-rec : ℕ → ℕ → 2CC.Configuration (F × ℕ) → CCC.Configuration F +fnoc-rec zero n config f = n +fnoc-rec (suc limit) n config f with config (f , n) +fnoc-rec (suc limit) n config f | true = n +fnoc-rec (suc limit) n config f | false = fnoc-rec limit (suc n) config f + +fnoc : ℕ → 2CC.Configuration (F × ℕ) → CCC.Configuration F +fnoc limit config f = fnoc-rec limit zero config f + +fnoc-rec-false : + ∀ (config : 2CC.Configuration (F × ℕ)) (D : F) + → (limit n k : ℕ) + → k < fnoc-rec limit n config D + → (∀ (k' : ℕ) → k' < n → config (D , k') ≡ false) + → config (D , k) ≡ false +fnoc-rec-false config D zero n k k-) = List.max (List.map max-dimension cs) +max-dimension (D CCC.CCC.⟨ cs ⟩) = List⁺.length cs ⊔ List.max (List.map max-dimension (List⁺.toList cs)) + +choice-list : ∀ {A : 𝔸} → F → ℕ → 2CC.2CC (F × ℕ) ∞ A → List (2CC.2CC (F × ℕ) ∞ A) → 2CC.2CC (F × ℕ) ∞ A +choice-list D n c₁ [] = c₁ +choice-list D n c₁ (c₂ ∷ []) = (D , n) 2CC.2CC.⟨ c₁ , c₂ ⟩ +choice-list D n c₁ (c₂ ∷ c₃ ∷ cs) = (D , n) 2CC.2CC.⟨ c₁ , choice-list D (suc n) c₂ (c₃ ∷ cs) ⟩ + +choice-list-size : + ∀ {A : 𝔸} (D : F) (n : ℕ) + → (c : 2CC.2CC (F × ℕ) ∞ A) + → (cs : List (2CC.2CC (F × ℕ) ∞ A)) + → size2CC (choice-list D n c cs) ≡ List.length cs + List.sum (List.map size2CC (c ∷ cs)) +choice-list-size D n c₁ [] = Eq.sym (ℕ.+-identityʳ (size2CC c₁)) +choice-list-size D n c₁ (c₂ ∷ []) = + begin + size2CC (choice-list D n c₁ (c₂ ∷ [])) + ≡⟨⟩ + size2CC ((D , n) 2CC.2CC.⟨ c₁ , c₂ ⟩) + ≡⟨⟩ + suc (size2CC c₁ + size2CC c₂) + ≡⟨ Eq.cong (λ x → suc (size2CC c₁ + x)) (ℕ.+-identityʳ (size2CC c₂)) ⟨ + suc (size2CC c₁ + (size2CC c₂ + 0)) + ≡⟨⟩ + List.length (c₂ ∷ []) + List.sum (List.map size2CC (c₁ ∷ c₂ ∷ [])) + ∎ + where + open Eq.≡-Reasoning +choice-list-size D n c₁ (c₂ ∷ c₃ ∷ cs) = + begin + size2CC (choice-list D n c₁ (c₂ ∷ c₃ ∷ cs)) + ≡⟨⟩ + size2CC ((D , n) 2CC.2CC.⟨ c₁ , choice-list D (suc n) c₂ (c₃ ∷ cs) ⟩) + ≡⟨⟩ + suc (size2CC c₁ + size2CC (choice-list D (suc n) c₂ (c₃ ∷ cs))) + ≡⟨ Eq.cong (λ x → suc (size2CC c₁ + x)) (choice-list-size D (suc n) c₂ (c₃ ∷ cs)) ⟩ + suc (size2CC c₁ + (List.length (c₃ ∷ cs) + List.sum (List.map (size2CC) (c₂ ∷ c₃ ∷ cs)))) + ≡⟨ Eq.cong suc (ℕ.+-assoc (size2CC c₁) (List.length (c₃ ∷ cs)) (List.sum (List.map size2CC (c₂ ∷ c₃ ∷ cs)))) ⟨ + suc (size2CC c₁ + List.length (c₃ ∷ cs) + List.sum (List.map size2CC (c₂ ∷ c₃ ∷ cs))) + ≡⟨ Eq.cong (λ x → suc (x + List.sum (List.map size2CC (c₂ ∷ c₃ ∷ cs)))) (ℕ.+-comm (size2CC c₁) (List.length (c₃ ∷ cs))) ⟩ + suc (List.length (c₃ ∷ cs) + size2CC c₁ + List.sum (List.map size2CC (c₂ ∷ c₃ ∷ cs))) + ≡⟨ Eq.cong suc (ℕ.+-assoc (List.length (c₃ ∷ cs)) (size2CC c₁) (List.sum (List.map size2CC (c₂ ∷ c₃ ∷ cs)))) ⟩ + suc (List.length (c₃ ∷ cs) + (size2CC c₁ + List.sum (List.map size2CC (c₂ ∷ c₃ ∷ cs)))) + ≡⟨⟩ + List.length (c₂ ∷ c₃ ∷ cs) + List.sum (List.map size2CC (c₁ ∷ c₂ ∷ c₃ ∷ cs)) + ∎ + where + open Eq.≡-Reasoning + +translate : ∀ {i : Size} {A : 𝔸} + → CCC.CCC F i A + → 2CC.2CC (F × ℕ) ∞ A +translate (a CCC.CCC.-< cs >-) = a 2CC.2CC.-< List.map translate cs >- +translate (D CCC.CCC.⟨ c ∷ cs ⟩) = choice-list D zero (translate c) (List.map translate cs) + +translate-size : ∀ {i : Size} {A : 𝔸} + → (ccc : CCC.CCC F i A) + → size2CC (translate ccc) < 2 * sizeCCC ccc +translate-size {A = A} (a CCC.CCC.-< cs >-) = + begin-strict + size2CC (translate (a CCC.CCC.-< cs >-)) + ≡⟨⟩ + size2CC (a 2CC.2CC.-< List.map translate cs >-) + ≡⟨⟩ + suc (atomSize A a + List.sum (List.map size2CC (List.map translate cs))) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + List.sum x)) (List.map-∘ cs) ⟨ + suc (atomSize A a + List.sum (List.map (size2CC ∘ translate) cs)) + ≤⟨ s≤s (ℕ.+-monoʳ-≤ (atomSize A a) (List.sum-map-≤ (size2CC ∘ translate) (λ c → 2 * sizeCCC c) cs (ℕ.<⇒≤ ∘ translate-size))) ⟩ + suc (atomSize A a + List.sum (List.map (λ c → 2 * sizeCCC c) cs)) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + List.sum x)) (List.map-∘ cs) ⟩ + suc (atomSize A a + List.sum (List.map (2 *_) (List.map sizeCCC cs))) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + x)) (List.sum-* 2 (List.map sizeCCC cs)) ⟩ + suc (atomSize A a + 2 * List.sum (List.map sizeCCC cs)) + ≤⟨ s≤s (ℕ.+-monoˡ-≤ (2 * List.sum (List.map sizeCCC cs)) (ℕ.m≤m+n (atomSize A a) (1 * atomSize A a))) ⟩ + suc (atomSize A a + 1 * atomSize A a + 2 * List.sum (List.map sizeCCC cs)) + ≡⟨⟩ + suc (2 * atomSize A a + 2 * List.sum (List.map sizeCCC cs)) + ≡⟨ Eq.cong suc (ℕ.*-distribˡ-+ 2 (atomSize A a) (List.sum (List.map sizeCCC cs))) ⟨ + 1 + 2 * (atomSize A a + List.sum (List.map sizeCCC cs)) + <⟨ ℕ.+-monoˡ-< (2 * (atomSize A a + List.sum (List.map sizeCCC cs))) {x = 1} {y = 2} (ℕ.n<1+n 1) ⟩ + 2 + 2 * (atomSize A a + List.sum (List.map sizeCCC cs)) + ≡⟨ ℕ.*-suc 2 (atomSize A a + List.sum (List.map sizeCCC cs)) ⟨ + 2 * (suc (atomSize A a + List.sum (List.map sizeCCC cs))) + ≡⟨⟩ + 2 * sizeCCC (a CCC.CCC.-< cs >-) + ∎ + where + open ℕ.≤-Reasoning +translate-size (D CCC.CCC.⟨ c ∷ cs ⟩) = + begin-strict + size2CC (translate (D CCC.CCC.⟨ c ∷ cs ⟩)) + ≡⟨⟩ + size2CC (choice-list D zero (translate c) (List.map translate cs)) + ≡⟨ choice-list-size D zero (translate c) (List.map translate cs) ⟩ + List.length (List.map translate cs) + List.sum (List.map size2CC (List.map translate (c ∷ cs))) + ≡⟨ Eq.cong (λ x → List.length (List.map translate cs) + List.sum x) (List.map-∘ (c ∷ cs)) ⟨ + List.length (List.map translate cs) + List.sum (List.map (size2CC ∘ translate) (c ∷ cs)) + ≤⟨ ℕ.+-monoʳ-≤ (List.length (List.map translate cs)) (List.sum-map-< (size2CC ∘ translate) (λ c → 2 * sizeCCC c) (c ∷ cs) translate-size) ⟩ + List.length (List.map translate cs) + (List.sum (List.map (λ c → 2 * sizeCCC c) (c ∷ cs)) ∸ List.length (c ∷ cs)) + ≡⟨ Eq.cong (λ x → List.length (List.map translate cs) + (List.sum x ∸ List.length (c ∷ cs))) (List.map-∘ {g = 2 *_} {f = sizeCCC} (c ∷ cs)) ⟩ + List.length (List.map translate cs) + (List.sum (List.map (2 *_) (List.map sizeCCC (c ∷ cs))) ∸ List.length (c ∷ cs)) + ≡⟨ Eq.cong (λ x → List.length (List.map translate cs) + (x ∸ List.length (c ∷ cs))) (List.sum-* 2 (List.map sizeCCC (c ∷ cs))) ⟩ + List.length (List.map translate cs) + (2 * List.sum (List.map sizeCCC (c ∷ cs)) ∸ List.length (c ∷ cs)) + ≡⟨ Eq.cong (_+ (2 * List.sum (List.map sizeCCC (c ∷ cs)) ∸ List.length (c ∷ cs))) (List.length-map translate cs) ⟩ + List.length cs + (2 * List.sum (List.map sizeCCC (c ∷ cs)) ∸ List.length (c ∷ cs)) + ≡⟨ ℕ.+-∸-assoc (List.length cs) ( + begin + List.length (c ∷ cs) + ≡⟨ ℕ.*-identityʳ (List.length (c ∷ cs)) ⟨ + List.length (c ∷ cs) * 1 + ≡⟨ List.sum-replicate (List.length (c ∷ cs)) 1 ⟨ + List.sum (List.replicate (List.length (c ∷ cs)) 1) + ≡⟨ Eq.cong List.sum (List.map-const 1 (c ∷ cs)) ⟨ + List.sum (List.map (const 1) (c ∷ cs)) + ≤⟨ List.sum-map-≤ (const 1) sizeCCC (c ∷ cs) sizeCCC>0 ⟩ + List.sum (List.map sizeCCC (c ∷ cs)) + ≤⟨ ℕ.m≤n*m (List.sum (List.map sizeCCC (c ∷ cs))) 2 ⟩ + 2 * List.sum (List.map sizeCCC (c ∷ cs)) + ∎) + ⟨ + (List.length cs + 2 * List.sum (List.map sizeCCC (c ∷ cs))) ∸ List.length (c ∷ cs) + ≤⟨ ℕ.∸-monoʳ-≤ (List.length cs + 2 * List.sum (List.map sizeCCC (c ∷ cs))) (ℕ.n≤1+n (List.length cs)) ⟩ + (List.length cs + 2 * List.sum (List.map sizeCCC (c ∷ cs))) ∸ List.length cs + ≡⟨ ℕ.m+n∸m≡n (List.length cs) (2 * List.sum (List.map sizeCCC (c ∷ cs))) ⟩ + 2 * List.sum (List.map sizeCCC (c ∷ cs)) + <⟨ ℕ.*-monoʳ-< 2 (ℕ.n<1+n (List.sum (List.map sizeCCC (c ∷ cs)))) ⟩ + 2 * suc (List.sum (List.map sizeCCC (c ∷ cs))) + ≡⟨⟩ + 2 * sizeCCC (D CCC.CCC.⟨ c ∷ cs ⟩) + ∎ + where + open ℕ.≤-Reasoning + +translate-preserves-⊆ : ∀ {i : Size} {A : 𝔸} + → (e : CCC.CCC F i A) + → (limit : ℕ) + → max-dimension e ≤ limit + → 2CC.⟦ translate e ⟧ ⊆[ fnoc limit ] CCC.⟦ e ⟧ +translate-preserves-⊆ e@(a CCC.CCC.-< cs >-) limit max-dim≤limit config = + begin + 2CC.⟦ translate (a CCC.CCC.-< cs >-) ⟧ config + ≡⟨⟩ + 2CC.⟦ a 2CC.2CC.-< List.map translate cs >- ⟧ config + ≡⟨⟩ + a Rose.-< List.map (λ c → 2CC.⟦ c ⟧ config) (List.map translate cs) >- + ≡⟨ Eq.cong (a Rose.-<_>-) (List.map-∘ cs) ⟨ + a Rose.-< List.map (λ c → 2CC.⟦ translate c ⟧ config) cs >- + ≡⟨ Eq.cong (a Rose.-<_>-) (List.map-cong-with∈ cs (λ c' c'∈cs → translate-preserves-⊆ c' limit (ℕ.≤-trans (List.max-≤ (max-dimension c') (List.map max-dimension cs) (List.∈-map⁺ max-dimension c'∈cs)) max-dim≤limit) config)) ⟩ + a Rose.-< List.map (λ c → CCC.⟦ c ⟧ (fnoc limit config)) cs >- + ≡⟨⟩ + CCC.⟦ a CCC.CCC.-< cs >- ⟧ (fnoc limit config) + ∎ + where + open Eq.≡-Reasoning +translate-preserves-⊆ (D CCC.CCC.⟨ c ∷ cs ⟩) limit max-dim≤limit config = + begin + 2CC.⟦ translate (D CCC.CCC.⟨ c ∷ cs ⟩) ⟧ config + ≡⟨⟩ + 2CC.⟦ choice-list D zero (translate c) (List.map translate cs) ⟧ config + ≡⟨ lemma (fnoc limit config D) zero c cs (ℕ.≤-trans (ℕ.m≤m⊔n (List⁺.length (c ∷ cs)) (List.max (List.map max-dimension (c ∷ cs)))) max-dim≤limit) (λ k' k'-) config = + begin + CCC.⟦ a CCC.CCC.-< cs >- ⟧ config + ≡⟨⟩ + a Rose.-< List.map (λ c → CCC.⟦ c ⟧ config) cs >- + ≡⟨ Eq.cong (a Rose.-<_>-) (List.map-cong (λ c → translate-preserves-⊇ c config) cs) ⟩ + a Rose.-< List.map (λ c → 2CC.⟦ translate c ⟧ (conf config)) cs >- + ≡⟨ Eq.cong (a Rose.-<_>-) (List.map-∘ cs) ⟩ + a Rose.-< List.map (λ c → 2CC.⟦ c ⟧ (conf config)) (List.map translate cs) >- + ≡⟨⟩ + 2CC.⟦ a 2CC.2CC.-< List.map translate cs >- ⟧ (conf config) + ≡⟨⟩ + 2CC.⟦ translate (a CCC.CCC.-< cs >-) ⟧ (conf config) + ∎ + where + open Eq.≡-Reasoning +translate-preserves-⊇ (D CCC.CCC.⟨ c ∷ cs ⟩) config = + begin + CCC.⟦ D CCC.CCC.⟨ c ∷ cs ⟩ ⟧ config + ≡⟨⟩ + CCC.⟦ List.find-or-last (config D) (c ∷ cs) ⟧ config + ≡⟨ List.map-find-or-last (λ c → CCC.⟦ c ⟧ config) (config D) (c ∷ cs) ⟩ + List.find-or-last (config D) (List⁺.map (λ c → CCC.⟦ c ⟧ config) (c ∷ cs)) + ≡⟨ Eq.cong (λ x → List.find-or-last (config D) x) (List⁺.map-cong (λ c → translate-preserves-⊇ c config) (c ∷ cs)) ⟩ + List.find-or-last (config D) (List⁺.map (λ c → 2CC.⟦ translate c ⟧ (conf config)) (c ∷ cs)) + ≡⟨ Eq.cong (λ x → List.find-or-last (config D) x) (List⁺.map-∘ (c ∷ cs)) ⟩ + List.find-or-last (config D) (List⁺.map (λ c → 2CC.⟦ c ⟧ (conf config)) (List⁺.map translate (c ∷ cs))) + ≡⟨ List.map-find-or-last (λ c → 2CC.⟦ c ⟧ (conf config)) (config D) (List⁺.map translate (c ∷ cs)) ⟨ + 2CC.⟦ List.find-or-last (config D) (List⁺.map translate (c ∷ cs)) ⟧ (conf config) + ≡⟨ lemma (config D) zero (Eq.sym (ℕ.+-identityʳ (config D))) c cs ⟩ + 2CC.⟦ choice-list D zero (translate c) (List.map translate cs) ⟧ (conf config) + ≡⟨⟩ + 2CC.⟦ translate (D CCC.CCC.⟨ c ∷ cs ⟩) ⟧ (conf config) + ∎ + where + open Eq.≡-Reasoning + + lemma : ∀ {i : Size} {A : 𝔸} + → (m k : ℕ) + → config D ≡ m + k + → (c : CCC.CCC F i A) + → (cs : List (CCC.CCC F i A)) + → 2CC.⟦ List.find-or-last m (List⁺.map translate (c ∷ cs)) ⟧ (conf config) ≡ 2CC.⟦ choice-list D k (translate c) (List.map translate cs) ⟧ (conf config) + lemma zero k config-D≡m+k c₁ [] = refl + lemma zero k config-D≡m+k c₁ (c₂ ∷ []) = + begin + 2CC.⟦ List.find-or-last zero (List⁺.map translate (c₁ ∷ c₂ ∷ [])) ⟧ (conf config) + ≡⟨⟩ + 2CC.⟦ translate c₁ ⟧ (conf config) + ≡⟨⟩ + (if true then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ translate c₂ ⟧ (conf config)) + ≡⟨ Eq.cong (λ x → if x then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ translate c₂ ⟧ (conf config)) (Equivalence.to Bool.T-≡ (ℕ.≤⇒≤ᵇ (ℕ.≤-refl {k}))) ⟨ + (if zero + k ≤ᵇ k then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ translate c₂ ⟧ (conf config)) + ≡⟨ Eq.cong (λ x → if x ≤ᵇ k then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ translate c₂ ⟧ (conf config)) config-D≡m+k ⟨ + (if config D ≤ᵇ k then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ translate c₂ ⟧ (conf config)) + ≡⟨⟩ + (if conf config (D , k) then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ translate c₂ ⟧ (conf config)) + ≡⟨⟩ + 2CC.⟦ (D , k) 2CC.⟨ translate c₁ , translate c₂ ⟩ ⟧ (conf config) + ≡⟨⟩ + 2CC.⟦ choice-list D k (translate c₁) (List.map translate (c₂ ∷ [])) ⟧ (conf config) + ∎ + lemma zero k config-D≡m+k c₁ (c₂ ∷ c₃ ∷ cs) = + begin + 2CC.⟦ List.find-or-last zero (List⁺.map translate (c₁ ∷ c₂ ∷ c₃ ∷ cs)) ⟧ (conf config) + ≡⟨⟩ + 2CC.⟦ translate c₁ ⟧ (conf config) + ≡⟨⟩ + (if true then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ choice-list D (suc k) (translate c₂) (List.map translate (c₃ ∷ cs)) ⟧ (conf config)) + ≡⟨ Eq.cong (λ x → if x then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ choice-list D (suc k) (translate c₂) (List.map translate (c₃ ∷ cs)) ⟧ (conf config)) (Equivalence.to Bool.T-≡ (ℕ.≤⇒≤ᵇ (ℕ.≤-refl {k}))) ⟨ + (if zero + k ≤ᵇ k then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ choice-list D (suc k) (translate c₂) (List.map translate (c₃ ∷ cs)) ⟧ (conf config)) + ≡⟨ Eq.cong (λ x → if x ≤ᵇ k then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ choice-list D (suc k) (translate c₂) (List.map translate (c₃ ∷ cs)) ⟧ (conf config)) config-D≡m+k ⟨ + (if config D ≤ᵇ k then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ choice-list D (suc k) (translate c₂) (List.map translate (c₃ ∷ cs)) ⟧ (conf config)) + ≡⟨⟩ + (if conf config (D , k) then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ choice-list D (suc k) (translate c₂) (List.map translate (c₃ ∷ cs)) ⟧ (conf config)) + ≡⟨⟩ + 2CC.⟦ (D , k) 2CC.⟨ translate c₁ , choice-list D (suc k) (translate c₂) (List.map translate (c₃ ∷ cs)) ⟩ ⟧ (conf config) + ≡⟨⟩ + 2CC.⟦ choice-list D k (translate c₁) (List.map translate (c₂ ∷ c₃ ∷ cs)) ⟧ (conf config) + ∎ + lemma (suc m) k config-D≡m+k c₁ [] = refl + lemma (suc m) k config-D≡m+k c₁ (c₂ ∷ []) = + begin + 2CC.⟦ List.find-or-last (suc m) (List⁺.map translate (c₁ ∷ c₂ ∷ [])) ⟧ (conf config) + ≡⟨⟩ + 2CC.⟦ translate c₂ ⟧ (conf config) + ≡⟨⟩ + (if false then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ translate c₂ ⟧ (conf config)) + ≡⟨ Eq.cong (λ x → if x then 2CC.⟦ translate c₁ ⟧ (conf config) else 2CC.⟦ translate c₂ ⟧ (conf config)) (Equivalence.to Bool.T-not-≡ (>⇒¬≤ᵇ (ℕ.m⇒¬≤ᵇ (ℕ.m_; _+_; _∸_; _*_; _^_; _≟_) +open import Data.Product as Prod using (_×_; _,_; proj₁; proj₂; Σ-syntax; ∃-syntax) +open import Function using (_∘_; _∘′_; const; id) +open import Relation.Binary using (DecidableEquality) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; _≗_; _≢_; refl) +open import Vatras.Framework.Definitions using (𝔸; 𝔽; NAT; atomSize) + +module Vatras.Succinctness.Relations.2CC≰FST + (F : 𝔽) + (f : ℕ → F) + (_==_ : DecidableEquality F) + (f-injective : ∀ {i j : ℕ} → i ≢ j → f i ≢ f j) + (diagonalization : F × ℕ → F) + (diagonalization⁻¹ : F → F × ℕ) + (diagonalization-injective : diagonalization⁻¹ ∘ diagonalization ≗ id) + where + +open import Data.Bool as Bool using (Bool; true; false; _∨_; if_then_else_) +import Data.Bool.Properties as Bool +open import Data.Empty using (⊥-elim) +import Data.Nat.Properties as ℕ +open import Data.Fin as Fin using (Fin; zero; suc) +import Data.Fin.Properties as Fin +open import Data.List as List using (List; []; _∷_; _++_) +import Data.List.Properties as List +import Data.List.Membership.Propositional as List +open import Data.List.Relation.Binary.Sublist.Propositional as Sublist using ([]; _∷_; _∷ʳ_) +import Data.List.Relation.Binary.Subset.Propositional as Subset +import Data.List.Relation.Binary.Subset.Propositional.Properties as Subset +open import Data.List.Relation.Unary.Any using (here; there) +open import Data.List.Relation.Unary.All as All using (All; []; _∷_) +import Data.List.Relation.Unary.All.Properties as All +open import Data.List.Relation.Unary.AllPairs as AllPairs using (AllPairs; []; _∷_) +import Data.List.Relation.Unary.AllPairs.Properties as AllPairs +import Data.List.Relation.Unary.Unique.Propositional as List +import Data.List.Relation.Unary.Unique.Propositional.Properties as Unique +import Data.Product.Properties as Prod +open import Data.Unit using (tt) +open import Function.Bundles using (Equivalence) +open import Relation.Nullary.Decidable using (Dec; does; yes; no) +open import Relation.Nullary.Negation using (¬_) +open import Relation.Unary using (Decidable) +open import Size using (Size; ∞) + +open import Vatras.Util.AuxProofs using (true≢false; does≡true; does≡false) +open import Vatras.Data.EqIndexedSet using (_⊆_; ⊆-trans; _∈_) +open import Vatras.Framework.Variants using (Rose; Rose-injective) +import Vatras.Util.List as List +open import Vatras.Lang.All.Fixed F (Rose ∞) +import Vatras.Lang.2CC.ReflectsVariantSize as 2CC +import Vatras.Translation.LanguageMap +open Vatras.Translation.LanguageMap.Expressiveness diagonalization diagonalization⁻¹ diagonalization-injective using (2CC≽FST) +open import Vatras.Succinctness.ProofDefinition (Rose ∞) using (_≰ₛ_) +open import Vatras.Succinctness.Sizes using (sizeRose; Sized2CC; size2CC; SizedFST; sizeFST; size2CC>0) + +open FST.Impose NAT hiding (_∈_; _==_) +open import Vatras.Lang.FST.Composition F NAT using (⊛-all-unique) +open import Vatras.Lang.FST.Util F NAT using (select≗filter) +open import Vatras.Lang.2CC.FixedArtifactLength F NAT using (different-children-counts) renaming (_≉_ to _≉'_) + +artifact : ℕ → ℕ → FSTA ∞ +artifact n zero = (0 , 2 ^ n) Rose.-< [] >- +artifact n (suc i) = (suc i , 0) Rose.-< [] >- + +artifact-wf : (n i : ℕ) → WellFormed (artifact n i) +artifact-wf n zero = [] , [] +artifact-wf n (suc i) = [] , [] + +feature : ℕ → ℕ → FSF +feature n i = (artifact n i ∷ []) ⊚ ([] ∷ [] , artifact-wf n i ∷ []) + +fst : ℕ → SPL +fst n = (0 , 0) ◀ List.applyUpTo (λ i → f i :: feature n i) (suc n) + +size-fst : + ∀ (n : ℕ) + → sizeFST (fst n) ≡ 3 + 2 ^ n + 2 * n +size-fst n = + begin + sizeFST (fst n) + ≡⟨⟩ + 1 + List.sum (List.map (suc ∘ List.sum ∘ List.map sizeRose ∘ FST.Impose.trees ∘ FST.Impose.impl) (List.applyUpTo (λ i → f i :: feature n i) (suc n))) + ≡⟨⟩ + 2 + (sizeRose (artifact n zero) + 0) + List.sum (List.map (suc ∘ List.sum ∘ List.map sizeRose ∘ FST.Impose.trees ∘ FST.Impose.impl) (List.applyUpTo (λ i → f (suc i) :: feature n (suc i)) n)) + ≡⟨ Eq.cong (λ x → 2 + (sizeRose (artifact n zero) + 0 + List.sum (List.map (suc ∘ List.sum ∘ List.map sizeRose ∘ FST.Impose.trees ∘ FST.Impose.impl) x))) (List.map-upTo (λ i → f (suc i) :: feature n (suc i)) n) ⟨ + 2 + (sizeRose (artifact n zero) + 0) + List.sum (List.map (suc ∘ List.sum ∘ List.map sizeRose ∘ FST.Impose.trees ∘ FST.Impose.impl) (List.map (λ i → f (suc i) :: feature n (suc i)) (List.upTo n))) + ≡⟨ Eq.cong (λ x → 2 + (sizeRose (artifact n zero) + 0) + List.sum x) (List.map-∘ (List.upTo n)) ⟨ + 2 + (sizeRose (artifact n zero) + 0) + List.sum (List.map (λ i → suc (sizeRose (artifact n (suc i)) + 0)) (List.upTo n)) + ≡⟨⟩ + 3 + (2 ^ n + 0 + 0) + List.sum (List.map (const 2) (List.upTo n)) + ≡⟨ Eq.cong (λ x → 3 + x + List.sum (List.map (const 2) (List.upTo n))) (ℕ.+-identityʳ (2 ^ n + 0)) ⟩ + 3 + (2 ^ n + 0) + List.sum (List.map (const 2) (List.upTo n)) + ≡⟨ Eq.cong (λ x → 3 + x + List.sum (List.map (const 2) (List.upTo n))) (ℕ.+-identityʳ (2 ^ n)) ⟩ + 3 + 2 ^ n + List.sum (List.map (const 2) (List.upTo n)) + ≡⟨ Eq.cong (λ x → 3 + 2 ^ n + List.sum x) (List.map-const 2 (List.upTo n)) ⟩ + 3 + 2 ^ n + List.sum (List.replicate (List.length (List.upTo n)) 2) + ≡⟨ Eq.cong (λ x → 3 + 2 ^ n + List.sum (List.replicate x 2)) (List.length-upTo n) ⟩ + 3 + 2 ^ n + List.sum (List.replicate n 2) + ≡⟨ Eq.cong (λ x → 3 + 2 ^ n + x) (List.sum-replicate n 2) ⟩ + 3 + 2 ^ n + n * 2 + ≡⟨ Eq.cong (3 + 2 ^ n +_) (ℕ.*-comm n 2) ⟩ + 3 + 2 ^ n + 2 * n + ∎ + where + open Eq.≡-Reasoning + +variant : ℕ → ℕ → FSTA ∞ +variant n i = (0 , 0) Rose.-< List.applyUpTo (artifact n) (suc i) >- + +size-variant + : (n i : ℕ) + → 2 ^ n ≤ sizeRose (variant n i) +size-variant n i = + begin + 2 ^ n + ≡⟨ ℕ.+-identityʳ (2 ^ n) ⟨ + 2 ^ n + 0 + <⟨ ℕ.m-) ( + begin + List.applyUpTo (artifact n) (suc i) + ≡⟨ List.map-applyUpTo id (artifact n) (suc i) ⟨ + List.map (artifact n) (List.upTo (suc i)) + ≡⟨ List.concat-[-] (List.map (artifact n) (List.upTo (suc i))) ⟨ + List.concat (List.map (_∷ []) (List.map (artifact n) (List.upTo (suc i)))) + ≡⟨ Eq.cong List.concat (List.map-∘ {g = (_∷ [])} (List.upTo (suc i))) ⟨ + List.concat (List.map (λ k → artifact n k ∷ []) (List.upTo (suc i))) + ≡⟨⟩ + List.concat (List.map (λ k → forget-uniqueness (feature n k)) (List.upTo (suc i))) + ≡⟨ Eq.cong List.concat (List.map-∘ {g = forget-uniqueness} {f = feature n} (List.upTo (suc i))) ⟩ + List.concatMap forget-uniqueness (List.map (feature n) (List.upTo (suc i))) + ≡⟨ Eq.cong (List.concatMap forget-uniqueness) (List.map-applyUpTo id (feature n) (suc i)) ⟩ + List.concatMap forget-uniqueness (List.applyUpTo (feature n) (suc i)) + ≡⟨ ⊛-all-unique (List.applyUpTo (feature n) (suc i)) (unique-variant n zero (suc i)) ⟨ + forget-uniqueness (⊛-all (List.applyUpTo (feature n) (suc i))) + ≡⟨ Eq.cong (λ x → forget-uniqueness (⊛-all x)) (select-applyUpTo-feature n n i i≤n) ⟨ + forget-uniqueness (⊛-all (select (fst-config i) (List.applyUpTo (λ m → f m :: feature n m) (suc n)))) + ∎) + where + open Eq.≡-Reasoning + +⊆⇒All∈ : ∀ {i} n l k + → k + l ≤ suc n + → (2cc : 2CC.2CC i NAT) + → FST.⟦ fst n ⟧ ⊆ 2CC.⟦ 2cc ⟧ + → All (_∈ 2CC.⟦ 2cc ⟧) (List.applyUpTo (λ m → variant n (k + m)) l) +⊆⇒All∈ n zero k l≤n 2cc fst⊆2cc = [] +⊆⇒All∈ n (suc l) k l≤n 2cc fst⊆2cc with variant∈fst n k (ℕ.≤-pred ( + begin + suc k + ≤⟨ ℕ.m≤m+n (suc k) l ⟩ + suc k + l + ≡⟨ ℕ.+-suc k l ⟨ + k + suc l + ≤⟨ l≤n ⟩ + suc n + ∎)) + where + open ℕ.≤-Reasoning +⊆⇒All∈ n (suc l) k l≤n 2cc fst⊆2cc | fst-conf , variant≡fst with fst⊆2cc fst-conf +⊆⇒All∈ n (suc l) k l≤n 2cc fst⊆2cc | fst-conf , variant≡fst | 2cc-conf , fst≡2cc = + (2cc-conf , Eq.subst + (λ x → variant n x ≡ 2CC.⟦ 2cc ⟧ 2cc-conf) + (Eq.sym (ℕ.+-identityʳ k)) + (Eq.trans variant≡fst fst≡2cc)) + ∷ Eq.subst + (All (_∈ 2CC.⟦ 2cc ⟧)) + (List.applyUpTo-cong (λ l → Eq.cong (variant n) (Eq.sym (ℕ.+-suc k l))) l) + (⊆⇒All∈ n l (suc k) (ℕ.≤-trans (ℕ.≤-reflexive (Eq.sym (ℕ.+-suc k l))) l≤n) 2cc fst⊆2cc) + +2*n≤2^n : (n : ℕ) → 2 * n ≤ 2 ^ n +2*n≤2^n zero = ℕ.n≤1+n zero +2*n≤2^n (suc zero) = ℕ.≤-refl +2*n≤2^n (suc n@(suc _)) = + begin + 2 * suc n + ≡⟨ ℕ.*-suc 2 n ⟩ + 2 + 2 * n + ≤⟨ ℕ.+-monoˡ-≤ (2 * n) (ℕ.m≤m*n 2 n) ⟩ + 2 * n + 2 * n + ≡⟨ Eq.cong (2 * n +_) (ℕ.+-identityʳ (2 * n)) ⟨ + 2 * n + (2 * n + 0) + ≡⟨⟩ + 2 * (2 * n) + ≤⟨ ℕ.*-monoʳ-≤ 2 (2*n≤2^n n) ⟩ + 2 * 2 ^ n + ≡⟨ ℕ.^-distribˡ-+-* 2 1 n ⟩ + 2 ^ suc n + ∎ + where + open ℕ.≤-Reasoning + +2CC≰FST : Sized2CC F ≰ₛ SizedFST F +2CC≰FST zero = NAT , fst zero , 2CC≽FST (f 0) _==_ (fst zero) , λ 2cc 2cc≅fst → size2CC>0 2cc +2CC≰FST (suc n) = NAT , fst m , 2CC≽FST (f 0) _==_ (fst m) , λ 2cc 2cc≅fst → + begin-strict + suc n * sizeFST (fst m) + <⟨ ℕ.*-monoʳ-< (suc n) ( + begin-strict + sizeFST (fst m) + ≡⟨ size-fst m ⟩ + 3 + 2 ^ m + 2 * m + ≤⟨ ℕ.+-monoʳ-≤ (3 + 2 ^ m) (2*n≤2^n m) ⟩ + 3 + 2 ^ m + 2 ^ m + ≤⟨ ℕ.+-monoˡ-≤ (2 ^ m) (ℕ.+-monoˡ-≤ (2 ^ m) (ℕ.m≤m*n 3 (2 ^ m) {{ℕ.>-nonZero (ℕ.m^n>0 2 m)}})) ⟩ + 3 * 2 ^ m + 2 ^ m + 2 ^ m + ≡⟨ Eq.cong (λ x → 3 * 2 ^ m + x + x) (ℕ.*-identityˡ (2 ^ m)) ⟨ + 3 * 2 ^ m + 1 * 2 ^ m + 1 * 2 ^ m + ≡⟨ Eq.cong (_+ 1 * 2 ^ m) (ℕ.*-distribʳ-+ (2 ^ m) 3 1) ⟨ + 4 * 2 ^ m + 1 * 2 ^ m + ≡⟨ ℕ.*-distribʳ-+ (2 ^ m) 4 1 ⟨ + 5 * 2 ^ m + <⟨ ℕ.*-monoˡ-< (2 ^ m) ⦃ ℕ.>-nonZero (ℕ.m^n>0 2 m) ⦄ (ℕ.n<1+n 5) ⟩ + 6 * 2 ^ m + ∎) + ⟩ + suc n * (6 * 2 ^ m) + ≡⟨ ℕ.*-assoc (suc n) 6 (2 ^ m) ⟨ + suc n * 6 * 2 ^ m + ≡⟨ Eq.cong (_* 2 ^ m) (ℕ.*-comm (suc n) 6) ⟩ + 6 * suc n * 2 ^ m + ≡⟨⟩ + m * 2 ^ m + ≡⟨ Eq.cong (_* 2 ^ m) (List.length-applyUpTo (variant m) m) ⟨ + List.length (List.applyUpTo (variant m) m) * 2 ^ m + ≤⟨ different-children-counts + (2 ^ m) + 2cc + (List.applyUpTo (variant m) m) + (⊆⇒All∈ m m 0 (ℕ.n≤1+n m) 2cc (proj₂ 2cc≅fst)) + (All.applyUpTo⁺₂ (variant m) m (size-variant m)) + (AllPairs.applyUpTo⁺₁ (variant m) m (λ i0) + +options : ℕ → List (OC.OC ∞ NAT) +options zero = [] +options (suc n) = f n OC.❲ (0 , 0) OC.-< [] >- ❳ ∷ options n + +oc : ℕ → OC.WFOC ∞ NAT +oc n = OC.Root (0 , 0) ((0 , 2 ^ n) OC.-< [] >- ∷ options n) + +size-options : ∀ n → List.sum (List.map sizeOC (options n)) ≡ 2 * n +size-options zero = Eq.refl +size-options (suc n) = + List.sum (List.map sizeOC (options (suc n))) + ≡⟨⟩ + suc (suc (List.sum (List.map sizeOC (options n)))) + ≡⟨ Eq.cong (λ x → suc (suc x)) (size-options n) ⟩ + suc (suc (2 * n)) + ≡⟨ ℕ.*-suc 2 n ⟨ + 2 * (suc n) + ∎ + where + open Eq.≡-Reasoning + +size-oc : ∀ (n : ℕ) → sizeWFOC (oc n) ≡ 2 ^ n + 2 * suc n +size-oc n = + sizeWFOC (oc n) + ≡⟨⟩ + 1 + List.sum (List.map sizeOC ((0 , 2 ^ n) OC.-< [] >- ∷ options n)) + ≡⟨⟩ + 1 + sizeOC {A = NAT} ((0 , 2 ^ n) OC.-< [] >-) + List.sum (List.map sizeOC (options n)) + ≡⟨⟩ + 2 + atomSize NAT (0 , 2 ^ n) + 0 + List.sum (List.map sizeOC (options n)) + ≡⟨⟩ + 2 + (2 ^ n + 0) + List.sum (List.map sizeOC (options n)) + ≡⟨ Eq.cong (λ x → 2 + (2 ^ n + 0) + x) (size-options n) ⟩ + 2 + (2 ^ n + 0) + 2 * n + ≡⟨ Eq.cong (λ x → 2 + x + 2 * n) (ℕ.+-identityʳ (2 ^ n)) ⟩ + 2 + 2 ^ n + 2 * n + ≡⟨ Eq.cong (_+ 2 * n) (ℕ.+-comm 2 (2 ^ n)) ⟩ + 2 ^ n + 2 + 2 * n + ≡⟨ ℕ.+-assoc (2 ^ n) 2 (2 * n) ⟩ + 2 ^ n + (2 + 2 * n) + ≡⟨ Eq.cong (2 ^ n +_) (ℕ.*-suc 2 n) ⟨ + 2 ^ n + 2 * suc n + ∎ + where + open Eq.≡-Reasoning + +exponential-artifact : ℕ → Rose ∞ NAT +exponential-artifact n = (0 , 2 ^ n) Rose.-< [] >- + +variant-cs : ℕ → List (Rose ∞ NAT) +variant-cs i = List.replicate i ((0 , 0) Rose.-< [] >-) + +variant : ℕ → ℕ → Rose ∞ NAT +variant n i = (0 , 0) Rose.-< exponential-artifact n ∷ variant-cs i >- + +size-variant + : (n l : ℕ) + → 2 ^ n ≤ sizeRose (variant n l) +size-variant n l = + begin + 2 ^ n + ≡⟨ ℕ.+-identityʳ (2 ^ n) ⟨ + 2 ^ n + 0 + ≤⟨ ℕ.m≤m+n (2 ^ n + 0) _ ⟩ + 2 ^ n + 0 + List.sum (List.map sizeRose (variant-cs l)) + <⟨ ℕ.m- ❳ ∷ options n)) + ≡⟨⟩ + List.catMaybes (OC.⟦ f n OC.❲ (0 , 0) OC.-< [] >- ❳ ⟧ₒ (config l) ∷ List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n)) + ≡⟨⟩ + List.catMaybes ((if config l (f n) then just ((0 , 0) Rose.-< [] >-) else nothing) ∷ List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n)) + ≡⟨ Eq.cong (λ x → List.catMaybes ((if x then just ((0 , 0) Rose.-< [] >-) else nothing) ∷ List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n))) (config≡true l n n-) else nothing) ∷ List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n)) + ≡⟨⟩ + List.catMaybes ((just ((0 , 0) Rose.-< [] >-)) ∷ List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n)) + ≡⟨⟩ + ((0 , 0) Rose.-< [] >-) ∷ List.catMaybes (List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n)) + ≡⟨ Eq.cong ((0 , 0) Rose.-< [] >- ∷_) (⟦options⟧-tail n l (ℕ.<⇒≤ n-) ∷ variant-cs n + ∎ + where + open Eq.≡-Reasoning + +⟦options⟧ : ∀ n l + → l ≤ n + → List.catMaybes (List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n)) + ≡ variant-cs l +⟦options⟧ zero .zero z≤n = Eq.refl +⟦options⟧ (suc n) l l≤n with n ℕ.- ❳ ∷ options n)) + ≡⟨⟩ + List.catMaybes (OC.⟦ f n OC.❲ (0 , 0) OC.-< [] >- ❳ ⟧ₒ (config l) ∷ List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n)) + ≡⟨⟩ + List.catMaybes ((if config l (f n) then just ((0 , 0) Rose.-< [] >-) else nothing) ∷ List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n)) + ≡⟨ Eq.cong (λ x → List.catMaybes ((if x then just ((0 , 0) Rose.-< [] >-) else nothing) ∷ List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n))) (config≡false l n (ℕ.≮⇒≥ n≮l)) ⟩ + List.catMaybes ((if false then just ((0 , 0) Rose.-< [] >-) else nothing) ∷ List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n)) + ≡⟨⟩ + List.catMaybes (List.map (λ e → OC.⟦ e ⟧ₒ (config l)) (options n)) + ≡⟨ ⟦options⟧ n l (ℕ.≮⇒≥ n≮l) ⟩ + variant-cs l + ∎ + where + open Eq.≡-Reasoning +⟦options⟧ (suc n) l l≤n | yes n- ∷ options n ⟧ₒ-recurse (config l) >- + ≡⟨⟩ + (0 , 0) Rose.-< exponential-artifact n ∷ OC.⟦ options n ⟧ₒ-recurse (config l) >- + ≡⟨ Eq.cong (λ x → (0 , 0) Rose.-< exponential-artifact n ∷ x >-) (⟦options⟧ n l l≤n) ⟩ + (0 , 0) Rose.-< exponential-artifact n ∷ variant-cs l >- + ≡⟨⟩ + variant n l + ∎ + where + open Eq.≡-Reasoning + +⊆⇒All∈ : ∀ {i} n l + → l ≤ suc n + → (2cc : 2CC.2CC i NAT) + → OC.⟦ oc n ⟧ ⊆ 2CC.⟦ 2cc ⟧ + → All (_∈ 2CC.⟦ 2cc ⟧) (List.applyUpTo (variant n) l) +⊆⇒All∈ n zero l≤n 2cc oc⊆2cc = [] +⊆⇒All∈ n (suc l) (s≤s l≤n) 2cc oc⊆2cc = + Eq.subst + (All (λ l → l ∈ 2CC.⟦ 2cc ⟧)) + (List.applyUpTo-∷ʳ⁺ (variant n) l) + (All.∷ʳ⁺ + (⊆⇒All∈ n l (ℕ.<⇒≤ (s≤s l≤n)) 2cc oc⊆2cc) + (Eq.subst + (_∈ 2CC.⟦ 2cc ⟧) + (⟦oc⟧ n l l≤n) + (oc⊆2cc (config l)))) + +4*n<16^n : ∀ n → 4 * n < 16 ^ n +4*n<16^n zero = s≤s z≤n +4*n<16^n (suc n) = + begin-strict + 4 * suc n + ≡⟨ ℕ.*-suc 4 n ⟩ + 4 + 4 * n + <⟨ ℕ.+-mono-< (s≤s (s≤s (s≤s (s≤s (s≤s z≤n))))) (4*n<16^n n) ⟩ + 15 + 16 ^ n + ≤⟨ ℕ.+-monoˡ-≤ (16 ^ n) (ℕ.*-monoʳ-≤ 15 (ℕ.m^n>0 16 n)) ⟩ + 15 * 16 ^ n + 16 ^ n + ≡⟨ Eq.cong (15 * 16 ^ n +_) (ℕ.+-identityʳ (16 ^ n)) ⟨ + 15 * 16 ^ n + (16 ^ n + 0) + ≡⟨ ℕ.*-distribʳ-+ (16 ^ n) 15 1 ⟨ + 16 * 16 ^ n + ≡⟨⟩ + 16 ^ suc n + ∎ + where + open ℕ.≤-Reasoning + +goal : ∀ {i} (n : ℕ) (2cc : 2CC.2CC i NAT) + → 2CC.⟦ 2cc ⟧ ≅ OC.⟦ oc (4 * n) ⟧ + → n * sizeWFOC (oc (4 * n)) < size2CC 2cc +goal zero 2cc oc≅2cc = size2CC>0 2cc +goal n@(suc n-1) 2cc (2cc⊆oc , oc⊆2cc) = + begin-strict + n * sizeWFOC (oc m) + ≡⟨ Eq.cong (n *_) (size-oc m) ⟩ + n * (2 ^ m + 2 * suc m) + ≤⟨ ℕ.*-monoʳ-≤ n (ℕ.+-monoʳ-≤ (2 ^ m) (ℕ.*-monoʳ-≤ 2 (4*n<16^n n))) ⟩ + n * (2 ^ m + 2 * 16 ^ n) + ≡⟨ Eq.cong (λ x → n * (2 ^ m + 2 * x)) (ℕ.^-*-assoc 2 4 n) ⟩ + n * (2 ^ m + 2 * 2 ^ m) + ≡⟨⟩ + n * (3 * 2 ^ m) + <⟨ ℕ.*-monoʳ-< n (ℕ.*-monoˡ-< (2 ^ m) {{ℕ.>-nonZero (ℕ.m^n>0 2 m)}} (ℕ.n<1+n 3)) ⟩ + n * (4 * 2 ^ m) + ≡⟨ ℕ.*-assoc n 4 (2 ^ m) ⟨ + n * 4 * 2 ^ m + ≡⟨ Eq.cong (_* 2 ^ m) (ℕ.*-comm n 4) ⟩ + m * 2 ^ m + <⟨ ℕ.*-monoˡ-< (2 ^ m) {{ℕ.>-nonZero (ℕ.m^n>0 2 m)}} (ℕ.n<1+n m) ⟩ + suc m * 2 ^ m + ≡⟨ Eq.cong (_* 2 ^ m) (List.length-applyUpTo (variant m) (suc m)) ⟨ + List.length (List.applyUpTo (variant m) (suc m)) * 2 ^ m + ≤⟨ different-children-counts + (2 ^ m) + 2cc + (List.applyUpTo (variant m) (suc m)) + (⊆⇒All∈ m (suc m) ℕ.≤-refl 2cc oc⊆2cc) + (All.applyUpTo⁺₂ (variant m) (suc m) (size-variant m)) + (AllPairs.applyUpTo⁺₁ (variant m) (suc m) (λ i0; SizedADT; sizeADT) +open import Vatras.Lang.All +open ADT using (ADT) +open NADT using (NADT) + +open import Vatras.Translation.Lang.ADT-to-VariantList using () + +translate : ∀ {i : Size} {A : 𝔸} → NADT F V i A → ADT (F × ℕ) V A +translate-cs : ∀ {i : Size} {A : 𝔸} → F → ℕ → (NADT F V i A) → List (NADT F V i A) → ADT (F × ℕ) V A + +-- TODO why do I need ADT.ADT +translate (NADT.leaf v) = ADT.ADT.leaf v +translate (f NADT.⟨ c ∷ cs ⟩) = translate-cs f zero c cs + +translate-cs f n c [] = translate c +translate-cs f n c₁ (c₂ ∷ cs) = (f , n) ADT.ADT.⟨ translate c₁ , translate-cs f (suc n) c₂ cs ⟩ + +⌈_⌉ : ∀ {i : Size} {A : 𝔸} → NADT F V i A → ℕ +⌈ NADT.leaf v ⌉ = 1 +⌈ f NADT.⟨ c ∷ cs ⟩ ⌉ = length (c ∷ cs) ⊔ max (map ⌈_⌉ (c ∷ cs)) + +data ChoiceArity≤ (n : ℕ) {A : 𝔸} : {i : Size} → NADT F V i A → Set₁ where + leaf : + ∀ {i : Size} + → (v : V A) + → ChoiceArity≤ n {i = ↑ i} (NADT.NADT.leaf v) + choice : + ∀ {i : Size} + → (f : F) + → (c : NADT F V i A) + → (cs : List (NADT F V i A)) + → length (c ∷ cs) ≤ n + → All (ChoiceArity≤ n) (c ∷ cs) + → ChoiceArity≤ n (f NADT.NADT.⟨ c ∷ cs ⟩) + +⌈⌉-head : + ∀ {i : Size} {A : 𝔸} + → (c : NADT F V i A) + → (cs : List (NADT F V i A)) + → ⌈ c ⌉ ≤ length (c ∷ cs) ⊔ max (map ⌈_⌉ (c ∷ cs)) +⌈⌉-head c cs = + begin + ⌈ c ⌉ + ≤⟨ ℕ.m≤m⊔n ⌈ c ⌉ (max (map ⌈_⌉ cs)) ⟩ + ⌈ c ⌉ ⊔ max (map ⌈_⌉ cs) + ≤⟨ ℕ.m≤n⊔m (length (c ∷ cs)) (⌈ c ⌉ ⊔ max (map ⌈_⌉ cs)) ⟩ + length (c ∷ cs) ⊔ (⌈ c ⌉ ⊔ max (map ⌈_⌉ cs)) + ≡⟨⟩ + length (c ∷ cs) ⊔ max (map ⌈_⌉ (c ∷ cs)) + ∎ + where + open ℕ.≤-Reasoning + +⌈⌉-tail : + ∀ {i : Size} {A : 𝔸} + → (c : NADT F V i A) + → (cs : List (NADT F V i A)) + → length cs ⊔ max (map ⌈_⌉ cs) ≤ length (c ∷ cs) ⊔ max (map ⌈_⌉ (c ∷ cs)) +⌈⌉-tail c cs = + begin + length cs ⊔ max (map ⌈_⌉ cs) + ≤⟨ ℕ.⊔-monoʳ-≤ (length cs) (ℕ.m≤n⊔m ⌈ c ⌉ (max (map ⌈_⌉ cs))) ⟩ + length cs ⊔ (⌈ c ⌉ ⊔ max (map ⌈_⌉ cs)) + ≤⟨ ℕ.⊔-monoˡ-≤ (⌈ c ⌉ ⊔ max (map ⌈_⌉ cs)) (ℕ.n≤1+n (length cs)) ⟩ + length (c ∷ cs) ⊔ (⌈ c ⌉ ⊔ max (map ⌈_⌉ cs)) + ≡⟨⟩ + length (c ∷ cs) ⊔ max (map ⌈_⌉ (c ∷ cs)) + ∎ + where + open ℕ.≤-Reasoning + +weaken-ChoiceArity : + ∀ {i : Size} → {A : 𝔸} + → {m n : ℕ} + → m ≤ n + → {nadt : NADT F V i A} + → ChoiceArity≤ m nadt + → ChoiceArity≤ n nadt +weaken-ChoiceArity m≤n (leaf v) = leaf v +weaken-ChoiceArity m≤n (choice f c cs cs≤m ChoiceArity-cs) = choice f c cs (ℕ.≤-trans cs≤m m≤n) (All.map (weaken-ChoiceArity m≤n) ChoiceArity-cs) + +ChoiceArity≤-⌈⌉ : ∀ {i : Size} → {A : 𝔸} → (nadt : NADT F V i A) → ChoiceArity≤ ⌈ nadt ⌉ nadt +ChoiceArity≤-⌈⌉ (NADT.leaf v) = leaf v +ChoiceArity≤-⌈⌉ {A = A} (f NADT.⟨ c ∷ cs ⟩) = choice f c cs (ℕ.m≤m⊔n (length (c ∷ cs)) (max (map ⌈_⌉ (c ∷ cs)))) (lemma c cs) + where + open ℕ.≤-Reasoning + + lemma : ∀ {i : Size} → (c : NADT F V i A) → (cs : List (NADT F V i A)) → All (ChoiceArity≤ ⌈ f NADT.NADT.⟨ c ∷ cs ⟩ ⌉) (c ∷ cs) + lemma c [] = weaken-ChoiceArity (⌈⌉-head c []) (ChoiceArity≤-⌈⌉ c) ∷ [] + lemma c₁ (c₂ ∷ cs) = + weaken-ChoiceArity (⌈⌉-head c₁ (c₂ ∷ cs)) (ChoiceArity≤-⌈⌉ c₁) + ∷ All.map (weaken-ChoiceArity (⌈⌉-tail c₁ (c₂ ∷ cs))) (lemma c₂ cs) + +conf' : ℕ → ℕ → ADT.Configuration (F × ℕ) → NADT.Configuration F +conf' zero n config f = n +conf' (suc fuel) n config f with config (f , n) +conf' (suc fuel) n config f | true = n +conf' (suc fuel) n config f | false = conf' fuel (suc n) config f + +conf : ℕ → ADT.Configuration (F × ℕ) → NADT.Configuration F +conf fuel config f = conf' fuel zero config f + +fnoc : NADT.Configuration F → ADT.Configuration (F × ℕ) +fnoc config (f , n) = does (config f ≤? n) + +conf≡n : + ∀ fuel n config f goal + → goal < n + fuel + → n ≤ goal + → (∀ k → k < goal → config (f , k) ≡ false) + → config (f , goal) ≡ true + → conf' fuel n config f ≡ goal +conf≡n zero n config f goal goaln : + ∀ fuel n config f goal + → goal < n + fuel + → n ≤ goal + → (∀ k → k < goal → config (f , k) ≡ false) + → config (f , goal) ≡ false + → goal < conf' fuel n config f +conf>n zero n config f goal goaln (suc fuel) n config f goal goaln fuel (suc n) config f goal + (ℕ.≤-trans goaln m zero config f n ( + begin-strict + n + ≡⟨ ℕ.+-identityʳ n ⟨ + n + 0 + <⟨ ℕ.+-monoʳ-< n (s≤s z≤n) ⟩ + n + length (c₁ ∷ c₂ ∷ cs) + ≤⟨ n+cs≤m ⟩ + m + ∎) z≤n config≡false config-f) + ⟩ + conf m config f ∸ n + ∎ + where + open ℕ.≤-Reasoning + + open Eq.≡-Reasoning + +translate-preserves-⊇ : ∀ {A : 𝔸} → (nadt : NADT F V ∞ A) → NADT.⟦ nadt ⟧ ⊆[ fnoc ] ADT.⟦ translate nadt ⟧ +translate-preserves-⊇ (NADT.leaf v) config = refl +translate-preserves-⊇ {A} (f NADT.⟨ c ∷ cs ⟩) config = go zero c cs + where + go : (n : ℕ) → (c : NADT F V ∞ A) → (cs : List (NADT F V ∞ A)) → NADT.⟦ find-or-last (config f ∸ n) (c ∷ cs) ⟧ config ≡ ADT.⟦ translate-cs f n c cs ⟧ (fnoc config) + go n c [] = translate-preserves-⊇ c config + go n c₁ (c₂ ∷ cs) with config f ≤? n in config-f≤n-proof + go n c₁ (c₂ ∷ cs) | yes config-f≤n = + NADT.⟦ find-or-last (config f ∸ n) (c₁ ∷ c₂ ∷ cs) ⟧ config + ≡⟨ Eq.cong (λ x → NADT.⟦ find-or-last x (c₁ ∷ c₂ ∷ cs) ⟧ config) (ℕ.m≤n⇒m∸n≡0 config-f≤n) ⟩ + NADT.⟦ find-or-last zero (c₁ ∷ c₂ ∷ cs) ⟧ config + ≡⟨⟩ + NADT.⟦ c₁ ⟧ config + ≡⟨ translate-preserves-⊇ c₁ config ⟩ + ADT.⟦ translate c₁ ⟧ (fnoc config) + ≡⟨⟩ + (if true then ADT.⟦ translate c₁ ⟧ (fnoc config) else ADT.⟦ translate-cs f (suc n) c₂ cs ⟧ (fnoc config) ) + ≡⟨ Eq.cong (if_then ADT.⟦ translate c₁ ⟧ (fnoc config) else ADT.⟦ translate-cs f (suc n) c₂ cs ⟧ (fnoc config)) (Eq.cong does config-f≤n-proof) ⟨ + (if fnoc config (f , n) then ADT.⟦ translate c₁ ⟧ (fnoc config) else ADT.⟦ translate-cs f (suc n) c₂ cs ⟧ (fnoc config) ) + ≡⟨⟩ + ADT.⟦ (f , n) ADT.ADT.⟨ translate c₁ , translate-cs f (suc n) c₂ cs ⟩ ⟧ (fnoc config) + ≡⟨⟩ + ADT.⟦ translate-cs f n c₁ (c₂ ∷ cs) ⟧ (fnoc config) + ∎ + where + open Eq.≡-Reasoning + go n c₁ (c₂ ∷ cs) | no config-f≰n = + NADT.⟦ find-or-last (config f ∸ n) (c₁ ∷ c₂ ∷ cs) ⟧ config + ≡⟨ Eq.cong (λ x → NADT.⟦ x ⟧ config) (List.find-or-last-prepend-∸ {n = config f ∸ n} (c₁ ∷ []) (c₂ ∷ cs) fnoc-lemma) ⟩ + NADT.⟦ find-or-last ((config f ∸ n) ∸ 1) (c₂ ∷ cs) ⟧ config + ≡⟨ Eq.cong (λ x → NADT.⟦ find-or-last x (c₂ ∷ cs) ⟧ config) (ℕ.∸-+-assoc (config f) n 1) ⟩ + NADT.⟦ find-or-last (config f ∸ (n + 1)) (c₂ ∷ cs) ⟧ config + ≡⟨ Eq.cong (λ x → NADT.⟦ find-or-last (config f ∸ x) (c₂ ∷ cs) ⟧ config) (ℕ.+-comm n 1) ⟩ + NADT.⟦ find-or-last (config f ∸ suc n) (c₂ ∷ cs) ⟧ config + ≡⟨ go (suc n) c₂ cs ⟩ + ADT.⟦ translate-cs f (suc n) c₂ cs ⟧ (fnoc config) + ≡⟨⟩ + (if false then ADT.⟦ translate c₁ ⟧ (fnoc config) else ADT.⟦ translate-cs f (suc n) c₂ cs ⟧ (fnoc config) ) + ≡⟨ Eq.cong (if_then ADT.⟦ translate c₁ ⟧ (fnoc config) else ADT.⟦ translate-cs f (suc n) c₂ cs ⟧ (fnoc config)) (Eq.cong does config-f≤n-proof) ⟨ + (if fnoc config (f , n) then ADT.⟦ translate c₁ ⟧ (fnoc config) else ADT.⟦ translate-cs f (suc n) c₂ cs ⟧ (fnoc config)) + ≡⟨⟩ + ADT.⟦ (f , n) ADT.ADT.⟨ translate c₁ , translate-cs f (suc n) c₂ cs ⟩ ⟧ (fnoc config) + ≡⟨⟩ + ADT.⟦ translate-cs f n c₁ (c₂ ∷ cs) ⟧ (fnoc config) + ∎ + where + fnoc-lemma : List⁺.length (c₁ ∷ []) Data.Nat.≤ config f ∸ n + fnoc-lemma = + begin + List⁺.length (c₁ ∷ []) + ≡⟨⟩ + 1 + ≡⟨ Eq.cong suc (ℕ.n∸n≡0 n) ⟨ + suc (n ∸ n) + ≡⟨ ℕ.+-∸-assoc 1 {n} ℕ.≤-refl ⟨ + suc n ∸ n + ≤⟨ ℕ.∸-monoˡ-≤ n (ℕ.≰⇒> config-f≰n) ⟩ + config f ∸ n + ∎ + where + open ℕ.≤-Reasoning + open Eq.≡-Reasoning + +translate-preserves : ∀ {A : 𝔸} → (nadt : NADT F V ∞ A) → ADT.⟦ translate nadt ⟧ ≅[ conf ⌈ nadt ⌉ ][ fnoc ] NADT.⟦ nadt ⟧ +translate-preserves nadt = translate-preserves-⊆ ⌈ nadt ⌉ (ChoiceArity≤-⌈⌉ nadt) , translate-preserves-⊇ nadt + +lemma : ∀ {i : Size} {A : 𝔸} → (nadt : NADT F V i A) → sizeADT sizeV (translate nadt) ≤ 2 * sizeNADT sizeV nadt ∸ 1 +lemma {A = A} (NADT.leaf v) = + begin + sizeADT sizeV (translate (NADT.NADT.leaf v)) + ≡⟨⟩ + sizeNADT {V = V} sizeV (NADT.NADT.leaf {F = F} v) + ≡⟨⟩ + suc (sizeV v) + ≡⟨⟩ + 2 + sizeV v ∸ 1 + ≡⟨ Eq.cong (λ x → 2 + x ∸ 1) (ℕ.*-identityˡ (sizeV v)) ⟨ + 2 + 1 * sizeV v ∸ 1 + ≤⟨ ℕ.∸-monoˡ-≤ 1 (ℕ.+-monoʳ-≤ 2 (ℕ.*-monoˡ-≤ (sizeV v) (s≤s (z≤n {1})))) ⟩ + 2 + 2 * sizeV v ∸ 1 + ≡⟨ Eq.cong (_∸ 1) (ℕ.*-distribˡ-+ 2 1 (sizeV v)) ⟨ + 2 * suc (sizeV v) ∸ 1 + ≡⟨⟩ + 2 * sizeNADT {V = V} sizeV (NADT.NADT.leaf {F = F} v) ∸ 1 + ∎ + where + open ℕ.≤-Reasoning +lemma {A = A} (f NADT.⟨ c ∷ cs ⟩) = + begin + sizeADT sizeV (translate (f NADT.NADT.⟨ c ∷ cs ⟩)) + ≡⟨⟩ + sizeADT sizeV (translate-cs f zero c cs) + ≤⟨ go zero c cs ⟩ + 2 * sum (map (sizeNADT sizeV) (c ∷ cs)) + ≤⟨ ℕ.n≤1+n (2 * sum (map (sizeNADT sizeV) (c ∷ cs))) ⟩ + 1 + 2 * sum (map (sizeNADT sizeV) (c ∷ cs)) + ≡⟨⟩ + (2 + 2 * sum (map (sizeNADT sizeV) (c ∷ cs))) ∸ 1 + ≡⟨ Eq.cong (_∸ 1) (ℕ.*-distribˡ-+ 2 1 (sum (map (sizeNADT sizeV) (c ∷ cs)))) ⟨ + 2 * suc (sum (map (sizeNADT sizeV) (c ∷ cs))) ∸ 1 + ≡⟨⟩ + 2 * suc (sum (map (sizeNADT sizeV) (c ∷ cs))) ∸ 1 + ≡⟨⟩ + 2 * sizeNADT sizeV (f NADT.NADT.⟨ c ∷ cs ⟩) ∸ 1 + ∎ + where + open ℕ.≤-Reasoning + + go : ∀ {i : Size} → (n : ℕ) → (c : NADT F V i A) → (cs : List (NADT F V i A)) + → sizeADT sizeV (translate-cs f n c cs) + ≤ 2 * sum (map (sizeNADT sizeV) (c ∷ cs)) + go n c [] = + begin + sizeADT sizeV (translate-cs f n c []) + ≡⟨⟩ + sizeADT sizeV (translate c) + ≤⟨ lemma c ⟩ + 2 * sizeNADT sizeV c ∸ 1 + ≤⟨ ℕ.m∸n≤m (2 * sizeNADT sizeV c) 1 ⟩ + 2 * sizeNADT sizeV c + ≡⟨ Eq.cong (2 *_) (ℕ.+-identityʳ (sizeNADT sizeV c)) ⟨ + 2 * (sizeNADT sizeV c + 0) + ≡⟨⟩ + 2 * sum (map (sizeNADT sizeV) (c ∷ [])) + ∎ + go n c₁ (c₂ ∷ cs) = + begin + sizeADT sizeV (translate-cs f n c₁ (c₂ ∷ cs)) + ≡⟨⟩ + sizeADT sizeV ((f , n) ADT.ADT.⟨ translate c₁ , translate-cs f (suc n) c₂ cs ⟩) + ≡⟨⟩ + suc (sizeADT sizeV (translate c₁) + sizeADT sizeV (translate-cs f (suc n) c₂ cs)) + ≤⟨ ℕ.+-monoˡ-≤ (sizeADT sizeV (translate-cs f (suc n) c₂ cs)) (s≤s (lemma c₁)) ⟩ + suc (2 * sizeNADT sizeV c₁ ∸ 1) + sizeADT sizeV (translate-cs f (suc n) c₂ cs) + ≤⟨ ℕ.+-monoʳ-≤ (suc (2 * sizeNADT sizeV c₁ ∸ 1)) (go (suc n) c₂ cs) ⟩ + suc (2 * sizeNADT sizeV c₁ ∸ 1) + 2 * sum (map (sizeNADT sizeV) (c₂ ∷ cs)) + ≡⟨ Eq.cong (_+ 2 * sum (map (sizeNADT sizeV) (c₂ ∷ cs))) (ℕ.+-∸-assoc 1 {2 * sizeNADT sizeV c₁} {1} (ℕ.≤-trans (sizeNADT>0 sizeV c₁) (ℕ.m≤n*m (sizeNADT sizeV c₁) 2))) ⟨ + 2 * sizeNADT sizeV c₁ + 2 * sum (map (sizeNADT sizeV) (c₂ ∷ cs)) + ≡⟨ ℕ.*-distribˡ-+ 2 (sizeNADT sizeV c₁) (sum (map (sizeNADT sizeV) (c₂ ∷ cs))) ⟨ + 2 * (sizeNADT sizeV c₁ + sum (map (sizeNADT sizeV) (c₂ ∷ cs))) + ≡⟨⟩ + 2 * sum (map (sizeNADT sizeV) (c₁ ∷ c₂ ∷ cs)) + ∎ + +ADT≤NADT : SizedADT (F × ℕ) V sizeV ≤ₛ SizedNADT F V sizeV +ADT≤NADT .proj₁ = 2 +ADT≤NADT .proj₂ A e₂ e₂-translatable = translate e₂ , ≅[]→≅ (translate-preserves e₂) , ℕ.≤-trans (lemma e₂) (ℕ.m∸n≤m (2 * sizeNADT sizeV e₂) 1) diff --git "a/src/Vatras/Succinctness/Relations/CCC\342\211\244NCC.agda" "b/src/Vatras/Succinctness/Relations/CCC\342\211\244NCC.agda" new file mode 100644 index 00000000..2577e640 --- /dev/null +++ "b/src/Vatras/Succinctness/Relations/CCC\342\211\244NCC.agda" @@ -0,0 +1,70 @@ +open import Vatras.Framework.Definitions using (𝔽; 𝔸; atomSize) +module Vatras.Succinctness.Relations.CCC≤NCC (F : 𝔽) where + +open import Data.Nat as ℕ using (suc; _≤_; s≤s; _+_) +import Data.Nat.Properties as ℕ +import Data.List as List +open import Data.Vec as Vec using (_∷_) +import Data.Vec.Properties as Vec +import Data.List.Properties as List +import Data.List.NonEmpty as List⁺ +open import Data.Product using (_,_) +open import Function using (_∘_) +import Relation.Binary.PropositionalEquality as Eq +open import Size using (Size; ∞) + +open import Vatras.Data.EqIndexedSet using (≅-sym; ≅[]→≅) +open import Vatras.Framework.Variants using (Rose) +import Vatras.Util.List as List +open import Vatras.Util.Nat.AtLeast using (ℕ≥; sucs) +import Vatras.Util.Vec as Vec +open import Vatras.Lang.All.Fixed F (Rose ∞) +open import Vatras.Framework.Compiler using (LanguageCompiler) +open import Vatras.Translation.LanguageMap using (NCC→CCC) +open import Vatras.Succinctness.ProofDefinition (Rose ∞) using (_≤ₛ_) +open import Vatras.Succinctness.Sizes using (SizedNCC; sizeNCC; SizedCCC; sizeCCC) + +lemma : ∀ {i : Size} {A : 𝔸} (n : ℕ≥ 2) (ncc : NCC.NCC n i A) → sizeCCC (LanguageCompiler.compile (NCC→CCC n) ncc) ≤ sizeNCC n ncc +lemma {A = A} (sucs n) (a NCC.NCC.-< cs >-) = + begin + sizeCCC (LanguageCompiler.compile (NCC→CCC (sucs n)) (a NCC.NCC.-< cs >-)) + ≡⟨⟩ + sizeCCC (a CCC.CCC.-< List.map (LanguageCompiler.compile (NCC→CCC (sucs n))) cs >-) + ≡⟨⟩ + suc (atomSize A a + List.sum (List.map sizeCCC (List.map (LanguageCompiler.compile (NCC→CCC (sucs n))) cs))) + ≡⟨ Eq.cong (λ x → suc (atomSize A a + List.sum x)) (List.map-∘ cs) ⟨ + suc (atomSize A a + List.sum (List.map (sizeCCC ∘ LanguageCompiler.compile (NCC→CCC (sucs n))) cs)) + ≤⟨ s≤s (ℕ.+-monoʳ-≤ (atomSize A a) (List.sum-map-≤ (sizeCCC ∘ LanguageCompiler.compile (NCC→CCC (sucs n))) (sizeNCC (sucs n)) cs (lemma (sucs n)))) ⟩ + suc (atomSize A a + List.sum (List.map (sizeNCC (sucs n)) cs)) + ≡⟨⟩ + sizeNCC (sucs n) (a NCC.NCC.-< cs >-) + ∎ + where + open ℕ.≤-Reasoning +lemma (sucs n) (D NCC.NCC.⟨ c ∷ cs ⟩) = + begin + sizeCCC (LanguageCompiler.compile (NCC→CCC (sucs n)) (D NCC.NCC.⟨ c ∷ cs ⟩)) + ≡⟨⟩ + sizeCCC (D CCC.⟨ List⁺.fromVec (Vec.map (LanguageCompiler.compile (NCC→CCC (sucs n))) (c ∷ cs)) ⟩) + ≡⟨⟩ + suc (List.sum (List.map sizeCCC (List⁺.toList (List⁺.fromVec (Vec.map (LanguageCompiler.compile (NCC→CCC (sucs n))) (c ∷ cs)))))) + ≡⟨⟩ + suc (List.sum (List.map sizeCCC (Vec.toList (Vec.map (LanguageCompiler.compile (NCC→CCC (sucs n))) (c ∷ cs))))) + ≡⟨ Eq.cong (λ x → suc (List.sum (List.map sizeCCC x))) (Vec.toList-map (LanguageCompiler.compile (NCC→CCC (sucs n))) (c ∷ cs)) ⟩ + suc (List.sum (List.map sizeCCC (List.map (LanguageCompiler.compile (NCC→CCC (sucs n))) (Vec.toList (c ∷ cs))))) + ≡⟨ Eq.cong (λ x → suc (List.sum x)) (List.map-∘ (Vec.toList (c ∷ cs))) ⟨ + suc (List.sum (List.map (sizeCCC ∘ LanguageCompiler.compile (NCC→CCC (sucs n))) (Vec.toList (c ∷ cs)))) + ≤⟨ s≤s (List.sum-map-≤ (sizeCCC ∘ LanguageCompiler.compile (NCC→CCC (sucs n))) (sizeNCC (sucs n)) (Vec.toList (c ∷ cs)) (lemma (sucs n))) ⟩ + suc (List.sum (List.map (sizeNCC (sucs n)) (Vec.toList (c ∷ cs)))) + ≡⟨ Eq.cong (λ x → suc (List.sum x)) (Vec.toList-map (sizeNCC (sucs n)) (c ∷ cs)) ⟨ + suc (List.sum (Vec.toList (Vec.map (sizeNCC (sucs n)) (c ∷ cs)))) + ≡⟨ Eq.cong suc (Vec.sum-toList (Vec.map (sizeNCC (sucs n)) (c ∷ cs))) ⟩ + suc (Vec.sum (Vec.map (sizeNCC (sucs n)) (c ∷ cs))) + ≡⟨⟩ + sizeNCC (sucs n) (D NCC.NCC.⟨ c ∷ cs ⟩) + ∎ + where + open ℕ.≤-Reasoning + +CCC≤NCC : (n : ℕ≥ 2) → SizedCCC F ≤ₛ SizedNCC F n +CCC≤NCC n = 1 , λ A ncc ncc-translatable → LanguageCompiler.compile (NCC→CCC n) ncc , ≅-sym (≅[]→≅ (LanguageCompiler.preserves (NCC→CCC n) ncc)) , Eq.subst (sizeCCC (LanguageCompiler.compile (NCC→CCC n) ncc )≤_) (Eq.sym (ℕ.+-identityʳ (sizeNCC n ncc))) (lemma n ncc) diff --git "a/src/Vatras/Succinctness/Relations/NADT\342\211\244ADT.agda" "b/src/Vatras/Succinctness/Relations/NADT\342\211\244ADT.agda" new file mode 100644 index 00000000..8e2b20cb --- /dev/null +++ "b/src/Vatras/Succinctness/Relations/NADT\342\211\244ADT.agda" @@ -0,0 +1,94 @@ +open import Data.Nat using (ℕ; suc; _+_; _≟_; s≤s) +open import Vatras.Framework.Definitions using (𝔽; 𝔸; 𝕍) + +module Vatras.Succinctness.Relations.NADT≤ADT (F : 𝔽) (V : 𝕍) (sizeV : ∀ {A : 𝔸} → V A → ℕ) (sizeV : ∀ {A : 𝔸} → V A → ℕ) where + +open import Data.Bool using (true; false; if_then_else_) +open import Data.Product using (proj₁; proj₂) renaming (_,_ to _and_) +open import Data.List using ([]; _∷_) +open import Data.List.NonEmpty as List⁺ using (_∷_) +import Data.Nat.Properties as ℕ +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl) +open import Relation.Nullary.Decidable using (yes; no) +open import Size using (∞) + +open import Vatras.Util.List as List using (find-or-last) +open import Vatras.Data.EqIndexedSet using (_≅[_][_]_; _⊆[_]_; ≅[]→≅) +open import Vatras.Succinctness.ProofDefinition V using (_≤ₛ_) +open import Vatras.Succinctness.Sizes using (SizedNADT; sizeNADT; SizedADT; sizeADT) +open import Vatras.Lang.All.Fixed F V +open ADT using (ADT; _⟨_,_⟩; leaf) +open NADT using (NADT; _⟨_⟩; leaf) + +open import Vatras.Translation.Lang.ADT-to-VariantList using () + +translate : ∀ {A : 𝔸} → ADT A → NADT ∞ A +translate (leaf v) = leaf v +translate (f ⟨ l , r ⟩) = f ⟨ translate l ∷ translate r ∷ [] ⟩ + +conf : NADT.Configuration → ADT.Configuration +conf config f with config f ≟ 0 +conf config f | yes _ = true +conf config f | no _ = false + +fnoc : ADT.Configuration → NADT.Configuration +fnoc config f = if config f then 0 else 1 + +translate-preserves-⊆ : ∀ {A : 𝔸} → (adt : ADT A) → NADT.⟦ translate adt ⟧ ⊆[ conf ] ADT.⟦ adt ⟧ +translate-preserves-⊆ (leaf v) config = refl +translate-preserves-⊆ (f ⟨ l , r ⟩) config with config f ≟ 0 +translate-preserves-⊆ (f ⟨ l , r ⟩) config | yes config-f≡0 = + NADT.⟦ find-or-last (config f) (translate l ∷ translate r ∷ []) ⟧ config + ≡⟨ Eq.cong (λ x → NADT.⟦ find-or-last x (translate l ∷ translate r ∷ []) ⟧ config) config-f≡0 ⟩ + NADT.⟦ find-or-last 0 (translate l ∷ translate r ∷ []) ⟧ config + ≡⟨⟩ + NADT.⟦ translate l ⟧ config + ≡⟨ translate-preserves-⊆ l config ⟩ + ADT.⟦ l ⟧ (conf config) + ≡⟨⟩ + (if true then ADT.⟦ l ⟧ (conf config) else ADT.⟦ r ⟧ (conf config)) + ∎ + where + open Eq.≡-Reasoning +translate-preserves-⊆ (f ⟨ l , r ⟩) config | no config-f≢0 = + NADT.⟦ find-or-last (config f) (translate l ∷ translate r ∷ []) ⟧ config + ≡⟨ Eq.cong (λ x → NADT.⟦ x ⟧ config) (List.find-or-last-last (config f) (translate l ∷ translate r ∷ []) (s≤s (ℕ.n≢0⇒n>0 config-f≢0))) ⟩ + NADT.⟦ List⁺.last (translate l ∷ translate r ∷ []) ⟧ config + ≡⟨⟩ + NADT.⟦ translate r ⟧ config + ≡⟨ translate-preserves-⊆ r config ⟩ + ADT.⟦ r ⟧ (conf config) + ≡⟨⟩ + (if false then ADT.⟦ l ⟧ (conf config) else ADT.⟦ r ⟧ (conf config)) + ∎ + where + open Eq.≡-Reasoning + +translate-preserves-⊇ : ∀ {A : 𝔸} → (adt : ADT A) → ADT.⟦ adt ⟧ ⊆[ fnoc ] NADT.⟦ translate adt ⟧ +translate-preserves-⊇ (leaf v) config = refl +translate-preserves-⊇ (f ⟨ l , r ⟩) config with config f +translate-preserves-⊇ (f ⟨ l , r ⟩) config | true = translate-preserves-⊇ l config +translate-preserves-⊇ (f ⟨ l , r ⟩) config | false = translate-preserves-⊇ r config + +translate-preserves : ∀ {A : 𝔸} → (adt : ADT A) → NADT.⟦ translate adt ⟧ ≅[ conf ][ fnoc ] ADT.⟦ adt ⟧ +translate-preserves adt = translate-preserves-⊆ adt and translate-preserves-⊇ adt + +lemma : ∀ {A : 𝔸} → (adt : ADT A) → sizeNADT sizeV (translate adt) ≡ sizeADT sizeV adt +lemma (leaf v) = refl +lemma (f ⟨ l , r ⟩) = + sizeNADT sizeV (translate (f ⟨ l , r ⟩)) + ≡⟨⟩ + suc (sizeNADT sizeV (translate l) + (sizeNADT sizeV (translate r) + 0)) + ≡⟨ Eq.cong (λ x → suc (sizeNADT sizeV (translate l) + x)) (ℕ.+-identityʳ (sizeNADT sizeV (translate r))) ⟩ + suc (sizeNADT sizeV (translate l) + sizeNADT sizeV (translate r)) + ≡⟨ Eq.cong₂ (λ x y → suc (x + y)) (lemma l) (lemma r) ⟩ + suc (sizeADT sizeV l + sizeADT sizeV r) + ≡⟨⟩ + sizeADT sizeV (f ⟨ l , r ⟩) + ∎ + where + open Eq.≡-Reasoning + +NADT≤ADT : SizedNADT F V sizeV ≤ₛ SizedADT F V sizeV +NADT≤ADT .proj₁ = 1 +NADT≤ADT .proj₂ A e₂ e₂-translatable = translate e₂ and ≅[]→≅ (translate-preserves e₂) and ℕ.≤-reflexive (Eq.trans (lemma e₂) (Eq.sym (ℕ.+-identityʳ (sizeADT sizeV e₂)))) diff --git "a/src/Vatras/Succinctness/Relations/NADT\342\211\244VariantList.agda" "b/src/Vatras/Succinctness/Relations/NADT\342\211\244VariantList.agda" new file mode 100644 index 00000000..9440d90d --- /dev/null +++ "b/src/Vatras/Succinctness/Relations/NADT\342\211\244VariantList.agda" @@ -0,0 +1,105 @@ +open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _≤_; _>_; z≤n; s≤s) +open import Vatras.Framework.Definitions using (𝔽; 𝔸; 𝕍) + +module Vatras.Succinctness.Relations.NADT≤VariantList (F : 𝔽) (V : 𝕍) (sizeV : ∀ {A : 𝔸} → V A → ℕ) (sizeV>0 : ∀ {A} (v : V A) → sizeV v > 0) (f : F) where + +open import Data.Product using (_,_; proj₁; proj₂) +import Data.Nat.Properties as ℕ +open import Data.List using ([]; _∷_; map; sum; length) +import Data.List.Properties as List +open import Data.List.NonEmpty as List⁺ using (List⁺; _∷_) +import Relation.Binary.PropositionalEquality as Eq +open import Function using (const; _∘_) +open import Size using (∞) + +open import Vatras.Data.EqIndexedSet using (_≅[_][_]_; _⊆[_]_; ≅[]→≅) +open import Vatras.Util.List as List using (find-or-last) +open import Vatras.Succinctness.ProofDefinition V using (_≤ₛ_) +open import Vatras.Succinctness.Sizes using (SizedVariantList; sizeVariantList; SizedNADT; sizeNADT) +open import Vatras.Lang.All.Fixed F V +open VariantList using (VariantList) +open NADT using (NADT; _⟨_⟩; leaf) + +translate : ∀ {A : 𝔸} → VariantList A → NADT ∞ A +translate vs = f ⟨ List⁺.map leaf vs ⟩ + +translate-preserves-⊆ : ∀ {A : 𝔸} → (vs : VariantList A) → NADT.⟦ translate vs ⟧ ⊆[ (λ c → c f) ] VariantList.⟦ vs ⟧ +translate-preserves-⊆ vs config = + NADT.⟦ translate vs ⟧ config + ≡⟨⟩ + NADT.⟦ find-or-last (config f) (List⁺.map leaf vs) ⟧ config + ≡⟨ Eq.cong (λ x → NADT.⟦ x ⟧ config) (List.map-find-or-last leaf (config f) vs) ⟨ + NADT.⟦ leaf (find-or-last (config f) vs) ⟧ config + ≡⟨⟩ + find-or-last (config f) vs + ≡⟨⟩ + VariantList.⟦ vs ⟧ (config f) + ∎ + where + open Eq.≡-Reasoning + +translate-preserves-⊇ : ∀ {A : 𝔸} → (vs : VariantList A) → VariantList.⟦ vs ⟧ ⊆[ const ] NADT.⟦ translate vs ⟧ +translate-preserves-⊇ vs i = + VariantList.⟦ vs ⟧ i + ≡⟨⟩ + find-or-last i vs + ≡⟨⟩ + NADT.⟦ leaf (find-or-last i vs) ⟧ (const i) + ≡⟨ Eq.cong (λ x → NADT.⟦ x ⟧ (const i)) (List.map-find-or-last leaf i vs) ⟩ + NADT.⟦ find-or-last i (List⁺.map leaf vs) ⟧ (const i) + ≡⟨⟩ + NADT.⟦ translate vs ⟧ (const i) + ∎ + where + open Eq.≡-Reasoning + +translate-preserves : ∀ {A : 𝔸} → (vs : VariantList A) → NADT.⟦ translate vs ⟧ ≅[ (λ c → c f) ][ const ] VariantList.⟦ vs ⟧ +translate-preserves vs = translate-preserves-⊆ vs , translate-preserves-⊇ vs + +lemma : ∀ {A : 𝔸} (vs : VariantList A) → sizeNADT sizeV (translate vs) ≤ 3 * sizeVariantList {V} sizeV vs +lemma {A} vs = + begin + sizeNADT sizeV (translate vs) + ≡⟨⟩ + suc (sum (map (sizeNADT sizeV) (List⁺.toList (List⁺.map leaf vs)))) + ≡⟨⟩ + suc (sum (map (sizeNADT sizeV) (map leaf (List⁺.toList vs)))) + ≡⟨ Eq.cong (λ x → suc (sum x)) (List.map-∘ {g = sizeNADT sizeV} {f = leaf} (List⁺.toList vs)) ⟨ + suc (sum (map (sizeNADT sizeV ∘ leaf) (List⁺.toList vs))) + ≡⟨⟩ + suc (sum (map (λ v → suc (sizeV v)) (List⁺.toList vs))) + ≡⟨ Eq.cong (λ x → suc (sum x)) (List.map-∘ {g = suc} (List⁺.toList vs)) ⟩ + suc (sum (map suc (map sizeV (List⁺.toList vs)))) + ≡⟨ Eq.cong suc (List.sum-+ 1 (map sizeV (List⁺.toList vs))) ⟩ + suc (1 * length (map sizeV (List⁺.toList vs)) + sum (map sizeV (List⁺.toList vs))) + ≡⟨ Eq.cong (λ x → suc (x + sum (map sizeV (List⁺.toList vs)))) (ℕ.*-identityˡ (length (map sizeV (List⁺.toList vs)))) ⟩ + suc (length (map sizeV (List⁺.toList vs)) + sum (map sizeV (List⁺.toList vs))) + ≡⟨ Eq.cong (λ x → suc (x + sum (map sizeV (List⁺.toList vs)))) (List.length-map sizeV (List⁺.toList vs)) ⟩ + suc (List⁺.length vs + sum (map sizeV (List⁺.toList vs))) + ≡⟨⟩ + 1 + List⁺.length vs + sum (map sizeV (List⁺.toList vs)) + ≤⟨ ℕ.+-monoˡ-≤ (sum (map sizeV (List⁺.toList vs))) (ℕ.+-monoˡ-≤ (List⁺.length vs) (s≤s (z≤n {length (List⁺.tail vs)}))) ⟩ + List⁺.length vs + List⁺.length vs + sum (map sizeV (List⁺.toList vs)) + ≡⟨ Eq.cong (λ x → (List⁺.length vs + x) + sum (map sizeV (List⁺.toList vs))) (ℕ.+-identityʳ (List⁺.length vs)) ⟨ + List⁺.length vs + (List⁺.length vs + 0) + sum (map sizeV (List⁺.toList vs)) + ≡⟨⟩ + 2 * List⁺.length vs + sum (map sizeV (List⁺.toList vs)) + ≡⟨ Eq.cong (λ x → 2 * x + sum (map sizeV (List⁺.toList vs))) (ℕ.*-identityˡ (List⁺.length vs)) ⟨ + 2 * (1 * List⁺.length vs) + sum (map sizeV (List⁺.toList vs)) + ≡⟨ Eq.cong (λ x → 2 * x + sum (map sizeV (List⁺.toList vs))) (List.sum-map-const 1 (List⁺.toList vs)) ⟨ + 2 * sum (map (const 1) (List⁺.toList vs)) + sum (map sizeV (List⁺.toList vs)) + ≤⟨ ℕ.+-monoˡ-≤ (sum (map sizeV (List⁺.toList vs))) (ℕ.*-monoʳ-≤ 2 (List.sum-map-≤ (const 1) sizeV (List⁺.toList vs) sizeV>0)) ⟩ + 2 * sum (map sizeV (List⁺.toList vs)) + sum (map sizeV (List⁺.toList vs)) + ≡⟨ Eq.cong (2 * sum (map sizeV (List⁺.toList vs)) +_) (ℕ.*-identityˡ (sum (map sizeV (List⁺.toList vs)))) ⟨ + 2 * sum (map sizeV (List⁺.toList vs)) + 1 * sum (map sizeV (List⁺.toList vs)) + ≡⟨ ℕ.*-distribʳ-+ (sum (map sizeV (List⁺.toList vs))) 2 1 ⟨ + 3 * sum (map sizeV (List⁺.toList vs)) + ≡⟨⟩ + 3 * sizeVariantList {V} sizeV vs + ∎ + where + open ℕ.≤-Reasoning + +NADT≤VariantList : SizedNADT F V sizeV ≤ₛ SizedVariantList V sizeV +NADT≤VariantList .proj₁ = 3 +NADT≤VariantList .proj₂ A vs vs-translatable = translate vs , ≅[]→≅ (translate-preserves vs) , lemma {A} vs diff --git "a/src/Vatras/Succinctness/Relations/PropOC\342\211\244OC.agda" "b/src/Vatras/Succinctness/Relations/PropOC\342\211\244OC.agda" new file mode 100644 index 00000000..2181860a --- /dev/null +++ "b/src/Vatras/Succinctness/Relations/PropOC\342\211\244OC.agda" @@ -0,0 +1,89 @@ +open import Vatras.Framework.Definitions using (𝔽; 𝔸; atomSize) + +module Vatras.Succinctness.Relations.PropOC≤OC (F : 𝔽) where + +import Data.List as List +import Data.List.Properties as List +open import Data.Nat using (_+_; _*_; _≤_; z≤n; s≤s) +import Data.Nat.Properties as ℕ +open import Data.Product using (_,_) +open import Function using (_∘_) +open import Size using (Size; ∞) +import Relation.Binary.PropositionalEquality as Eq + +import Vatras.Util.List as List +open import Vatras.Data.EqIndexedSet using (≅[]→≅) +open import Vatras.Data.Prop using (var) +open import Vatras.Framework.Variants as V using (Rose) +open import Vatras.Succinctness.Sizes using (sizeProp; SizedWFOC; sizeOC; sizeWFOC; SizedWFPropOC; sizePropOC; sizeWFPropOC) +open import Vatras.Succinctness.ProofDefinition (Rose ∞) using (_≤ₛ_) +import Vatras.Lang.All +open Vatras.Lang.All.OC using (OC; WFOC; Root; _-<_>-; _❲_❳) +open import Vatras.Translation.Lang.OC-to-PropOC F using (translate; translate'; translate-preserves) + +prop-oc≤oc : ∀ {i : Size} {A : 𝔸} (oc : OC F i A) → sizePropOC (translate' oc) ≤ 2 * sizeOC oc +prop-oc≤oc {A = A} (a -< cs >-) = + begin + sizePropOC (translate' (a -< cs >-)) + ≡⟨⟩ + 1 + (atomSize A a + List.sum (List.map sizePropOC (List.map translate' cs))) + ≡⟨ Eq.cong (λ x → 1 + (atomSize A a + List.sum x)) (List.map-∘ cs) ⟨ + 1 + (atomSize A a + List.sum (List.map (sizePropOC ∘ translate') cs)) + ≤⟨ ℕ.+-monoʳ-≤ 1 (ℕ.+-monoʳ-≤ (atomSize A a) (List.sum-map-≤ (sizePropOC ∘ translate') ((2 *_) ∘ sizeOC) cs prop-oc≤oc)) ⟩ + 1 + (atomSize A a + List.sum (List.map ((2 *_) ∘ sizeOC) cs)) + ≡⟨ Eq.cong (λ x → 1 + (atomSize A a + List.sum x)) (List.map-∘ cs) ⟩ + 1 + (atomSize A a + List.sum (List.map (2 *_) (List.map sizeOC cs))) + ≡⟨ Eq.cong (λ x → 1 + (atomSize A a + x)) (List.sum-* 2 (List.map sizeOC cs)) ⟩ + 1 + (atomSize A a + 2 * List.sum (List.map sizeOC cs)) + ≡⟨ Eq.cong (λ x → 1 + (x + 2 * List.sum (List.map sizeOC cs))) (ℕ.*-identityˡ (atomSize A a)) ⟨ + 1 + (1 * atomSize A a + 2 * List.sum (List.map sizeOC cs)) + ≤⟨ ℕ.+-monoʳ-≤ 1 (ℕ.+-monoˡ-≤ (2 * List.sum (List.map sizeOC cs)) (ℕ.*-monoˡ-≤ (atomSize A a) (s≤s (z≤n {1})))) ⟩ + 1 + (2 * atomSize A a + 2 * List.sum (List.map sizeOC cs)) + ≤⟨ ℕ.+-monoˡ-≤ (2 * atomSize A a + 2 * List.sum (List.map sizeOC cs)) (s≤s (z≤n {1})) ⟩ + 2 + (2 * atomSize A a + 2 * List.sum (List.map sizeOC cs)) + ≡⟨ Eq.cong (2 +_) (ℕ.*-distribˡ-+ 2 (atomSize A a) (List.sum (List.map sizeOC cs))) ⟨ + 2 + 2 * (atomSize A a + List.sum (List.map sizeOC cs)) + ≡⟨ ℕ.*-distribˡ-+ 2 1 (atomSize A a + List.sum (List.map sizeOC cs)) ⟨ + 2 * (1 + (atomSize A a + List.sum (List.map sizeOC cs))) + ≡⟨⟩ + 2 * sizeOC (a -< cs >-) + ∎ + where + open ℕ.≤-Reasoning +prop-oc≤oc (prop ❲ c ❳) = + begin + sizePropOC (translate' (prop ❲ c ❳)) + ≡⟨⟩ + 1 + (sizeProp (var prop) + sizePropOC (translate' c)) + ≡⟨⟩ + 2 + sizePropOC (translate' c) + ≤⟨ ℕ.+-monoʳ-≤ 2 (prop-oc≤oc c) ⟩ + 2 + 2 * sizeOC c + ≡⟨ ℕ.*-distribˡ-+ 2 1 (sizeOC c) ⟨ + 2 * (1 + sizeOC c) + ≡⟨⟩ + 2 * sizeOC (prop ❲ c ❳) + ∎ + where + open ℕ.≤-Reasoning + +wf-prop-oc≤wf-oc : ∀ {i : Size} {A : 𝔸} (oc : WFOC F i A) → sizeWFPropOC (translate oc) ≤ 2 * sizeWFOC oc +wf-prop-oc≤wf-oc {A = A} (Root a cs) = + begin + sizeWFPropOC (translate (Root a cs)) + ≡⟨⟩ + 1 + (atomSize A a + List.sum (List.map sizePropOC (List.map translate' cs))) + ≡⟨⟩ + sizePropOC (translate' (a -< cs >-)) + ≤⟨ prop-oc≤oc (a -< cs >-) ⟩ + 2 * sizeOC (a -< cs >-) + ≡⟨⟩ + 2 * (1 + (atomSize A a + List.sum (List.map sizeOC cs))) + ≡⟨⟩ + 2 * sizeWFOC (Root a cs) + ∎ + where + open ℕ.≤-Reasoning + +WFPropOC≤ₛWFOC : SizedWFPropOC F ≤ₛ SizedWFOC F +WFPropOC≤ₛWFOC = 2 , λ A oc oc-translatable → translate oc , ≅[]→≅ (translate-preserves oc) , wf-prop-oc≤wf-oc oc diff --git "a/src/Vatras/Succinctness/Relations/VariantList\342\211\244ADT.agda" "b/src/Vatras/Succinctness/Relations/VariantList\342\211\244ADT.agda" new file mode 100644 index 00000000..7fb2c89e --- /dev/null +++ "b/src/Vatras/Succinctness/Relations/VariantList\342\211\244ADT.agda" @@ -0,0 +1,123 @@ +open import Data.Nat using (ℕ; suc; _+_; _≤_; s≤s) +open import Relation.Binary using (DecidableEquality) +open import Vatras.Framework.Definitions using (𝔽; 𝔸; 𝕍) + +module Vatras.Succinctness.Relations.VariantList≤ADT + (F : 𝔽) + (V : 𝕍) + (_==_ : DecidableEquality F) + (sizeV : ∀ {A : 𝔸} → V A → ℕ) + where + +open import Data.Bool using (true; false; if_then_else_) +import Data.Bool.Properties as Bool +open import Data.List as List using ([]; _∷_) +import Data.List.Properties as List +open import Data.List.NonEmpty as List⁺ using (_⁺++⁺_) +import Data.List.NonEmpty.Properties as List⁺ +open import Data.Product using (_,_; proj₁; proj₂) +import Data.Nat.Properties as ℕ +import Relation.Binary.PropositionalEquality as Eq +open import Relation.Nullary.Decidable using (yes; no) + +open import Vatras.Util.AuxProofs using (Predicate-if) +import Vatras.Util.List as List +open import Vatras.Data.EqIndexedSet using (≅-sym; ≅[]→≅) +open import Vatras.Framework.Compiler using (LanguageCompiler) +open import Vatras.Succinctness.ProofDefinition V using (_≤ₛ_) +open import Vatras.Succinctness.Sizes using (SizedVariantList; sizeVariantList; SizedADT; sizeADT) + +open import Vatras.Lang.All.Fixed F V +open ADT using (ADT; leaf; _⟨_,_⟩) +open VariantList using (VariantList) + +open import Vatras.Lang.ADT.Path F V _==_ using (Path; _↣_; getValue; _∈?_) +open import Vatras.Translation.Lang.ADT.DeadElim F V _==_ using (kill-dead-below; kill-dead) +open import Vatras.Translation.Lang.ADT-to-VariantList F V _==_ using (ADT→VariantList; tr; tr-undead) + +size-kill-dead : ∀ {A : 𝔸} (defined : Path) (adt : ADT A) → sizeADT sizeV (kill-dead-below defined adt) ≤ sizeADT sizeV adt +size-kill-dead defined (leaf v) = ℕ.≤-refl +size-kill-dead defined (D ⟨ l , r ⟩) with D ∈? defined +size-kill-dead defined (D ⟨ l , r ⟩) | yes D∈defined = + begin + sizeADT sizeV (if getValue D∈defined then kill-dead-below defined l else kill-dead-below defined r) + ≡⟨ Bool.if-float (sizeADT sizeV) (getValue D∈defined) ⟩ + (if getValue D∈defined then sizeADT sizeV (kill-dead-below defined l) else sizeADT sizeV (kill-dead-below defined r)) + ≤⟨ Predicate-if (_≤ _) (getValue D∈defined) + (ℕ.≤-trans (size-kill-dead defined l) (ℕ.m≤m+n (sizeADT sizeV l) (sizeADT sizeV r))) + (ℕ.≤-trans (size-kill-dead defined r) (ℕ.m≤n+m (sizeADT sizeV r) (sizeADT sizeV l))) + ⟩ + sizeADT sizeV l + sizeADT sizeV r + <⟨ ℕ.n<1+n (sizeADT sizeV l + sizeADT sizeV r) ⟩ + suc (sizeADT sizeV l + sizeADT sizeV r) + ≡⟨⟩ + sizeADT sizeV (D ⟨ l , r ⟩) + ∎ + where + open ℕ.≤-Reasoning +size-kill-dead defined (D ⟨ l , r ⟩) | no D∉defined = + begin + sizeADT sizeV (D ⟨ kill-dead-below (D ↣ true ∷ defined) l , kill-dead-below (D ↣ false ∷ defined) r ⟩) + ≡⟨⟩ + suc (sizeADT sizeV (kill-dead-below (D ↣ true ∷ defined) l) + sizeADT sizeV (kill-dead-below (D ↣ false ∷ defined) r)) + ≤⟨ s≤s (ℕ.+-mono-≤ (size-kill-dead (D ↣ true ∷ defined) l) (size-kill-dead (D ↣ false ∷ defined) r)) ⟩ + suc (sizeADT sizeV l + sizeADT sizeV r) + ≡⟨⟩ + sizeADT sizeV (D ⟨ l , r ⟩) + ∎ + where + open ℕ.≤-Reasoning + +size-tr : ∀ {A : 𝔸} (adt : ADT A) → sizeVariantList {V} sizeV (tr adt) ≤ sizeADT sizeV adt +size-tr (leaf v) = + begin + sizeVariantList {V} sizeV (tr (leaf v)) + ≡⟨⟩ + sizeV v + 0 + ≡⟨ ℕ.+-identityʳ (sizeV v) ⟩ + sizeV v + <⟨ ℕ.n<1+n (sizeV v) ⟩ + 1 + sizeV v + ≡⟨⟩ + sizeADT sizeV (leaf v) + ∎ + where + open ℕ.≤-Reasoning +size-tr (f ⟨ l , r ⟩) = + begin + sizeVariantList {V} sizeV (tr (f ⟨ l , r ⟩)) + ≡⟨⟩ + sizeVariantList {V} sizeV (tr l ⁺++⁺ tr r) + ≡⟨⟩ + List.sum (List⁺.toList (List⁺.map sizeV (tr l ⁺++⁺ tr r))) + ≡⟨ Eq.cong (λ x → List.sum (List⁺.toList x)) (List⁺.map-⁺++⁺ sizeV (tr l) (tr r)) ⟩ + List.sum (List⁺.toList (List⁺.map sizeV (tr l) ⁺++⁺ List⁺.map sizeV (tr r))) + ≡⟨ List.sum-++ (List⁺.toList (List⁺.map sizeV (tr l))) (List⁺.toList (List⁺.map sizeV (tr r))) ⟩ + List.sum (List⁺.toList (List⁺.map sizeV (tr l))) + List.sum (List⁺.toList (List⁺.map sizeV (tr r))) + ≡⟨⟩ + sizeVariantList {V} sizeV (tr l) + sizeVariantList {V} sizeV (tr r) + ≤⟨ ℕ.+-mono-≤ (size-tr l) (size-tr r) ⟩ + sizeADT sizeV l + sizeADT sizeV r + <⟨ ℕ.n<1+n (sizeADT sizeV l + sizeADT sizeV r) ⟩ + suc (sizeADT sizeV l + sizeADT sizeV r) + ≡⟨⟩ + sizeADT sizeV (f ⟨ l , r ⟩) + ∎ + where + open ℕ.≤-Reasoning + +size-tr-kill-dead : ∀ {A : 𝔸} (adt : ADT A) → sizeVariantList {V} sizeV (tr-undead (kill-dead adt)) ≤ sizeADT sizeV adt +size-tr-kill-dead adt = + begin + sizeVariantList {V} sizeV (tr-undead (kill-dead adt)) + ≤⟨ size-tr (kill-dead-below [] adt) ⟩ + sizeADT sizeV (kill-dead-below [] adt) + ≤⟨ size-kill-dead [] adt ⟩ + sizeADT sizeV adt + ∎ + where + open ℕ.≤-Reasoning + +VariantList≤ADT : SizedVariantList V sizeV ≤ₛ SizedADT F V sizeV +VariantList≤ADT .proj₁ = 1 +VariantList≤ADT .proj₂ A e₂ e₂-translatable = LanguageCompiler.compile ADT→VariantList e₂ , ≅-sym (≅[]→≅ (LanguageCompiler.preserves ADT→VariantList e₂)) , ℕ.≤-trans (size-tr-kill-dead e₂) (ℕ.≤-reflexive (Eq.sym (ℕ.+-identityʳ (sizeADT sizeV e₂)))) diff --git a/src/Vatras/Succinctness/Sizes.agda b/src/Vatras/Succinctness/Sizes.agda new file mode 100644 index 00000000..da75aa1d --- /dev/null +++ b/src/Vatras/Succinctness/Sizes.agda @@ -0,0 +1,149 @@ +open import Vatras.Framework.Definitions using (𝔽; 𝕍; 𝔸; atoms; atomSize) +module Vatras.Succinctness.Sizes where + +open import Data.Nat using (ℕ; suc; zero; _+_; _>_; s≤s; z≤n) +import Data.List as List +import Data.List.NonEmpty as List⁺ +import Data.Vec as Vec +open import Function using (_∘_) +open import Size using (Size; ∞) + +open import Vatras.Data.Prop using (Prop; true; false; var; ¬_; _∧_) +open import Vatras.Util.Nat.AtLeast using (ℕ≥) +open import Vatras.Framework.VariabilityLanguage using (VariabilityLanguage; Expression) +open import Vatras.Framework.Variants using (Rose) +open import Vatras.Lang.All + +record SizedLang (V : 𝕍) : Set₂ where + field + Lang : VariabilityLanguage V + size : {A : 𝔸} → Expression Lang A → ℕ +open SizedLang public + +sizeRose : ∀ {i : Size} {A : 𝔸} → Rose i A → ℕ +sizeRose {A = A} (a Rose.-< cs >-) = suc (atomSize A a + List.sum (List.map sizeRose cs)) + +sizeRose>0 : ∀ {i : Size} {A : 𝔸} → (v : Rose i A) → sizeRose v > 0 +sizeRose>0 {A = A} (a Rose.-< cs >-) = s≤s z≤n + +size2CC : ∀ {F : 𝔽} {i : Size} {A : 𝔸} → 2CC.2CC F i A → ℕ +size2CC {A = A} (a 2CC.2CC.-< cs >-) = suc (atomSize A a + List.sum (List.map size2CC cs)) +size2CC (D 2CC.2CC.⟨ l , r ⟩) = suc (size2CC l + size2CC r) + +size2CC>0 : ∀ {F : 𝔽} {i : Size} {A : 𝔸} → (2cc : 2CC.2CC F i A) → size2CC 2cc > 0 +size2CC>0 (a 2CC.-< cs >-) = s≤s z≤n +size2CC>0 (D 2CC.⟨ l , r ⟩) = s≤s z≤n + +Sized2CC : 𝔽 → SizedLang (Rose ∞) +Sized2CC F = record + { Lang = 2CC.2CCL F + ; size = size2CC + } + +sizeNCC : ∀ {F : 𝔽} {i : Size} {A : 𝔸} (n : ℕ≥ 2) → NCC.NCC F n i A → ℕ +sizeNCC {A = A} n (a NCC.NCC.-< cs >-) = suc (atomSize A a + List.sum (List.map (sizeNCC n) cs)) +sizeNCC n (D NCC.NCC.⟨ cs ⟩) = suc (Vec.sum (Vec.map (sizeNCC n) cs)) + +SizedNCC : 𝔽 → ℕ≥ 2 → SizedLang (Rose ∞) +SizedNCC F n = record + { Lang = NCC.NCCL F n + ; size = sizeNCC n + } + +sizeCCC : ∀ {F : 𝔽} {i : Size} {A : 𝔸} → CCC.CCC F i A → ℕ +sizeCCC {A = A} (a CCC.CCC.-< cs >-) = suc (atomSize A a + List.sum (List.map sizeCCC cs)) +sizeCCC (D CCC.CCC.⟨ cs ⟩) = suc (List.sum (List.map sizeCCC (List⁺.toList cs))) + +sizeCCC>0 : ∀ {F : 𝔽} {i : Size} {A : 𝔸} → (ccc : CCC.CCC F i A) → sizeCCC ccc > 0 +sizeCCC>0 (a CCC.-< cs >-) = s≤s z≤n +sizeCCC>0 (D CCC.⟨ cs ⟩) = s≤s z≤n + +SizedCCC : 𝔽 → SizedLang (Rose ∞) +SizedCCC F = record + { Lang = CCC.CCCL F + ; size = sizeCCC + } + +sizeADT : {F : 𝔽} {V : 𝕍} {A : 𝔸} → ({A : 𝔸} → V A → ℕ) → ADT.ADT F V A → ℕ +sizeADT variantSize (ADT.ADT.leaf v) = suc (variantSize v) +sizeADT variantSize (D ADT.ADT.⟨ l , r ⟩) = suc (sizeADT variantSize l + sizeADT variantSize r) + +sizeADT>0 : {F : 𝔽} {V : 𝕍} → (variantSize : {A : 𝔸} → V A → ℕ) → {A : 𝔸} → (adt : ADT.ADT F V A) → sizeADT variantSize adt > 0 +sizeADT>0 variantSize (ADT.ADT.leaf v) = s≤s z≤n +sizeADT>0 variantSize (D ADT.ADT.⟨ l , r ⟩) = s≤s z≤n + +SizedADT : 𝔽 → (V : 𝕍) → ({A : 𝔸} → V A → ℕ) → SizedLang V +SizedADT F V variantSize = record + { Lang = ADT.ADTL F V + ; size = sizeADT variantSize + } + +sizeNADT : {F : 𝔽} {V : 𝕍} {i : Size} {A : 𝔸} → ({A : 𝔸} → V A → ℕ) → NADT.NADT F V i A → ℕ +sizeNADT variantSize (NADT.NADT.leaf v) = suc (variantSize v) +sizeNADT variantSize (D NADT.NADT.⟨ cs ⟩) = suc (List.sum (List.map (sizeNADT variantSize) (List⁺.toList cs))) + +sizeNADT>0 : {F : 𝔽} {V : 𝕍} → (variantSize : {A : 𝔸} → V A → ℕ) → {A : 𝔸} → {i : Size} → (nadt : NADT.NADT F V i A) → sizeNADT variantSize nadt > 0 +sizeNADT>0 variantSize (NADT.NADT.leaf v) = s≤s z≤n +sizeNADT>0 variantSize (D NADT.NADT.⟨ cs ⟩) = s≤s z≤n + +SizedNADT : 𝔽 → (V : 𝕍) → ({A : 𝔸} → V A → ℕ) → SizedLang V +SizedNADT F V variantSize = record + { Lang = NADT.NADTL F V + ; size = sizeNADT variantSize + } + +sizeVariantList : {V : 𝕍} {A : 𝔸} → ({A : 𝔸} → V A → ℕ) → VariantList.VariantList V A → ℕ +sizeVariantList variantSize l = List.sum (List.map variantSize (List⁺.toList l)) + +SizedVariantList : (V : 𝕍) → ({A : 𝔸} → V A → ℕ) → SizedLang V +SizedVariantList V variantSize = record + { Lang = VariantList.VariantListL V + ; size = sizeVariantList {V = V} variantSize + } + +sizeOC : ∀ {F : 𝔽} {i : Size} {A : 𝔸} → OC.OC F i A → ℕ +sizeOC {A = A} (a OC.-< cs >-) = suc (atomSize A a + List.sum (List.map sizeOC cs)) +sizeOC (D OC.❲ c ❳) = suc (sizeOC c) + +sizeOC>0 : ∀ {F : 𝔽} {i : Size} {A : 𝔸} → (oc : OC.OC F i A) → sizeOC oc > 0 +sizeOC>0 (a OC.-< cs >-) = s≤s z≤n +sizeOC>0 (f OC.❲ c ❳) = s≤s z≤n + +sizeWFOC : ∀ {F : 𝔽} {i : Size} {A : 𝔸} → OC.WFOC F i A → ℕ +sizeWFOC {A = A} (OC.Root a cs) = suc (atomSize A a + List.sum (List.map sizeOC cs)) + +SizedWFOC : 𝔽 → SizedLang (Rose ∞) +SizedWFOC F = record + { Lang = OC.WFOCL F + ; size = sizeWFOC + } + +sizeFST : {F : 𝔽} {A : 𝔸} → FST.Impose.SPL {F} A → ℕ +sizeFST (root FST.Impose.◀ features) = 1 + List.sum (List.map (suc ∘ List.sum ∘ List.map sizeRose ∘ FST.Impose.trees ∘ FST.Impose.impl) features) + +SizedFST : 𝔽 → SizedLang (Rose ∞) +SizedFST F = record + { Lang = FST.FSTL F + ; size = sizeFST + } + + +sizeProp : ∀ {F : 𝔽} → Prop F → ℕ +sizeProp true = 1 +sizeProp false = 1 +sizeProp (var v) = 1 +sizeProp (¬ e) = suc (sizeProp e) +sizeProp (e₁ ∧ e₂) = suc (sizeProp e₁ + sizeProp e₂) + +sizePropOC : ∀ {F : 𝔽} {i : Size} {A : 𝔸} → PropOC.PropOC F i A → ℕ +sizePropOC {A = A} (a PropOC.-< cs >-) = suc (atomSize A a + List.sum (List.map sizePropOC cs)) +sizePropOC (prop PropOC.❲ c ❳) = suc (sizeProp prop + sizePropOC c) + +sizeWFPropOC : ∀ {F : 𝔽} {i : Size} {A : 𝔸} → PropOC.WFPropOC F i A → ℕ +sizeWFPropOC {A = A} (PropOC.Root a cs) = suc (atomSize A a + List.sum (List.map sizePropOC cs)) + +SizedWFPropOC : 𝔽 → SizedLang (Rose ∞) +SizedWFPropOC F = record + { Lang = PropOC.WFPropOCL F + ; size = sizeWFPropOC + } diff --git a/src/Vatras/Test/Examples/CCC.agda b/src/Vatras/Test/Examples/CCC.agda index d840bb75..0b03d271 100644 --- a/src/Vatras/Test/Examples/CCC.agda +++ b/src/Vatras/Test/Examples/CCC.agda @@ -10,14 +10,14 @@ open import Data.Product open import Size using (Size; ∞; ↑_) -open import Vatras.Framework.Definitions using (𝔸; atoms) +open import Vatras.Framework.Definitions using (𝔸; atoms; STRING) open import Vatras.Lang.All open CCC -- use strings as dimensions open import Vatras.Test.Example CCCExample : Set₁ -CCCExample = Example (CCC String ∞ (String , String._≟_)) +CCCExample = Example (CCC String ∞ STRING) -- some smart constructors ccA : ∀ {i : Size} {A : 𝔸} → List⁺ (CCC String i A) → CCC String (↑ i) A diff --git a/src/Vatras/Test/Examples/OC.agda b/src/Vatras/Test/Examples/OC.agda index 85de1a9d..327ab3dd 100644 --- a/src/Vatras/Test/Examples/OC.agda +++ b/src/Vatras/Test/Examples/OC.agda @@ -6,7 +6,7 @@ open import Data.Product using (_,_) open import Size using (Size; ↑_; ∞) -- open import Framework.Annotation.Name using (Option) -open import Vatras.Framework.Definitions using (𝔸; 𝔽) +open import Vatras.Framework.Definitions using (STRING) open import Vatras.Lang.All open OC using (WFOC; Root; _❲_❳; opt; oc-leaf) open import Vatras.Lang.OC.Util using (singleton) @@ -14,7 +14,7 @@ open import Vatras.Lang.OC.Util using (singleton) open import Vatras.Test.Example OCExample : Set₁ -OCExample = Example (WFOC String ∞ (String , String._≟_)) +OCExample = Example (WFOC String ∞ STRING) optex-unary : OCExample optex-unary = "unary" ≔ (Root "r" [ opt "O" (oc-leaf "a") ]) diff --git a/src/Vatras/Test/Examples/Variants.agda b/src/Vatras/Test/Examples/Variants.agda index 1a3989e0..9ed72d37 100644 --- a/src/Vatras/Test/Examples/Variants.agda +++ b/src/Vatras/Test/Examples/Variants.agda @@ -6,19 +6,20 @@ open import Data.Product using (∃-syntax; _,_) open import Data.List using (List; []; _∷_) open import Data.String as String using (String) open import Size using (∞) +open import Vatras.Framework.Definitions using (NAT'; STRING) open import Vatras.Framework.Variants using (Rose; rose-leaf) open import Vatras.Framework.VariantGenerator (Rose ∞) using (VariantGenerator) open import Vatras.Test.Example -𝕍-123 : Example (VariantGenerator (ℕ , ℕ._≟_) 2) +𝕍-123 : Example (VariantGenerator NAT' 2) 𝕍-123 = "123" ≔ set - where set : VariantGenerator (ℕ , ℕ._≟_) 2 + where set : VariantGenerator NAT' 2 set zero = rose-leaf 1 set (suc zero) = rose-leaf 2 set (suc (suc zero)) = rose-leaf 3 -𝕍-lr : Example (VariantGenerator (String , String._≟_) 1) +𝕍-lr : Example (VariantGenerator STRING 1) getName 𝕍-lr = "lr" get 𝕍-lr zero = rose-leaf "left" get 𝕍-lr (suc zero) = rose-leaf "right" diff --git a/src/Vatras/Test/Experiments/ADT-to-TikZ-Forest.agda b/src/Vatras/Test/Experiments/ADT-to-TikZ-Forest.agda index db55b172..cfca63e7 100644 --- a/src/Vatras/Test/Experiments/ADT-to-TikZ-Forest.agda +++ b/src/Vatras/Test/Experiments/ADT-to-TikZ-Forest.agda @@ -22,12 +22,9 @@ open import Vatras.Test.Experiment open import Vatras.Show.Lines open import Vatras.Util.Named -STR : 𝔸 -STR = (String , String._≟_) - -STRCCC = CCC String ∞ STR -STR2CC = 2CC String ∞ STR -STRADT = ADT String (Rose ∞) STR +STRCCC = CCC String ∞ STRING +STR2CC = 2CC String ∞ STRING +STRADT = ADT String (Rose ∞) STRING rose-to-tikz-forest : ∀ {i} {A : 𝔸} → (atoms A → String) → Rose i A → Lines rose-to-tikz-forest pretty-atom (a -< [] >-) = > "[" ++ pretty-atom a ++ "]" diff --git a/src/Vatras/Test/Experiments/FST-Experiments.agda b/src/Vatras/Test/Experiments/FST-Experiments.agda index 9aadf628..667bdbfe 100644 --- a/src/Vatras/Test/Experiments/FST-Experiments.agda +++ b/src/Vatras/Test/Experiments/FST-Experiments.agda @@ -16,7 +16,7 @@ open import Vatras.Test.Example open import Vatras.Test.Experiment open import Vatras.Show.Lines hiding (map) open import Vatras.Util.ShowHelpers -open import Data.String using (String; _<+>_; _++_) renaming (_≟_ to _≟ˢ_) +open import Data.String as String using (String; _<+>_; _++_) renaming (_≟_ to _≟ˢ_) open import Vatras.Framework.Variants using (show-rose) @@ -66,7 +66,13 @@ module Java where _≟-ast_ : DecidableEquality ASTNode _≟-ast_ = _≟ˢ_ - open FST.Impose {String} (ASTNode , _≟-ast_) + A : 𝔸 + A = record + { atoms = ASTNode + ; atomsEqual? = _≟-ast_ + ; atomSize = String.length + } + open FST.Impose {String} A module Calculator where fname-Add = "Add" @@ -120,4 +126,4 @@ module Java where toy-calculator-experiment = let eq = _≟-ast_ in - exp String (ASTNode , eq) id id (pick-all ∷ pick-only eq fname-Add ∷ []) + exp String A id id (pick-all ∷ pick-only eq fname-Add ∷ []) diff --git a/src/Vatras/Test/Experiments/OC-to-2CC.agda b/src/Vatras/Test/Experiments/OC-to-2CC.agda index fab1cbb3..8d6a6e23 100644 --- a/src/Vatras/Test/Experiments/OC-to-2CC.agda +++ b/src/Vatras/Test/Experiments/OC-to-2CC.agda @@ -13,7 +13,7 @@ open import Level using (0ℓ) import Relation.Binary.PropositionalEquality as Eq open Eq using (_≡_; refl) -open import Vatras.Framework.Definitions using (ℂ) +open import Vatras.Framework.Definitions using (ℂ; STRING) open import Vatras.Framework.Variants using (Rose; show-rose) Feature = String @@ -60,7 +60,7 @@ OC→2CC-Test-conffnoc-allno = refl ∷ refl ∷ refl ∷ refl ∷ [] -- Translate an option calculus expression. -- Then configure it with an all-yes and an all-no config and print the resulting variants. -exp-oc-to-bcc : Experiment (WFOC Feature ∞ (String , String._≟_)) +exp-oc-to-bcc : Experiment (WFOC Feature ∞ STRING) getName exp-oc-to-bcc = "Translate OC to 2CC" get exp-oc-to-bcc ex@(name ≔ oc) = do let --trans-result = translate oc diff --git a/src/Vatras/Test/Experiments/RoundTrip.agda b/src/Vatras/Test/Experiments/RoundTrip.agda index 32c35619..1531e20c 100644 --- a/src/Vatras/Test/Experiments/RoundTrip.agda +++ b/src/Vatras/Test/Experiments/RoundTrip.agda @@ -17,7 +17,7 @@ import Relation.Binary.PropositionalEquality as Eq open Eq using (_≡_; refl) open import Vatras.Framework.Compiler using (LanguageCompiler) -open import Vatras.Framework.Definitions using (ℂ; 𝔸) +open import Vatras.Framework.Definitions using (ℂ; STRING) open import Vatras.Framework.Variants using (Rose; show-rose) open import Vatras.Framework.VariabilityLanguage using (VariabilityLanguage; Expression) open import Vatras.Util.AuxProofs using (decidableEquality-×) @@ -50,12 +50,10 @@ open import Vatras.Test.Example open import Vatras.Test.Examples.OC Feature = String -Artifact : 𝔸 -Artifact = String , String._≟_ open CCC-to-NCC using (⌈_⌉; numberOfAlternatives≤⌈_⌉) -CCC→NCC-Exact : (e : CCC Feature ∞ Artifact) → NCC Feature ⌈ e ⌉ ∞ Artifact +CCC→NCC-Exact : (e : CCC Feature ∞ STRING) → NCC Feature ⌈ e ⌉ ∞ STRING CCC→NCC-Exact e = CCC-to-NCC.translate ⌈ e ⌉ e (numberOfAlternatives≤⌈_⌉ e) @@ -75,14 +73,14 @@ translate e E₂-name translator show = return-level e' do pretty-e' = show e' compile : ∀ {VL₁ VL₂ : VariabilityLanguage Variant} - → Expression VL₁ Artifact + → Expression VL₁ STRING → String → LanguageCompiler VL₁ VL₂ - → (Expression VL₂ Artifact → Lines) - → Lines' (Expression VL₂ Artifact) + → (Expression VL₂ STRING → Lines) + → Lines' (Expression VL₂ STRING) compile e VL₂-name compiler show = translate e VL₂-name (LanguageCompiler.compile compiler) show -round-trip : Experiment (CCC Feature ∞ (String , String._≟_)) +round-trip : Experiment (CCC Feature ∞ STRING) getName round-trip = "Translate CCC in one round-trip into equally expressive variability languages" get round-trip ex@(name ≔ ccc) = do [ Center ]> "CCC, original expression" @@ -102,10 +100,10 @@ get round-trip ex@(name ≔ ccc) = do linebreak -ex-trivial : Example (CCC Feature ∞ Artifact) +ex-trivial : Example (CCC Feature ∞ STRING) ex-trivial = "trivial" ≔ "D" ⟨ "l" -< [] >- ∷ "r" -< [] >- ∷ [] ⟩ -ex-sandwich : Example (CCC Feature ∞ Artifact) +ex-sandwich : Example (CCC Feature ∞ STRING) ex-sandwich = "Sandwich Recipe" ≔ "🍞" -< "Salad?" @@ -129,5 +127,5 @@ ex-sandwich = "Sandwich Recipe" ≔ ∷ [] >- -examples : List (Example (CCC Feature ∞ Artifact)) +examples : List (Example (CCC Feature ∞ STRING)) examples = ex-trivial ∷ ex-sandwich ∷ [] diff --git a/src/Vatras/Translation/Lang/2CC/Idempotence.agda b/src/Vatras/Translation/Lang/2CC/Idempotence.agda index 4efc6f1b..7ae4703b 100644 --- a/src/Vatras/Translation/Lang/2CC/Idempotence.agda +++ b/src/Vatras/Translation/Lang/2CC/Idempotence.agda @@ -1,4 +1,4 @@ -open import Vatras.Framework.Definitions using (𝔸; 𝔽) +open import Vatras.Framework.Definitions using (𝔸; 𝔽; atomsEqual?) open import Relation.Binary.Definitions using (DecidableEquality) module Vatras.Translation.Lang.2CC.Idempotence (Dimension : 𝔽) (_==_ : DecidableEquality Dimension) where @@ -22,7 +22,7 @@ open import Vatras.Lang.All open 2CC _≟_ : ∀ {i : Size} {A : 𝔸} → DecidableEquality (2CC Dimension i A) -_≟_ {A = _ , _≟ₐ_} (a₁ -< cs₁ >-) (a₂ -< cs₂ >-) with a₁ ≟ₐ a₂ | List.≡-dec _≟_ cs₁ cs₂ +_≟_ {A = A} (a₁ -< cs₁ >-) (a₂ -< cs₂ >-) with atomsEqual? A a₁ a₂ | List.≡-dec _≟_ cs₁ cs₂ (a₁ -< cs₁ >-) ≟ (a₂ -< cs₂ >-) | yes a₁≡a₂ | yes cs₁≡cs₂ = yes (Eq.cong₂ _-<_>- a₁≡a₂ cs₁≡cs₂) (a₁ -< cs₁ >-) ≟ (a₂ -< cs₂ >-) | yes a₁≡a₂ | no cs₁≢cs₂ = no λ where refl → cs₁≢cs₂ refl (a₁ -< cs₁ >-) ≟ (a₂ -< cs₂ >-) | no a₁≢a₂ | _ = no λ where refl → a₁≢a₂ refl diff --git a/src/Vatras/Translation/Lang/FST-to-OC.lagda.md b/src/Vatras/Translation/Lang/FST-to-OC.lagda.md index 6a7f30ba..412bffa4 100644 --- a/src/Vatras/Translation/Lang/FST-to-OC.lagda.md +++ b/src/Vatras/Translation/Lang/FST-to-OC.lagda.md @@ -1,7 +1,7 @@ # Option calculus is not as expressive as feature structure trees ```agda -open import Vatras.Framework.Definitions using (𝔽; 𝔸) +open import Vatras.Framework.Definitions using (𝔽; NAT') open import Relation.Binary using (DecidableEquality) open import Relation.Binary.PropositionalEquality as Eq using (_≡_; _≢_; refl) @@ -25,7 +25,7 @@ open import Data.List.Relation.Binary.Sublist.Heterogeneous using ([]; _∷_; _ open import Data.List.Relation.Unary.All using ([]; _∷_) open import Data.List.Relation.Unary.AllPairs using ([]; _∷_) open import Data.Maybe using (nothing; just) -open import Data.Nat using (_≟_; ℕ; _+_; _≤_; z≤n; s≤s) +open import Data.Nat using (_+_; _≤_; z≤n; s≤s) import Data.Nat.Properties as ℕ open import Data.Product using (_,_; ∃-syntax) open import Data.Sum as Sum using (_⊎_; inj₁; inj₂) @@ -45,9 +45,6 @@ open FST.Impose using (SPL; _◀_; _::_; _⊚_) V = Rose ∞ open import Vatras.Framework.Relation.Expressiveness V using (_⋡_) - -A : 𝔸 -A = ℕ , _≟_ ``` ## Counter-Example @@ -72,7 +69,7 @@ Hence, at least one inner child is required for a valid variant of this counter-example SPL (or no children in which case there is only the root). As FSTs require a fixed root artifact, the outermost artifact is always set to 0. ```agda -counter-example : SPL A +counter-example : SPL NAT' counter-example = 0 ◀ ( (f₁ :: ((0 -< 0 -< [] >- ∷ [] >- ∷ []) ⊚ ([] ∷ [] , (([] ∷ []) , (([] , []) ∷ [])) ∷ []))) ∷ (f₂ :: ((0 -< 1 -< [] >- ∷ [] >- ∷ []) ⊚ ([] ∷ [] , (([] ∷ []) , (([] , []) ∷ [])) ∷ []))) @@ -132,13 +129,13 @@ from `counter-example`. Agda can't compute with `==ꟳ` so we need the following two lemmas to sort out invalid definitions of `==ꟳ`. Then Agda can actually compute the semantics of `counter-example`. ```agda -compute-counter-example-c₁ : {v : Rose ∞ A} → FST.⟦ counter-example ⟧ c₁ ≡ v → 0 -< 0 -< 0 -< [] >- ∷ [] >- ∷ [] >- ≡ v +compute-counter-example-c₁ : {v : Rose ∞ NAT'} → FST.⟦ counter-example ⟧ c₁ ≡ v → 0 -< 0 -< 0 -< [] >- ∷ [] >- ∷ [] >- ≡ v compute-counter-example-c₁ p with f₁ ==ꟳ f₁ | f₂ ==ꟳ f₁ | c₁ f₁ in c₁-f₁ | c₁ f₂ in c₁-f₂ compute-counter-example-c₁ p | yes f₁≡f₁ | yes f₂≡f₁ | _ | _ = ⊥-elim (f₁≢f₂ (Eq.sym f₂≡f₁)) compute-counter-example-c₁ p | yes f₁≡f₁ | no f₂≢f₁ | true | false = p compute-counter-example-c₁ p | no f₁≢f₁ | _ | _ | _ = ⊥-elim (f₁≢f₁ refl) -compute-counter-example-c₂ : {v : Rose ∞ A} → FST.⟦ counter-example ⟧ c₂ ≡ v → 0 -< 0 -< 1 -< [] >- ∷ [] >- ∷ [] >- ≡ v +compute-counter-example-c₂ : {v : Rose ∞ NAT'} → FST.⟦ counter-example ⟧ c₂ ≡ v → 0 -< 0 -< 1 -< [] >- ∷ [] >- ∷ [] >- ≡ v compute-counter-example-c₂ p with f₁ ==ꟳ f₂ | f₂ ==ꟳ f₂ | c₂ f₁ in c₂-f₁ | c₂ f₂ in c₂-f₂ compute-counter-example-c₂ p | yes f₁≡f₂ | _ | _ | _ = ⊥-elim (f₁≢f₂ f₁≡f₂) compute-counter-example-c₂ p | no f₁≢f₂ | yes f₂≡f₂ | false | true = p @@ -178,7 +175,7 @@ they must be included in both variants. Simultaneously, this excludes the artifacts themselves because each configuration excludes one of them. ```agda shared-artifact : ∀ {F' : 𝔽} - → (e : OC F' ∞ A) + → (e : OC F' ∞ NAT') → (c₁ c₂ : OC.Configuration F') → just (0 -< rose-leaf 0 ∷ [] >-) ≡ OC.⟦ e ⟧ₒ c₁ → just (0 -< rose-leaf 1 ∷ [] >-) ≡ OC.⟦ e ⟧ₒ c₂ @@ -210,9 +207,9 @@ only prove that there is at least one more artifact. ```agda more-artifacts : ∀ {F' : 𝔽} - → (cs : List (OC F' ∞ A)) + → (cs : List (OC F' ∞ NAT')) → (cₙ : OC.Configuration F') - → (v : Rose ∞ A) + → (v : Rose ∞ NAT') → 0 -< v ∷ [] >- ∷ [] ≡ OC.⟦ cs ⟧ₒ-recurse cₙ → 1 ≤ length (OC.⟦ cs ⟧ₒ-recurse (all-oc true)) more-artifacts (a -< cs' >- ∷ cs) cₙ v p = s≤s z≤n @@ -255,7 +252,7 @@ variants forcing it to have exactly one shape. In this case, called under the intersection of `c₁` and `c₂`. ```agda induction : ∀ {F' : 𝔽} - → (cs : List (OC F' ∞ A)) + → (cs : List (OC F' ∞ NAT')) → (c₁ c₂ c₃ : OC.Configuration F') → 0 -< rose-leaf 0 ∷ [] >- ∷ [] ≡ OC.⟦ cs ⟧ₒ-recurse c₁ → 0 -< rose-leaf 1 ∷ [] >- ∷ [] ≡ OC.⟦ cs ⟧ₒ-recurse c₂ @@ -295,7 +292,7 @@ expression. The proof evaluates the FST expression on all relevant configurations which results in contradictions in every case. ```agda impossible : ∀ {F' : 𝔽} - → (cs : List (OC F' ∞ A)) + → (cs : List (OC F' ∞ NAT')) → (c₁ c₂ : OC.Configuration F') → ((c : OC.Configuration F') → ∃[ c' ] OC.⟦ Root 0 cs ⟧ c ≡ FST.⟦ counter-example ⟧ c') → 2 ≤ length (OC.⟦ cs ⟧ₒ-recurse (all-oc true)) diff --git a/src/Vatras/Translation/Lang/OC-to-FST.agda b/src/Vatras/Translation/Lang/OC-to-FST.agda index 3ff32227..79285117 100644 --- a/src/Vatras/Translation/Lang/OC-to-FST.agda +++ b/src/Vatras/Translation/Lang/OC-to-FST.agda @@ -3,7 +3,7 @@ This module provides an example of neighboring artifacts with equal atoms and uses the `cannotEncodeNeighbors` lemma from `FST` to show that there are expressions in `WFOC` that cannot be encoded in `FST`. -} -open import Vatras.Framework.Definitions using (𝔽; 𝔸) +open import Vatras.Framework.Definitions using (𝔽; 𝔸; NAT') module Vatras.Translation.Lang.OC-to-FST (F : 𝔽) where @@ -23,10 +23,7 @@ open import Vatras.Lang.FST.Properties using (cannotEncodeNeighbors) V = Rose ∞ open import Vatras.Framework.Relation.Expressiveness V using (_⋡_) -A : 𝔸 -A = ℕ , _≟_ - -neighbors : WFOC F ∞ A +neighbors : WFOC F ∞ NAT' neighbors = Root zero (zero -< [] >- ∷ zero -< [] >- ∷ []) FST⋡WFOC : FSTL F ⋡ WFOCL F diff --git a/src/Vatras/Translation/Lang/OC-to-PropOC.agda b/src/Vatras/Translation/Lang/OC-to-PropOC.agda new file mode 100644 index 00000000..e1cb5002 --- /dev/null +++ b/src/Vatras/Translation/Lang/OC-to-PropOC.agda @@ -0,0 +1,76 @@ +open import Vatras.Framework.Definitions using (𝔽; 𝔸; atoms) + +module Vatras.Translation.Lang.OC-to-PropOC (F : 𝔽) where + +open import Data.Bool using (if_then_else_) +open import Data.List as List using (List) +import Data.List.Properties as List +open import Data.Maybe using (nothing; just) +open import Function using (flip; id) +open import Size using (Size; ∞) +open import Relation.Binary.PropositionalEquality as Eq using (_≗_) + +open import Vatras.Data.EqIndexedSet using (_≅[_][_]_; ≗→≅[]; ≅[]-sym) +open import Vatras.Data.Prop using (var) +open import Vatras.Framework.Compiler using (LanguageCompiler) +open import Vatras.Framework.Relation.Function using (from; to) +open import Vatras.Framework.Variants as V using (Rose) +open import Vatras.Framework.Relation.Expressiveness (Rose ∞) using (expressiveness-from-compiler; _≽_) +open import Vatras.Lang.All +open OC using (OC; WFOC; WFOCL; Root; _-<_>-; _❲_❳) +open PropOC using (PropOC; WFPropOC; WFPropOCL) + +translate' : ∀ {i : Size} {A : 𝔸} → OC F i A → PropOC F i A +translate' (a -< cs >-) = a -< List.map translate' cs >- +translate' (f ❲ c ❳) = var f ❲ translate' c ❳ + +translate : ∀ {i : Size} {A : 𝔸} → WFOC F i A → WFPropOC F i A +translate (Root a cs) = Root a (List.map translate' cs) + +translate'-preserves-≗ + : ∀ {i : Size} {A : 𝔸} + → (e : OC F i A) + → PropOC.⟦ translate' e ⟧ₒ ≗ OC.⟦ e ⟧ₒ + +translate'-preserves-≗-recurse : ∀ {i : Size} {A : 𝔸} + → (cs : List (OC F i A)) + → PropOC.⟦ List.map translate' cs ⟧ₒ-recurse ≗ OC.⟦ cs ⟧ₒ-recurse + +translate'-preserves-≗ (a -< cs >-) assignment = Eq.cong (λ x → just (a V.-< x >-)) (translate'-preserves-≗-recurse cs assignment) +translate'-preserves-≗ (f ❲ c ❳) assignment = Eq.cong (if assignment f then_else nothing) (translate'-preserves-≗ c assignment) + +translate'-preserves-≗-recurse cs assignment = + begin + PropOC.⟦ List.map translate' cs ⟧ₒ-recurse assignment + ≡⟨⟩ + List.catMaybes (List.map (flip PropOC.⟦_⟧ₒ assignment) (List.map translate' cs)) + ≡⟨ Eq.cong List.catMaybes (List.map-∘ cs) ⟨ + List.catMaybes (List.map (λ e → PropOC.⟦ translate' e ⟧ₒ assignment) cs) + ≡⟨ Eq.cong List.catMaybes (List.map-cong (flip translate'-preserves-≗ assignment) cs) ⟩ + List.catMaybes (List.map (flip OC.⟦_⟧ₒ assignment) cs) + ≡⟨⟩ + OC.⟦ cs ⟧ₒ-recurse assignment + ∎ + where + open Eq.≡-Reasoning + +translate-preserves-≗ + : ∀ {i : Size} {A : 𝔸} + → (e : WFOC F i A) + → PropOC.⟦ translate e ⟧ ≗ OC.⟦ e ⟧ +translate-preserves-≗ (Root a cs) assignment = Eq.cong (a V.-<_>-) (translate'-preserves-≗-recurse cs assignment) + +translate-preserves + : ∀ {i : Size} {A : 𝔸} + → (e : WFOC F i A) + → PropOC.⟦ translate e ⟧ ≅[ id ][ id ] OC.⟦ e ⟧ +translate-preserves e = ≗→≅[] (translate-preserves-≗ e) + +OC→PropOC : LanguageCompiler (WFOCL F) (WFPropOCL F) +OC→PropOC .LanguageCompiler.compile = translate +OC→PropOC .LanguageCompiler.config-compiler e .to = id +OC→PropOC .LanguageCompiler.config-compiler e .from = id +OC→PropOC .LanguageCompiler.preserves e = ≅[]-sym (translate-preserves e) + +PropOC≽OC : WFPropOCL F ≽ WFOCL F +PropOC≽OC = expressiveness-from-compiler OC→PropOC diff --git a/src/Vatras/Translation/Lang/OC/DeadElim.agda b/src/Vatras/Translation/Lang/OC/DeadElim.agda new file mode 100644 index 00000000..ecc0ef6a --- /dev/null +++ b/src/Vatras/Translation/Lang/OC/DeadElim.agda @@ -0,0 +1,212 @@ +{-| +Removes dead options from an option calculus expression. +A dead option is an option which can be replaced by its child (i.e., removed) without altering the semantics of the expression. +In particular, an option which is below another option the same dimension can never be disabled. +If the dimension is disabled, the parent option is already disable. +Hence, the child option is not even considered. + +Given an `Undead` expression, we then apply some transformations like join top level options. +-} + +open import Vatras.Framework.Definitions using (𝔽; 𝔸; atoms) +open import Relation.Binary using (DecidableEquality) +module Vatras.Translation.Lang.OC.DeadElim (F : 𝔽) (_≟_ : DecidableEquality F) where + +open import Data.Bool using (Bool; true; false; if_then_else_) +import Data.Bool.Properties as Bool +open import Data.Empty using (⊥-elim) +open import Data.List as List using (List; []; _∷_) +import Data.List.Properties as List +open import Data.List.Relation.Unary.All as All using (All; []; _∷_) +open import Data.List.Relation.Unary.Any using (here; there) +open import Data.List.Membership.DecPropositional _≟_ using (_∈_; _∉_; _∈?_) +open import Data.Maybe using (just; nothing) +open import Data.Product using (Σ; _,_; proj₁; proj₂) +open import Function using (id) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; _≢_) +open import Relation.Nullary.Decidable using (yes; no; decidable-stable) +open import Size using (Size; ∞) + +open import Vatras.Util.AuxProofs using (true≢false) +import Vatras.Util.List as List +open import Vatras.Data.EqIndexedSet using (_≅[_][_]_; ≗→≅[]; _≅_; _⊆_) +open import Vatras.Framework.Variants using (_-<_>-) +open import Vatras.Lang.OC F using (OC; _-<_>-; _❲_❳; Configuration; ⟦_⟧ₒ) +open import Vatras.Lang.OC.Util using (all-oc) + +{-| +An option calculus expression with no dead options and a list of dimensions that do not appear in that expression. +-} +data RestrictOptions {A : 𝔸} : {i : Size} → List F → OC i A → Set₁ where + _-<_>- : ∀ {i} → {a : atoms A} → {cs : List (OC i A)} → (env : List F) → All (RestrictOptions env) cs → RestrictOptions env (a -< cs >-) + _❲_❳ : ∀ {i} → {f : F} → {c : OC i A} → {env : List F} → f ∉ env → RestrictOptions (f ∷ env) c → RestrictOptions env (f ❲ c ❳) + +{-| +An option calculus expression with no dead options. +-} +data Undead {A : 𝔸} : {i : Size} → OC i A → Set₁ where + undead : {i : Size} → {env : List F} → {e : OC i A} → RestrictOptions env e → Undead e + +{-| +Given a list of dimensions that are dead in this expression, remove all dead options. +-} +elimDead' : {i : Size} → {A : 𝔸} → (env : List F) → OC i A → Σ (OC ∞ A) (RestrictOptions env) +elimDead' env (a -< cs >-) = a -< List.map proj₁ (List.map (elimDead' env) cs) >- , (env -< All.fromList (List.map (elimDead' env) cs) >-) +elimDead' env (f ❲ c ❳) with f ∈? env +elimDead' env (f ❲ c ❳) | yes a∈env = elimDead' env c +elimDead' env (f ❲ c ❳) | no a∉env = f ❲ proj₁ (elimDead' (f ∷ env) c) ❳ , a∉env ❲ proj₂ (elimDead' (f ∷ env) c) ❳ + +{-| +Remove all dead options. +-} +elimDead : {i : Size} → {A : 𝔸} → OC i A → OC ∞ A +elimDead e = proj₁ (elimDead' [] e) + +elimDead-preserves' : {i : Size} → {A : 𝔸} → (env : List F) → (e : OC i A) → (c : Configuration) → All (λ f → c f ≡ true) env → ⟦ proj₁ (elimDead' env e) ⟧ₒ c ≡ ⟦ e ⟧ₒ c +elimDead-preserves' env (a -< cs >-) c c-env≡true = + ⟦ proj₁ (elimDead' env (a -< cs >-)) ⟧ₒ c + ≡⟨⟩ + ⟦ a -< List.map proj₁ (List.map (elimDead' env) cs) >- ⟧ₒ c + ≡⟨⟩ + just (a -< List.catMaybes (List.map (λ e → ⟦ e ⟧ₒ c) (List.map proj₁ (List.map (elimDead' env) cs))) >-) + ≡⟨ Eq.cong (λ e → just (a -< List.catMaybes e >-)) (List.map-∘ (List.map (elimDead' env) cs)) ⟨ + just (a -< List.catMaybes (List.map (λ e → ⟦ proj₁ e ⟧ₒ c) (List.map (elimDead' env) cs)) >-) + ≡⟨ Eq.cong (λ e → just (a -< List.catMaybes e >-)) (List.map-∘ cs) ⟨ + just (a -< List.catMaybes (List.map (λ e → ⟦ proj₁ (elimDead' env e) ⟧ₒ c) cs) >-) + ≡⟨ Eq.cong (λ e → just (a -< List.catMaybes e >-)) (List.map-cong (λ e → elimDead-preserves' env e c c-env≡true) cs) ⟩ + just (a -< List.catMaybes (List.map (λ e → ⟦ e ⟧ₒ c) cs) >-) + ≡⟨⟩ + ⟦ a -< cs >- ⟧ₒ c + ∎ + where + open Eq.≡-Reasoning +elimDead-preserves' env (f ❲ e ❳) c c-env≡true with f ∈? env +elimDead-preserves' env (f ❲ e ❳) c c-env≡true | yes a∈env with c f in c-a +elimDead-preserves' env (f ❲ e ❳) c c-env≡true | yes a∈env | true = elimDead-preserves' env e c c-env≡true +elimDead-preserves' env (f ❲ e ❳) c c-env≡true | yes a∈env | false = ⊥-elim (true≢false (All.lookup c-env≡true a∈env) c-a) +elimDead-preserves' env (f ❲ e ❳) c c-env≡true | no a∉env with c f in c-a +elimDead-preserves' env (f ❲ e ❳) c c-env≡true | no a∉env | true = elimDead-preserves' (f ∷ env) e c (c-a ∷ c-env≡true) +elimDead-preserves' env (f ❲ e ❳) c c-env≡true | no a∉env | false = Eq.refl + +{-| +`elimDead` doesn't change the semantics of the expression. +-} +elimDead-preserves : {i : Size} → {A : 𝔸} → (e : OC i A) → ⟦ elimDead e ⟧ₒ ≅[ id ][ id ] ⟦ e ⟧ₒ +elimDead-preserves e = ≗→≅[] (λ c → elimDead-preserves' [] e c []) + +-- TODO WFOC + + +-- The following lemmas show that we can join top level options if the expression is `Undead`. + +{-| +In an undead option calculus expression, +child dimensions need to be different. +-} +undead→≢ : {i : Size} → {A : 𝔸} → {f₁ f₂ : F} → {e : OC i A} → Undead (f₁ ❲ f₂ ❲ e ❳ ❳) → f₁ ≢ f₂ +undead→≢ (undead (f₁∉env ❲ f₂∉env ❲ undead-e ❳ ❳)) f₁≡f₂ = f₂∉env (here (Eq.sym f₁≡f₂)) + +{-| +Change a configuration at a particular dimension to a specific value. +-} +changeConfig : F → Bool → Configuration → Configuration +changeConfig f₁ b c f₂ with f₁ ≟ f₂ +changeConfig f₁ b c f₂ | yes f₁≡f₂ = b +changeConfig f₁ b c f₂ | no f₁≢f₂ = c f₂ + +changeConfig-≡ : (f : F) → (b : Bool) → (c : Configuration) → changeConfig f b c f ≡ b +changeConfig-≡ f b c with f ≟ f +changeConfig-≡ f b c | yes f≡f = Eq.refl +changeConfig-≡ f b c | no f≢f = ⊥-elim (f≢f Eq.refl) + +changeConfig-≢ : {f₁ f₂ : F} → (b : Bool) → f₁ ≢ f₂ → (c : Configuration) → changeConfig f₁ b c f₂ ≡ c f₂ +changeConfig-≢ {f₁} {f₂} b f₁≢f₂ c with f₁ ≟ f₂ +changeConfig-≢ {f₁} {f₂} b f₁≢f₂ c | yes f₁≡f₂ = ⊥-elim (f₁≢f₂ f₁≡f₂) +changeConfig-≢ {f₁} {f₂} b f₁≢f₂ c | no f₁≢f₂ = Eq.refl + +{-| +We can change the configuration of dimensions which don't appear in an expression. +-} +changeConfig-∉ : {i : Size} → {A : 𝔸} → {env : List F} → (f : F) → (f ∈ env) → (b : Bool) → (c : Configuration) → (e : OC i A) → RestrictOptions env e → ⟦ e ⟧ₒ (changeConfig f b c) ≡ ⟦ e ⟧ₒ c +changeConfig-∉ f f∈env b c (a -< cs >-) (env -< undead-e >-) = + ⟦ a -< cs >- ⟧ₒ (changeConfig f b c) + ≡⟨⟩ + just (a -< List.catMaybes (List.map (λ e → ⟦ e ⟧ₒ (changeConfig f b c)) cs) >-) + ≡⟨ Eq.cong (λ x → just (a -< List.catMaybes x >-)) (List.map-cong-with∈ cs (λ e e∈cs → changeConfig-∉ f f∈env b c e (All.lookup undead-e e∈cs))) ⟩ + just (a -< List.catMaybes (List.map (λ e → ⟦ e ⟧ₒ c) cs) >-) + ≡⟨⟩ + ⟦ a -< cs >- ⟧ₒ c + ∎ + where + open Eq.≡-Reasoning +changeConfig-∉ f f∈env b c (f' ❲ e ❳) undead-e with f ≟ f' +changeConfig-∉ {env = env} f f∈env b c (f' ❲ e ❳) (f'∉env ❲ undead-e ❳) | yes f≡f' = ⊥-elim (f'∉env (Eq.subst (_∈ env) f≡f' f∈env)) +changeConfig-∉ f f∈env b c (f' ❲ e ❳) (f'∉env ❲ undead-e ❳) | no f≢f' = Eq.cong (λ e → if c f' then e else nothing) (changeConfig-∉ f (there f∈env) b c e undead-e) + +{-| +An option whose dimensions is configured to `true` is semantically equivalent to its child. +-} +eval-option : {i : Size} → {A : 𝔸} → {f : F} → {e : OC i A} → Undead (f ❲ e ❳) → (c : Configuration) → ⟦ f ❲ e ❳ ⟧ₒ (changeConfig f true c) ≡ ⟦ e ⟧ₒ c +eval-option {f = f} {e = e} (undead (_ ❲ undead-e ❳)) c = + ⟦ f ❲ e ❳ ⟧ₒ (changeConfig f true c) + ≡⟨⟩ + (if changeConfig f true c f then ⟦ e ⟧ₒ (changeConfig f true c) else nothing) + ≡⟨ Eq.cong (λ b → if b then ⟦ e ⟧ₒ (changeConfig f true c) else nothing) (changeConfig-≡ f true c) ⟩ + ⟦ e ⟧ₒ (changeConfig f true c) + ≡⟨ changeConfig-∉ f (here Eq.refl) true c e undead-e ⟩ + ⟦ e ⟧ₒ c + ∎ + where + open Eq.≡-Reasoning + +{-| +We can collapse top-level options if there are no dead options. +-} +join-options : {i : Size} → {A : 𝔸} → (f₁ f₂ : F) → (e : OC i A) → Undead (f₁ ❲ f₂ ❲ e ❳ ❳) → ⟦ f₁ ❲ f₂ ❲ e ❳ ❳ ⟧ₒ ≅ ⟦ f₂ ❲ e ❳ ⟧ₒ +join-options f₁ f₂ e undead-e'@(undead (f₁∉env ❲ f₂∉env ❲ undead-e ❳ ❳)) = go-⊆ , go-⊇ + where + go-⊆ : ⟦ f₁ ❲ f₂ ❲ e ❳ ❳ ⟧ₒ ⊆ ⟦ f₂ ❲ e ❳ ⟧ₒ + go-⊆ c with c f₂ in c-f₂ + go-⊆ c | false = c , ( + (if c f₁ then nothing else nothing) + ≡⟨ Bool.if-eta (c f₁) ⟩ + nothing + ≡⟨ Eq.cong (λ b → if b then ⟦ e ⟧ₒ c else nothing) c-f₂ ⟨ + (if c f₂ then ⟦ e ⟧ₒ c else nothing) + ∎) + where + open Eq.≡-Reasoning + go-⊆ c | true with c f₁ + go-⊆ c | true | false = all-oc false , Eq.refl + go-⊆ c | true | true = c , ( + ⟦ e ⟧ₒ c + ≡⟨ Eq.cong (λ b → if b then ⟦ e ⟧ₒ c else nothing) c-f₂ ⟨ + (if c f₂ then ⟦ e ⟧ₒ c else nothing) + ∎) + where + open Eq.≡-Reasoning + + go-⊇ : ⟦ f₂ ❲ e ❳ ⟧ₒ ⊆ ⟦ f₁ ❲ f₂ ❲ e ❳ ❳ ⟧ₒ + go-⊇ c with c f₂ in c-f₂ + go-⊇ c | false = all-oc false , Eq.refl + go-⊇ c | true = changeConfig f₁ true c , ( + ⟦ e ⟧ₒ c + ≡⟨ changeConfig-∉ f₁ (there (here Eq.refl)) true c e undead-e ⟨ + ⟦ e ⟧ₒ (changeConfig f₁ true c) + ≡⟨ Eq.cong (λ b → if b then ⟦ e ⟧ₒ (changeConfig f₁ true c) else nothing) c-f₂ ⟨ + (if c f₂ + then ⟦ e ⟧ₒ (changeConfig f₁ true c) + else nothing) + ≡⟨ Eq.cong (λ b → if b then ⟦ e ⟧ₒ (changeConfig f₁ true c) else nothing) (changeConfig-≢ true (undead→≢ undead-e') c) ⟨ + (if changeConfig f₁ true c f₂ + then ⟦ e ⟧ₒ (changeConfig f₁ true c) + else nothing) + ≡⟨ Eq.cong (λ b → if b then if changeConfig f₁ true c f₂ then ⟦ e ⟧ₒ (changeConfig f₁ true c) else nothing else nothing) (changeConfig-≡ f₁ true c) ⟨ + (if changeConfig f₁ true c f₁ + then if changeConfig f₁ true c f₂ + then ⟦ e ⟧ₒ (changeConfig f₁ true c) + else nothing + else nothing) + ∎) + where + open Eq.≡-Reasoning diff --git a/src/Vatras/Translation/LanguageMap.lagda.md b/src/Vatras/Translation/LanguageMap.lagda.md index 880e7333..423c438f 100644 --- a/src/Vatras/Translation/LanguageMap.lagda.md +++ b/src/Vatras/Translation/LanguageMap.lagda.md @@ -54,6 +54,7 @@ open PropADT using (PropADTL) open OC using (WFOCL) open FST using (FSTL) open VT using (VTL) +open PropOC using (WFPropOCL) open import Vatras.Lang.CCC.Encode using () renaming (encoder to CCC-Rose-encoder) open import Vatras.Translation.Lang.ADT.Rename using (ADT-rename≽ADT) @@ -85,6 +86,7 @@ import Vatras.Translation.Lang.FST-to-OC as FST-to-OC import Vatras.Translation.Lang.FST-to-VariantList as FST-to-VariantList import Vatras.Translation.Lang.VariantList-to-ADT as VariantList-to-ADT import Vatras.Translation.Lang.VT-to-ADT as VT-to-ADT +import Vatras.Translation.Lang.OC-to-PropOC as OC-to-PropOC ``` @@ -235,6 +237,10 @@ module Expressiveness {F : 𝔽} (f : F × ℕ → F) (f⁻¹ : F → F × ℕ) 2CC≽FST D _==_ = ≽-trans 2CC≽CCC (≽-trans (CCC≽VariantList D) (VariantList≽FST _==_)) + PropOC≽OC : WFPropOCL F ≽ WFOCL F + PropOC≽OC = OC-to-PropOC.PropOC≽OC F + + CCC≋NCC : ∀ (n : ℕ≥ 2) → CCCL F ≋ NCCL F n CCC≋NCC n = CCC≽NCC n , NCC≽CCC n diff --git a/src/Vatras/Util/AuxProofs.agda b/src/Vatras/Util/AuxProofs.agda index b803fefb..18d6fa10 100644 --- a/src/Vatras/Util/AuxProofs.agda +++ b/src/Vatras/Util/AuxProofs.agda @@ -3,12 +3,15 @@ module Vatras.Util.AuxProofs where open import Level using (Level) open import Function using (id; _∘_) -open import Data.Bool using (Bool; false; true) +open import Data.Bool using (Bool; false; true; if_then_else_) +open import Data.Empty using (⊥-elim) +open import Data.Fin using (Fin; zero; suc; fromℕ<) open import Data.Nat using (ℕ; zero; suc; _≡ᵇ_; _+_; _∸_; _<_; _≤_; s≤s; z≤n) open import Data.Nat.Properties using (n<1+n; n∸n≡0; m≤n+m) open import Data.Product using (_×_; _,_) open import Relation.Binary using (DecidableEquality) -open import Relation.Nullary.Decidable using (yes; no) +open import Relation.Nullary using (¬_) +open import Relation.Nullary.Decidable using (Dec; does; yes; no) import Relation.Binary.PropositionalEquality as Eq open Eq using (_≡_; _≢_; _≗_; refl) @@ -43,6 +46,27 @@ n∸1+mm : ∀ {m n : ℕ} → n ≤ m → m ≤ List.sum (List.upTo (suc m)) ∸ List.sum (List.upTo n) +upTo-m∸upTo-n>m {m} {n} n≤m = + begin + m + ≡⟨ ℕ.m+n∸m≡n n m ⟨ + n + m ∸ n + ≡⟨ ℕ.+-∸-assoc n n≤m ⟩ + n + (m ∸ n) + ≡⟨ ℕ.+-identityʳ (n + (m ∸ n)) ⟨ + n + (m ∸ n) + 0 + ≤⟨ ℕ.m≤n+m ((n + (m ∸ n) + 0)) (List.sum (List.applyUpTo (n +_) (m ∸ n))) ⟩ + List.sum (List.applyUpTo (n +_) (m ∸ n)) + (n + (m ∸ n) + 0) + ≡⟨ List.sum-++ (List.applyUpTo (n +_) (m ∸ n)) (n + (m ∸ n) ∷ []) ⟨ + List.sum (List.applyUpTo (n +_) (m ∸ n) List.∷ʳ (n + (m ∸ n))) + ≡⟨ Eq.cong List.sum (applyUpTo-∷ʳ⁺ (n +_) (m ∸ n)) ⟩ + List.sum (List.applyUpTo (n +_) (suc (m ∸ n))) + ≡⟨ Eq.cong (λ x → List.sum (List.applyUpTo (n +_) x)) (ℕ.+-∸-assoc 1 n≤m) ⟨ + List.sum (List.applyUpTo (n +_) (suc m ∸ n)) + ≡⟨ ℕ.m+n∸m≡n (List.sum (List.upTo n)) (List.sum (List.applyUpTo (n +_) (suc m ∸ n))) ⟨ + List.sum (List.upTo n) + List.sum (List.applyUpTo (n +_) (suc m ∸ n)) ∸ List.sum (List.upTo n) + ≡⟨ Eq.cong (_∸ List.sum (List.upTo n)) (List.sum-++ (List.upTo n) (List.applyUpTo (n +_) (suc m ∸ n))) ⟨ + List.sum (List.upTo n ++ List.applyUpTo (n +_) (suc m ∸ n)) ∸ List.sum (List.upTo n) + ≡⟨ Eq.cong (λ x → List.sum x ∸ List.sum (List.upTo n)) (applyUpTo-++⁺ id n (suc m ∸ n)) ⟨ + List.sum (List.upTo (n + (suc m ∸ n))) ∸ List.sum (List.upTo n) + ≡⟨ Eq.cong (λ x → List.sum (List.upTo x) ∸ List.sum (List.upTo n)) (ℕ.+-∸-assoc n (ℕ.≤-trans n≤m (ℕ.n≤1+n m))) ⟨ + List.sum (List.upTo (n + suc m ∸ n)) ∸ List.sum (List.upTo n) + ≡⟨ Eq.cong (λ x → List.sum (List.upTo x) ∸ List.sum (List.upTo n)) (ℕ.m+n∸m≡n n (suc m)) ⟩ + List.sum (List.upTo (suc m)) ∸ List.sum (List.upTo n) + ∎ + where + open ℕ.≤-Reasoning diff --git a/src/Vatras/Util/Nat/Diagonalization.agda b/src/Vatras/Util/Nat/Diagonalization.agda new file mode 100644 index 00000000..45fc0374 --- /dev/null +++ b/src/Vatras/Util/Nat/Diagonalization.agda @@ -0,0 +1,230 @@ +{-| +This module is a formal proof that ℕ and ℕ × ℕ have equal cardinality. +In particular, we provide a bijection between ℕ and ℕ × ℕ +using a version of Cantor's diagonal argument. + +This is already a well established result. +We only provide a full proof of this result due to procrastination 😅. +-} +module Vatras.Util.Nat.Diagonalization where + +open import Data.Bool using (Bool; true; false) +open import Data.Empty using (⊥-elim) +open import Data.List as List using (List; []; _∷_; _∷ʳ_; _++_; replicate) +import Data.List.Properties as List +open import Data.Nat using (ℕ; zero; suc; _+_; _∸_; _≤_; _<_; z≤n; s≤s; _≤?_) +import Data.Nat.Properties as ℕ +open import Data.Product as Product using (_×_; _,_; uncurry; Σ-syntax) +open import Function using (_∘_; id; const) +open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; _≗_) +open import Relation.Nullary.Decidable using (yes; no) + +import Vatras.Util.List as List + +{-| +A bijection between ℕ × ℕ and ℕ. +It counts through the pair like in a triangle: +y\x 0 1 2 3 +0 0 2 5 9 +1 1 4 8 +2 3 7 +3 6 +-} +diagonalization : ℕ × ℕ → ℕ +diagonalization (x , y) = List.sum (List.upTo (suc (x + y))) + x + +diagonalization⁻¹ : ℕ → ℕ × ℕ +diagonalization⁻¹ n = go (suc n) n zero + module diagonalization⁻¹-implementation where + go : ℕ → ℕ → ℕ → ℕ × ℕ + go zero n i = zero , i + go (suc fuel) n i with suc i ≤? n + go (suc fuel) n i | yes ii = + go fuel (n ∸ List.sum (List.upTo (suc i)) ∸ suc i) (suc i) + ≡⟨ Eq.cong (λ x → go fuel x (suc i)) (ℕ.∸-+-assoc n (List.sum (List.upTo (suc i))) (suc i)) ⟩ + go fuel (n ∸ (List.sum (List.upTo (suc i)) + suc i)) (suc i) + ≡⟨ Eq.cong (λ x → go fuel (n ∸ (List.sum (List.upTo (suc i)) + x)) (suc i)) (ℕ.+-identityʳ (suc i)) ⟨ + go fuel (n ∸ (List.sum (List.upTo (suc i)) + (suc i + 0))) (suc i) + ≡⟨ Eq.cong (λ x → go fuel (n ∸ x) (suc i)) (List.sum-++ (List.upTo (suc i)) (suc i ∷ [])) ⟨ + go fuel (n ∸ (List.sum (List.upTo (suc i) ∷ʳ suc i))) (suc i) + ≡⟨ Eq.cong (λ x → go fuel (n ∸ List.sum x) (suc i)) (List.applyUpTo-∷ʳ⁺ id (suc i)) ⟩ + go fuel (n ∸ List.sum (List.upTo (suc (suc i)))) (suc i) + ≡⟨ lemma fuel (suc i) n x+y>i) ⟩ + x , y + ∎ + where + nm (ℕ.≰⇒> x+y≰i) ⟩ + List.sum (List.upTo (suc (x + y))) ∸ List.sum (List.upTo (suc i)) + ≤⟨ ℕ.∸-monoˡ-≤ (List.sum (List.upTo (suc i))) (ℕ.m≤m+n (List.sum (List.upTo (suc (x + y)))) x) ⟩ + List.sum (List.upTo (suc (x + y))) + x ∸ List.sum (List.upTo (suc i)) + ≡⟨⟩ + n ∸ List.sum (List.upTo (suc i)) + <⟨ ℕ.≰⇒> i x+y≰i ⟩ + x + y + ∎)) + where + open ℕ.≤-Reasoning + +diagonalization-surjective : diagonalization ∘ diagonalization⁻¹ ≗ id +diagonalization-surjective n = lemma (suc n) n zero (ℕ.n<1+n n) refl + where + open diagonalization⁻¹-implementation n + + lemma : (fuel n' i : ℕ) → n ∸ List.sum (List.upTo (suc i)) < fuel → List.sum (List.upTo (suc i)) + n' ≡ n → diagonalization (go fuel n' i) ≡ n + lemma zero n' i n i≥n'))) ⟨ + List.sum (List.upTo (suc (n' + i ∸ n'))) + n' + ≡⟨ Eq.cong (λ x → List.sum (List.upTo (suc x)) + n') (ℕ.m+n∸m≡n n' i) ⟩ + List.sum (List.upTo (suc i)) + n' + ≡⟨ upTo+n'≡n ⟩ + n + ∎ + where + open Eq.≡-Reasoning diff --git a/src/Vatras/Util/Vec.agda b/src/Vatras/Util/Vec.agda index d573888a..4cab8cec 100644 --- a/src/Vatras/Util/Vec.agda +++ b/src/Vatras/Util/Vec.agda @@ -4,7 +4,7 @@ open import Data.Fin as Fin using (Fin; zero; suc) open import Data.List as List using (List; []; _∷_) open import Data.List.NonEmpty as List⁺ using (_∷_) import Data.List.Properties as List -open import Data.Nat as ℕ using (ℕ; zero; suc; _≤_; s≤s; z≤n) +open import Data.Nat as ℕ using (ℕ; zero; suc; _≤_; s≤s; z≤n; _+_) open import Data.Vec as Vec using (Vec; []; _∷_) open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl) import Vatras.Util.List as List @@ -67,3 +67,7 @@ zipWith₂ : ∀ {ℓA ℓB ℓC} {A : Set ℓA} {B : Set ℓB} {C : Set ℓC} { → Vec.zipWith (λ x y → f y) xs ys ≡ Vec.map f ys zipWith₂ f [] [] = refl zipWith₂ f (x ∷ xs) (y ∷ ys) = Eq.cong (f y ∷_) (zipWith₂ f xs ys) + +sum-toList : ∀ {n : ℕ} → (xs : Vec ℕ n) → List.sum (Vec.toList xs) ≡ Vec.sum xs +sum-toList [] = refl +sum-toList (x ∷ xs) = Eq.cong (x +_) (sum-toList xs)