├── .github └── workflows │ └── lean_build.yml ├── .gitignore ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── LICENSE ├── NOTICE ├── README.md ├── leanpkg.toml └── src ├── aggregation.lean ├── circuits.lean ├── incremental.lean ├── linear.lean ├── operators.lean ├── ordering.lean ├── recursive.lean ├── recursive_example.lean ├── relational.lean ├── relational_example.lean ├── relational_incremental.lean ├── stream.lean ├── stream_elim.lean └── zset.lean /.github/workflows/lean_build.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | workflow_dispatch: 6 | 7 | jobs: 8 | build_project: 9 | runs-on: ubuntu-latest 10 | name: Build Lean project 11 | steps: 12 | - uses: actions/checkout@v3 13 | - name: build project 14 | uses: leanprover-contrib/lean-build-action@master 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.olean 2 | /_target 3 | /leanpkg.path 4 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | We as members, contributors, and leaders pledge to make participation in database-stream-processing-theory project and our 6 | community a harassment-free experience for everyone, regardless of age, body 7 | size, visible or invisible disability, ethnicity, sex characteristics, gender 8 | identity and expression, level of experience, education, socio-economic status, 9 | nationality, personal appearance, race, religion, or sexual identity 10 | and orientation. 11 | 12 | We pledge to act and interact in ways that contribute to an open, welcoming, 13 | diverse, inclusive, and healthy community. 14 | 15 | ## Our Standards 16 | 17 | Examples of behavior that contributes to a positive environment for our 18 | community include: 19 | 20 | * Demonstrating empathy and kindness toward other people 21 | * Being respectful of differing opinions, viewpoints, and experiences 22 | * Giving and gracefully accepting constructive feedback 23 | * Accepting responsibility and apologizing to those affected by our mistakes, 24 | and learning from the experience 25 | * Focusing on what is best not just for us as individuals, but for the 26 | overall community 27 | 28 | Examples of unacceptable behavior include: 29 | 30 | * The use of sexualized language or imagery, and sexual attention or 31 | advances of any kind 32 | * Trolling, insulting or derogatory comments, and personal or political attacks 33 | * Public or private harassment 34 | * Publishing others' private information, such as a physical or email 35 | address, without their explicit permission 36 | * Other conduct which could reasonably be considered inappropriate in a 37 | professional setting 38 | 39 | ## Enforcement Responsibilities 40 | 41 | Community leaders are responsible for clarifying and enforcing our standards of 42 | acceptable behavior and will take appropriate and fair corrective action in 43 | response to any behavior that they deem inappropriate, threatening, offensive, 44 | or harmful. 45 | 46 | Community leaders have the right and responsibility to remove, edit, or reject 47 | comments, commits, code, wiki edits, issues, and other contributions that are 48 | not aligned to this Code of Conduct, and will communicate reasons for moderation 49 | decisions when appropriate. 50 | 51 | ## Scope 52 | 53 | This Code of Conduct applies within all community spaces, and also applies when 54 | an individual is officially representing the community in public spaces. 55 | Examples of representing our community include using an official e-mail address, 56 | posting via an official social media account, or acting as an appointed 57 | representative at an online or offline event. 58 | 59 | ## Enforcement 60 | 61 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 62 | reported to the community leaders responsible for enforcement at oss-coc@vmware.com. 63 | All complaints will be reviewed and investigated promptly and fairly. 64 | 65 | All community leaders are obligated to respect the privacy and security of the 66 | reporter of any incident. 67 | 68 | ## Enforcement Guidelines 69 | 70 | Community leaders will follow these Community Impact Guidelines in determining 71 | the consequences for any action they deem in violation of this Code of Conduct: 72 | 73 | ### 1. Correction 74 | 75 | **Community Impact**: Use of inappropriate language or other behavior deemed 76 | unprofessional or unwelcome in the community. 77 | 78 | **Consequence**: A private, written warning from community leaders, providing 79 | clarity around the nature of the violation and an explanation of why the 80 | behavior was inappropriate. A public apology may be requested. 81 | 82 | ### 2. Warning 83 | 84 | **Community Impact**: A violation through a single incident or series 85 | of actions. 86 | 87 | **Consequence**: A warning with consequences for continued behavior. No 88 | interaction with the people involved, including unsolicited interaction with 89 | those enforcing the Code of Conduct, for a specified period of time. This 90 | includes avoiding interactions in community spaces as well as external channels 91 | like social media. Violating these terms may lead to a temporary or 92 | permanent ban. 93 | 94 | ### 3. Temporary Ban 95 | 96 | **Community Impact**: A serious violation of community standards, including 97 | sustained inappropriate behavior. 98 | 99 | **Consequence**: A temporary ban from any sort of interaction or public 100 | communication with the community for a specified period of time. No public or 101 | private interaction with the people involved, including unsolicited interaction 102 | with those enforcing the Code of Conduct, is allowed during this period. 103 | Violating these terms may lead to a permanent ban. 104 | 105 | ### 4. Permanent Ban 106 | 107 | **Community Impact**: Demonstrating a pattern of violation of community 108 | standards, including sustained inappropriate behavior, harassment of an 109 | individual, or aggression toward or disparagement of classes of individuals. 110 | 111 | **Consequence**: A permanent ban from any sort of public interaction within 112 | the community. 113 | 114 | ## Attribution 115 | 116 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], 117 | version 2.0, available at 118 | https://www.contributor-covenant.org/version/2/0/code_of_conduct.html. 119 | 120 | Community Impact Guidelines were inspired by [Mozilla's code of conduct 121 | enforcement ladder](https://github.com/mozilla/diversity). 122 | 123 | [homepage]: https://www.contributor-covenant.org 124 | 125 | For answers to common questions about this code of conduct, see the FAQ at 126 | https://www.contributor-covenant.org/faq. Translations are available at 127 | https://www.contributor-covenant.org/translations. 128 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to database-stream-processing-theory 2 | 3 | We welcome contributions from the community and first want to thank you for taking the time to contribute! 4 | 5 | Please familiarize yourself with the [Code of Conduct](https://github.com/tchajed/database-stream-processing-theory/blob/main/CODE_OF_CONDUCT.md) before contributing. 6 | 7 | Before you start working with database-stream-processing-theory, please read our [Developer Certificate of Origin](https://cla.vmware.com/dco). All contributions to this repository must be signed as described on that page. Your signature certifies that you wrote the patch or have the right to pass it on as an open-source patch. 8 | 9 | ## Ways to contribute 10 | 11 | We welcome many different types of contributions and not all of them need a Pull request. Contributions may include: 12 | 13 | * New features and proposals 14 | * Documentation 15 | * Bug fixes 16 | * Issue Triage 17 | * Answering questions and giving feedback 18 | * Helping to onboard new contributors 19 | * Other related activities 20 | 21 | ## Getting started 22 | 23 | * Please see the [README](https://github.com/tchajed/database-stream-processing-theory/blob/main/README.md) for instructions on how to build this project. 24 | * If you're contributing code, please make sure that the project builds and passes all tests with your changes. 25 | 26 | ## Contribution Flow 27 | 28 | This is a rough outline of what a contributor's workflow looks like: 29 | 30 | * Make a fork of the repository within your GitHub account 31 | * Create a topic branch in your fork from where you want to base your work 32 | * Make commits of logical units 33 | * Make sure your commit messages are with the proper format, quality and descriptiveness (see below) 34 | * Push your changes to the topic branch in your fork 35 | * Create a pull request containing that commit 36 | 37 | We follow the GitHub workflow and you can find more details on the [GitHub flow documentation](https://docs.github.com/en/get-started/quickstart/github-flow). 38 | 39 | ### Pull Request Checklist 40 | 41 | Before submitting your pull request, we advise you to use the following: 42 | 43 | 1. Check if your code changes will pass both code linting checks and unit tests. 44 | 2. Ensure your commit messages are descriptive. We follow the conventions on [How to Write a Git Commit Message](http://chris.beams.io/posts/git-commit/). Be sure to include any related GitHub issue references in the commit message. See [GFM syntax](https://guides.github.com/features/mastering-markdown/#GitHub-flavored-markdown) for referencing issues and commits. 45 | 3. Check the commits and commits messages and ensure they are free from typos. 46 | 47 | ## Reporting Bugs and Creating Issues 48 | 49 | For specifics on what to include in your report, please follow the guidelines in the issue and pull request templates when available. 50 | 51 | ## Ask for Help 52 | 53 | The best way to reach us with a question when contributing is to ask on the original GitHub issue, or open a new issue. 54 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Database Stream Processing Theory 2 | Copyright 2022 VMware, Inc. 3 | 4 | The BSD-2 license (the "License") set forth below applies to all parts of the Database Stream Processing Theory project. You may not use this file except in compliance with the License. 5 | 6 | BSD-2 License 7 | 8 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 9 | 10 | Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 11 | 12 | Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 15 | -------------------------------------------------------------------------------- /NOTICE: -------------------------------------------------------------------------------- 1 | Database Stream Processing Theory 2 | Copyright 2022 VMware, Inc. 3 | 4 | This product is licensed to you under the BSD-2 license (the "License"). You may not use this product except in compliance with the BSD-2 License. 5 | 6 | This product may include a number of subcomponents with separate copyright notices and license terms. Your use of these subcomponents is subject to the terms and conditions of the subcomponent's license, as noted in the LICENSE file. 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DBSP formalization 2 | 3 | [![CI](https://github.com/tchajed/database-stream-processing-theory/actions/workflows/lean_build.yml/badge.svg)](https://github.com/tchajed/database-stream-processing-theory/actions/workflows/lean_build.yml) 4 | 5 | Lean formalization of the theory behind [DBSP](https://arxiv.org/abs/2203.16684), a 6 | language for expressing incremental view maintenance for databases. 7 | 8 | DBSP can be divided into two parts: a general theory of operators over streams, 9 | and a specialization of that theory to implement relational algebra queries. 10 | 11 | ## Defining the basic DBSP operators 12 | 13 | - [stream.lean](src/stream.lean) defines infinite streams over an arbitrary type `a` as `ℕ → a`. 14 | - [operators.lean](src/operators.lean) defines the notion of an operator (a 15 | function between streams) and properties of operators (like causality, 16 | strictness). It defines three core operators: the pointwise lifting of a 17 | function, the delay operator `z⁻¹`, and a general fixpoint construction for 18 | constructing a stream recursively. 19 | - [linear.lean](src/linear.lean) defines the differentiation and integration 20 | operators for streams over an arbitrary group, and the associated property of 21 | linearity. 22 | - [incremental.lean](src/incremental.lean) defines the core DBSP idea of the 23 | incrementalization `Q^Δ` of an operator `Q`, defind as `D ∘ Q ∘ I`. It also 24 | has proofs of an equational theory of incrementalization. 25 | - [circuits.lean](src/circuits.lean) defines a "circuit", which is a restricted 26 | language for defining operators. We can define and prove correct a general 27 | algorithm for incrementalizing and optimizing any circuit, and thus any operator 28 | expressible as a circuit. 29 | 30 | ## Relational algebra in DBSP 31 | 32 | - [zset.lean](src/zset.lean) defines Z-sets, a generalization of multisets used 33 | to model relations and changes to relations. A Z-set `Z[A]` over a type `A` is 34 | a function from `A` to integers `ℤ` with finite support: only finitely many 35 | elements map to non-zero integers. 36 | - [relational.lean](src/relational.lean) defines versions of the basic 37 | relational operators over Z-sets, and proves that they implement the set 38 | versions of the operators in an appropriate sense. This includes the 39 | DBSP-specific `distinct` operator, used to convert a Z-set to a set. 40 | - [relational_incremental.lean](src/relational_incremental.lean) proves some 41 | rules for the incremental version of relational operators (perhaps most 42 | interestingly, of the lifted distinct operator). 43 | - [relational_example.lean](src/relational_example.lean) is a self-contained 44 | file that works through an example of optimizing a relational query and its 45 | incremental version. 46 | - [stream_elim.lean](src/stream_elim.lean) defines stream introduction and 47 | elimination functions `δ0` and `∫`. Stream elimination is complicated because 48 | it is only computable for streams that are zero almost everywhere. 49 | - [recursive.lean](src/recursive.lean) defines and proves the correctness of a 50 | circuit that implements the recursive version of a relational query. This uses 51 | the stream introduction and elimination functions to create a new time domain, 52 | which we can think of as successive iterations of the recursion (rather than 53 | the usual notion of time). 54 | - [aggregation.lean](src/aggregation.lean) defines the count and sum 55 | aggregations, which go from a Z-set to a number. 56 | 57 | ## Contributing 58 | 59 | The DBSP team welcomes contributions from the community. Before you start working on this project, please 60 | read our [Developer Certificate of Origin](https://cla.vmware.com/dco). All contributions to this repository must be 61 | signed as described on that page. Your signature certifies that you wrote the patch or have the right to pass it on 62 | as an open-source patch. For more detailed information, refer to [CONTRIBUTING.md](CONTRIBUTING.md). 63 | 64 | ## License 65 | 66 | Copyright 2022-2023 VMware, Inc. 67 | 68 | SPDX-License-Identifier: BSD-2-Clause 69 | 70 | See [NOTICE](NOTICE) and [LICENSE](LICENSE). 71 | -------------------------------------------------------------------------------- /leanpkg.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "dbsp" 3 | version = "0.1" 4 | lean_version = "leanprover-community/lean:3.51.1" 5 | path = "src" 6 | 7 | [dependencies] 8 | mathlib = {git = "https://github.com/leanprover-community/mathlib", rev = "44b58b42794e5abe2bf86397c38e26b587e07e59"} 9 | -------------------------------------------------------------------------------- /src/aggregation.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .relational 5 | 6 | open zset 7 | 8 | section count. 9 | variables {a: Type} [decidable_eq a]. 10 | 11 | def count (m: Z[a]) : ℤ := 12 | m.support.sum (λ a, m a). 13 | 14 | def count' : Z[a] → Z[ℤ] := λ m, {count m}. 15 | 16 | theorem count_ok (s: finset a) : 17 | count (zset.from_set s) = s.card := 18 | begin 19 | unfold count zset.from_set, 20 | simp, 21 | congr' 1, 22 | ext a, simp, 23 | end 24 | 25 | theorem count_linear (m1 m2: Z[a]) : 26 | count (m1 + m2) = count m1 + count m2 := 27 | begin 28 | unfold count, 29 | rw add_support, 30 | simp only [ne.def], 31 | rw finset.sum_filter_of_ne, swap, 32 | { intros x, simp, }, 33 | conv_lhs { 34 | congr, skip, 35 | funext, 36 | simp, skip, 37 | }, 38 | rw finset.sum_add_distrib, 39 | congr' 1, 40 | { rw sum_union_zero_l, simp, }, 41 | { rw finset.union_comm, 42 | rw sum_union_zero_l, simp, } 43 | end 44 | 45 | theorem count'_ok (s: finset a) : 46 | zset.to_set (count' (zset.from_set s)) = {s.card} := 47 | begin 48 | unfold count' zset.to_set, 49 | rw count_ok, 50 | simp, 51 | end 52 | end count. 53 | 54 | namespace zset. 55 | 56 | -- NOTE: this could be generalized to any vector space with ℤ as its constants 57 | protected def sum (m: Z[ℚ]) : ℚ := 58 | m.support.sum (λ a, a * m a). 59 | 60 | def sum' : Z[ℚ] → Z[ℚ] := λ m, {zset.sum m}. 61 | 62 | theorem sum_ok (s: finset ℚ) : 63 | zset.sum (zset.from_set s) = finset.sum s (λ a, a) := 64 | begin 65 | unfold zset.sum zset.from_set, 66 | simp, 67 | apply finset.sum_congr, 68 | { ext a, simp, }, 69 | { intros, refl, }, 70 | end 71 | 72 | theorem sum_linear (m1 m2: Z[ℚ]) : 73 | zset.sum (m1 + m2) = zset.sum m1 + zset.sum m2 := 74 | begin 75 | unfold zset.sum, 76 | apply general_sum_linear (λ a m, a * (↑m : ℚ)), 77 | { intros, simp, }, 78 | { intros, simp, rw mul_add, }, 79 | end 80 | 81 | theorem sum'_ok (s: finset ℚ) : 82 | zset.to_set (sum' (zset.from_set s)) = {finset.sum s (λ a, a)} := 83 | begin 84 | unfold sum' zset.to_set, 85 | rw sum_ok, 86 | simp, 87 | end 88 | 89 | end zset. 90 | -------------------------------------------------------------------------------- /src/circuits.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .operators 5 | import .linear 6 | import .stream_elim 7 | import .incremental 8 | 9 | import tactic.induction 10 | 11 | namespace ckt. 12 | 13 | section ckts. 14 | 15 | parameter (Func: ∀ (a b: Type) [add_comm_group a] [add_comm_group b], Type). 16 | parameter (Func_denote: ∀ {a b: Type} [add_comm_group a] [add_comm_group b], Func a b → (a → b)). 17 | 18 | inductive ckt : ∀ (a b: Type) [add_comm_group a] [add_comm_group b], Type 1 19 | | delay {a: Type} [add_comm_group a] 20 | : ckt a a 21 | | derivative {a: Type} [add_comm_group a] 22 | : ckt a a 23 | | integral {a: Type} [add_comm_group a] 24 | : ckt a a 25 | | incremental {a b: Type} [add_comm_group a] [add_comm_group b] 26 | (f: ckt a b) : ckt a b 27 | | lifting {a b: Type} [add_comm_group a] [add_comm_group b] 28 | (f: Func a b) : ckt a b 29 | -- | ckt_lift {a b: Type} [add_comm_group a] [add_comm_group b] 30 | -- (f: ckt a b) : ckt (stream a) (stream b) 31 | | seq {a b c: Type} [add_comm_group a] [add_comm_group b] [add_comm_group c] 32 | (f1: ckt a b) (f2: ckt b c) : ckt a c 33 | | par {a₁ b₁ a₂ b₂: Type} 34 | [add_comm_group a₁] [add_comm_group a₂] [add_comm_group b₁] [add_comm_group b₂] 35 | (f1: ckt a₁ b₁) (f2: ckt a₂ b₂) : ckt (a₁ × a₂) (b₁ × b₂) 36 | | feedback {a b: Type} [add_comm_group a] [add_comm_group b] 37 | (F: ckt (a × b) b) : ckt a b 38 | -- | intro {a: Type} [add_comm_group a] 39 | -- : ckt a (stream a) 40 | -- | elim {a: Type} [add_comm_group a] 41 | -- : ckt (stream a) a 42 | . 43 | 44 | local notation f1 ` ~~> ` f2:25 := ckt _ f1 f2. 45 | 46 | variables {a b c d: Type} [add_comm_group a] [add_comm_group b] [add_comm_group c] [add_comm_group d]. 47 | 48 | section denote. 49 | 50 | include Func_denote. 51 | 52 | def denote (c: ckt a b) : (stream a → stream b) := 53 | begin 54 | -- unfreezingI { revert_deps a b, revert a b, }, 55 | -- apply (@ckt.rec (λ {a b: Type} [_i1: add_comm_group a] [_i2: add_comm_group b] (f: @ckt a b _i1 _i2), (stream a → stream b))); dsimp; introv; resetI, 56 | 57 | -- resetI resets the (typeclass) instance cache, so that the new local 58 | -- hypotheses can be used for instance search 59 | -- unfortunately we need this unfreezingI thing and induction rather than 60 | -- mathlib induction' because of its improper handling of dependencies 61 | unfreezingI { induction c } , 62 | { resetI, apply delay, }, 63 | { resetI, apply D, }, 64 | { resetI, apply I, }, 65 | { resetI, apply c_ih^Δ, }, 66 | { resetI, apply ↑↑(Func_denote c_f), }, 67 | { -- seq 68 | exact (λ a, c_ih_f2 (c_ih_f1 a)), }, 69 | { -- par 70 | resetI, 71 | apply (uncurry_op (λ x1 x2, sprod (c_ih_f1 x1, c_ih_f2 x2))), }, 72 | { -- feedback 73 | resetI, 74 | intros s, 75 | apply fix (λ α, c_ih (sprod (s, z⁻¹ α))), 76 | }, 77 | -- { resetI, exact ↑↑δ0, }, 78 | -- { resetI, exact ↑↑stream_elim, } 79 | end 80 | end denote. 81 | 82 | def equiv (f1 f2: ckt a b) := denote f1 = denote f2. 83 | 84 | local infix ` === `:50 := equiv. 85 | 86 | @[refl] 87 | lemma equiv_refl (f: ckt a b) : f === f := 88 | by { unfold equiv }. 89 | 90 | @[symm] 91 | lemma equiv_symm (f1 f2: ckt a b) : f1 === f2 → f2 === f1 := 92 | by { unfold equiv, cc, }. 93 | 94 | @[trans] 95 | lemma equiv_trans (f1 f2 f3: ckt a b) : f1 === f2 → f2 === f3 → f1 === f3 := 96 | by { unfold equiv, cc, }. 97 | 98 | @[simp] 99 | lemma denote_seq (f1: ckt a b) (f2: ckt b c) : 100 | denote (ckt.seq f1 f2) = λ x, denote f2 (denote f1 x) := rfl. 101 | 102 | @[simp] 103 | lemma denote_par 104 | (f1: ckt a b) (f2: ckt c d) : 105 | denote (ckt.par f1 f2) = uncurry_op (λ x1 x2, sprod (denote f1 x1, denote f2 x2)) 106 | := rfl. 107 | 108 | @[simp] 109 | lemma denote_delay : 110 | denote (@ckt.delay a _) = delay := rfl. 111 | 112 | @[simp] 113 | lemma denote_derivative : 114 | denote (@ckt.derivative a _) = D := rfl. 115 | 116 | @[simp] 117 | lemma denote_incremental (f: ckt a b) : 118 | denote (ckt.incremental f) = (denote f)^Δ := rfl. 119 | 120 | @[simp] 121 | lemma denote_integral : 122 | denote (@ckt.integral a _) = I := rfl. 123 | 124 | @[simp] 125 | lemma denote_lifting (f: Func a b) : 126 | denote (ckt.lifting f) = ↑↑(Func_denote f) := rfl. 127 | 128 | -- @[simp] 129 | -- lemma denote_ckt_lift (f: ckt a b) : 130 | -- denote (ckt.ckt_lift f) = ↑↑(denote f) := rfl. 131 | 132 | @[simp] 133 | lemma denote_feedback (F: ckt (a × b) b) : 134 | denote (ckt.feedback F) = λ s, fix (λ α, denote F (sprod (s, z⁻¹ α))) := rfl. 135 | 136 | -- @[simp] 137 | -- lemma denote_intro : 138 | -- denote (@ckt.intro a _) = ↑↑δ0 := rfl. 139 | -- 140 | -- @[simp] 141 | -- lemma stream_elim_intro : 142 | -- denote (@ckt.elim a _) = ↑↑∫ := rfl. 143 | 144 | local notation x ` >>> `:55 y:55 := ckt.seq x y. 145 | 146 | -- These definitions rely on being able to lift a few fixed functions; they 147 | -- still make sense, but with relatively complicated assumptions that these 148 | -- functions are available in [Func] with the appropriate meaning according to 149 | -- [Func_denote]. 150 | /- 151 | def lifting2 (f: a → b → c) : ckt (a × b) c := 152 | ckt.lifting (λ xy, f xy.1 xy.2). 153 | 154 | def derivative : ckt a a := 155 | ckt.lifting (λ a, (a, a)) >>> ckt.par (ckt.lifting id) ckt.delay >>> 156 | ckt.lifting2 (λ x y, x - y). 157 | 158 | theorem derivative_denote : 159 | @derivative a _ === ckt.derivative := 160 | begin 161 | unfold derivative, 162 | funext s, simp, 163 | unfold lifting2, simp, 164 | funext t, simp, 165 | refl, 166 | end 167 | 168 | def integral : ckt a a := 169 | ckt.feedback (ckt.lifting2 (λ x y, x + y)). 170 | 171 | theorem integral_denote : 172 | @integral a _ === ckt.integral := 173 | begin 174 | unfold integral, 175 | funext s, simp, 176 | unfold lifting2, simp, 177 | unfold I feedback, simp, 178 | refl, 179 | end 180 | -/ 181 | 182 | def ckt_causal (f: ckt a b) : causal (denote f) := 183 | begin 184 | unfreezingI { induction f }; resetI; try { simp }, 185 | { apply delay_causal, }, 186 | { apply causal_incremental, assumption, }, 187 | { apply causal_comp_causal; assumption, }, 188 | { rw causal2, 189 | introv heq1 heq2, 190 | simp, 191 | split, 192 | { apply f_ih_f1, assumption, }, 193 | { apply f_ih_f2, assumption, }, 194 | }, 195 | { apply (feedback_ckt_causal delay _ (λ (s: stream f_a) (α: stream f_b), ckt.denote f_F (sprod (s, α)))), 196 | rw causal2, 197 | introv heq1 heq2, 198 | apply f_ih, 199 | intros m hle, simp, 200 | split, { apply heq1, omega, }, { apply heq2, omega, }, 201 | apply delay_strict, 202 | }, 203 | end 204 | 205 | def is_strict (f: ckt a b) : {b:bool | b → strict (denote f)} := 206 | begin 207 | unfreezingI { induction f }; simp, 208 | { use true, simp, apply delay_strict, }, 209 | { -- derivative 210 | use false, }, 211 | { -- integral 212 | use false, }, 213 | { -- incremental 214 | cases f_ih with b hstrict, simp at *, 215 | use b, intros hb, 216 | unfold incremental, 217 | apply causal_strict_strict, swap, simp, 218 | apply strict_causal_strict, simp, 219 | tauto, 220 | }, 221 | { -- lifting 222 | use false, }, 223 | { -- seq (composition) 224 | cases f_ih_f1 with b1 hstrict1, 225 | cases f_ih_f2 with b2 hstrict2, simp at *, 226 | use (b1 || b2), simp, 227 | intros h, cases h; resetI, 228 | apply causal_strict_strict, tauto, apply ckt_causal, 229 | apply strict_causal_strict, apply ckt_causal, tauto, 230 | }, 231 | { -- par 232 | cases f_ih_f1 with b1 hstrict1, cases f_ih_f2 with b2 hstrict2, 233 | use (b1 && b2), simp at *, intros h1 h2, 234 | intros s1 s2 n heq, 235 | unfold uncurry_op sprod, simp, 236 | split, 237 | { apply (hstrict1 h1), intros, simp, rw heq, omega, }, 238 | { apply (hstrict2 h2), intros, simp, rw heq, omega, }, 239 | }, 240 | { use false, }, 241 | end 242 | 243 | /- 244 | def incrementalize (f: ckt a b) : ckt a b := 245 | ckt.integral >>> f >>> ckt.derivative. 246 | 247 | theorem incrementalize_ok (f: ckt a b) : 248 | denote (incrementalize f) = (denote f)^Δ := 249 | begin 250 | unfold incrementalize, simp, 251 | funext s, rw incremental_unfold, 252 | end 253 | -/ 254 | 255 | theorem seq_assoc (f1: ckt a b) (f2: ckt b c) (f3: ckt c d) : 256 | f1 >>> f2 >>> f3 === f1 >>> (f2 >>> f3) := 257 | begin 258 | unfold equiv, simp, 259 | end 260 | 261 | section recursive_opt. 262 | 263 | variables (opt: Π {a b: Type} [inst1: add_comm_group a] [inst2: add_comm_group b], 264 | @ckt a b inst1 inst2 → option (@ckt a b inst1 inst2)). 265 | 266 | include opt 267 | def recursive_opt : ckt a b → ckt a b := 268 | begin 269 | intros f, unfreezingI { induction f }, 270 | { apply (opt $ ckt.delay).get_or_else ckt.delay, }, 271 | { apply (opt $ ckt.derivative).get_or_else ckt.derivative, }, 272 | { apply (opt $ ckt.integral).get_or_else ckt.integral, }, 273 | { apply (opt $ ckt.incremental f_f).get_or_else (ckt.incremental f_ih), }, 274 | { resetI, apply (opt $ ckt.lifting f_f).get_or_else (ckt.lifting f_f), }, 275 | { resetI, apply (opt $ ckt.seq f_f1 f_f2).get_or_else (ckt.seq f_ih_f1 f_ih_f2), }, 276 | { resetI, apply (opt $ ckt.par f_f1 f_f2).get_or_else (ckt.par f_ih_f1 f_ih_f2), }, 277 | { resetI, apply (opt $ ckt.feedback f_F).get_or_else (ckt.feedback f_ih), }, 278 | -- { apply (opt $ ckt.intro).get_or_else ckt.intro, }, 279 | -- { apply (opt $ ckt.elim).get_or_else ckt.elim, }, 280 | end 281 | 282 | @[simp] 283 | lemma recursive_opt_seq (f1: ckt a b) (f2: ckt b c) : 284 | recursive_opt @opt (ckt.seq f1 f2) = 285 | (opt $ ckt.seq f1 f2).get_or_else (ckt.seq (recursive_opt @opt f1) (recursive_opt @opt f2)) := rfl. 286 | 287 | @[simp] 288 | lemma recursive_opt_par (f1: ckt a b) (f2: ckt c d) : 289 | recursive_opt @opt (ckt.par f1 f2) = 290 | (opt $ ckt.par f1 f2).get_or_else (ckt.par (recursive_opt @opt f1) (recursive_opt @opt f2)) := rfl. 291 | 292 | @[simp] 293 | lemma recursive_opt_feedback (f: ckt (a × b) b) : 294 | recursive_opt @opt (ckt.feedback f) = 295 | (opt $ ckt.feedback f).get_or_else (ckt.feedback (recursive_opt @opt f)) := rfl. 296 | 297 | @[simp] 298 | lemma recursive_opt_incremental (f: ckt a b) : 299 | recursive_opt @opt (ckt.incremental f) = 300 | (opt $ ckt.incremental f).get_or_else (ckt.incremental (recursive_opt @opt f)) := rfl. 301 | 302 | variables (h_opt: ∀ {a b: Type} [inst1: add_comm_group a] [inst2: add_comm_group b] 303 | (f1 f2: @ckt.ckt a b inst1 inst2), 304 | @opt a b inst1 inst2 f1 = some f2 -> 305 | @ckt.equiv a b inst1 inst2 f1 f2). 306 | 307 | include h_opt 308 | 309 | lemma opt_or_else_ok (f1 f2: ckt a b) : 310 | f2 === f1 → 311 | (opt f1).get_or_else f2 === f1 := 312 | begin 313 | intros heq, 314 | destruct (opt f1); introv hopt; rw hopt; simp, 315 | assumption, 316 | symmetry, apply h_opt, assumption, 317 | end 318 | 319 | theorem recursive_opt_ok : 320 | ∀ (f: ckt a b), recursive_opt @opt f === f := 321 | begin 322 | intros f, unfreezingI { induction f }, 323 | { apply (opt_or_else_ok _ @Func_denote _ @h_opt), refl, }, 324 | { apply (opt_or_else_ok _ @Func_denote _ @h_opt), refl, }, 325 | { apply (opt_or_else_ok _ @Func_denote _ @h_opt), refl, }, 326 | { simp, apply (opt_or_else_ok _ @Func_denote _ @h_opt), 327 | unfold equiv at f_ih |-, 328 | simp, dsimp, rw f_ih, }, 329 | { apply (opt_or_else_ok _ @Func_denote _ @h_opt), refl, }, 330 | { simp, apply (opt_or_else_ok _ @Func_denote _ @h_opt), 331 | unfold equiv at f_ih_f1 f_ih_f2 |-, 332 | simp, dsimp, rw [f_ih_f2, f_ih_f1], 333 | }, 334 | { simp, apply (opt_or_else_ok _ @Func_denote _ @h_opt), 335 | unfold equiv at f_ih_f1 f_ih_f2 |-, 336 | simp, dsimp, rw [f_ih_f1, f_ih_f2], 337 | }, 338 | { simp, apply (opt_or_else_ok _ @Func_denote _ @h_opt), 339 | unfold equiv at f_ih |-, 340 | simp, dsimp, rw f_ih, 341 | }, 342 | end 343 | 344 | end recursive_opt. 345 | 346 | section incrementalize. 347 | 348 | parameters (is_linear: ∀ {a b: Type} [i1: add_comm_group a] [i2: add_comm_group b] 349 | (f: @Func a b i1 i2), bool) 350 | (is_linear_ok: ∀ {a b: Type} [i1: add_comm_group a] [i2: add_comm_group b] 351 | (f: @Func a b i1 i2), @is_linear _ _ i1 i2 f → 352 | ∀ (x y: a), 353 | -- use tactic mode to run resetI; something is weird about 354 | -- elaboration here where instances aren't picked up 355 | (by { resetI, 356 | exact Func_denote f (x + y) = Func_denote f x + Func_denote f y })). 357 | 358 | include is_linear. 359 | 360 | -- returns an optimized version of c^Δ 361 | def incrementalize (c: ckt a b) : ckt a b := 362 | begin 363 | unfreezingI { induction c }, 364 | { exact ckt.delay, }, 365 | { exact ckt.derivative, }, 366 | { exact ckt.integral, }, 367 | { apply ckt.incremental c_ih, }, 368 | { apply (if is_linear c_f 369 | then ckt.lifting c_f 370 | else ckt.incremental (ckt.lifting c_f)), }, 371 | { apply ckt.seq c_ih_f1 c_ih_f2, }, 372 | { apply ckt.par c_ih_f1 c_ih_f2, }, 373 | { apply ckt.feedback c_ih, }, 374 | end 375 | 376 | @[simp] 377 | lemma incrementalize_incremental (c: ckt a b) : 378 | incrementalize (ckt.incremental c) = ckt.incremental (incrementalize c) := rfl. 379 | 380 | @[simp] 381 | lemma incrementalize_lifting (f: Func a b) : 382 | incrementalize (ckt.lifting f) = 383 | if is_linear f then 384 | ckt.lifting f else ckt.incremental (ckt.lifting f) := rfl. 385 | 386 | @[simp] 387 | lemma incrementalize_seq (f1: ckt a b) (f2: ckt b c) : 388 | incrementalize (f1 >>> f2) = incrementalize f1 >>> incrementalize f2 := rfl. 389 | 390 | @[simp] 391 | lemma incrementalize_par (f1: ckt a b) (f2: ckt c d) : 392 | incrementalize (ckt.par f1 f2) = ckt.par (incrementalize f1) (incrementalize f2) := rfl. 393 | 394 | @[simp] 395 | lemma incrementalize_feedback (f: ckt (a × b) b) : 396 | incrementalize (ckt.feedback f) = ckt.feedback (incrementalize f) := rfl. 397 | 398 | include is_linear_ok. 399 | 400 | theorem incrementalize_ok (f: ckt a b) : 401 | denote (incrementalize f) = (denote f)^Δ := 402 | begin 403 | unfreezingI { induction f, }; try { unfold incrementalize; simp; done }, 404 | { simp, rw f_ih, }, 405 | { simp, split_ifs, 406 | { simp, rw lti_incremental, 407 | apply lifting_lti, 408 | intros, apply is_linear_ok, assumption, 409 | }, 410 | { simp, }, 411 | }, 412 | { simp, rw [f_ih_f1, f_ih_f2], 413 | funext s, 414 | rw (incremental_comp 415 | (denote _ @Func_denote f_f2) (denote _ @Func_denote f_f1)), }, 416 | { simp, funext s, 417 | rw [f_ih_f1, f_ih_f2], 418 | unfold uncurry_op, 419 | unfold incremental, 420 | rw [derivative_sprod, integral_fst_comm, integral_snd_comm], 421 | }, 422 | { simp, 423 | rw cycle_incremental (λ s α, denote _ @Func_denote f_F (sprod (s, α))), 424 | { dsimp, 425 | rw f_ih, 426 | funext s, 427 | congr' 1, funext α, 428 | rw incremental_sprod, }, 429 | { dsimp, 430 | rw causal2, introv heq1 heq2, 431 | apply ckt_causal, 432 | intros t hle, simp, 433 | rw [heq1, heq2], finish, assumption, assumption, 434 | }, 435 | }, 436 | end 437 | 438 | end incrementalize. 439 | 440 | end ckts. 441 | end ckt. 442 | -------------------------------------------------------------------------------- /src/incremental.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .linear 5 | 6 | /-! 7 | # Incremental version of an operator 8 | 9 | A key idea of DBSP is to define for any `Q: operator a b` an incremental version 10 | of it, `Q^Δ := D ∘ Q ∘ I`. Notice that `Q^Δ : operator a b` - it has the same 11 | type as `Q`, but it takes as input a stream of changes and outputs a stream of 12 | diffs. 13 | -/ 14 | 15 | section groups. 16 | 17 | variables {a : Type} [add_comm_group a]. 18 | variables {b : Type} [add_comm_group b]. 19 | variables {c : Type} [add_comm_group c]. 20 | 21 | /-- The core definition of DBSP is the incremental version of an operator Q, Q^Δ. 22 | 23 | If we think of the operator Q as a transformation on databases, Q^Δ operates on 24 | a stream of changes and outputs a stream of changes. It does this by simply 25 | integrating the input, applying Q, and differentiating the output. The power of 26 | DBSP comes from re-arranging incremental computations to produce more efficient plans. 27 | -/ 28 | def incremental (Q: operator a b) : operator a b := 29 | λ s, D (Q (I s)). 30 | 31 | -- applied version of incremental that can be useful for rewriting 32 | lemma incremental_unfold (Q: operator a b) (s: stream a) : 33 | incremental Q s = D (Q (I s)) := rfl. 34 | 35 | /-- A version of incremental for curried operators, defined directly. Written 36 | T^Δ2. -/ 37 | def incremental2 (T: operator2 a b c) : operator2 a b c := 38 | λ s1 s2, D (T (I s1) (I s2)). 39 | 40 | -- applied version of incremental2 that can be useful for rewriting 41 | lemma incremental2_unfold (Q: operator2 a b c) (s1: stream a) (s2: stream b) : 42 | incremental2 Q s1 s2 = D (Q (I s1) (I s2)) := rfl. 43 | 44 | postfix `^Δ`:90 := incremental. 45 | postfix `^Δ2`:90 := incremental2. 46 | 47 | private def incremental_inv (Q: operator a b) : operator a b := 48 | I ∘ Q ∘ D. 49 | 50 | local attribute [simp] derivative_integral integral_derivative. 51 | 52 | theorem incremental_inversion_l : 53 | function.left_inverse (@incremental a _ b _) incremental_inv := 54 | begin 55 | intros Q, 56 | unfold incremental incremental_inv, 57 | funext s, simp, 58 | end 59 | 60 | theorem incremental_inversion_r : 61 | function.right_inverse (@incremental a _ b _) incremental_inv := 62 | begin 63 | intros Q, 64 | unfold incremental incremental_inv, 65 | funext s, simp, 66 | end 67 | 68 | theorem incremental_bijection : 69 | function.bijective (@incremental a _ b _) := 70 | begin 71 | split, 72 | { apply function.left_inverse.injective, 73 | apply incremental_inversion_r, }, 74 | { apply function.right_inverse.surjective, 75 | apply incremental_inversion_l, }, 76 | end 77 | 78 | private meta def prove_incremental : tactic unit := 79 | do 80 | tactic.interactive.unfold [``incremental, ``incremental2] (interactive.loc.ns [none]), 81 | tactic.interactive.funext [`s], 82 | tactic.interactive.simp none none false [] [] (interactive.loc.ns [none]), 83 | return () 84 | 85 | theorem delay_invariance : incremental (@delay a _) = delay := 86 | begin 87 | funext s, rw incremental_unfold, 88 | rw derivative_time_invariant, 89 | simp, 90 | end 91 | 92 | theorem integral_invariance : incremental (@I a _) = I := 93 | by prove_incremental. 94 | 95 | theorem derivative_invariance : incremental (@D a _) = D := 96 | by prove_incremental. 97 | 98 | theorem integrate_push (Q: operator a b) : 99 | Q ∘ I = I ∘ Q^Δ := 100 | by prove_incremental. 101 | 102 | theorem derivative_push (Q: operator a b) : 103 | D ∘ Q = Q^Δ ∘ D := 104 | by prove_incremental. 105 | 106 | theorem I_push (Q: operator a b) (s: stream a) : 107 | Q (I s) = I (Q^Δ s) := 108 | by prove_incremental. 109 | 110 | theorem D_push (Q: operator a b) (s: stream a) : 111 | D (Q s) = Q^Δ (D s) := 112 | by prove_incremental. 113 | 114 | theorem D_push2 (Q: operator2 a b c) (s1: stream a) (s2: stream b) : 115 | D (Q s1 s2) = Q^Δ2 (D s1) (D s2) := 116 | by prove_incremental. 117 | 118 | theorem chain_incremental (Q1: operator b c) (Q2: operator a b) : 119 | (Q1 ∘ Q2)^Δ = Q1^Δ ∘ Q2^Δ := 120 | by prove_incremental. 121 | 122 | theorem incremental_comp (Q1: operator b c) (Q2: operator a b) (s: stream a) : 123 | (λ s, Q1 (Q2 (s)))^Δ s = Q1^Δ (Q2^Δ s) := 124 | by prove_incremental. 125 | 126 | theorem add_incremental (Q1 Q2: operator a b) : 127 | (Q1 + Q2)^Δ = Q1^Δ + Q2^Δ := 128 | begin 129 | prove_incremental, 130 | rw derivative_linear, 131 | end 132 | 133 | lemma cycle_body_strict (T: operator2 a b b) (hcausal: causal (uncurry_op T)) : 134 | ∀ s, strict (λ (α : stream b), T s (z⁻¹ α)) := 135 | begin 136 | intros s, 137 | apply (causal_strict_strict delay delay_strict _ _), 138 | apply causal_uncurry_op_fixed, assumption, 139 | end 140 | 141 | lemma cycle_body_integral_strict (T: operator2 a b b) (hcausal: causal (uncurry_op T)) : 142 | ∀ s, strict (λ (α : stream b), T (I s) (z⁻¹ α)) := 143 | begin 144 | intros s, 145 | apply (causal_strict_strict delay delay_strict _ _), 146 | apply causal_uncurry_op_fixed, assumption, 147 | end 148 | 149 | lemma cycle_body_incremental_strict (T: operator2 a b b) (hcausal: causal (uncurry_op T)) 150 | (s: stream a) : strict (λ α, T^Δ2 s (z⁻¹ α)) := 151 | begin 152 | apply (causal_strict_strict delay delay_strict 153 | (λ α, D (T (I s) (I α))) _), 154 | apply (causal_comp_causal _ _ _ derivative_causal), 155 | apply (causal_comp_causal _ integral_causal _ _), 156 | apply causal_uncurry_op_fixed, assumption, 157 | end 158 | 159 | theorem cycle_incremental (T: operator2 a b b) (hcausal: causal (uncurry_op T)) : 160 | (λ (s: stream a), fix (λ α, T s (z⁻¹ α)))^Δ = 161 | λ s, fix (λ α, T^Δ2 s (z⁻¹ α)) := 162 | begin 163 | funext s, 164 | apply fix_unique, 165 | { -- strictness of the body 166 | apply cycle_body_incremental_strict, assumption, }, 167 | { -- fixpoint equation 168 | unfold incremental incremental2, 169 | rw integral_time_invariant, simp, 170 | congr' 1, 171 | apply fix_eq, apply cycle_body_integral_strict; assumption, } 172 | end 173 | 174 | lemma incremental_sprod (f: operator (a×b) c) (s1: stream a) (s2: stream b) : 175 | f^Δ (sprod (s1, s2)) = (λ s1 s2, f (sprod (s1, s2)))^Δ2 s1 s2 := 176 | begin 177 | unfold incremental incremental2, 178 | rw integral_sprod, 179 | end 180 | 181 | theorem lifting_cycle_body_strict2 (T: operator2 a b b) (hcausal: causal (uncurry_op T)) : 182 | ∀ s, strict2 (λ (α : stream (stream b)), ↑²T s (↑↑z⁻¹ α)) := 183 | begin 184 | rw causal2 at hcausal, 185 | intros s, 186 | intros s1 s2 n t heq, 187 | apply hcausal, refl, 188 | intros n' hle, 189 | by_cases (n' = 0), { subst n', simp, }, 190 | simp, 191 | rw delay_sub_1, swap, omega, 192 | rw delay_sub_1, swap, omega, 193 | apply heq; omega, 194 | end 195 | 196 | lemma sum_vals_nested (s: stream (stream a)) (n t: ℕ) : 197 | sum_vals s n t = sum_vals (λ n, s n t) n := 198 | begin 199 | induction n with n; simp, finish, 200 | end 201 | 202 | lemma integral_lift_time_invariant (s: stream (stream a)) : 203 | I (↑↑z⁻¹ s) = ↑↑z⁻¹ (I s) := 204 | begin 205 | funext n t, simp, 206 | repeat { rw integral_sum_vals }, 207 | rw sum_vals_nested, 208 | by_cases (t = 0), 209 | { subst t, simp, rw sum_vals_zero, finish, }, 210 | simp, 211 | rw delay_linear, simp, 212 | rw delay_sub_1, swap, omega, 213 | rw sum_vals_nested, 214 | congr' 1, 215 | funext n, 216 | rw delay_sub_1, omega, 217 | end 218 | 219 | lemma lift_integral_lift_time_invariant (s: stream (stream a)) : 220 | ↑↑I (↑↑z⁻¹ s) = ↑↑z⁻¹ (↑↑I s) := 221 | begin 222 | funext n t, simp, 223 | rw integral_time_invariant, 224 | end 225 | 226 | lemma lifting_delay_linear : linear (↑↑(@delay a _)) := 227 | begin 228 | apply (lifting_lti _ _).1, 229 | intros, rw delay_linear, 230 | end 231 | 232 | lemma integral_causal_nested' (s1 s2: stream (stream a)) (n t: ℕ) 233 | (heq: ∀ n' ≤ n, s1 n' t = s2 n' t) : 234 | I s1 n t = I s2 n t := 235 | begin 236 | rw [integral_sum_vals, integral_sum_vals], 237 | repeat { rw sum_vals_nested }, simp, 238 | rw heq; try { omega }, simp, 239 | induction n with n; simp, 240 | rw heq; try { omega }, simp, 241 | apply n_ih, 242 | intros, apply heq; omega, 243 | end 244 | 245 | @[simp] 246 | lemma integral_causal_nested : causal_nested (@I (stream a) _) := 247 | begin 248 | intros s1 s2 n t heq, 249 | apply integral_causal_nested', 250 | intros, apply heq; omega, 251 | end 252 | 253 | @[simp] 254 | lemma derivative_causal_nested : causal_nested (@D (stream a) _) := 255 | begin 256 | intros s1 s2 n t heq, 257 | unfold D, simp, 258 | rw heq, rotate, omega, omega, 259 | simp, 260 | unfold delay, split_ifs, simp, 261 | rw heq; omega, 262 | end 263 | 264 | lemma cycle_body_strict2 (T: operator2 a (stream b) (stream b)) 265 | (s: stream a) : 266 | causal_nested (T s) → 267 | strict2 (λ α, T s (↑↑z⁻¹ α)) := 268 | begin 269 | intros hcausal, 270 | unfold strict2, intros s1 s2 n t hseq, 271 | funext t, 272 | apply hcausal, intros, 273 | apply lifting_delay_strict2, intros, 274 | apply hseq; omega, 275 | end 276 | 277 | lemma cycle_body_incremental_strict2 (T: operator2 a (stream b) (stream b)) 278 | (s: stream a) : 279 | causal_nested (T (I s)) → 280 | strict2 (λ α, T^Δ2 s (↑↑z⁻¹ α)) := 281 | begin 282 | intros hcausal, 283 | unfold incremental2, 284 | unfold strict2, intros s1 s2 n t hseq, 285 | funext t, 286 | apply derivative_causal_nested, intros, 287 | apply hcausal, intros, 288 | apply integral_causal_nested, intros, 289 | apply lifting_delay_strict2, intros, 290 | apply hseq; omega, 291 | end 292 | 293 | theorem lifting_cycle (T: operator2 a b b) (hcausal: causal (uncurry_op T)) : 294 | ↑↑(λ s, fix (λ α, T s (z⁻¹ α))) = λ s, fix2 (λ α, ↑²T s (↑↑z⁻¹ α)) := 295 | begin 296 | funext s, 297 | apply fix2_unique, 298 | { apply lifting_cycle_body_strict2, assumption, }, 299 | { funext t, simp, 300 | apply fix_eq, apply cycle_body_strict, assumption, 301 | } 302 | end 303 | 304 | theorem cycle2_incremental (T: operator2 a (stream b) (stream b)) 305 | (hcausal: ∀ s, causal_nested (T s)) : 306 | (λ (s: stream a), fix2 (λ α, T s (↑↑z⁻¹ α)))^Δ = 307 | λ s, fix2 (λ α, T^Δ2 s (↑↑z⁻¹ α)) := 308 | begin 309 | funext s, 310 | apply fix2_unique, 311 | { -- strictness of the body 312 | apply (cycle_body_incremental_strict2 T), finish, }, 313 | { -- fixpoint equation 314 | unfold incremental incremental2, 315 | rw integral_lift_time_invariant, simp, 316 | congr' 1, 317 | apply fix2_eq, apply cycle_body_strict2, finish, }, 318 | end 319 | 320 | theorem lti_incremental (Q: operator a b) (h: lti Q) : 321 | Q^Δ = Q := 322 | begin 323 | funext s, unfold incremental, 324 | unfold D, 325 | rw<- h.2, 326 | rw<- integral_time_invariant, 327 | rw<- (linear_sub h.1), 328 | rw<- (linear_sub integral_linear), 329 | change (s - z⁻¹ s) with (D s), simp, 330 | end 331 | 332 | @[simp] 333 | theorem I_incremental : 334 | I^Δ = @I a _ := 335 | begin 336 | apply lti_incremental, 337 | apply integral_lti, 338 | end 339 | 340 | @[simp] 341 | theorem D_incremental : 342 | D^Δ = @D a _ := 343 | begin 344 | apply lti_incremental, 345 | apply derivative_lti, 346 | end 347 | 348 | theorem delay_lti : 349 | lti (@delay a _) := 350 | begin 351 | split, 352 | apply delay_linear, 353 | apply delay_time_invariant, 354 | end 355 | 356 | @[simp] 357 | theorem delay_incremental : 358 | z⁻¹^Δ = @delay a _ := 359 | begin 360 | apply lti_incremental, 361 | apply delay_lti, 362 | end 363 | 364 | lemma sprod_time_invariant (T : operator2 a b c) 365 | (s1 : stream a) (s2 : stream b) : 366 | ↑(z⁻¹ s1, z⁻¹ s2) = z⁻¹ (↑(s1, s2) : stream (a × b)) := 367 | begin 368 | funext t, simp, 369 | unfold delay, 370 | split_ifs; simp, 371 | end 372 | 373 | lemma time_invariant_map_fst (s: stream (a × b)) (n: ℕ) : 374 | (z⁻¹ s n).fst = z⁻¹ (λ (n : ℕ), (s n).fst) n := 375 | begin 376 | unfold delay, 377 | split_ifs; simp, 378 | end 379 | 380 | lemma time_invariant_map_snd (s: stream (a × b)) (n: ℕ) : 381 | (z⁻¹ s n).snd = z⁻¹ (λ (n : ℕ), (s n).snd) n := 382 | begin 383 | unfold delay, 384 | split_ifs; simp, 385 | end 386 | 387 | lemma time_invariant2 (T: operator2 a b c) : 388 | time_invariant (uncurry_op T) ↔ 389 | (∀ s1 s2, T (z⁻¹ s1) (z⁻¹ s2) = z⁻¹ (T s1 s2)) := 390 | begin 391 | split, 392 | { intros hti, intros _ _, 393 | rw (uncurry_op_intro T), 394 | rw (uncurry_op_intro T), 395 | rw<- hti, 396 | congr, 397 | rw<- (sprod_time_invariant T), }, 398 | { intros h s, 399 | funext t, simp [uncurry_op, lifting], 400 | rw<- h, 401 | congr' 1; funext t, 402 | { rw time_invariant_map_fst, }, 403 | { rw time_invariant_map_snd, }, 404 | } 405 | end 406 | 407 | @[simp] 408 | theorem causal_incremental (Q: operator a b) : 409 | causal Q → 410 | causal (Q^Δ) := 411 | begin 412 | intros h, 413 | unfold incremental, 414 | apply causal_comp_causal, swap, apply derivative_causal, 415 | apply causal_comp_causal, swap, apply h, 416 | apply integral_causal, 417 | end 418 | 419 | theorem causal_incremental2 (Q: operator2 a b c) : 420 | causal (uncurry_op Q) → 421 | causal (λ s, Q^Δ2 (↑↑prod.fst s) (↑↑prod.snd s)) := 422 | begin 423 | intros h, 424 | apply causal_comp_causal, swap, apply derivative_causal, 425 | rw causal2 at h, 426 | intros s1 s2 n heq, simp, 427 | apply h, 428 | { apply causal_respects_agree_upto, apply integral_causal, 429 | apply causal_respects_agree_upto, apply lifting_causal, 430 | assumption, 431 | }, 432 | { apply causal_respects_agree_upto, apply integral_causal, 433 | apply causal_respects_agree_upto, apply lifting_causal, 434 | assumption, 435 | }, 436 | end 437 | 438 | @[simp] 439 | theorem causal_nested_incremental 440 | (Q: operator (stream a) (stream b)) : 441 | causal_nested Q → 442 | causal_nested (Q^Δ) := 443 | begin 444 | intros h, 445 | unfold causal_nested, intros, 446 | rw [incremental_unfold, incremental_unfold], 447 | apply causal_nested_comp, apply derivative_causal_nested, 448 | apply h, 449 | intros, 450 | apply integral_causal_nested, intros, apply heq; omega, 451 | end 452 | 453 | @[simp] 454 | theorem causal_nested_lifting2 {d: Type} [add_comm_group d] 455 | (f: stream b → stream c → stream d) (g: operator (stream a) (stream b)) (h: operator (stream a) (stream c)) : 456 | causal (uncurry_op f) → 457 | causal_nested g → 458 | causal_nested h → 459 | causal_nested (λ s, ↑²f (g s) (h s)) := 460 | begin 461 | intros hf hg hh, 462 | intros s1 s2 n t heq, simp, 463 | rw causal2 at hf, 464 | apply hf, 465 | { intros n' hle, apply hg, intros, apply heq; omega }, 466 | { intros n' hle, apply hh, intros, apply heq; omega }, 467 | end 468 | 469 | @[simp] 470 | theorem causal_nested_lifting2_incremental {d: Type} [add_comm_group d] 471 | (f: stream b → stream c → stream d) (g: operator (stream a) (stream b)) (h: operator (stream a) (stream c)) : 472 | causal (uncurry_op f) → 473 | causal_nested g → 474 | causal_nested h → 475 | causal_nested (λ s, ↑²f^Δ2 (g s) (h s)) := 476 | begin 477 | intros hf hg hh, 478 | unfold incremental2, 479 | apply causal_nested_comp, simp, 480 | apply causal_nested_lifting2, 481 | { assumption, }, 482 | { apply causal_nested_comp, simp, assumption, }, 483 | { apply causal_nested_comp, simp, assumption, }, 484 | end 485 | 486 | @[simp] 487 | theorem causal_lifting2 {d: Type} [add_comm_group d] 488 | (f: b → c → d) (g: operator a b) (h: operator a c) : 489 | causal g → 490 | causal h → 491 | causal (λ s, ↑²f (g s) (h s)) := 492 | begin 493 | intros hg hh, 494 | intros s1 s2 n heq, simp, 495 | rw [hg, hh]; assumption, 496 | end 497 | 498 | @[simp] 499 | theorem causal_lifting2_incremental {d: Type} [add_comm_group d] 500 | (f: b → c → d) (g: operator a b) (h: operator a c) : 501 | causal g → 502 | causal h → 503 | causal (λ s, ↑²f^Δ2 (g s) (h s)) := 504 | begin 505 | intros hg hh, 506 | apply causal_comp_causal, swap, simp, 507 | apply causal_lifting2, 508 | { apply causal_comp_causal; simp, assumption, }, 509 | { apply causal_comp_causal; simp, assumption, }, 510 | end 511 | 512 | lemma lifting2_sum (f g: a → b → c) : 513 | (↑² (λ x y, f x y + g x y)) = ↑²f + ↑²g := rfl. 514 | 515 | theorem lifting2_incremental_sum (f g: a → b → c) : 516 | (↑² (λ x y, f x y + g x y))^Δ2 = ↑²f^Δ2 + ↑²g^Δ2 := 517 | begin 518 | unfold incremental2, 519 | funext s1 s2 t, simp, 520 | rw lifting2_sum, simp, 521 | rw derivative_linear, simp, 522 | end 523 | 524 | private lemma lifting2_incremental_unfold {d e: Type} [add_comm_group d] [add_comm_group e] 525 | (f: b → c → d) (g: a → b) (h: e → c) : 526 | ↑²(λ x y, f (g x) (h y))^Δ2 = λ s1 s2, D (↑²f (↑↑g (I s1)) (↑↑h (I s2))) := 527 | begin 528 | refl, 529 | end 530 | 531 | lemma lifting2_incremental_comp {d e: Type} [add_comm_group d] [add_comm_group e] 532 | (f: b → c → d) (g: a → b) (h: e → c) : 533 | ↑²(λ x y, f (g x) (h y))^Δ2 = λ s1 s2, ↑²f^Δ2 (↑↑g^Δ s1) (↑↑h^Δ s2) := 534 | begin 535 | funext s1 s2, 536 | rw lifting2_incremental_unfold, dsimp, 537 | rw incremental2_unfold, 538 | rw D_push2, 539 | refl, 540 | end 541 | 542 | @[simp] 543 | lemma incremental_id : 544 | incremental (λ (x:stream a), x) = id := 545 | by { funext s, rw incremental_unfold, simp, }. 546 | 547 | @[simp] 548 | lemma incremental_id' : 549 | incremental (@id (stream a)) = id := 550 | by { funext s, rw incremental_unfold, simp, }. 551 | 552 | lemma lifting2_incremental_comp_1' {d: Type} [add_comm_group d] 553 | (f: b → c → d) (g: a → b) : 554 | ↑²(λ x, f (g x))^Δ2 = λ s1, ↑²f^Δ2 (↑↑g^Δ s1) := 555 | begin 556 | funext s1 s2, 557 | rw lifting2_incremental_comp, simp, 558 | end 559 | 560 | lemma lifting2_incremental_comp_1 {d: Type} [add_comm_group d] 561 | (f: b → c → d) (g: a → b) : 562 | ↑²(λ x y, f (g x) y)^Δ2 = λ s1 s2, ↑²f^Δ2 (↑↑g^Δ s1) s2 := 563 | begin 564 | simp, 565 | apply lifting2_incremental_comp_1', 566 | end 567 | 568 | lemma lifting2_incremental_comp_2 {d e: Type} [add_comm_group d] [add_comm_group e] 569 | (f: b → c → d) (h: e → c) : 570 | ↑²(λ x y, f x (h y))^Δ2 = λ s1 s2, ↑²f^Δ2 s1 (↑↑h^Δ s2) := 571 | begin 572 | funext s1 s2, 573 | rw lifting2_incremental_comp, simp, 574 | end 575 | 576 | end groups. 577 | 578 | -- This theorem is much more clearly stated using the metavariables a, b, c for 579 | -- terms (to match the paper), so here we instead use α, β, γ for the types. 580 | section bilinear. 581 | 582 | variables {α : Type} [add_comm_group α]. 583 | variables {β : Type} [add_comm_group β]. 584 | variables {γ : Type} [add_comm_group γ]. 585 | 586 | variable (times: operator2 α β γ). 587 | 588 | -- write times a b as a ** b for this section 589 | -- NOTE: this isn't printed, sadly 590 | local notation a ` ** `:70 b:70 := times a b. 591 | 592 | local attribute [simp] derivative_integral integral_derivative. 593 | 594 | def times_incremental : stream α → stream β → stream γ := 595 | λ a b, a ** b + I (z⁻¹ a) ** b + a ** I (z⁻¹ b). 596 | 597 | theorem bilinear_incremental : 598 | time_invariant (uncurry_op times) → 599 | bilinear times → 600 | times^Δ2 = times_incremental times := 601 | begin 602 | intros hti hbil, funext a b, 603 | -- this calculation is almost a transcription of the paper proof in 604 | -- https://github.com/vmware/database-stream-processor/blob/main/doc/spec.pdf 605 | calc times^Δ2 a b = D (I a ** I b) : by refl 606 | ... = I a ** I b - z⁻¹ (I a ** I b) : by refl 607 | ... = I a ** I b - z⁻¹ (I a) ** z⁻¹ (I b) : by { 608 | rw (time_invariant2 _).mp hti 609 | } 610 | ... = I a ** I b - z⁻¹ (I a) ** z⁻¹ (I b) 611 | + z⁻¹ (I a) ** I b - z⁻¹ (I a) ** I b : by { abel } 612 | ... = D (I a) ** I b + z⁻¹ (I a) ** D (I b) : by { 613 | unfold D, 614 | rw (bilinear_sub_1 hbil), 615 | rw (bilinear_sub_2 hbil), abel, 616 | } 617 | ... = a ** I b + z⁻¹ (I a) ** b : by simp 618 | ... = a ** I b - a ** z⁻¹ (I b) + a ** z⁻¹ (I b) 619 | + z⁻¹ (I a) ** b : by abel 620 | ... = a ** D (I b) + a ** z⁻¹ (I b) + z⁻¹ (I a) ** b : by { 621 | unfold D, 622 | rw (bilinear_sub_2 hbil), 623 | } 624 | ... = a ** b + z⁻¹ (I a) ** b + a ** z⁻¹ (I b) : by { simp, abel, } 625 | -- this one extra step is needed that the paper skips over 626 | ... = a ** b + I (z⁻¹ a) ** b + a ** I (z⁻¹ b) : by { 627 | repeat { rw integral_time_invariant }, 628 | }, 629 | end 630 | 631 | -- NOTE: this is a much simpler proof than the one in the paper 632 | theorem bilinear_incremental_forward_proof : 633 | time_invariant (uncurry_op times) → 634 | bilinear times → 635 | ∀ a b, times^Δ2 a b = 636 | a ** b + I (z⁻¹ a) ** b + a ** I (z⁻¹ b) := 637 | begin 638 | intros hti hbil a b, 639 | unfold incremental2 D, 640 | -- we're just going to expand (I a) and (I b) in the first occurrence 641 | conv { 642 | find (times (I a) (I b)) { 643 | rw [integral_unfold a, integral_unfold b] 644 | } 645 | }, 646 | -- push delays as far inward as possible 647 | rw<- (time_invariant2 _).mp hti, 648 | repeat { rw<- integral_time_invariant }, 649 | -- and now we can expand using bilinearity 650 | repeat { rw hbil.1 <|> rw hbil.2 }, 651 | abel, 652 | end 653 | 654 | -- variant of [bilinear_incremental_forward_proof] written with [conv] so the 655 | -- proof itself is readable 656 | theorem bilinear_incremental_short_paper_proof : 657 | time_invariant (uncurry_op times) → 658 | bilinear times → 659 | ∀ a b, times^Δ2 a b = 660 | a ** b + I (z⁻¹ a) ** b + a ** I (z⁻¹ b) := 661 | begin 662 | intros hti hbil a b, 663 | calc times^Δ2 a b = D (I a ** I b) : by refl 664 | ... = I a ** I b - z⁻¹ (I a ** I b) : by refl 665 | ... = I a ** I b - z⁻¹ (I a) ** z⁻¹ (I b) : by { 666 | rw<- (time_invariant2 _).mp hti, 667 | } 668 | ... = (a + z⁻¹ (I a)) ** (b + z⁻¹ (I b)) - z⁻¹ (I a) ** z⁻¹ (I b) : by { 669 | congr' 1, 670 | conv_lhs { 671 | find (times (I a) (I b)) { 672 | rw [integral_unfold a, integral_unfold b] 673 | } 674 | }, 675 | } 676 | ... = a ** b + z⁻¹ (I a) ** b + a ** z⁻¹ (I b) + z⁻¹ (I a) ** z⁻¹ (I b) 677 | - z⁻¹ (I a) ** z⁻¹ (I b) : by { 678 | -- bilinearity to distribute (a + b) × (c + d) 679 | rw [hbil.2, hbil.1, hbil.1], 680 | abel, 681 | } 682 | ... = a ** b + z⁻¹ (I a) ** b + a ** z⁻¹ (I b) : by { 683 | -- cancel terms 684 | abel, 685 | } 686 | ... = a ** b + I (z⁻¹ a) ** b + a ** I (z⁻¹ b) : by { 687 | rw [integral_time_invariant, integral_time_invariant], 688 | }, 689 | end 690 | 691 | end bilinear. 692 | 693 | attribute [irreducible] incremental incremental2. 694 | 695 | -- #lint only doc_blame simp_nf 696 | -------------------------------------------------------------------------------- /src/linear.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .operators 5 | import algebra.group.defs 6 | import algebra.group.pi 7 | import algebra.ring.basic 8 | import tactic.abel 9 | 10 | /-! 11 | # Linearity, differentiation, and integration 12 | 13 | This file extends DBSP with two key operators: differentiation and integration. 14 | These are based on the idea of linearity, a property of streams over Abelian 15 | (commutative) groups. 16 | -/ 17 | 18 | variables {a : Type} [add_comm_group a]. 19 | variables {b : Type} [add_comm_group b]. 20 | variables {c : Type} [add_comm_group c]. 21 | 22 | instance stream_group : add_comm_group (stream a) := by { unfold stream, apply_instance }. 23 | 24 | /-- An operator `S` is linear if S (x + y) = S x + S y; that is, it should be a 25 | homomorphism between `stream a` and `stream b`. -/ 26 | def linear (S: operator a b) := 27 | -- note this is phrased in the stream group 28 | (∀ x y, S (x + y) = S x + S y). 29 | 30 | -- for symmetry with the other properties derived from linear (and to avoid 31 | -- directly depending on this definition) 32 | lemma linear_add {S: operator a b} (h: linear S) : 33 | ∀ s1 s2, S (s1 + s2) = S s1 + S s2 := h. 34 | 35 | lemma linear_zero {S: operator a b} (h: linear S) : 36 | S 0 = 0 := 37 | begin 38 | have h0 := h 0 0, 39 | simp at h0, 40 | apply h0, 41 | end 42 | 43 | lemma linear_neg {S: operator a b} (h: linear S) : 44 | ∀ s, S (-s) = -S s := 45 | begin 46 | intros s, 47 | have h0 := h (-s) s, simp at h0, 48 | rw (linear_zero h) at h0, 49 | apply add_eq_zero_iff_eq_neg.mp, rw<- h0, 50 | end 51 | 52 | lemma linear_sub {S: operator a b} (h: linear S) : 53 | ∀ s1 s2, S (s1 - s2) = S s1 - S s2 := 54 | begin 55 | intros, 56 | repeat { rw sub_eq_add_neg }, 57 | rw h, 58 | rw (linear_neg h), 59 | end 60 | 61 | theorem lifted_linear (f: a → b) : 62 | (∀ x y, f (x + y) = f x + f y) → 63 | linear (lifting f) := 64 | begin 65 | intros hlin s1 s2, funext s, simp, 66 | rw hlin, 67 | end 68 | 69 | /-- LTI stands for linear time invariant. -/ 70 | def lti (S: operator a b) := 71 | linear S ∧ time_invariant S. 72 | 73 | -- a weak zero-preservation at only t=0 74 | lemma lti_operator_zpp (S: operator a b) : 75 | lti S → S 0 0 = 0 := λ h, time_invariant_0_0 S h.2. 76 | 77 | /-- A function of two arguments is bilinear if it is linear in each argument 78 | separately (holding the other constant). A classic example is multiplication. -/ 79 | def bilinear (f: a → b → c) := 80 | -- linear in each argument, separately 81 | (∀ x1 x2 y, f (x1 + x2) y = f x1 y + f x2 y) ∧ 82 | (∀ x y1 y2, f x (y1 + y2) = f x y1 + f x y2). 83 | 84 | lemma bilinear_sub_1 {f: operator2 a b c} (hblin: bilinear f) : 85 | ∀ x1 x2 y, f (x1 - x2) y = f x1 y - f x2 y := 86 | begin 87 | intros _ _ _, 88 | have h: linear (λ x, f x y) := by { 89 | unfold linear, 90 | intros _ _, 91 | apply hblin.1, 92 | }, 93 | apply (linear_sub h), 94 | end 95 | 96 | lemma bilinear_sub_2 {f: operator2 a b c} (hblin: bilinear f) : 97 | ∀ x y1 y2, f x (y1 - y2) = f x y1 - f x y2 := 98 | begin 99 | intros _ _ _, 100 | have h: linear (f x) := hblin.2 x, 101 | apply (linear_sub h), 102 | end 103 | 104 | theorem lifting_bilinear (f: a → b → c) : 105 | bilinear f → bilinear ↑²f := 106 | begin 107 | intros hf, unfold lifting2, 108 | split, 109 | { intros x1 x2 z, 110 | funext t, simp, 111 | apply hf.1, }, 112 | { intros x1 x2 z, 113 | funext t, simp, 114 | apply hf.2, }, 115 | end 116 | 117 | -- note that this is for the specific group ℤ 118 | theorem mul_Z_bilinear : 119 | bilinear (lifting2 (λ (z1 z2 : ℤ), z1 * z2)) := 120 | begin 121 | apply lifting_bilinear, 122 | split; intros _ _ _; ring_nf, 123 | end 124 | 125 | -- NOTE: it is important to take {a: Type} since we don't want to assume the 126 | -- group and ring structures over a separately, we need the group structure to 127 | -- be the one from the ring 128 | theorem mul_ring_bilinear {a: Type} [ring a] : 129 | bilinear (@lifting2 a a a (λ (z1 z2 : a), z1 * z2)) := 130 | begin 131 | apply lifting_bilinear, 132 | split; intros _ _ _; ring_nf, 133 | { rw right_distrib, }, 134 | { rw left_distrib, }, 135 | end 136 | 137 | /-- 138 | 139 | A "feedback" circuit that keeps adding its output from the previous time step, 140 | defined using a fixpoint. To be well-defined, `S` must be causal. 141 | 142 | ``` 143 | ┌─────┐ 144 | s ────▶ + ────▶│ S │───▶ α 145 | ▲ └─────┘ 146 | │ │ 147 | ┌─────┐ │ 148 | │ z⁻¹ │◀─────┘ 149 | └─────┘ 150 | ``` 151 | -/ 152 | def feedback (S: operator a a) : operator a a := 153 | λ s, fix (λ α, S (s + delay α)). 154 | 155 | theorem feedback_strict {S : operator a a} 156 | (hcausal : causal S) (s : stream a) : 157 | strict (λ (α : stream a), S (s + delay α)) := 158 | begin 159 | apply (feedback_ckt_body_strict _ delay_strict (λ s t, S (s + t))), 160 | rw causal2, 161 | introv h1 h2, 162 | apply hcausal, 163 | intros i hle, simp, 164 | rw [h1, h2]; omega 165 | end 166 | 167 | /-- As long as `S` is [causal], the body of the feedback loop is strict and 168 | [feedback] can be unfolded according to its recursive definition. -/ 169 | theorem feedback_unfold (S: operator a a) : 170 | causal S → 171 | ∀ s, feedback S s = S (s + delay (feedback S s)) := 172 | begin 173 | intros hcausal s, 174 | unfold feedback, 175 | apply fix_eq, 176 | apply (feedback_strict hcausal), 177 | end 178 | 179 | lemma delay_linear : linear (@delay a _) := 180 | begin 181 | intros x y, 182 | funext t, 183 | unfold delay, simp, 184 | by_cases h_t : t = 0, 185 | { repeat { rw (if_pos h_t) }, simp, }, 186 | { repeat { rw (if_neg h_t) } }, 187 | end 188 | 189 | theorem add_linear : 190 | linear (uncurry_op ((+) : stream a → stream a → stream a)) := 191 | begin 192 | intros x y, 193 | funext t, 194 | unfold uncurry_op delay, simp, 195 | abel, 196 | end 197 | 198 | lemma agree_upto_respects_add (s1 s2 s1' s2': stream a) (n: ℕ) : 199 | s1 ==n== s1' → 200 | s2 ==n== s2' → 201 | (s1 + s2) ==n== (s1' + s2') := 202 | begin 203 | intros h1 h2, 204 | intros t hle, simp, 205 | rw [h1, h2]; assumption, 206 | end 207 | 208 | lemma agree_upto_respects_sub (s1 s2 s1' s2': stream a) (n: ℕ) : 209 | s1 ==n== s1' → 210 | s2 ==n== s2' → 211 | (s1 - s2) ==n== (s1' - s2') := 212 | begin 213 | intros h1 h2, 214 | intros t hle, simp, 215 | rw [h1, h2]; assumption, 216 | end 217 | 218 | -- TODO: can we give a general characterization of time invariance of fixpoints? 219 | 220 | theorem feedback_time_invariant (S: operator a a) : 221 | causal S → time_invariant S → 222 | time_invariant (feedback S) := 223 | begin 224 | intros hcausal hti, 225 | intros s, 226 | rw agree_everywhere_eq, 227 | intros n, 228 | induction n with n, 229 | { rw agree_upto_0, 230 | unfold feedback, simp, 231 | rw (time_invariant_t hti), simp, 232 | }, 233 | { rw feedback_unfold; try { assumption }, 234 | rw<- delay_linear, 235 | rw hti, 236 | apply delay_succ_upto, 237 | have h : s + feedback S (delay s) ==n== s + delay (feedback S s) := by { 238 | apply agree_upto_respects_add, 239 | reflexivity, assumption, 240 | }, 241 | have heq := (causal_respects_agree_upto _ hcausal _ _ _ h), 242 | transitivity, assumption, 243 | rw<- (feedback_unfold _ hcausal s), 244 | }, 245 | end 246 | 247 | theorem feedback_causal (S: operator a a) : 248 | causal S → 249 | causal (feedback S) := 250 | begin 251 | intros hcausal, 252 | have h := hcausal, 253 | rw causal_to_agree at h |-, 254 | introv heq, 255 | induction n with n, 256 | { rw [feedback_unfold _ hcausal s1, 257 | feedback_unfold _ hcausal s2], 258 | apply h, 259 | rw agree_upto_0 at heq |-, simp, assumption, 260 | }, 261 | { rw [feedback_unfold _ hcausal s1, 262 | feedback_unfold _ hcausal s2], 263 | apply h, 264 | apply agree_upto_respects_add, assumption, 265 | apply delay_succ_upto, 266 | apply n_ih, 267 | apply agree_upto_weaken1, assumption, } 268 | end 269 | 270 | theorem feedback_linear (S: operator a a) : 271 | causal S → lti S → 272 | linear (feedback S) := 273 | begin 274 | intros hcausal hlti, 275 | cases hlti with hlin hti, 276 | intros s1 s2, 277 | symmetry, apply fix_unique, 278 | { apply (feedback_strict hcausal) }, 279 | conv_lhs begin 280 | rw [feedback_unfold _ hcausal s1, 281 | feedback_unfold _ hcausal s2] 282 | end, 283 | repeat { rw hlin <|> rw delay_linear }, 284 | abel, 285 | end 286 | 287 | theorem feedback_lti (S: operator a a) : 288 | causal S → lti S → 289 | lti (feedback S) := 290 | begin 291 | intros hcausal hlti, 292 | split, 293 | { apply feedback_linear; assumption, }, 294 | { apply feedback_time_invariant; cases hlti; assumption }, 295 | end 296 | 297 | /-- The derivative operator, written simply `D`, is a core operator in DBSP. It 298 | "differentiates" a stream: `(D s)(t) = s(t) - s(t - 1)` (with `(D s)(0) = 0`), 299 | producing a stream of what we can think of as changes, although both the input 300 | and output are streams of a's. 301 | 302 | Theorem names related to the derivative will use 'derivative'. 303 | -/ 304 | def D : operator a a := λ s, s - delay s. 305 | 306 | @[simp] 307 | lemma derivative_causal : causal (@D a _) := 308 | begin 309 | rw causal_to_agree, 310 | unfold D, 311 | intros s s' t hagree, 312 | apply agree_upto_respects_sub, 313 | assumption, 314 | apply agree_upto_weaken1, 315 | apply delay_succ_upto, assumption, 316 | end 317 | 318 | lemma derivative_time_invariant : time_invariant (@D a _) := 319 | begin 320 | unfold time_invariant D, 321 | intros s, 322 | rw (linear_sub delay_linear), 323 | end 324 | 325 | lemma derivative_linear : linear (@D a _) := 326 | begin 327 | intros s1 s2, 328 | unfold D, 329 | funext s, simp, 330 | repeat { rw delay_linear }, 331 | abel, simp, 332 | rw add_comm, 333 | end 334 | 335 | lemma derivative_lti : lti (@D a _) := 336 | begin 337 | split, apply derivative_linear, apply derivative_time_invariant, 338 | end 339 | 340 | /-- The integral operator is another fundamental operator in DBSP. It takes a 341 | stream of changes and computes the sum of the changes so far; this is 342 | implemented recursively with a fixpoint. 343 | 344 | Theorem names will use 'integral' even though the operator is named I. 345 | -/ 346 | def I : operator a a := feedback id. 347 | 348 | protected lemma id_causal : causal (@id (stream a)) := 349 | begin 350 | unfold causal, 351 | intros s s' t heq, 352 | apply heq, omega, 353 | end 354 | 355 | protected lemma id_time_invariant : time_invariant (@id (stream a)) := 356 | begin 357 | unfold time_invariant, 358 | simp, 359 | end 360 | 361 | protected lemma id_lti : lti (@id (stream a)) := 362 | begin 363 | split, 364 | { intros s1 s2, simp }, 365 | apply id_time_invariant, 366 | end 367 | 368 | @[simp] 369 | lemma integral_causal : causal (@I a _) := 370 | begin 371 | apply feedback_causal, 372 | apply id_causal 373 | end 374 | 375 | theorem integral_lti : lti (@I a _) := 376 | begin 377 | unfold I, 378 | apply feedback_lti, 379 | { apply id_causal, }, 380 | { apply id_lti, } 381 | end 382 | 383 | theorem integral_time_invariant : time_invariant (@I a _) := 384 | integral_lti.2. 385 | 386 | theorem integral_linear : linear (@I a _) := 387 | integral_lti.1. 388 | 389 | theorem integral_unfold : 390 | ∀ (s: stream a), I s = s + delay (I s) := 391 | begin 392 | intros s, 393 | unfold I, 394 | apply feedback_unfold, 395 | apply id_causal, 396 | end 397 | 398 | /-- The sum of `s[0] .. s[n-1]`. This is a closed form version of the integral 399 | operator (offset by 1), as proven in [integral_sum_vals]. -/ 400 | def sum_vals (s: stream a) : ℕ → a 401 | | 0 := 0 402 | | (nat.succ n) := s n + sum_vals n. 403 | 404 | @[simp] 405 | lemma sum_vals_0 (s: stream a) : sum_vals s 0 = 0 := rfl. 406 | 407 | @[simp] 408 | lemma sum_vals_1 (s: stream a) : sum_vals s 1 = s 0 := 409 | begin 410 | unfold sum_vals, simp, 411 | end 412 | 413 | attribute [simp] sum_vals.equations._eqn_2. 414 | 415 | /- The sum of an all-zero stream is zero. -/ 416 | lemma sum_vals_zero (s: stream a) : 417 | (∀ n, s n = 0) → 418 | ∀ (n:ℕ), sum_vals s n = 0 := 419 | begin 420 | intros hz n, 421 | induction n with n, 422 | { simp, }, 423 | { simp, rw [hz, n_ih], abel, }, 424 | end 425 | 426 | @[simp] 427 | lemma integral_0 (s: stream a) : I s 0 = s 0 := 428 | begin 429 | rw integral_unfold, simp, 430 | end 431 | 432 | theorem integral_sum_vals (s: stream a) (n: ℕ) : 433 | I s n = sum_vals s n.succ := 434 | begin 435 | induction n with n, 436 | { simp, }, 437 | { rw integral_unfold, simp, 438 | rw n_ih, refl, } 439 | end 440 | 441 | @[simp] 442 | lemma integral_zpp : I (0: stream a) = 0 := 443 | begin 444 | funext t, 445 | rw integral_sum_vals, simp, 446 | rw sum_vals_zero, simp, 447 | end 448 | 449 | -- simple expression for the values of derivative s 450 | @[simp] 451 | lemma derivative_0 (s: stream a) : 452 | D s 0 = s 0 := 453 | begin 454 | unfold D; simp, 455 | end 456 | 457 | theorem derivative_difference_t (s: stream a) (t: ℕ) : 458 | 0 < t → 459 | D s t = s t - s (t - 1) := 460 | begin 461 | intros hnz, 462 | unfold D delay, dsimp, 463 | rw if_neg, omega, 464 | end 465 | 466 | @[simp] 467 | lemma derivative_zpp : D (0: stream a) = 0 := 468 | begin 469 | funext t, unfold D, simp, 470 | end 471 | 472 | lemma add_causal : 473 | causal (uncurry_op ((+) : operator2 a a a)) := 474 | begin 475 | unfold causal, introv heq, 476 | unfold uncurry_op, simp, rw heq, linarith, 477 | end 478 | 479 | lemma sum_causal (f g: operator a b) : 480 | causal f → 481 | causal g → 482 | causal (λ x, f x + g x) := 483 | begin 484 | unfold causal, intros hf hg, introv heq, 485 | simp, rw [hf, hg]; assumption, 486 | end 487 | 488 | lemma sum_causal_nested (f g: operator (stream a) (stream b)) : 489 | causal_nested f → 490 | causal_nested g → 491 | causal_nested (λ x, f x + g x) := 492 | begin 493 | unfold causal_nested, intros hf hg, introv heq, 494 | simp, rw [hf, hg]; assumption, 495 | end 496 | 497 | lemma sum_vals_succ_n (s: stream a) (t: ℕ) : 498 | sum_vals (D s) t.succ = s t := 499 | begin 500 | induction t with t, 501 | { unfold sum_vals D, simp, }, 502 | simp only [sum_vals] at t_ih |-, 503 | rw derivative_difference_t; try { omega }, 504 | rw t_ih, simp, 505 | end 506 | 507 | @[simp] 508 | theorem derivative_integral (s: stream a) : 509 | I (D s) = s := 510 | begin 511 | funext t, 512 | rw integral_sum_vals, 513 | rw sum_vals_succ_n, 514 | end 515 | 516 | -- We can give an alternative proof based on the fact that I is the unique 517 | -- fixpoint of α = α + z⁻¹ α. 518 | private theorem derivative_integral_alt (s: stream a) : 519 | I (D s) = s := 520 | begin 521 | symmetry, 522 | simp [I, feedback], 523 | apply fix_unique, 524 | { apply feedback_ckt_body_strict, 525 | apply delay_strict, 526 | apply add_causal, }, 527 | { unfold D, abel, }, 528 | end 529 | 530 | -- And yet another proof, based on linearity, the fixpoint equation, and time 531 | -- invariance. 532 | private theorem derivative_integral_alt2 (s: stream a) : 533 | I (D s) = s := 534 | begin 535 | unfold D, 536 | rw (linear_sub integral_linear), 537 | rw (integral_unfold s), 538 | rw integral_time_invariant, abel, 539 | end 540 | 541 | @[simp] 542 | theorem integral_derivative (s: stream a) : 543 | D (I s) = s := 544 | begin 545 | unfold D, 546 | calc I s - delay (I s) 547 | = s + delay (I s) - delay (I s) : by { congr', apply integral_unfold, } 548 | ... = s : by { rw add_sub_cancel, }, 549 | end 550 | 551 | theorem derivative_integral_inverse (α s: stream a): 552 | α = I s ↔ D α = s := 553 | begin 554 | split, 555 | { intros h, subst α, 556 | rw integral_derivative, }, 557 | { intros h, subst s, 558 | rw derivative_integral, 559 | } 560 | end 561 | 562 | lemma i_d_comp : 563 | I ∘ D = @id (stream a) := 564 | begin 565 | funext s, simp, 566 | end 567 | 568 | lemma d_i_comp : 569 | D ∘ I = @id (stream a) := 570 | begin 571 | funext s, simp, 572 | end 573 | 574 | theorem lifting_linear (f: a → b) : 575 | (∀ x y, f (x + y) = f x + f y) → 576 | linear (↑↑f) := 577 | begin 578 | intros hlin, 579 | intros x y, ext t, simp, apply hlin, 580 | end 581 | 582 | -- convenience for generating lti theorems 583 | theorem lifting_lti (f: a → b) : 584 | (∀ x y, f (x + y) = f x + f y) → 585 | lti (↑↑ f) := 586 | begin 587 | intros hlin, 588 | split, 589 | { apply lifting_linear, assumption, }, 590 | { apply lifting_time_invariant, 591 | have h0 := hlin 0 0, simp at h0, 592 | apply h0, }, 593 | end 594 | 595 | lemma derivative_sprod (s1: stream a) (s2: stream b) : 596 | D (sprod (s1, s2)) = sprod (D s1, D s2) := 597 | begin 598 | funext t, simp, 599 | by_cases (t = 0), 600 | { subst t, simp, }, 601 | { repeat { rw derivative_difference_t }; try { omega }, 602 | simp, 603 | }, 604 | end 605 | 606 | lemma integral_sprod (s1: stream a) (s2: stream b) : 607 | I (sprod (s1, s2)) = sprod (I s1, I s2) := 608 | begin 609 | funext t, simp, 610 | repeat { rw integral_sum_vals }, 611 | simp, 612 | induction t, 613 | { simp, }, 614 | { simp, rw t_ih, refl, }, 615 | end 616 | 617 | lemma integral_lift_comm (f: a → b) (s: stream a) : 618 | (∀ x y, f (x + y) = f x + f y) → 619 | I (↑↑f s) = ↑↑f (I s) := 620 | begin 621 | intros hlin, 622 | funext t, simp, 623 | repeat { rw integral_sum_vals }, 624 | induction t, 625 | { simp, }, 626 | { simp at t_ih |-, 627 | rw [hlin, t_ih], 628 | } 629 | end 630 | 631 | lemma integral_fst_comm (s: stream (a × b)) : 632 | I (↑↑prod.fst s) = ↑↑prod.fst (I s) := 633 | begin 634 | apply integral_lift_comm, 635 | intros x y, simp, 636 | end 637 | 638 | lemma integral_snd_comm (s: stream (a × b)) : 639 | I (↑↑prod.snd s) = ↑↑prod.snd (I s) := 640 | begin 641 | apply integral_lift_comm, 642 | intros x y, simp, 643 | end 644 | 645 | -- #lint only doc_blame simp_nf 646 | -------------------------------------------------------------------------------- /src/operators.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .stream 5 | -- for prod.has_zero 6 | import algebra.group.prod 7 | import tactic.omega.main 8 | import tactic.linarith 9 | import tactic.split_ifs 10 | 11 | /-! 12 | # DBSP operators 13 | 14 | We define the DBSP core constructs (lifting, delay, and fixpoints) and the 15 | associated properties of causality, time invariance, and strict causality. 16 | 17 | This file defines properties over `stream a` that only depend on the existence 18 | of an arbitrary "zero" element `0 : a`. This zero need not have particular 19 | properties. 20 | 21 | NOTE: paper implicitly assumes groups throughout, here we are able to weaken 22 | that assumption. 23 | -/ 24 | 25 | universes u v. 26 | 27 | /-- An operator is a function between streams. -/ 28 | @[reducible] 29 | def operator (a b: Type u) : Type u := stream a → stream b. 30 | /-- An operator2 is a function on two streams. 31 | 32 | This is isomorphic to `operator (a × b) c`, but in Lean this is easier to use; 33 | there may be a better way to use the uncurried version to avoid defining this 34 | specially. -/ 35 | @[reducible] 36 | def operator2 (a b c: Type u) : Type u := stream a → stream b → stream c. 37 | 38 | /-- ↑↑f turns an ordinary function into an operator by pointwise lifting. 39 | 40 | The paper uses ↑f for this notion, but that means a different notion (also 41 | called lift) in mathlib. 42 | -/ 43 | def lifting {a b: Type} (f: a → b) : operator a b := 44 | λ s, λ n, f (s n). 45 | -- lifting binds very tightly (similar to ⁻¹), so that ↑↑f x is (↑↑f) x 46 | prefix `↑↑`:std.prec.max := lifting. 47 | 48 | @[simp] 49 | lemma lifting_eq {a b: Type} (f: a → b) (s: stream a) (n: ℕ) : 50 | ↑↑f s n = f (s n) := rfl. 51 | 52 | /-- Lift a curried function. See [lifting]. -/ 53 | def lifting2 {a b c: Type} (f: a → b → c) : operator2 a b c := 54 | λ s1 s2, λ n, f (s1 n) (s2 n). 55 | 56 | @[simp] 57 | lemma lifting2_apply {a b c: Type} (f: a → b → c) 58 | (s1: stream a) (s2: stream b) (n: ℕ) : 59 | lifting2 f s1 s2 n = f (s1 n) (s2 n) := rfl. 60 | 61 | @[simp] 62 | lemma lifting_id {a: Type} : 63 | lifting (λ (x:a), x) = id := rfl. 64 | 65 | prefix `↑²`:std.prec.max := lifting2. 66 | 67 | variables {a : Type} [has_zero a]. 68 | variables {b : Type} [has_zero b]. 69 | variables {c : Type} [has_zero c]. 70 | 71 | -- this is moderately dangerous because ↑ is actually recursive, so without a 72 | -- type from the environment this can lift to `operator (stream a) (stream b)` 73 | -- (with an arbitrary number of streams). 74 | instance stream_lift : has_lift (a → b) (operator a b) := ⟨lifting⟩. 75 | 76 | /- 77 | note that we will overload 0 for 78 | - 0 : ℕ 79 | - 0 : a (the group element) 80 | - 0 : stream a (which is just [λ _, (0:a)]) 81 | -/ 82 | 83 | /-- 84 | Product of two streams as a single stream. 85 | 86 | This is part of how multi-argument streams are formalized, which is more 87 | explicit than in the paper. 88 | -/ 89 | def sprod {a b: Type} : stream a × stream b → stream (a × b) := 90 | λ s, λ n, (s.1 n, s.2 n). 91 | 92 | @[reducible] 93 | instance sprod_coe : has_coe (stream a × stream b) (stream (a × b)) := 94 | ⟨ λ ⟨s1, s2⟩ n, (s1 n, s2 n) ⟩. 95 | 96 | @[simp] 97 | lemma sprod_apply (s: stream a × stream b) (n: ℕ) : 98 | (sprod s) n = (s.1 n, s.2 n) := rfl. 99 | 100 | @[simp] 101 | lemma sprod_coe_unfold (s: stream a × stream b) (n: ℕ) : 102 | (↑s : stream (a × b)) n = (s.1 n, s.2 n) := 103 | begin 104 | cases s with s1 s2, 105 | refl, 106 | end 107 | 108 | /-- Convert a curried [operator2] into an ordinary [operator] over a tuple. -/ 109 | def uncurry_op (T: operator2 a b c) : operator (a × b) c := 110 | λ s, T (↑↑prod.fst s) (↑↑prod.snd s). 111 | 112 | lemma uncurry_op_intro (T: operator2 a b c) (s1: stream a) (s2: stream b) : 113 | T s1 s2 = uncurry_op T (s1, s2) := by { funext t, refl }. 114 | 115 | theorem lifting_distributivity {a b c: Type} (f: a → b) (g: b → c) : 116 | lifting (g ∘ f) = lifting g ∘ lifting f := rfl. 117 | 118 | theorem lifting_comp {a b c: Type} (f: a → b) (g: b → c) (s: stream a) : 119 | ↑↑ (λ x, g (f x)) s = ↑↑ g (↑↑ f s) := rfl. 120 | 121 | theorem lifting2_comp {a b c d e: Type} 122 | (f: a → c) (g: b → d) (T: c → d → e) 123 | (s1: stream a) (s2: stream b) : 124 | ↑² (λ x y, T (f x) (g y)) s1 s2 = ↑²T (↑↑f s1) (↑↑g s2) := rfl. 125 | 126 | theorem lifting2_comp' {a b c d e: Type} 127 | (f: a → c) (g: b → d) (T: c → d → e) : 128 | ↑² (λ x y, T (f x) (g y)) = λ s1 s2, ↑²T (↑↑f s1) (↑↑g s2) := rfl. 129 | 130 | /-- The delay operator `z⁻¹` is a fundamental DBSP operator that shifts a stream over by one time 131 | step. For `t=0` it inserts a zero element, which is the main reason a `0 : a` 132 | (expressed with `has_zero a` here) is required. 133 | -/ 134 | def delay : operator a a := 135 | λ (s: stream a), λ t, if t = 0 then 0 else s (t - 1). 136 | 137 | notation `z⁻¹` := delay. 138 | 139 | /-- Time invariance intuitively expresses that an operator does not depend on 140 | the exact time, only the sequence. It is expressed by saying that `S ∘ z⁻¹ = z⁻¹ 141 | ∘ S`, that is, that the operator commutes with delay (see [time_invariant_comp] 142 | for a proof that this definition equals that one). 143 | 144 | Essentially all operators considered in DBSP are time invariant (although this 145 | may not be strictly necessary). 146 | -/ 147 | def time_invariant (S: operator a b) := 148 | ∀ s, S (z⁻¹ s) = z⁻¹ (S s). 149 | 150 | /-- Show [time_invariant] is equivalent to the definition in the paper. 151 | 152 | The definition of [time_invariant] is easier to use in Lean since it can be used 153 | directly as a rewrite, whereas composed functions don't appear syntactically in 154 | proofs. -/ 155 | lemma time_invariant_comp (S: operator a b) : 156 | time_invariant S ↔ S ∘ z⁻¹ = z⁻¹ ∘ S := 157 | begin 158 | split; intros h, 159 | { funext s, simp, rw h, }, 160 | { intros s, apply (congr_fun h s), }, 161 | end 162 | 163 | /-- Characterizes time invariance for lifted operators: they must satisfy the 164 | "zero preservation property", namely `f 0 = 0`. This arises because the delay 165 | inserts a 0 at `z⁻¹ (S ↑↑f) 0`, and the function must do the same in `S (z⁻¹ (↑↑ 166 | f)) 0`. -/ 167 | theorem lifting_time_invariance (f: a → b) : 168 | time_invariant (lifting f) ↔ f 0 = 0 := 169 | begin 170 | unfold time_invariant, 171 | split, 172 | { intro h, 173 | have heq := congr_fun (h 0) 0, 174 | simp [delay, lifting] at heq, 175 | assumption, 176 | }, 177 | { intros h0 s, 178 | funext t, 179 | simp [delay, lifting], 180 | split_ifs; clarify, 181 | }, 182 | end 183 | 184 | lemma lifting_time_invariant (f: a → b) : 185 | f 0 = 0 → time_invariant (↑↑ f) := 186 | (lifting_time_invariance f).mpr. 187 | 188 | -- delay by definition produces 0 at time t 189 | @[simp] 190 | lemma delay_t_0 (s: stream a) : z⁻¹ s 0 = 0 191 | := rfl. 192 | 193 | @[simp] 194 | lemma delay_0 : z⁻¹ (0 : stream a) = 0 := 195 | begin 196 | funext t, unfold delay, simp, 197 | end 198 | 199 | @[simp] 200 | lemma delay_succ (s: stream a) (n: ℕ) : z⁻¹ s n.succ = s n 201 | := rfl. 202 | 203 | lemma delay_sub_1 (s: stream a) (n: ℕ) : 204 | 0 < n → z⁻¹ s n = s (n-1) := 205 | begin 206 | intros h, 207 | unfold delay, rw if_neg, omega, 208 | end 209 | 210 | lemma delay_eq_at (s1 s2: stream a) (t: ℕ) : 211 | (0 < t → s1 (t-1) = s2 (t-1)) → 212 | z⁻¹ s1 t = z⁻¹ s2 t := 213 | begin 214 | intros heq, 215 | unfold delay, split_ifs, simp, 216 | apply heq, omega, 217 | end 218 | 219 | lemma time_invariant_0_0 (S: operator a b) : 220 | time_invariant S → S 0 0 = 0 := 221 | begin 222 | intros hti, 223 | unfold time_invariant at hti, 224 | have h := congr_fun (hti 0) 0, 225 | simp at h, 226 | assumption, 227 | end 228 | 229 | -- time_invariant definition applied to a specific s and t 230 | lemma time_invariant_t {S: operator a b} (h: time_invariant S) : 231 | ∀ s t, S (delay s) t = delay (S s) t := 232 | begin 233 | unfold time_invariant at h, 234 | intros s t, 235 | have heq := congr_fun (h s) t, 236 | assumption, 237 | end 238 | 239 | -- this is zero-preservation over zero streams 240 | lemma time_invariant_zpp (S: operator a b) : 241 | time_invariant S → S 0 = 0 := 242 | begin 243 | intros hti, 244 | funext t, 245 | change ((0: stream b) t) with (0: b), 246 | induction t, 247 | { apply time_invariant_0_0, assumption, }, 248 | { rw<- delay_0, 249 | rw (time_invariant_t hti), simp, 250 | assumption, 251 | } 252 | end 253 | 254 | lemma lift_time_invariant (f: a → b) : 255 | f 0 = 0 → 256 | time_invariant ↑↑f := 257 | begin 258 | intros hzpp s, 259 | funext t; simp, 260 | unfold delay, split_ifs, 261 | { apply hzpp }, 262 | { simp } 263 | end 264 | 265 | lemma delay_time_invariant : time_invariant (@delay a _) := 266 | by { intros s, refl }. 267 | 268 | 269 | theorem lifting2_time_invariant (f: a → b → c) : 270 | time_invariant (uncurry_op (↑² f)) ↔ f 0 0 = 0 := 271 | begin 272 | split, 273 | { intros h, 274 | apply (congr_fun (h 0) 0), }, 275 | { intros h0 s, 276 | funext t, 277 | simp [delay, lifting2, uncurry_op], 278 | split_ifs; clarify, 279 | } 280 | end 281 | 282 | 283 | /-- A causal operator intuitively depends at time `t` only on previous inputs. 284 | Note that an operator can use its input at time `t` itself; imagine all 285 | operators operate synchronously, and we compute all of them before emitting the 286 | output. The formal definition says that if two streams agree up to time t, then 287 | S must return the same result at time t for both. 288 | -/ 289 | def causal (S: operator a b) := 290 | ∀ (s s': stream a), ∀ t, s ==t== s' → S s t = S s' t. 291 | 292 | @[simp] 293 | theorem lifting_causal (f: a → b) : causal (lifting f) := 294 | begin 295 | intros s s' t hpre, 296 | simp [lifting], 297 | rw (hpre t), 298 | omega, 299 | end 300 | 301 | theorem delay_causal : causal (@delay a _) := 302 | begin 303 | intros s s' t hpre, 304 | simp [causal, delay], 305 | rw hpre, 306 | omega, 307 | end 308 | 309 | -- composition of two causal operators is causal 310 | theorem causal_comp_causal 311 | (S1: operator a b) (h1: causal S1) 312 | (S2: operator b c) (h2: causal S2) : 313 | causal (λ s, S2 (S1 s)) := 314 | begin 315 | intros s1 s2 n heq, simp, 316 | apply h2, 317 | intros i hle, 318 | apply h1, 319 | intros j hle_j, apply heq, omega, 320 | end 321 | 322 | lemma causal_respects_agree_upto (S: operator a b) (h: causal S) 323 | (s1 s2: stream a) (n: ℕ) : 324 | s1 ==n== s2 → 325 | S s1 ==n== S s2 := 326 | begin 327 | intros heq n hle, 328 | apply h, 329 | intros _ hle', apply heq, omega, 330 | end 331 | 332 | lemma causal_to_agree (S: operator a b) : 333 | causal S ↔ (∀ s1 s2 n, s1 ==n== s2 → S s1 ==n== S s2) := 334 | begin 335 | split, 336 | { intros s1 s2 n h, 337 | apply causal_respects_agree_upto; assumption, }, 338 | intros heq_n, 339 | intros s1 s2 t hagree, 340 | apply (heq_n _ _ t), 341 | { intros i, apply hagree, }, 342 | omega, 343 | end 344 | 345 | -- More convenient definition of causal for two-argument operators. `causal 346 | -- (uncurry_op T)` is a convenient way to re-use the definition of causal, but 347 | -- this is easier to use for the curried operator directly. 348 | lemma causal2 (T: operator2 a b c) : 349 | causal (uncurry_op T) ↔ 350 | (∀ s1 s1' s2 s2' n, s1 ==n== s1' → s2 ==n== s2' → 351 | T s1 s2 n = T s1' s2' n) := 352 | begin 353 | split, 354 | { intros hcausal, 355 | intros _ _ _ _ _ h1 h2, 356 | have h := hcausal (sprod (s1, s2)) (sprod (s1', s2')) n, 357 | unfold uncurry_op sprod at h, simp at h, 358 | apply h, 359 | { intros i hle, simp, 360 | rw [h1, h2]; try { omega }, 361 | split; refl, 362 | }, 363 | }, 364 | { intros h, intros _ _ _ heq, 365 | unfold uncurry_op sprod at ⊢, 366 | apply h, 367 | { intros i hle, simp, 368 | rw heq, omega, }, 369 | { intros i hle, simp, 370 | rw heq, omega, }, 371 | }, 372 | end 373 | 374 | lemma causal2_agree (T: operator2 a b c) : 375 | causal (uncurry_op T) → 376 | (∀ s1 s1' s2 s2' n, s1 ==n== s1' → s2 ==n== s2' → 377 | T s1 s2 ==n== T s1' s2') := 378 | begin 379 | rw causal2, introv hcausal heq1 heq2, 380 | intros m hle, 381 | apply hcausal, 382 | apply agree_upto_weaken, assumption, omega, 383 | apply agree_upto_weaken, assumption, omega, 384 | end 385 | 386 | theorem uncurry_op_lifting {d:Type} [add_comm_group d] (f: c → d) (t: stream a → stream b → stream c) : 387 | uncurry_op (λ (x: stream a) (y: stream b), ↑↑f (t x y)) = ↑↑f ∘ uncurry_op t := 388 | begin 389 | funext xy t, simp [uncurry_op], 390 | end 391 | 392 | -- causal (uncurry_op T) can be weakened to a specific fixed first argument 393 | lemma causal_uncurry_op_fixed (T: operator2 a b b) : 394 | causal (uncurry_op T) → 395 | ∀ s, causal (T s) := 396 | begin 397 | intros hcausal, 398 | intros s s' n heq, 399 | rw causal2 at hcausal, 400 | apply hcausal, refl, 401 | end 402 | 403 | lemma lifting_lifting2_comp {d: Type} [has_zero d] (f: c → d) (g: a → b → c) : 404 | ∀ s1 s2, ↑↑f (↑²g s1 s2) = ↑²(λ x y, f (g x y)) s1 s2 := 405 | begin 406 | intros s1 s2, funext t, simp, 407 | end 408 | 409 | lemma uncurry_op_lifting2 (f: a → b → c) : 410 | uncurry_op (↑²f) = ↑ (λ (xy: a × b), f xy.1 xy.2) := rfl. 411 | 412 | /-- Strictly causal. Similar to [causal], a strictly causal (or simply _strict_) 413 | operator depends only on past inputs; unlike causal, a strict operator at time 414 | `n` can depend only on `t < n` and not `n` itself. -/ 415 | def strict (S: operator a b) := 416 | ∀ (s s': stream a), ∀ t, (∀ i < t, s i = s' i) → S s t = S s' t. 417 | 418 | /-- Strictly causal operators have a unique output at time 0 (because they 419 | aren't allowed to depend on the input at time 0), but it need not actually be 0. 420 | That requirement can come from [time_invariant]. 421 | -/ 422 | theorem strict_unique_zero (S: operator a b) (h: strict S) : 423 | ∀ s s', S s 0 = S s' 0 := 424 | begin 425 | intros s s', 426 | apply h, 427 | intros i hcontra, 428 | by_contradiction, 429 | apply nat.not_lt_zero, assumption, 430 | end 431 | 432 | theorem strict_causal_to_causal (S: operator a b) : strict S → causal S := 433 | begin 434 | intros hstrict, 435 | intros s s' t hpre, 436 | apply hstrict, 437 | intros i hlt, 438 | apply hpre, omega, 439 | end 440 | 441 | theorem delay_strict : strict (@delay a _) := 442 | begin 443 | intros s s' t hpre, 444 | simp [causal, delay], 445 | split_ifs; try { simp <|> assumption }, 446 | apply hpre, omega, 447 | end 448 | 449 | theorem causal_strict_strict 450 | (F: operator a b) (hstrict: strict F) 451 | (T: operator b c) (hcausal: causal T) : 452 | strict (λ α, T (F α)) := 453 | begin 454 | intros s1 s2 n hagree, 455 | simp, 456 | apply hcausal, 457 | intros i hle, 458 | apply hstrict, 459 | intros j hjle, 460 | apply hagree, omega, 461 | end 462 | 463 | theorem strict_causal_strict 464 | (F: operator a b) (hcausal: causal F) 465 | (T: operator b c) (hstrict: strict T) : 466 | strict (λ α, T (F α)) := 467 | begin 468 | intros s1 s2 n hagree, 469 | simp, 470 | apply hstrict, 471 | intros i hle, 472 | apply hcausal, 473 | intros j hjle, 474 | apply hagree, omega, 475 | end 476 | 477 | /- To construct the fixpoint of F, we first define nth F n, which is F (F ... (F 478 | 0)) with (n+1) copies of F. The fixpoint [fix] turns out to be `nth F n n` - the nth 479 | iterate is correct up to time n. -/ 480 | private def nth (F: operator a a) : ℕ → stream a 481 | -- We apply F at the bottom so that fix F 0 is given by F rather than being 482 | -- forced to be (0 : a). This seems to generalize the paper, which doesn't 483 | -- consider such operators! (The assumption that everything is time invariant 484 | -- forces operators to have F 0 0 = 0, as proven in [time_invariant_0_0].) 485 | | nat.zero := F 0 486 | | (nat.succ n) := F (nth n). 487 | 488 | @[simp] 489 | lemma nth_0 (F: operator a a) : nth F 0 = F 0 := rfl. 490 | 491 | @[simp] 492 | lemma nth_succ (F: operator a a) (n: ℕ) : nth F n.succ = F (nth F n) := rfl. 493 | 494 | /-- `fix (α, F α)` for a [strict] operator `F` is a fundamental operator that 495 | implements a form of recursion. It is a fixpoint in that `fix F` is a solution 496 | to `α = F(α)`. When `F` is [strict], this recursion is well-defined: `fix F = F 497 | (fix F)` (see [fix_eq]), and the solution is unique (see [fix_unique]). 498 | 499 | Note that in this formalization, `fix F` always produces _some_ stream; however, 500 | if F is not strict, then it need not satisfy `fix F = F (fix F)`. 501 | -/ 502 | def fix (F: operator a a) : stream a := 503 | λ t, nth F t t. 504 | 505 | @[simp] 506 | lemma fix_0 (F: operator a a) : fix F 0 = F 0 0 := rfl. 507 | 508 | lemma strict_zpp_zero (S: operator a b) (hstrict: strict S) (hzpp: S 0 0 = 0) : 509 | ∀ s, S s 0 = 0 := 510 | begin 511 | intros s, 512 | calc S s 0 = S 0 0 : by { 513 | apply strict_unique_zero, 514 | assumption, 515 | } 516 | ... = 0 : by apply hzpp, 517 | end 518 | 519 | lemma strict_agree_at_next (S: operator a b) (hstrict: strict S) : 520 | ∀ s s' n, agree_upto n s s' → S s n.succ = S s' n.succ := 521 | begin 522 | unfold agree_upto, 523 | intros s s' n hagree, 524 | apply hstrict, 525 | intros i hlt, 526 | apply hagree, omega, 527 | end 528 | 529 | lemma agree_upto_strict_extend (S: operator a b) (hstrict: strict S) (s s': stream a) : 530 | ∀ n, s ==n== s' → S s ==n.succ== S s' := 531 | begin 532 | intros n hagree, 533 | intros t hle, 534 | apply hstrict, 535 | intros i hlt, 536 | apply hagree, omega, 537 | end 538 | 539 | /- 540 | We don't actually use this characterization of strictness, but it might help 541 | build intuition. 542 | -/ 543 | lemma strict_as_agree_upto (S: operator a b) : 544 | strict S ↔ ((∀ s s', S s ==0== S s') ∧ ∀ s s' n, s ==n== s' → S s ==n.succ== S s') := 545 | begin 546 | unfold strict, 547 | split, 548 | { intros hstrict, 549 | split, 550 | { intros s s', 551 | rw agree_upto_0, 552 | apply hstrict, 553 | intros i hlt0, 554 | exfalso, 555 | apply (nat.not_lt_zero _ hlt0), }, 556 | { intros s s' n hagree, 557 | apply agree_upto_strict_extend; assumption, } 558 | }, 559 | { intros h, 560 | cases h with h_zpp h_agree_extend, 561 | intros s s' t hagree, 562 | have h: (t = 0 ∨ 0 < t) := by omega, 563 | cases h, 564 | { subst t, apply h_zpp, omega, }, 565 | { apply (h_agree_extend _ _ (t-1)), 566 | intros i hle, 567 | apply hagree, omega, omega, 568 | } 569 | } 570 | end 571 | 572 | lemma delay_succ_upto (s1 s2: stream a) (n: ℕ) : 573 | s1 ==n== s2 → 574 | delay s1 ==n.succ== delay s2 := 575 | begin 576 | intros heqn, 577 | unfold agree_upto, 578 | intros t, 579 | intros hle, 580 | unfold delay, 581 | rw heqn; omega, 582 | end 583 | 584 | private lemma and_wlog2 {p1 p2: Prop} (h2: p2) (h21: p2 → p1) : 585 | p1 ∧ p2 := ⟨h21 h2, h2⟩ . 586 | 587 | private lemma nth_fix_agree_aux (F: operator a a) (hstrict: strict F) (n: ℕ) : 588 | nth F n ==n== fix F ∧ fix F ==n== F (fix F) := 589 | begin 590 | induction n with n, 591 | { rw [agree_upto_0, agree_upto_0], 592 | split, 593 | { refl, }, 594 | { unfold fix, simp [nth], 595 | apply strict_unique_zero, assumption, } 596 | }, 597 | change (nth F n.succ) with (F (nth F n)), 598 | cases n_ih with h_fix h_unfold, 599 | have h : F (nth F n) ==n.succ== F (fix F) := by { 600 | apply (agree_upto_strict_extend _ hstrict), 601 | exact h_fix, 602 | }, 603 | apply and_wlog2, 604 | { apply agree_upto_extend, 605 | { exact h_unfold, }, 606 | { simp [fix, nth], 607 | apply (strict_agree_at_next _ hstrict), 608 | exact h_fix, 609 | } 610 | }, 611 | { intros h2, 612 | -- BUG: prove by reflexivity to instantiate the n argument to agree_upto 613 | -- (Lean seems to ignore the n in the first relation) 614 | calc F (nth F n) ==n.succ== F (nth F n) : by apply (agree_refl n.succ) 615 | ... ==n.succ== F (fix F) : by assumption 616 | ... ==n.succ== fix F : by { symmetry, assumption }, 617 | }, 618 | end 619 | 620 | -- The key characterization of fix F. 621 | theorem fix_eq (F: operator a a) (hstrict: strict F) : 622 | fix F = F (fix F) := 623 | begin 624 | funext t, 625 | have h := nth_fix_agree_aux _ hstrict t, 626 | cases h with _ h_unfold, 627 | apply h_unfold, omega, 628 | end 629 | 630 | -- We show two solutions α to α = F(α) are equal, from which obviously 631 | -- they are all equal to fix F, which is one such solution from [fix_eq] 632 | -- 633 | -- Users will typically want the special case of [fix_unique], which is written 634 | -- in terms of our particular solution [fix]. 635 | protected theorem fixpoints_unique (F: operator a a) (hstrict: strict F) 636 | (α β: stream a) : 637 | -- α and β are two possible solutions 638 | α = F α → β = F β → 639 | α = β := 640 | begin 641 | intros hα hβ, 642 | rw agree_everywhere_eq, intros n, 643 | induction n with n, 644 | { rw hα, rw hβ, 645 | rw agree_upto_0, 646 | apply strict_unique_zero, assumption, }, 647 | { rw hα, rw hβ, 648 | apply agree_upto_strict_extend, assumption, 649 | assumption, } 650 | end 651 | 652 | theorem fix_unique (F: operator a a) (hstrict: strict F) 653 | (α: stream a) (h_fix: α = F α) : 654 | α = fix F := 655 | begin 656 | apply (fixpoints_unique _ hstrict α (fix F)), 657 | { assumption }, 658 | { apply fix_eq, assumption, } 659 | end 660 | 661 | section fix2. 662 | 663 | def fix2 (F: operator (stream a) (stream a)) : stream (stream a) := 664 | λ n t, nth F t n t. 665 | 666 | def causal_nested (Q: operator (stream a) (stream b)) := 667 | ∀ (s s': stream (stream a)), 668 | ∀ n t, ∀ (heq: ∀ n' ≤ n, ∀ t' (hle_t': t' ≤ t), s n' t' = s' n' t'), 669 | Q s n t = Q s' n t. 670 | 671 | def strict2 (Q: operator (stream a) (stream b)) := 672 | ∀ (s s': stream (stream a)), 673 | ∀ n t, ∀ (heq: ∀ n' ≤ n, ∀ t' (hle_t': t' < t), s n' t' = s' n' t'), 674 | Q s n t = Q s' n t. 675 | 676 | theorem strict2_is_causal_nested (Q: operator (stream a) (stream b)) : 677 | strict2 Q → causal_nested Q := 678 | begin 679 | unfold strict2 causal_nested, intros hstrict, 680 | intros, 681 | apply hstrict, intros, apply heq; omega, 682 | end 683 | 684 | meta def tauto_omega := `[tauto {closer := `[omega]}]. 685 | 686 | lemma strict2_agree_0 (F: operator (stream a) (stream b)) (hstrict: strict2 F) : 687 | ∀ s s' n, F s n 0 = F s' n 0 := 688 | begin 689 | intros, apply hstrict, 690 | intros, 691 | have hcontra : ¬(t' < 0) := by omega, 692 | contradiction, 693 | end 694 | 695 | lemma strict2_eq_0 (F: operator (stream a) (stream b)) (hstrict: strict2 F) : 696 | ∀ s n, F s n 0 = F 0 n 0 := 697 | begin 698 | intros, apply (strict2_agree_0 _ hstrict), 699 | end 700 | 701 | def agree_upto2 (t: ℕ) (s1 s2: stream (stream a)) := 702 | ∀ n, ∀ t' (hle: t' ≤ t), s1 n t' = s2 n t'. 703 | local notation (name := agree2) s1 ` ==` t `== ` s2:35 := agree_upto2 t s1 s2. 704 | 705 | lemma agree_upto2_symm (t: ℕ) (s1 s2: stream (stream a)) : 706 | s1 ==t== s2 → 707 | s2 ==t== s1 := 708 | begin 709 | unfold agree_upto2, intros, 710 | finish, 711 | end 712 | 713 | lemma agree_upto2_trans (t: ℕ) (s1 s2 s3: stream (stream a)) : 714 | s1 ==t== s2 → 715 | s2 ==t== s3 → 716 | s1 ==t== s3 := 717 | begin 718 | unfold agree_upto2, intros, 719 | transitivity (s2 n t'); finish, 720 | end 721 | 722 | lemma agree_upto2_0 (s1 s2: stream (stream a)) : 723 | s1 ==0== s2 ↔ (∀ n, s1 n 0 = s2 n 0) := 724 | begin 725 | unfold agree_upto2, 726 | split; introv h; clarify, 727 | end 728 | 729 | lemma agree_upto2_extend (t: ℕ) (s s': stream (stream a)) : 730 | s ==t== s' → 731 | (∀ n, s n t.succ = s' n t.succ) → 732 | s ==t.succ== s' := 733 | begin 734 | intros hagree heqn, 735 | unfold agree_upto2, intros, 736 | have ht': (t' ≤ t ∨ t' = t.succ) := by omega, 737 | cases ht', 738 | { tauto_omega, }, 739 | subst ht', tauto_omega, 740 | end 741 | 742 | lemma agree_upto2_strict_extend (S: operator (stream a) (stream b)) 743 | (hstrict: strict2 S) (s s': stream (stream a)) : 744 | ∀ t, s ==t== s' → 745 | S s ==t.succ== S s' := 746 | begin 747 | introv hagree, 748 | unfold agree_upto2, intros, 749 | apply hstrict, 750 | intros n' _ t'' _, 751 | have h1 : t'' ≤ t := by omega, 752 | apply hagree, finish, 753 | end 754 | 755 | lemma strict_agree2_at_next (S: operator (stream a) (stream b)) (hstrict: strict2 S) : 756 | ∀ s s' t, s ==t== s' → ∀ n, S s n t.succ = S s' n t.succ := 757 | begin 758 | unfold agree_upto2, 759 | intros s s' t hagree n, 760 | apply hstrict, 761 | intros, apply hagree, omega, 762 | end 763 | 764 | private lemma nth_fix2_agree_aux (F: operator (stream a) (stream a)) (hstrict: strict2 F) (t: ℕ) : 765 | nth F t ==t== fix2 F ∧ fix2 F ==t== F (fix2 F) := 766 | begin 767 | induction t with t, 768 | { rw [agree_upto2_0, agree_upto2_0], 769 | split, 770 | { intros, unfold fix2, 771 | }, 772 | { intros, unfold fix2, simp, 773 | apply (strict2_agree_0 _ hstrict), 774 | }, 775 | }, 776 | change (nth F t.succ) with (F (nth F t)), 777 | cases t_ih with h_fix h_unfold, 778 | have h : F (nth F t) ==t.succ== F (fix2 F) := by { 779 | apply agree_upto2_strict_extend; assumption, 780 | }, 781 | apply and_wlog2, 782 | { apply agree_upto2_extend, 783 | { exact h_unfold, }, 784 | { intros n, 785 | simp [fix2, nth], 786 | apply (strict_agree2_at_next _ hstrict), 787 | exact h_fix, 788 | } 789 | }, 790 | { intros h2, 791 | apply agree_upto2_trans, assumption, 792 | apply agree_upto2_symm, assumption, }, 793 | end 794 | 795 | theorem fix2_eq (F: operator (stream a) (stream a)) (hstrict: strict2 F) : 796 | fix2 F = F (fix2 F) := 797 | begin 798 | funext n t, 799 | have h := nth_fix2_agree_aux _ hstrict t, 800 | cases h with _ h_unfold, 801 | apply h_unfold, omega, 802 | end 803 | 804 | theorem agree2_everywhere_eq (s1 s2: stream (stream a)) : 805 | (∀ t, s1 ==t== s2) → s1 = s2 := 806 | begin 807 | intros heq, 808 | funext n t, 809 | apply (heq t), omega, 810 | end 811 | 812 | protected theorem fixpoints2_unique (F: operator (stream a) (stream a)) (hstrict: strict2 F) 813 | (α β: stream (stream a)) : 814 | -- α and β are two possible solutions 815 | α = F α → β = F β → 816 | α = β := 817 | begin 818 | intros hα hβ, 819 | apply agree2_everywhere_eq, intros n, 820 | induction n with n, 821 | { rw hα, rw hβ, 822 | intros n t' hle, 823 | have ht : t' = 0 := by omega, subst ht, 824 | apply strict2_agree_0, assumption, }, 825 | { rw hα, rw hβ, 826 | apply agree_upto2_strict_extend, assumption, 827 | assumption, } 828 | end 829 | 830 | theorem fix2_unique (F: operator (stream a) (stream a)) (hstrict: strict2 F) 831 | (α: stream (stream a)) (h_fix: α = F α) : 832 | α = fix2 F := 833 | begin 834 | apply (fixpoints2_unique _ hstrict α (fix2 F)), 835 | { assumption }, 836 | { apply fix2_eq, assumption, } 837 | end 838 | 839 | end fix2. 840 | 841 | theorem lifting_delay_strict2 : 842 | strict2 (↑↑ (@delay a _)) := 843 | begin 844 | unfold strict2, introv heq, 845 | unfold delay, simp, 846 | split_ifs; try { refl }, 847 | apply heq; omega, 848 | end 849 | 850 | @[simp] 851 | theorem causal_nested_const (c: stream (stream b)) : 852 | causal_nested (λ (x: stream (stream a)), c) := 853 | begin 854 | unfold causal_nested, intros, refl, 855 | end 856 | 857 | theorem causal_nested_id : 858 | causal_nested (λ (x: stream (stream a)), x) := 859 | begin 860 | unfold causal_nested, intros, apply heq; omega 861 | end 862 | 863 | theorem causal_nested_comp 864 | (Q1: operator (stream b) (stream c)) 865 | (Q2: operator (stream a) (stream b)) : 866 | causal_nested Q1 → causal_nested Q2 → 867 | causal_nested (λ s, Q1 (Q2 s)) := 868 | begin 869 | intros h1 h2, 870 | unfold causal_nested, intros, 871 | apply h1, intros, 872 | apply h2, intros, 873 | apply heq; omega, 874 | end 875 | 876 | @[simp] 877 | theorem causal_nested_lifting 878 | (Q: operator a b) : 879 | causal Q → 880 | causal_nested (↑↑Q) := 881 | begin 882 | intros h, 883 | unfold causal_nested, intros, simp, 884 | rw h, 885 | intros t' hle, 886 | apply heq; omega, 887 | end 888 | 889 | theorem feedback_ckt_body_strict 890 | (F: operator b b) (hstrict: strict F) 891 | (T: operator2 a b b) (hcausal: causal (uncurry_op T)) (s: stream a) : 892 | strict (λ α, T s (F α)) := 893 | begin 894 | apply causal_strict_strict, 895 | { apply hstrict, }, 896 | { apply causal_uncurry_op_fixed, assumption, }, 897 | end 898 | 899 | lemma feedback_ckt_unfold 900 | (F: operator b b) (hstrict: strict F) 901 | (T: operator2 a b b) (hcausal: causal (uncurry_op T)) (s: stream a) : 902 | fix (λ α, T s (F α)) = T s (F (fix (λ α, T s (F α)))) := 903 | begin 904 | apply fix_eq, 905 | apply feedback_ckt_body_strict; assumption, 906 | end 907 | 908 | theorem feedback_ckt_causal 909 | (F: operator b b) (hstrict: strict F) 910 | (T: operator2 a b b) (hcausal: causal (uncurry_op T)) : 911 | causal (λ s, fix (λ α, T s (F α))) := 912 | begin 913 | have h := hcausal, 914 | rw causal_to_agree, 915 | rw causal2 at h, 916 | have h2 := causal2_agree _ hcausal, 917 | introv heq, 918 | induction n with n, 919 | { rw [feedback_ckt_unfold _ hstrict _ hcausal s1, 920 | feedback_ckt_unfold _ hstrict _ hcausal s2], 921 | rw agree_upto_0, 922 | apply h, assumption, 923 | rw agree_upto_0, 924 | apply strict_unique_zero, assumption, 925 | }, 926 | { rw [feedback_ckt_unfold _ hstrict _ hcausal s1, 927 | feedback_ckt_unfold _ hstrict _ hcausal s2], 928 | apply h2, assumption, 929 | apply agree_upto_strict_extend, assumption, 930 | apply n_ih, 931 | apply agree_upto_weaken1, assumption, }, 932 | end 933 | 934 | -- #lint only doc_blame simp_nf 935 | -------------------------------------------------------------------------------- /src/ordering.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .linear 5 | 6 | variables {a: Type} [ordered_add_comm_group a]. 7 | 8 | def positive (s: stream a) := 0 <= s. 9 | def stream_monotone (s: stream a) := ∀ t, s t ≤ s (t+1). 10 | def is_positive {b: Type} [ordered_add_comm_group b] 11 | (f: stream a → stream b) := ∀ s, positive s → positive (f s). 12 | 13 | -- TODO: could not get library monotone definition to work, possibly due to 14 | -- partial_order.to_preorder? 15 | 16 | -- set_option pp.notation false. 17 | -- set_option pp.implicit true. 18 | 19 | -- prove that [stream_monotone] can be rephrased in terms of order preservation 20 | theorem stream_monotone_order (s: stream a) : 21 | stream_monotone s ↔ (∀ t1 t2, t1 ≤ t2 → s t1 ≤ s t2) := 22 | begin 23 | unfold stream_monotone, split; intro h; introv, 24 | { intros hle, have heq : t2 = t1 + (t2 - t1) := by omega, 25 | rw heq at *, 26 | generalize : (t2 - t1) = d, 27 | clear_dependent t2, 28 | induction d, 29 | { simp, }, 30 | { transitivity s (t1 + d_n), assumption, 31 | apply h, } 32 | }, 33 | { apply h, linarith, }, 34 | end 35 | 36 | lemma integral_monotone (s: stream a) : 37 | positive s → stream_monotone (I s) := 38 | begin 39 | intros hp, 40 | intros t, 41 | repeat { rw integral_sum_vals }, 42 | repeat { simp [sum_vals] }, 43 | have h := hp (t + 1), simp at h, 44 | assumption, 45 | end 46 | 47 | lemma derivative_pos (s: stream a) : 48 | -- NOTE: paper is missing this, but it is also necessary (maybe they 49 | -- intend `s[-1] =0` in the definition of monotone) 50 | 0 ≤ s 0 → 51 | stream_monotone s → positive (D s) := 52 | begin 53 | intros h0 hp, intros t; simp, 54 | unfold D delay; simp, 55 | split_ifs, 56 | { subst t, assumption }, 57 | { have hle := hp (t - 1), 58 | have heq : t - 1 + 1 = t := by omega, rw heq at hle, 59 | assumption, 60 | }, 61 | end 62 | 63 | lemma derivative_pos_counter_example : 64 | (∃ (x:a), x < 0) → 65 | ¬(∀ (s: stream a), stream_monotone s → positive (D s)) := 66 | begin 67 | intros h, cases h with x hneg, 68 | simp, 69 | -- pushing the negation through, we're going to prove 70 | -- ∃ (x : stream a), stream_monotone x ∧ ¬positive (D x) 71 | use (λ _n, x), 72 | split, 73 | { intros t, simp, }, 74 | { unfold positive, 75 | rw stream_le_ext, simp, 76 | use 0, simp [D], 77 | apply not_le_of_gt, assumption, 78 | }, 79 | end 80 | -------------------------------------------------------------------------------- /src/recursive.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .relational 5 | import .relational_incremental 6 | import .stream_elim 7 | import logic.function.iterate 8 | 9 | open zset 10 | 11 | section recursion. 12 | 13 | variables {a: Type}. 14 | variables [decidable_eq a]. 15 | 16 | -- idea is that we're supposed to compute O such that R(O) = O 17 | variables (R: Z[a] → Z[a]). 18 | 19 | private def approxs : stream Z[a] := 20 | fix (λ (o: stream Z[a]), ↑↑R (z⁻¹ o)). 21 | 22 | lemma approxs_unfold : 23 | approxs R = ↑↑R (z⁻¹ (approxs R)) := 24 | begin 25 | unfold approxs, 26 | apply fix_eq, 27 | apply causal_strict_strict, swap, simp, 28 | apply delay_strict, 29 | end 30 | 31 | noncomputable def recursive_fixpoint : Z[a] := 32 | ∫ (D (approxs R)). 33 | 34 | lemma approxs_apply 35 | (n: ℕ) : 36 | approxs R n = (R^[n.succ]) 0 := 37 | begin 38 | induction n, simp, 39 | { unfold approxs, 40 | rw fix_0, simp, }, 41 | { rw approxs_unfold, simp, 42 | rw n_ih, simp, 43 | repeat { rw (function.commute.iterate_self R) }, }, 44 | end 45 | 46 | lemma approxs_unfold_succ 47 | (n: ℕ) : 48 | approxs R n.succ = R (approxs R n) := 49 | begin 50 | rw approxs_apply, 51 | rw approxs_apply, 52 | simp, 53 | rw function.commute.iterate_self R, 54 | end 55 | 56 | private lemma eq_succ_is_fixpoint 57 | (n: ℕ) (heqn: R^[n.succ] 0 = (R^[n]) 0) : 58 | ∀ m ≥ n, 59 | R^[m] 0 = (R^[n]) 0 := 60 | begin 61 | intros m hge, 62 | by_cases (m = n), cc, 63 | generalize hdiff : m - n - 1 = d, 64 | have hm : m = (n + d).succ := by omega, 65 | rw hm, rw hm at *, clear_dependent m, clear hdiff, 66 | clear hge h, 67 | induction d, 68 | { simp, assumption, }, 69 | { have hnsucc : (n + d_n.succ) = (n + d_n).succ := by omega, 70 | simp, rw function.commute.iterate_self, 71 | rw [hnsucc, d_ih], 72 | simp at heqn, rw function.commute.iterate_self at heqn, 73 | exact heqn, 74 | }, 75 | end 76 | 77 | lemma derivative_approx_almost_zero 78 | (n: ℕ) (heqn: (R^[n.succ]) 0 = (R^[n]) 0) : 79 | zero_after (D (approxs R)) n.succ := 80 | begin 81 | intros m hge, 82 | rw derivative_difference_t, swap, omega, 83 | repeat { rw approxs_apply }, 84 | have heq : (m - 1).succ = m := by omega, rw heq, clear heq, 85 | rw (eq_succ_is_fixpoint _ n heqn m.succ), swap, omega, 86 | rw (eq_succ_is_fixpoint _ n heqn m), swap, omega, 87 | simp, 88 | end 89 | 90 | theorem recursive_fixpoint_ok 91 | (n: ℕ) (heqn: (R^[n.succ]) 0 = (R^[n]) 0) : 92 | recursive_fixpoint R = (R^[n]) 0 := 93 | begin 94 | unfold recursive_fixpoint, 95 | rw (stream_elim_zero_after (D (approxs R)) n.succ), 96 | { rw <- integral_sum_vals, 97 | simp, 98 | rw approxs_apply, dsimp, 99 | exact heqn, }, 100 | apply (derivative_approx_almost_zero _ n heqn), 101 | end 102 | 103 | end recursion. 104 | 105 | section seminaive. 106 | 107 | 108 | variables {a b: Type}. 109 | variables [decidable_eq a] [decidable_eq b]. 110 | 111 | variables (R: Z[b] → Z[a] → Z[a]). 112 | 113 | noncomputable def naive : Z[b] → Z[a] := 114 | λ i, ∫ (D (fix (λ (o: stream Z[a]), ↑²R (I (δ0 i)) (z⁻¹ o)))). 115 | 116 | noncomputable def seminaive : Z[b] → Z[a] := 117 | λ i, ∫ (fix (λ (o: stream Z[a]), ↑²R^Δ2 (δ0 i) (z⁻¹ o))). 118 | 119 | -- hack to make the change work (need a better way to introduce incremental) 120 | local attribute [reducible] incremental. 121 | 122 | theorem seminaive_equiv : 123 | seminaive R = naive R := 124 | begin 125 | ext x, 126 | unfold naive seminaive, 127 | congr' 1, 128 | congr' 1, 129 | change (D (fix (λ (o : stream Z[a]), ↑²R (I (δ0 x)) (z⁻¹ o)))) with 130 | (λ i, (fix (λ (o : stream Z[a]), ↑²R i (z⁻¹ o))))^Δ (δ0 x), 131 | rw cycle_incremental (λ i o, ↑²R i o), 132 | dsimp, 133 | rw uncurry_op_lifting2, 134 | apply lifting_causal, 135 | end 136 | 137 | theorem naive_ok (i: Z[b]) 138 | (n: ℕ) (heqn: (R i)^[n.succ] 0 = ((R i)^[n]) 0) : 139 | naive R i = ((R i)^[n]) 0 := 140 | begin 141 | unfold naive, 142 | have heq := (recursive_fixpoint_ok (R i)) _ heqn, 143 | unfold recursive_fixpoint approxs at heq, 144 | rw<- heq, 145 | congr' 3, 146 | funext o, 147 | congr' 1, 148 | funext t, simp, 149 | end 150 | 151 | theorem seminaive_ok (i: Z[b]) 152 | (n: ℕ) (heqn: (R i)^[n.succ] 0 = ((R i)^[n]) 0) : 153 | seminaive R i = ((R i)^[n]) 0 := 154 | begin 155 | rw seminaive_equiv, 156 | apply naive_ok, assumption, 157 | end 158 | 159 | end seminaive. 160 | -------------------------------------------------------------------------------- /src/recursive_example.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .relational 5 | import .relational_incremental 6 | import .recursive 7 | 8 | open zset. 9 | 10 | variables {Node: Type} [decidable_eq Node]. 11 | 12 | def Edge (Node: Type) := Node × Node. 13 | 14 | instance : decidable_eq (Edge Node) := by apply_instance. 15 | 16 | -- get a self-edge for the head 17 | def πh (input: Edge Node) : Edge Node := (input.1, input.1). 18 | -- get a self-edge for the tail 19 | def πt (input: Edge Node) : Edge Node := (input.2, input.2). 20 | 21 | def πht (x: Edge Node × Edge Node) : Edge Node := 22 | let r1 := x.1 in 23 | let e := x.2 in 24 | (r1.1, e.2). 25 | 26 | local prefix (name := lifting) `↑`:std.prec.max := lifting. 27 | 28 | def closure1 (E R1: Z[Edge Node]) : Z[Edge Node] := 29 | distinct $ 30 | zset.map πht (equi_join prod.snd prod.fst R1 E) + 31 | E + 32 | zset.map πh E + 33 | zset.map πt E. 34 | 35 | lemma lifting_closure1_eq (E R1: stream Z[Edge Node]) : 36 | ↑²closure1 E R1 = 37 | ↑distinct ( 38 | ↑(zset.map πht) (↑²(equi_join prod.snd prod.fst) R1 E) + 39 | E + 40 | ↑(zset.map πh) E + 41 | ↑(zset.map πt) E) := rfl. 42 | 43 | noncomputable def closure : Z[Edge Node] → Z[Edge Node] := naive closure1. 44 | 45 | noncomputable def closure_seminaive : Z[Edge Node] → Z[Edge Node] := 46 | λ E, let E := δ0 E in 47 | ∫ $ fix (λ R, ↑distinct^Δ 48 | (↑(zset.map πht) (↑²(equi_join prod.snd prod.fst)^Δ2 (z⁻¹ R) E) + 49 | E + 50 | ↑(zset.map πh) E + 51 | ↑(zset.map πt) E)). 52 | 53 | theorem closure_efficient_ok : 54 | @closure_seminaive Node _ = closure := 55 | begin 56 | unfold closure, 57 | symmetry, 58 | rw<- seminaive_equiv, 59 | funext E, 60 | unfold closure_seminaive seminaive, 61 | dsimp, 62 | congr' 2, 63 | funext R1, 64 | conv_lhs { 65 | simp [incremental2], rw lifting_closure1_eq, skip, 66 | }, 67 | simp, 68 | rw D_push, congr' 1, 69 | repeat { rw derivative_linear }, simp, 70 | rw D_push, simp, 71 | rw incremental2_unfold, 72 | end 73 | 74 | noncomputable def incremental_closure : operator (Z[Edge Node]) (Z[Edge Node]) := 75 | incremental (λ dE, 76 | let E := ↑δ0 dE in 77 | ↑∫ $ fix2 (λ R, ↑((↑distinct)^Δ) 78 | (↑(↑(zset.map πht)) 79 | (↑²(↑²(equi_join prod.snd prod.fst)^Δ2) (↑z⁻¹ R) E) + 80 | E + 81 | ↑(↑(zset.map πh)) E + 82 | ↑(↑(zset.map πt)) E))). 83 | 84 | local attribute [simp] sum_causal causal_comp_causal. 85 | 86 | theorem incremental_closure_ok : 87 | @incremental_closure Node _ = (↑closure)^Δ := 88 | begin 89 | funext EΔ, 90 | unfold incremental_closure, unfold incremental, dsimp, 91 | rw<- closure_efficient_ok, 92 | generalize heq : I EΔ = E, clear_dependent EΔ, 93 | congr' 1, 94 | change (↑closure_seminaive E) with 95 | (↑∫ $ ↑(λ E, fix (λ R, ↑distinct^Δ 96 | (↑(zset.map πht) (↑²(equi_join prod.snd prod.fst)^Δ2 (z⁻¹ R) E) + 97 | E + 98 | ↑(zset.map πh) E + 99 | ↑(zset.map πt) E))) $ ↑δ0 $ E), 100 | rw lifting_cycle (λ (E R: stream Z[Edge Node]), ↑distinct^Δ (↑(zset.map πht) 101 | (↑²(equi_join prod.snd prod.fst)^Δ2 R E) + 102 | E + 103 | ↑(zset.map πh) E + 104 | ↑(zset.map πt) E)), 105 | { simp, 106 | congr' 2, }, 107 | unfold uncurry_op, 108 | simp, 109 | end 110 | 111 | noncomputable def incremental_closure2 : operator Z[Edge Node] Z[Edge Node] := 112 | λ dE, 113 | let E := ↑δ0 dE in 114 | (↑∫)^Δ $ fix2 (λ R, ↑((↑distinct)^Δ)^Δ 115 | (↑(↑(zset.map πht)) 116 | (↑²(↑²(equi_join prod.snd prod.fst)^Δ2)^Δ2 (↑z⁻¹ R) E) + 117 | E + 118 | ↑(↑(zset.map πh)) E + 119 | ↑(↑(zset.map πt)) E)). 120 | 121 | lemma fix2_congr {a: Type} [add_comm_group a] (F1 F2: operator (stream a) (stream a)) : 122 | F1 = F2 → 123 | fix2 F1 = fix2 F2 := by cc. 124 | 125 | @[simp] 126 | lemma lifting_map_πht_incremental : 127 | ↑(↑(zset.map (@πht Node _)))^Δ = ↑(↑(zset.map πht)) := 128 | begin 129 | apply lifting_map_incremental, 130 | end 131 | 132 | theorem incremental_closure2_ok : 133 | @incremental_closure2 Node _ = (↑closure)^Δ := 134 | begin 135 | rw<- incremental_closure_ok, 136 | funext dE, simp [incremental_closure, incremental_closure2], 137 | symmetry, 138 | rw (incremental_comp (↑∫) _ dE), 139 | congr' 1, 140 | rw (cycle2_incremental 141 | (λ s (R : stream (stream Z[Edge Node])), 142 | ↑(↑distinct^Δ) 143 | (↑ ↑(zset.map πht) (↑²(↑²(equi_join prod.snd prod.fst)^Δ2) R (↑δ0 s)) + 144 | ↑δ0 s + 145 | ↑ ↑(zset.map πh) (↑δ0 s) + 146 | ↑ ↑(zset.map πt) (↑δ0 s))) 147 | ), dsimp, 148 | apply fix2_congr, funext R, 149 | rw (incremental2_unfold _ dE), 150 | rw D_push, 151 | congr' 1, 152 | rw derivative_linear, 153 | rw derivative_linear, 154 | rw derivative_linear, 155 | rw D_push, simp, 156 | rw D_push2, simp, 157 | rw D_push, simp, 158 | rw D_push, simp, 159 | rw D_push, simp, 160 | rw D_push, simp, 161 | rw D_push, simp, 162 | 163 | -- need to prove causal_nested 164 | intros s, dsimp, 165 | apply causal_nested_comp; simp, 166 | apply sum_causal_nested; simp, 167 | apply sum_causal_nested; simp, 168 | apply sum_causal_nested; simp, 169 | apply causal_nested_comp, simp, 170 | apply causal_nested_lifting2; simp, 171 | { unfold uncurry_op, 172 | apply causal_lifting2_incremental; simp, }, 173 | { apply causal_nested_id, }, 174 | end 175 | 176 | def distinct_double_incremental {A: Type} [decidable_eq A] : operator (stream Z[A]) (stream Z[A]) := 177 | λ i, D $ ↑²(↑² (@distinct_H A _)) (↑z⁻¹ (↑I (I i))) (I i). 178 | 179 | theorem distinct_double_incremental_ok {A: Type} [decidable_eq A] : 180 | (↑(↑(@distinct A _)^Δ))^Δ = 181 | distinct_double_incremental := 182 | begin 183 | funext s, 184 | unfold distinct_double_incremental, 185 | rw distinct_incremental_ok, 186 | unfold distinct_incremental, 187 | rw incremental_unfold, 188 | refl, 189 | end 190 | 191 | section equi_join. 192 | variables {A B C: Type}. 193 | variables [decidable_eq A] [decidable_eq B] [decidable_eq C]. 194 | 195 | variables (π1: A → C) (π2: B → C). 196 | 197 | local notation x `▹◃`:40 y := (lifting2 (lifting2 (equi_join x y))). 198 | 199 | local attribute [irreducible] lifting2 equi_join. 200 | 201 | def join_double_incremental1 : operator2 (stream (Z[A])) (stream Z[B]) (stream Z[A × B]) := 202 | λ a b, 203 | ↑²(↑²(equi_join π1 π2))^Δ2 a b + 204 | ↑²(↑²(equi_join π1 π2))^Δ2 (↑z⁻¹ $ ↑I $ a) b + 205 | ↑²(↑²(equi_join π1 π2))^Δ2 a (↑z⁻¹ $ ↑I $ b). 206 | 207 | @[simp] 208 | lemma lifting_I_delay_incremental {a: Type} [add_comm_group a] : 209 | incremental ↑(λ (x: stream a), I (z⁻¹ x)) = ↑(λ x, I (z⁻¹ x)) := 210 | begin 211 | apply lti_incremental, 212 | apply lifting_lti, 213 | intros s1 s2, 214 | rw [delay_linear, integral_linear], 215 | end 216 | 217 | lemma lifting_I_delay_simplify (s: stream (stream Z[A])) : 218 | ↑(λ x, I (z⁻¹ x)) s = ↑z⁻¹ (↑I s) := 219 | begin 220 | rw<- lifting_comp, 221 | funext t, simp, 222 | rw integral_time_invariant, 223 | end 224 | 225 | theorem join_double_incremental1_ok : 226 | ↑²(↑²(equi_join π1 π2)^Δ2)^Δ2 = join_double_incremental1 π1 π2 := 227 | begin 228 | unfold join_double_incremental1, 229 | rw equi_join_incremental, unfold times_incremental, 230 | funext a b, 231 | rw lifting2_incremental_sum, 232 | rw lifting2_incremental_sum, 233 | simp, 234 | rw (lifting2_incremental_comp_1 _ (λ (x: stream Z[A]), I (z⁻¹ x))), 235 | rw (lifting2_incremental_comp_2 _ (λ (y: stream Z[B]), I (z⁻¹ y))), 236 | simp, 237 | rw lifting_I_delay_simplify, 238 | rw lifting_I_delay_simplify, 239 | end 240 | 241 | -- this is the fully optimized circuit 242 | def join_double_incremental : operator2 (stream Z[A]) (stream Z[B]) (stream Z[A × B]) := 243 | λ a b, 244 | let join := ↑²(↑²(equi_join π1 π2)) in 245 | join (z⁻¹ (I a)) (↑z⁻¹ $ ↑I b) + 246 | join (I $ ↑I $ a) b + 247 | join (↑I a) (z⁻¹ $ I b) + 248 | join a (↑z⁻¹ $ I $ ↑I b). 249 | 250 | lemma equi_join_lifting2_time_invariant : 251 | ∀ s1 s2, z⁻¹ (↑²(↑² (equi_join π1 π2)) s1 s2) = 252 | ↑²(↑² (equi_join π1 π2)) (z⁻¹ s1) (z⁻¹ s2) := 253 | begin 254 | intros s1 s2, 255 | funext n t, simp, 256 | unfold delay, split_ifs; simp, 257 | end 258 | 259 | lemma equi_join_double_lift_bilinear : 260 | bilinear (↑²(↑² (equi_join π1 π2))) := 261 | begin 262 | split; intros, 263 | { funext n t, simp, rw (equi_join_bilinear _ _).1, }, 264 | { funext n t, simp, rw (equi_join_bilinear _ _).2, }, 265 | end 266 | 267 | lemma equi_join_I_1 : 268 | ∀ a b, ↑²(↑² (equi_join π1 π2)) (I a) b = 269 | ↑²(↑² (equi_join π1 π2)) a b + 270 | ↑²(↑² (equi_join π1 π2)) (z⁻¹ (I a)) b := 271 | begin 272 | intros, 273 | conv_lhs { 274 | rw [integral_unfold a], 275 | }, 276 | rw (equi_join_double_lift_bilinear _ _).1, 277 | end 278 | 279 | lemma equi_join_lift_I_1 : 280 | ∀ a b, 281 | ↑²(↑² (equi_join π1 π2)) (↑I a) b = 282 | ↑²(↑² (equi_join π1 π2)) a b + 283 | ↑²(↑² (equi_join π1 π2)) (↑I (↑z⁻¹ a)) b := 284 | begin 285 | intros, 286 | funext n t, simp, 287 | conv_lhs { 288 | rw integral_unfold, 289 | }, 290 | simp, 291 | rw (equi_join_bilinear _ _).1, 292 | rw integral_time_invariant, 293 | end 294 | 295 | lemma equi_join_lift_I_2 : 296 | ∀ a b, 297 | ↑²(↑² (equi_join π1 π2)) a (↑I b) = 298 | ↑²(↑² (equi_join π1 π2)) a b + 299 | ↑²(↑² (equi_join π1 π2)) a (↑I (↑z⁻¹ b)) := 300 | begin 301 | intros, 302 | funext n t, simp, 303 | conv_lhs { 304 | rw integral_unfold, 305 | }, 306 | simp, 307 | rw (equi_join_bilinear _ _).2, 308 | rw integral_time_invariant, 309 | end 310 | 311 | lemma equi_join_I_2 : 312 | ∀ a b, ↑²(↑² (equi_join π1 π2)) a (I b) = 313 | ↑²(↑² (equi_join π1 π2)) a b + 314 | ↑²(↑² (equi_join π1 π2)) a (z⁻¹ (I b)) := 315 | begin 316 | intros, 317 | conv_lhs { 318 | rw [integral_unfold b], 319 | }, 320 | rw (equi_join_double_lift_bilinear _ _).2, 321 | end 322 | 323 | lemma equi_join_I_unfold : 324 | ∀ a b, ↑²(↑² (equi_join π1 π2)) (I a) (I b) = 325 | ↑²(↑² (equi_join π1 π2)) a b + 326 | ↑²(↑² (equi_join π1 π2)) a (z⁻¹ (I b)) + 327 | ↑²(↑² (equi_join π1 π2)) (z⁻¹ (I a)) b + 328 | ↑²(↑² (equi_join π1 π2)) (z⁻¹ (I a)) (z⁻¹ (I b)) := 329 | begin 330 | intros, 331 | repeat { rw equi_join_I_1 <|> rw equi_join_I_2 }, 332 | abel, 333 | end 334 | 335 | private lemma neg_add_sub {α: Type} [add_comm_group α] (x y: α) : 336 | (-1 : ℤ) • x + y = y - x := 337 | begin 338 | abel, 339 | end 340 | 341 | private lemma add_both_sides {G} [has_add G] [is_right_cancel_add G] (x: G) {a b: G} : 342 | a + x = b + x -> a = b := 343 | begin 344 | apply add_right_cancel, 345 | end 346 | 347 | private lemma fold_join_helper : 348 | ∀ a b, ((-1 : ℤ) • (π1▹◃π2) (I (z⁻¹ (↑I a))) b + (π1▹◃π2) (I (z⁻¹ (↑I (↑z⁻¹ a)))) b) = 349 | (-1 : ℤ) • (π1▹◃π2) (I (z⁻¹ a)) b := 350 | begin 351 | intros, 352 | apply (add_both_sides ((π1▹◃π2) (I (z⁻¹ a)) b)), 353 | abel, 354 | rw neg_add_sub, 355 | rw<- add_sub_assoc, 356 | rw<- (equi_join_double_lift_bilinear π1 π2).1, 357 | rw<- integral_linear, 358 | rw<- delay_linear, 359 | rw<- (bilinear_sub_1 (equi_join_double_lift_bilinear π1 π2)), 360 | rw<- (linear_sub integral_linear), 361 | rw<- (linear_sub delay_linear), 362 | have hz: a + ↑I (↑z⁻¹ a) - ↑I a = 0 := by { 363 | have h: ↑I a = a + ↑I (↑z⁻¹ a) := by { 364 | funext n, simp, 365 | conv_lhs { 366 | rw integral_unfold, 367 | }, 368 | rw integral_time_invariant, 369 | }, 370 | rw h, abel, 371 | }, 372 | rw hz, simp, 373 | funext n t, simp, 374 | end 375 | 376 | theorem join_double_incremental_ok : 377 | ↑²(↑²(equi_join π1 π2)^Δ2)^Δ2 = join_double_incremental π1 π2 := 378 | begin 379 | rw join_double_incremental1_ok, 380 | unfold join_double_incremental1 join_double_incremental, 381 | funext a b, simp, 382 | unfold incremental2, 383 | unfold D, 384 | repeat { rw equi_join_lifting2_time_invariant }, 385 | rw equi_join_I_unfold, 386 | rw equi_join_I_unfold, 387 | rw equi_join_I_unfold, 388 | abel, 389 | repeat { rw<- integral_lift_time_invariant <|> 390 | rw<- lift_integral_lift_time_invariant <|> 391 | rw<- integral_time_invariant }, 392 | conv_rhs { 393 | rw equi_join_I_1 π1 π2 (↑I a) b, 394 | rw equi_join_I_2 π1 π2 a _, 395 | rw (equi_join_lift_I_1 π1 π2 a), 396 | rw (equi_join_lift_I_1 π1 π2 a), 397 | }, 398 | repeat { rw<- integral_lift_time_invariant <|> 399 | rw<- lift_integral_lift_time_invariant <|> 400 | rw<- integral_time_invariant }, 401 | repeat { rw add_assoc }, 402 | apply eq_of_sub_eq_zero, 403 | abel, 404 | abel, 405 | rw fold_join_helper, 406 | abel, 407 | end 408 | 409 | end equi_join. 410 | 411 | noncomputable def incremental_closure_opt : operator Z[Edge Node] Z[Edge Node] := 412 | λ dE, 413 | let E := ↑δ0 dE in 414 | (↑∫)^Δ $ fix2 (λ R, distinct_double_incremental 415 | (↑(↑(zset.map πht)) 416 | (join_double_incremental prod.snd prod.fst (↑z⁻¹ R) E) + 417 | E + 418 | ↑(↑(zset.map πh)) E + 419 | ↑(↑(zset.map πt)) E)). 420 | 421 | theorem incremental_closure_opt_ok : 422 | @incremental_closure_opt Node _ = (↑closure)^Δ := 423 | begin 424 | rw<- incremental_closure2_ok, 425 | unfold incremental_closure_opt incremental_closure2, 426 | funext dE, dsimp, 427 | congr' 1, 428 | congr' 1, 429 | funext R, 430 | rw distinct_double_incremental_ok, 431 | rw join_double_incremental_ok, 432 | end 433 | -------------------------------------------------------------------------------- /src/relational.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .zset 5 | import .linear 6 | 7 | open zset 8 | 9 | variables {A B C: Type}. 10 | variables [decidable_eq A] [decidable_eq B] [decidable_eq C]. 11 | 12 | lemma distinct_is_set (m: Z[A]) : is_set (distinct m) := 13 | begin 14 | intros a, rw elem_mp, simp, 15 | intros, linarith, 16 | end 17 | 18 | lemma distinct_is_bag (m: Z[A]) : is_bag (distinct m) := 19 | begin 20 | apply set_is_bag, apply distinct_is_set, 21 | end 22 | 23 | lemma distinct_set_id (m: Z[A]) : is_set m → m.distinct = m := 24 | begin 25 | intros h, 26 | ext a, simp, 27 | cases (is_set_or _).mp h a with hma hma; rw hma, 28 | { rw if_neg, omega, }, 29 | { rw if_pos, omega, }, 30 | end 31 | 32 | @[simp] 33 | lemma distinct_set_simp (m: Z[A]) : is_set (distinct m) ↔ true := 34 | by { simp, apply distinct_is_set }. 35 | 36 | @[simp] 37 | lemma distinct_bag_simp (m: Z[A]) : is_bag (distinct m) ↔ true := 38 | by { simp, apply distinct_is_bag }. 39 | 40 | lemma distinct_elem {m: Z[A]} {a: A} : 41 | is_bag m → 42 | (a ∈ m.distinct ↔ a ∈ m) := 43 | begin 44 | intros hpos, 45 | rw [elem_mp, elem_mp], 46 | rw distinct_apply, 47 | have h := hpos a, simp at h, 48 | split_ifs; simp, 49 | omega, omega, 50 | end 51 | 52 | lemma distinct_pos : fun_positive (@distinct A _) := 53 | begin 54 | intros f hp, simp, 55 | end 56 | 57 | @[simp] 58 | lemma distinct_0 : distinct (0 : Z[A]) = 0 := rfl. 59 | 60 | def query (A B: Type) := operator Z[A] Z[B]. 61 | 62 | def union (m1 m2: Z[A]) := distinct (m1 + m2). 63 | instance zset_union : has_union Z[A] := ⟨union⟩. 64 | lemma union_eq (m1 m2: Z[A]) : m1 ∪ m2 = union m1 m2 := rfl. 65 | 66 | lemma union_apply (m1 m2: Z[A]) (a: A) : 67 | union m1 m2 a = if 0 < m1 a + m2 a then 1 else 0 := 68 | begin 69 | unfold union distinct; simp, 70 | apply if_congr; try { refl }, 71 | simp, omega, 72 | end 73 | 74 | theorem union_ok (s1 s2: finset A) : 75 | zset.to_set (zset.from_set s1 ∪ zset.from_set s2) = s1 ∪ s2 := 76 | begin 77 | ext a, 78 | rw finset.mem_union, 79 | rw union_eq, unfold union, 80 | unfold distinct zset.from_set zset.to_set; simp, 81 | split_ifs; ring_nf; simp; tauto, 82 | end 83 | 84 | theorem union_pos : fun_positive2 (@union A _) := 85 | begin 86 | intros m1 m2 h1 h2, 87 | intros a, simp, 88 | rw union_apply, 89 | split_ifs; omega, 90 | end 91 | 92 | theorem map_ok (f: A → B) (s: finset A) : 93 | (zset.map f (zset.from_set s)).support = s.image f := 94 | begin 95 | ext b, simp, rw map_is_card, 96 | simp, 97 | tauto, 98 | end 99 | 100 | theorem map_pos (f: A → B) : fun_positive (zset.map f) := 101 | begin 102 | intros m h, 103 | intros a, simp, 104 | unfold zset.map, rw flatmap_apply, 105 | apply map_at_nonneg, assumption, 106 | end 107 | 108 | section filter. 109 | variables (p: A → Prop) [decidable_pred p]. 110 | 111 | def filter (m: Z[A]) : Z[A] := 112 | dfinsupp.mk (m.support.filter p) (λ a, m a). 113 | 114 | lemma filter_support (m: Z[A]) : 115 | dfinsupp.support (filter p m) = m.support.filter p := 116 | begin 117 | unfold filter, ext a, simp, 118 | tauto, 119 | end 120 | 121 | @[simp] 122 | lemma filter_apply (m: Z[A]) (a: A) : 123 | filter p m a = if p a then m a else 0 := 124 | begin 125 | unfold filter, simp, 126 | split_ifs; tauto, 127 | end 128 | 129 | theorem filter_ok (s: finset A) : 130 | zset.to_set (filter p (zset.from_set s)) = s.filter p := 131 | begin 132 | ext a, simp, 133 | rw [elem_mp, filter_apply], 134 | simp, tauto, 135 | end 136 | 137 | lemma filter_linear : 138 | ∀ (m1 m2: Z[A]), filter p (m1 + m2) = filter p m1 + filter p m2 := 139 | begin 140 | intros, 141 | ext a, simp, 142 | split_ifs, 143 | { simp }, 144 | { finish }, 145 | end 146 | 147 | theorem filter_pos : fun_positive (filter p) := 148 | begin 149 | intros m h, intros a, simp, 150 | split_ifs, 151 | { apply h, }, 152 | { linarith, } 153 | end 154 | 155 | lemma filter_0 : filter p 0 = 0 := rfl. 156 | 157 | end filter. 158 | 159 | section product. 160 | def product (m1: Z[A]) (m2: Z[B]) : Z[A × B] := 161 | -- the unusual binder is because dfinupp.mk actually supplies a proof that 162 | -- the input is in the support, which is being ignored here 163 | dfinsupp.mk 164 | (finset.product m1.support m2.support) 165 | (λ ⟨(a, b), _⟩, m1 a * m2 b). 166 | 167 | @[simp] 168 | lemma product_apply (m1: Z[A]) (m2: Z[B]) (ab: A × B) : 169 | product m1 m2 ab = m1 ab.1 * m2 ab.2 := 170 | begin 171 | unfold product, cases ab with a b, simp, 172 | split_ifs, 173 | { refl }, 174 | { finish }, 175 | end 176 | 177 | theorem product_ok (s1: finset A) (s2: finset B) : 178 | zset.to_set (product (zset.from_set s1) (zset.from_set s2)) = finset.product s1 s2 := 179 | begin 180 | ext ab, cases ab with a b, simp, 181 | rw elem_eq, simp, 182 | end 183 | 184 | theorem product_bilinear : bilinear (@product A B _ _) := 185 | begin 186 | split, 187 | { intros x1 x2 y, 188 | ext ab, cases ab with a b, simp, 189 | omega, }, 190 | { intros x y1 y2, 191 | ext ab, cases ab with a b, simp, 192 | omega, } 193 | end 194 | 195 | theorem product_pos : fun_positive2 (@product A B _ _) := 196 | begin 197 | intros m1 m2 h1 h2, 198 | intros ab, cases ab with a b, simp, 199 | have h1a := h1 a, 200 | have h2a := h2 b, 201 | simp at h1a h2a, 202 | nlinarith, 203 | end 204 | 205 | @[simp] 206 | lemma product_0 : @product A B _ _ 0 0 = 0 := rfl. 207 | 208 | section equi_join. 209 | 210 | variables (π1: A → C) (π2: B → C). 211 | 212 | def equi_join (m1: Z[A]) (m2: Z[B]) : Z[A × B] 213 | := filter (λ t, π1 t.1 = π2 t.2) (product m1 m2). 214 | 215 | @[simp] 216 | lemma equi_join_apply (m1: Z[A]) (m2: Z[B]) (t: A × B) : 217 | equi_join π1 π2 m1 m2 t = if π1 t.1 = π2 t.2 then m1 t.1 * m2 t.2 else 0 := 218 | by { unfold equi_join, simp, }. 219 | 220 | theorem equi_join_bilinear : bilinear (equi_join π1 π2) := 221 | begin 222 | split; intros, 223 | { unfold equi_join, rw [product_bilinear.1, filter_linear], }, 224 | { unfold equi_join, rw [product_bilinear.2, filter_linear], }, 225 | end 226 | 227 | theorem equi_join_pos : fun_positive2 (equi_join π1 π2) := 228 | begin 229 | intros m1 m2 h1 h2, 230 | apply filter_pos, apply product_pos; assumption, 231 | end 232 | 233 | @[simp] 234 | lemma equi_join_0_l (b: Z[B]) : equi_join π1 π2 0 b = 0 := rfl. 235 | 236 | @[simp] 237 | lemma equi_join_0_r (a: Z[A]) : equi_join π1 π2 a 0 = 0 := 238 | begin 239 | ext a, simp, 240 | end 241 | 242 | 243 | end equi_join. 244 | 245 | end product. 246 | 247 | -- TODO: paper says intersection can be defined as a special case of an 248 | -- equijoin, but this construction required projecting A × A → A (where both are 249 | -- equal due to the filter), and it's not obvious that project preserves 250 | -- bilinearity. In any case the direct definition is straightforward. 251 | 252 | def intersect (m1 m2: Z[A]) : Z[A] := 253 | dfinsupp.mk (m1.support ∩ m2.support) (λ a, m1 a * m2 a). 254 | instance : has_inter (Z[A]) := ⟨intersect⟩. 255 | 256 | @[simp] 257 | lemma intersect_apply (m1 m2: Z[A]) (a: A) : 258 | (m1 ∩ m2) a = m1 a * m2 a := 259 | begin 260 | change (m1 ∩ m2) with (intersect m1 m2), 261 | unfold intersect, simp, 262 | tauto, 263 | end 264 | 265 | @[simp] 266 | lemma intersect_0 : (0: Z[A]) ∩ 0 = 0 := rfl. 267 | 268 | @[simp] 269 | lemma intersect_support (m1 m2: Z[A]) : 270 | (m1 ∩ m2).support = m1.support ∩ m2.support := 271 | begin 272 | ext a, 273 | change (m1 ∩ m2) with (intersect m1 m2), 274 | unfold intersect, simp, 275 | tauto, 276 | end 277 | 278 | theorem intersect_ok (s1 s2: finset A) : 279 | zset.to_set (zset.from_set s1 ∩ zset.from_set s2) = s1 ∩ s2 := 280 | begin 281 | ext a, simp, 282 | rw elem_mp, simp, 283 | end 284 | 285 | theorem intersect_pos : fun_positive2 ((∩) : Z[A] → Z[A] → Z[A]) := 286 | begin 287 | intros m1 m2 hpos1 hpos2, 288 | intros a, simp, 289 | have h1 := hpos1 a, have h2 := hpos2 a, simp at h1 h2, 290 | nlinarith, 291 | end 292 | 293 | theorem intersect_bilinear : bilinear ((∩) : Z[A] → Z[A] → Z[A]) := 294 | begin 295 | split; introv; ext a; simp; nlinarith, 296 | end 297 | 298 | 299 | def difference (m1 m2: Z[A]) : Z[A] := distinct (m1 - m2). 300 | 301 | theorem difference_ok (s1 s2: finset A) : 302 | zset.to_set (difference (zset.from_set s1) (zset.from_set s2)) = s1 \ s2 := 303 | begin 304 | ext a, simp, 305 | rw elem_mp, unfold difference, simp, 306 | split_ifs; try { simp }; clarify, 307 | end 308 | 309 | section group_by. 310 | 311 | variables {K: Type} [decidable_eq K] (p: A → K). 312 | 313 | def group_by : Z[A] → Π₀ (_: K), Z[A] := 314 | λ m, dfinsupp.mk (m.support.image p) 315 | (λ k, dfinsupp.mk (m.support.filter (λ a, p a = k)) 316 | (λ a, if p a = k then m a else 0)). 317 | 318 | @[simp] 319 | lemma group_by_apply (m: Z[A]) (k: K) (a: A) : 320 | group_by p m k a = if p a = k then m a else 0 := 321 | begin 322 | unfold group_by, simp, 323 | split_ifs with hk hp; simp at hk |-, 324 | { split_ifs; try { tauto }, }, 325 | { tauto, }, 326 | { by_contra, apply (hk a); tauto, }, 327 | end 328 | 329 | lemma group_by_support (m: Z[A]) (k: K) : 330 | (group_by p m k).support = m.support.filter (λ a, p a = k) := 331 | begin 332 | ext a, simp, tauto, 333 | end 334 | 335 | lemma elem_group_by (m: Z[A]) (k: K) (a: A) : 336 | a ∈ group_by p m k ↔ p a = k ∧ a ∈ m := 337 | begin 338 | rw [elem_mp, elem_mp], simp, 339 | end 340 | 341 | lemma group_by_linear (m1 m2: Z[A]) : 342 | group_by p (m1 + m2) = group_by p m1 + group_by p m2 := 343 | begin 344 | ext k a, simp, 345 | split_ifs; refl 346 | end 347 | 348 | end group_by. 349 | 350 | /- A few properties about [distinct] -/ 351 | 352 | @[simp] 353 | lemma ite_ite {A: Type} {c1: Prop} [decidable c1] {c2: Prop} [decidable c2] (x z: A) : 354 | ite c1 (ite c2 x z) z = ite (c1 ∧ c2) x z := 355 | begin 356 | split_ifs; clarify, 357 | end 358 | 359 | -- this doesn't require is_bag i 360 | lemma filter_distinct_comm (p: A → Prop) [decidable_pred p] (i: Z[A]) : 361 | filter p (distinct i) = distinct (filter p i) := 362 | begin 363 | ext a, simp, 364 | apply if_congr; try { refl }, 365 | split_ifs; clarify, 366 | end 367 | 368 | theorem product_distinct_comm (i1: Z[A]) (i2: Z[B]) : 369 | is_bag i1 → is_bag i2 → 370 | product (distinct i1) (distinct i2) = distinct (product i1 i2) := 371 | begin 372 | intros hpos1 hpos2, 373 | ext ab, cases ab with a b, simp, 374 | have h1 := hpos1 a, have h2 := hpos2 b, 375 | simp at h1 h2, 376 | apply if_congr; try { refl }, 377 | tauto { closer := `[nlinarith] }, 378 | end 379 | 380 | theorem join_distinct_comm (π1: A → C) (π2: B → C) (i1: Z[A]) (i2: Z[B]) : 381 | is_bag i1 → is_bag i2 → 382 | equi_join π1 π2 (distinct i1) (distinct i2) = distinct (equi_join π1 π2 i1 i2) := 383 | begin 384 | intros hpos1 hpos2, 385 | unfold equi_join, 386 | rw <- filter_distinct_comm, 387 | { rw<- product_distinct_comm; assumption }, 388 | end 389 | 390 | theorem intersect_distinct_comm (i1 i2: Z[A]) : 391 | is_bag i1 → is_bag i2 → 392 | distinct i1 ∩ distinct i2 = distinct (i1 ∩ i2) := 393 | begin 394 | intros hpos1 hpos2, 395 | ext a, simp, 396 | apply if_congr; try { refl }, 397 | have h1 := hpos1 a, have h2 := hpos2 a, simp at h1 h2, 398 | tauto { closer := `[nlinarith] }, 399 | end 400 | 401 | private lemma map_at_distinct_none (f: A → B) (i: Z[A]) (b: B) : 402 | is_bag i → 403 | (∀ a, a ∈ i → f a ≠ b) → 404 | flatmap_at (λ a, {f a}) i.distinct b = 0 := 405 | begin 406 | intros hpos h, 407 | unfold flatmap_at, 408 | rw finset.sum_eq_zero, 409 | intros x ix_pos, simp at ix_pos, 410 | simp, intros hfx, 411 | suffices hne : f x ≠ b, { tauto }, 412 | apply h, rw elem_mp, linarith, 413 | end 414 | 415 | theorem map_inj_distinct_comm (f: A → B) [f_inj: function.injective f] (i: Z[A]) : 416 | is_bag i → 417 | distinct (zset.map f i) = zset.map f (distinct i) := 418 | begin 419 | intros hpos, 420 | ext b, simp, 421 | unfold zset.map, 422 | rw [flatmap_apply, flatmap_apply], 423 | split_ifs with h h; rw (map_at_pos _ _ _ hpos) at h, 424 | { cases h with a h, cases h with hel hf, 425 | have ha := hpos a, simp at ha, 426 | rw flatmap_map_at, 427 | -- split sum into a and everything else; intuition is that "everything else" 428 | -- can't include any matching elements because f is injective 429 | rw<- (@finset.sum_erase_add _ _ _ _ _ _ a), 430 | { rw finset.sum_eq_zero, 431 | { rw distinct_apply, 432 | rw elem_mp at hel, 433 | rw if_pos, swap, assumption, 434 | rw if_pos, swap, omega, 435 | refl, }, 436 | introv hel_erase, 437 | split_ifs, swap, refl, 438 | simp at hel_erase |-, 439 | suffices hxa : (x = a), { exfalso, tauto, }, 440 | apply f_inj, cc, 441 | }, 442 | simp, { rw elem_mp at hel, omega }, 443 | }, 444 | { push_neg at h, 445 | rw map_at_distinct_none, 446 | assumption, 447 | assumption, 448 | } 449 | end 450 | 451 | @[simp] 452 | lemma distinct_idem (i: Z[A]) : 453 | distinct (distinct i) = distinct i := 454 | begin 455 | ext a, simp, 456 | split_ifs; refl <|> linarith, 457 | end 458 | 459 | theorem filter_distinct_dedup (p: A → Prop) [decidable_pred p] (i: Z[A]) : 460 | distinct (filter p (distinct i)) = distinct (filter p i) := 461 | begin 462 | rw [filter_distinct_comm, distinct_idem], 463 | end 464 | 465 | theorem map_distinct_dedup (f: A → B) (i: Z[A]) : 466 | is_bag i → 467 | distinct (zset.map f (distinct i)) = distinct (zset.map f i) := 468 | begin 469 | intros hpos, 470 | ext b, simp, 471 | apply if_congr; try { refl }, 472 | unfold zset.map, 473 | rw [flatmap_apply, flatmap_apply], 474 | rw [map_at_pos, map_at_pos], 475 | { conv_lhs { 476 | congr, 477 | funext, 478 | rw (distinct_elem hpos), 479 | skip, 480 | }, 481 | }, 482 | { assumption, }, 483 | { simp, }, 484 | end 485 | 486 | theorem add_distinct_dedup (i1 i2: Z[A]) : 487 | is_bag i1 → is_bag i2 → 488 | distinct (i1.distinct + i2.distinct) = distinct (i1 + i2) := 489 | begin 490 | intros hpos1 hpos2, 491 | ext a, simp, 492 | have h1 := hpos1 a, have h2 := hpos2 a, simp at h1 h2, 493 | split_ifs; refl <|> linarith, 494 | end 495 | 496 | theorem product_distinct_dedup (i1: Z[A]) (i2: Z[B]) : 497 | is_bag i1 → is_bag i2 → 498 | distinct (product (distinct i1) (distinct i2)) = distinct (product i1 i2) := 499 | begin 500 | intros hpos1 hpos2, 501 | rw [product_distinct_comm, distinct_idem]; 502 | assumption 503 | end 504 | 505 | theorem join_distinct_dedup (π1: A → C) (π2: B → C) (i1: Z[A]) (i2: Z[B]) : 506 | is_bag i1 → is_bag i2 → 507 | distinct (equi_join π1 π2 (distinct i1) (distinct i2)) = distinct (equi_join π1 π2 i1 i2) := 508 | begin 509 | intros hpos1 hpos2, 510 | rw [join_distinct_comm, distinct_idem]; 511 | assumption, 512 | end 513 | 514 | theorem intersect_distinct_dedup (i1 i2: Z[A]) : 515 | is_bag i1 → is_bag i2 → 516 | distinct (distinct i1 ∩ distinct i2) = distinct (i1 ∩ i2) := 517 | begin 518 | intros hpos1 hpos2, 519 | rw [intersect_distinct_comm, distinct_idem]; 520 | assumption, 521 | end 522 | -------------------------------------------------------------------------------- /src/relational_example.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .incremental 5 | import .relational 6 | import .relational_incremental 7 | 8 | open zset 9 | 10 | class schema := 11 | -- the schemas for the two tables, T and R 12 | (T R : Type) 13 | -- t.a > 2 14 | -- r.s > 5 15 | (σT : T → Prop) (σR : R → Prop) 16 | -- the type of t1.x, t2.y, and the common id field 17 | (T1X T2Y Id : Type) 18 | (π1 : T → T1X × Id) (π2 : R → Id × T2Y). 19 | 20 | def πxy (S: schema) (t : (S.T1X × S.Id) × (S.Id × S.T2Y)) : S.T1X × S.T2Y := 21 | (t.1.1, t.2.2). 22 | 23 | class schema_ok (S: schema) := 24 | (i1 : decidable_eq S.T) 25 | (i2 : decidable_eq S.R) 26 | (i3 : decidable_pred S.σT) 27 | (i4 : decidable_pred S.σR) 28 | (i5 : decidable_eq S.T1X) 29 | (i6 : decidable_eq S.T2Y) 30 | (i7 : decidable_eq S.Id). 31 | 32 | section instances. 33 | open schema_ok. 34 | attribute [instance] i1 i2 i3 i4 i5 i6 i7. 35 | end instances. 36 | 37 | variables (S: schema) [schema_ok S]. 38 | 39 | def t1 : Z[S.T] → Z[S.T1X × S.Id] := 40 | λ t, zset.distinct (zset.map S.π1 (zset.distinct (filter S.σT (zset.distinct t)))). 41 | 42 | def t2 : Z[S.R] → Z[S.Id × S.T2Y] := 43 | λ r, zset.distinct (zset.map S.π2 (zset.distinct (filter S.σR (zset.distinct r)))). 44 | 45 | def V : Z[S.T] → Z[S.R] → Z[S.T1X × S.T2Y] := 46 | λ t r, zset.distinct 47 | (zset.map (πxy S) 48 | (equi_join prod.snd prod.fst (t1 S t) (t2 S r))). 49 | 50 | -- set up optimizations 51 | 52 | /- pos_equiv says f1 and f2 are equivalent on positive inputs -/ 53 | def pos_equiv {A B: Type} [decidable_eq A] [decidable_eq B] 54 | (f1 f2: Z[A] → Z[B]) := 55 | ∀ i, is_bag i → f1 i = f2 i. 56 | 57 | def pos_equiv2 {A B C: Type} [decidable_eq A] [decidable_eq B] [decidable_eq C] 58 | (f1 f2: Z[A] → Z[B] → Z[C]) := 59 | ∀ i1 i2, is_bag i1 → is_bag i2 → f1 i1 i2 = f2 i1 i2. 60 | 61 | infix ` =≤= `:50 := pos_equiv. 62 | infix ` =≤2= `:50 := pos_equiv2. 63 | 64 | /-- `same` is a technical device for automation purposes. It is just equality, 65 | but marked irreducible. 66 | 67 | The way this is used is that we can work on a goal `same x ?y` (where `?y` is 68 | an existential variable), gradually rewriting x to simplify it. If we tried to 69 | prove `x = ?y`, then `rw` an `simp` would always try to instantiate ?y with x, 70 | even if we want to continue rewriting. 71 | 72 | To make intermediate goals readable we provide `x === y` as notation for `same 73 | x y`. 74 | -/ 75 | def same {A : Type} (x y: A) := x = y. 76 | lemma same_def {A} (x y: A) : same x y = (x = y) := rfl. 77 | local attribute [irreducible] same. 78 | 79 | lemma same_intro {A: Type} (x y: A) : same x y → x = y := 80 | by { rw same_def, finish, }. 81 | 82 | lemma same_elim {A: Type} (x: A) : same x x := 83 | by { rw same_def, }. 84 | 85 | infix ` === `:50 := same. 86 | 87 | structure sig (A: Type) (p: A → Prop) := 88 | (witness: A) 89 | (pf: p witness). 90 | 91 | def t1_opt_goal : sig (Z[S.T] → Z[S.T1X × S.Id]) 92 | (λ opt, t1 S =≤= opt) := 93 | begin 94 | econstructor, 95 | intros t hpos, 96 | apply same_intro, 97 | simp [t1], 98 | rw filter_distinct_dedup, 99 | rw map_distinct_dedup, 100 | swap, { apply filter_pos, assumption, }, 101 | apply same_elim, 102 | end 103 | 104 | -- TODO: reduce this first 105 | def t1_opt := (t1_opt_goal S).witness. 106 | def t1_opt_ok : t1 S =≤= t1_opt S := (t1_opt_goal S).pf. 107 | 108 | def t2_opt_goal : sig (Z[S.R] → Z[S.Id × S.T2Y]) 109 | (λ opt, t2 S =≤= opt) := 110 | begin 111 | econstructor, 112 | intros t hpos, 113 | apply same_intro, 114 | simp [t2], 115 | rw filter_distinct_dedup, 116 | rw map_distinct_dedup, 117 | swap, { apply filter_pos, assumption, }, 118 | apply same_elim, 119 | end 120 | 121 | def v_opt_goal : sig (Z[S.T] → Z[S.R] → Z[S.T1X × S.T2Y]) 122 | (λ opt, V S =≤2= opt) := 123 | begin 124 | econstructor, intros i1 i2 hpos1 hpos2, 125 | apply same_intro, 126 | simp [V], 127 | rw (t1_opt_goal S).pf _ (by assumption), 128 | rw (t2_opt_goal S).pf _ (by assumption), 129 | simp [t1_opt_goal, t2_opt_goal], 130 | rw join_distinct_comm, rotate, 131 | { apply map_pos, apply filter_pos, assumption, }, 132 | { apply map_pos, apply filter_pos, assumption, }, 133 | rw map_distinct_dedup, rotate, 134 | { apply equi_join_pos; apply map_pos; apply filter_pos; assumption }, 135 | apply same_elim, 136 | end 137 | 138 | /- The optimized ℤ-set query from the paper -/ 139 | def Vopt (t1: Z[S.T]) (t2: Z[S.R]) := 140 | distinct $ zset.map (πxy S) 141 | (equi_join prod.snd prod.fst 142 | (zset.map schema.π1 (filter schema.σT t1)) 143 | (zset.map schema.π2 (filter schema.σR t2))). 144 | 145 | -- the simplifications above produce exactly what's in the paper 146 | lemma v_opt_ok : V S =≤2= Vopt S := 147 | (v_opt_goal S).pf. 148 | 149 | lemma v_lifted : ↑²(Vopt S) = 150 | λ t1 t2, ↑↑distinct (↑↑(zset.map (πxy S)) (↑²(equi_join prod.snd prod.fst) 151 | (↑↑(zset.map schema.π1) (↑↑(filter schema.σT) t1)) 152 | (↑↑(zset.map schema.π2) (↑↑(filter schema.σR) t2)))) := 153 | begin 154 | refl, 155 | end 156 | 157 | /- This is the intermediate incremental circuit -/ 158 | def VΔ1 (t1: stream Z[S.T]) (t2: stream Z[S.R]) := 159 | (↑↑distinct)^Δ $ ↑↑(zset.map (πxy S)) $ ↑²(equi_join prod.snd prod.fst)^Δ2 160 | (↑↑(zset.map schema.π1) (↑↑(filter schema.σT) t1)) 161 | (↑↑(zset.map schema.π2) (↑↑(filter schema.σR) t2)). 162 | 163 | lemma VΔ1_ok : 164 | ↑²(Vopt S)^Δ2 = VΔ1 S := 165 | begin 166 | funext t1 t2, 167 | -- hide the right-hand side 168 | transitivity, 169 | { apply same_intro, 170 | rw v_lifted, dsimp, 171 | dsimp only [incremental2], 172 | repeat { rw D_push2 <|> rw D_push }, simp, 173 | -- TODO: why does this have to be done explicitly? 174 | rw (map_incremental (πxy S)), 175 | rw (map_incremental schema.π1), simp, 176 | rw (map_incremental schema.π2), simp, 177 | apply same_elim, }, 178 | { refl }, 179 | end 180 | 181 | def VΔ (t1: stream Z[S.T]) (t2: stream Z[S.R]) := 182 | distinct_incremental $ ↑↑(zset.map $ πxy S) $ times_incremental ↑²(equi_join prod.snd prod.fst) 183 | (↑↑(zset.map schema.π1) (↑↑(filter schema.σT) t1)) 184 | (↑↑(zset.map schema.π2) (↑↑(filter schema.σR) t2)). 185 | 186 | theorem VΔ_ok : 187 | ↑²(Vopt S)^Δ2 = VΔ S := 188 | begin 189 | rw VΔ1_ok, funext t1 t2, unfold VΔ1, 190 | rw distinct_incremental_ok, 191 | rw equi_join_incremental, 192 | refl, 193 | end 194 | -------------------------------------------------------------------------------- /src/relational_incremental.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .relational 5 | import .incremental 6 | 7 | open zset 8 | 9 | variables {A B C: Type}. 10 | variables [decidable_eq A] [decidable_eq B] [decidable_eq C]. 11 | 12 | def distinct_H_at (i d: Z[A]) : A → ℤ := 13 | λ x, if 0 < i x ∧ (i + d) x ≤ 0 14 | then -1 else 15 | if i x ≤ 0 ∧ 0 < (i + d) x 16 | then 1 else 0. 17 | 18 | def distinct_H (i d: Z[A]) : Z[A] := 19 | dfinsupp.mk (i.support ∪ d.support) 20 | (λ x, distinct_H_at i d x). 21 | 22 | @[simp] 23 | lemma distinct_H_apply (i d: Z[A]) (x: A) : 24 | distinct_H i d x = distinct_H_at i d x := 25 | begin 26 | unfold distinct_H, simp, 27 | push_neg, 28 | intros h, cases h with h1 h2, 29 | simp [distinct_H_at], rw [h1, h2], 30 | rw [if_neg, if_neg]; simp, 31 | end 32 | 33 | def distinct_incremental : stream Z[A] → stream Z[A] := 34 | λ d, (↑² distinct_H) (z⁻¹ (I d)) d. 35 | 36 | theorem distinct_incremental_ok : 37 | (↑↑ distinct)^Δ = @distinct_incremental A _ := 38 | begin 39 | funext d, 40 | unfold incremental distinct_incremental, 41 | unfold D, 42 | conv_lhs { 43 | congr, { rw integral_unfold, skip}, { skip } 44 | }, 45 | rw<- lifting_time_invariant, swap, simp, 46 | repeat { rw<- integral_time_invariant }, 47 | ext t a, unfold lifting2, simp, 48 | generalize hi : I (z⁻¹ d) t = i, 49 | generalize hd : d t = d_t, 50 | clear hi hd d t, 51 | unfold distinct_H_at, 52 | simp, 53 | -- canonicalize the tests a little bit so splitting produces fewer cases 54 | rw (add_comm (i a) (d_t a)), 55 | repeat { rw <- ite_ite }, 56 | split_ifs; refl <|> { exfalso, omega }, 57 | end 58 | 59 | @[simp] 60 | lemma flatmap_incremental (f: A → Z[B]) : 61 | ↑↑(zset.flatmap f)^Δ = ↑↑(zset.flatmap f) := 62 | begin 63 | apply lti_incremental, 64 | apply lifting_lti, 65 | apply flatmap_linear, 66 | end 67 | 68 | @[simp] 69 | lemma map_incremental (f: A → B) : 70 | ↑↑(zset.map f)^Δ = ↑↑(zset.map f) := 71 | flatmap_incremental _. 72 | 73 | @[simp] 74 | lemma lifting_map_incremental {A B} [decidable_eq A] [decidable_eq B] (f: A → B) : 75 | ↑↑(↑↑(zset.map f))^Δ = ↑↑(↑↑(zset.map f)) := 76 | begin 77 | rw lti_incremental, 78 | apply lifting_lti, 79 | intros x y, rw lifting_linear, apply map_linear, 80 | end 81 | 82 | 83 | @[simp] 84 | lemma map_incremental_unfolded (f: A → B) (s: stream Z[A]) : 85 | D (↑↑(zset.map f) (I s)) = ↑↑(zset.map f) s := 86 | begin 87 | conv_rhs { 88 | rw<- map_incremental, 89 | }, 90 | rw incremental_unfold, 91 | end 92 | 93 | theorem equi_join_incremental (π1: A → C) (π2: B → C) : 94 | ↑²(equi_join π1 π2)^Δ2 = 95 | times_incremental ↑²(equi_join π1 π2) := 96 | begin 97 | rw (bilinear_incremental (↑²(equi_join π1 π2))), 98 | { rw lifting2_time_invariant, 99 | refl, }, 100 | { apply lifting_bilinear, 101 | apply equi_join_bilinear, 102 | }, 103 | end 104 | 105 | @[simp] 106 | lemma filter_incremental (p: A → Prop) [decidable_pred p] : 107 | ↑↑(filter p)^Δ = ↑↑(filter p) := 108 | begin 109 | apply lti_incremental, 110 | apply lifting_lti, 111 | apply filter_linear, 112 | end 113 | -------------------------------------------------------------------------------- /src/stream.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import tactic.omega.main 5 | import tactic.linarith 6 | import tactic.split_ifs 7 | 8 | /-! 9 | 10 | # Streams 11 | 12 | Definition of streams and some basic properties. We don't use mathlib streams 13 | because we hardly need any definitions from it. 14 | 15 | A stream over a type `a` is a `ℕ → a`. 16 | 17 | Defines agree_upto n s s', usually written with the notation s ==n== s', which 18 | says that s and s' agree on all indices in 0..n (inclusive). 19 | 20 | -/ 21 | 22 | universes u v. 23 | 24 | /-- A stream is an infinite sequence of elements from `a`. 25 | 26 | The indices usually use the metavariable `t`, meant to represent (a discrete 27 | notion of) time. 28 | -/ 29 | def stream (a: Type u) : Type u := ℕ → a. 30 | 31 | variable {a : Type u}. 32 | 33 | /-- s₁ ==n== s₂ says that streams s₁ and s₂ are equal up to (and including) time 34 | `n`. -/ 35 | def agree_upto (n: ℕ) (s₁ s₂: stream a) := ∀ t ≤ n, s₁ t = s₂ t. 36 | 37 | notation s ` ==` n `== ` s':35 := agree_upto n s s'. 38 | 39 | instance stream_po [partial_order a] : partial_order (stream a) := 40 | by { unfold stream, apply_instance }. 41 | 42 | @[ext] 43 | lemma stream_le_ext [partial_order a] (s1 s2: stream a) : 44 | s1 ≤ s2 = (∀ t, s1 t ≤ s2 t) := rfl. 45 | 46 | instance stream_zero [has_zero a] : has_zero (stream a) := ⟨λ (_: ℕ), 0⟩. 47 | 48 | @[refl] 49 | lemma agree_refl (n: ℕ) : ∀ (s: stream a), s ==n== s := 50 | begin 51 | unfold agree_upto, 52 | intros s i _, 53 | refl, 54 | end 55 | 56 | @[symm] 57 | lemma agree_symm (n: ℕ) : ∀ (s1 s2: stream a), s1 ==n== s2 → s2 ==n== s1 := 58 | begin 59 | unfold agree_upto, 60 | intros s1 s2 h12 i hle, 61 | rw [h12]; assumption, 62 | end 63 | 64 | @[trans] 65 | lemma agree_trans {n: ℕ} : ∀ (s1 s2 s3: stream a), s1 ==n== s2 → s2 ==n== s3 → s1 ==n== s3 := 66 | begin 67 | unfold agree_upto, 68 | intros s1 s2 s3 h12 h23 i hle, 69 | rw [h12, h23]; assumption, 70 | end 71 | 72 | -- TODO: these don't seem to do anything (don't help with rewriting) 73 | instance agree_upto_refl (n: ℕ) : is_refl (stream a) (agree_upto n) := ⟨agree_refl n⟩. 74 | instance agree_upto_symm (n: ℕ) : is_symm (stream a) (agree_upto n) := ⟨agree_symm n⟩. 75 | instance agree_upto_trans (n: ℕ) : is_trans (stream a) (agree_upto n) := ⟨agree_trans⟩. 76 | instance agree_upto_preorder (n: ℕ) : is_preorder (stream a) (agree_upto n) := ⟨⟩. 77 | instance agree_upto_equiv (n: ℕ) : is_equiv (stream a) (agree_upto n) := ⟨⟩. 78 | 79 | theorem agree_everywhere_eq (s s': stream a) : 80 | s = s' ↔ (∀ n, s ==n== s') := 81 | begin 82 | split, 83 | { intros h n, 84 | rw h, }, 85 | { intros h, 86 | funext n, 87 | apply (h n), omega, 88 | } 89 | end 90 | 91 | lemma agree_upto_weaken {s s': stream a} (n n': ℕ) : 92 | s ==n== s' → 93 | n' ≤ n → 94 | s ==n'== s' := 95 | begin 96 | intros heq hle, 97 | intros i hle_i, 98 | apply heq, omega, 99 | end 100 | 101 | lemma agree_upto_weaken1 {s s': stream a} (n: ℕ) : 102 | s ==n.succ== s' → 103 | s ==n== s' := 104 | begin 105 | intros heq, 106 | apply (agree_upto_weaken n.succ), assumption, omega, 107 | end 108 | 109 | lemma agree_upto_0 (s s': stream a) : 110 | s ==0== s' ↔ s 0 = s' 0 := 111 | begin 112 | unfold agree_upto, 113 | split, 114 | { intros hagree, 115 | apply (hagree 0), 116 | omega, }, 117 | { intros h0 t hle, 118 | have h: (t = 0) := by omega, 119 | cc, } 120 | end 121 | 122 | lemma agree_upto_extend (n: nat) (s s': stream a) : 123 | s ==n== s' → s n.succ = s' n.succ → s ==n.succ== s' := 124 | begin 125 | intros hagree heq, 126 | intros i hle, 127 | have h: (i ≤ n ∨ i = n.succ) := by omega, 128 | cases h, 129 | { apply hagree, assumption, }, 130 | { subst i, assumption, } 131 | end 132 | 133 | -- We don't use this theory because everything is based on [agree_upto], but 134 | -- formalize a little bit from the paper. 135 | namespace cutting. 136 | 137 | variables [has_zero a]. 138 | 139 | /-- Construct a stream that matches `s` up to time `t` and is 0 afterward. -/ 140 | def cut (s: stream a) (t: ℕ) : stream a := 141 | λ i, if (i < t) then s i else 0. 142 | 143 | lemma cut_at_0 (s: stream a) : cut s 0 = 0 := 144 | begin 145 | ext n, 146 | unfold cut, rw if_neg, simp, 147 | omega, 148 | end 149 | 150 | lemma cut_0 : cut (0 : stream a) = 0 := 151 | begin 152 | ext n, 153 | unfold cut, split_ifs; refl, 154 | end 155 | 156 | theorem cut_cut (s: stream a) (t1 t2: ℕ) : 157 | cut (cut s t1) t2 = cut s (min t1 t2) := 158 | begin 159 | funext i, simp [cut], 160 | split_ifs; try { simp }, 161 | tauto, 162 | { exfalso, linarith, }, 163 | { exfalso, linarith, }, 164 | end 165 | 166 | theorem cut_comm (s: stream a) (t1 t2: ℕ) : 167 | cut (cut s t1) t2 = cut (cut s t2) t1 := 168 | begin 169 | rw [cut_cut, cut_cut], 170 | rw min_comm, 171 | end 172 | 173 | theorem cut_idem (s: stream a) (t: ℕ) : 174 | cut (cut s t) t = cut s t := 175 | begin 176 | rw cut_cut, simp, 177 | end 178 | 179 | /-- Relate [agree_upto] to equality on [cut]. -/ 180 | theorem agree_upto_cut (s1 s2: stream a) (n: ℕ) : 181 | s1 ==n== s2 ↔ cut s1 n.succ = cut s2 n.succ := 182 | begin 183 | split, 184 | { intros heq, 185 | funext t, simp [cut], 186 | split_ifs; try { refl }, 187 | apply heq, omega, }, 188 | { intros heq, 189 | intros t hle, simp [cut] at heq, 190 | have h := congr_fun heq t, simp at h, 191 | split_ifs at *, 192 | { assumption, }, 193 | { exfalso, apply h_1, omega, }, 194 | }, 195 | end 196 | 197 | lemma cut_agree_succ (s1 s2: stream a) (t: ℕ) : 198 | cut s1 t = cut s2 t → 199 | s1 t = s2 t → 200 | cut s1 t.succ = cut s2 t.succ := 201 | begin 202 | cases t, 203 | { intros _hcut heq, 204 | ext n, 205 | unfold cut, split_ifs, swap, refl, 206 | have heq : n = 0 := by omega, 207 | subst n, assumption, 208 | }, 209 | repeat { rw<- agree_upto_cut }, 210 | apply agree_upto_extend, 211 | end 212 | 213 | theorem agree_with_cut (s: stream a) (n: ℕ) : 214 | s ==n== cut s n.succ := 215 | begin 216 | rw [agree_upto_cut, cut_idem], 217 | end 218 | 219 | end cutting. 220 | 221 | -- #lint only doc_blame simp_nf 222 | -------------------------------------------------------------------------------- /src/stream_elim.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import .stream 5 | import .linear 6 | import .incremental 7 | import tactic.abel 8 | import init.classical 9 | 10 | section zero. 11 | variables {a: Type} [has_zero a]. 12 | 13 | def δ0 (x:a) : stream a := 14 | λ t, if t = 0 then x else 0. 15 | 16 | @[simp] 17 | lemma δ0_apply (x: a) (n: ℕ) : 18 | δ0 x n = if n = 0 then x else 0 19 | := rfl. 20 | 21 | @[simp] 22 | lemma δ0_0 : δ0 (0: a) = 0 := 23 | begin 24 | ext n, simp, 25 | end 26 | 27 | def zero_after (s: stream a) (n: ℕ) := ∀ t ≥ n, s t = 0. 28 | 29 | lemma zero_after_ge {s: stream a} {n1: ℕ} (pf1: zero_after s n1) : 30 | ∀ n2 ≥ n1, zero_after s n2 := 31 | begin 32 | intros n2 hge, 33 | intros m hge2, 34 | apply pf1, omega, 35 | end 36 | 37 | def δ0_zero_after (x:a) : zero_after (δ0 x) 1 := 38 | begin 39 | intros t hge, unfold δ0, rw if_neg, omega 40 | end 41 | end zero. 42 | 43 | variables {a: Type} [add_comm_group a]. 44 | 45 | def drop (k: ℕ) (s: stream a) : stream a := 46 | λ n, s (k + n). 47 | 48 | lemma sum_vals_split (s: stream a) (n k: ℕ) : 49 | sum_vals s (n + k) = sum_vals s n + sum_vals (drop n s) k := 50 | begin 51 | revert n, 52 | induction k; introv, 53 | { simp, }, 54 | { change (n + k_n.succ) with (n + k_n).succ, 55 | unfold sum_vals, 56 | rw k_ih, 57 | abel, } 58 | end 59 | 60 | lemma sum_vals_zero_ge (s: stream a) (n m:ℕ) (hz: zero_after s n) (hge: m ≥ n) : 61 | sum_vals s n = sum_vals s m := 62 | begin 63 | have h := sum_vals_split s n (m - n), 64 | have hdiff : m = n + (m - n) := by omega, 65 | rw [hdiff, h], 66 | rw sum_vals_zero (drop _ _), abel, 67 | intros t, unfold drop, apply hz, omega, 68 | end 69 | 70 | lemma sum_vals_eq_helper (s: stream a) (n1 n2: ℕ) (hz1: zero_after s n1) (hz2: zero_after s n2) : 71 | n1 ≤ n2 → 72 | sum_vals s n1 = sum_vals s n2 := 73 | begin 74 | intros hle, 75 | rw sum_vals_zero_ge, 76 | assumption, 77 | omega, 78 | end 79 | 80 | lemma sum_vals_eq (s: stream a) (n1 n2: ℕ) (hz1: zero_after s n1) (hz2: zero_after s n2) : 81 | sum_vals s n1 = sum_vals s n2 := 82 | begin 83 | by_cases (n1 ≤ n2), 84 | { rw sum_vals_eq_helper; assumption, }, 85 | { symmetry, rw sum_vals_eq_helper; try { assumption }, omega, }, 86 | end 87 | 88 | noncomputable def stream_elim (s: stream a) : a := 89 | match classical.prop_decidable (∃ n, zero_after s n) with 90 | | decidable.is_true h := sum_vals s (classical.some h) 91 | | decidable.is_false _ := 0 92 | end. 93 | 94 | lemma stream_elim_zero_after (s: stream a) (n:ℕ) (pf:zero_after s n) : 95 | stream_elim s = sum_vals s n := 96 | begin 97 | unfold stream_elim, 98 | cases (classical.prop_decidable _), 99 | { exfalso, 100 | apply h, use n, assumption, 101 | }, 102 | { unfold stream_elim._match_1, 103 | apply sum_vals_eq, 104 | { apply classical.some_spec h, }, 105 | { assumption, }, 106 | } 107 | end 108 | 109 | notation `∫ ` := stream_elim. 110 | 111 | @[simp] 112 | lemma stream_elim_0 : ∫ (0: stream a) = 0 := 113 | begin 114 | rw stream_elim_zero_after _ 0, 115 | { simp, }, 116 | { intros t heq, simp, }, 117 | end 118 | 119 | theorem stream_elim_delta (x: a) : 120 | ∫ (δ0 x) = x := 121 | begin 122 | rw stream_elim_zero_after _ 1, 123 | simp, 124 | apply δ0_zero_after, 125 | end 126 | 127 | theorem delta_linear : 128 | ∀ (x y: a), δ0 (x + y) = δ0 x + δ0 y := 129 | begin 130 | introv, 131 | ext t, simp, 132 | split_ifs; simp, 133 | end 134 | 135 | @[simp] 136 | lemma delta_incremental : 137 | ↑↑(@δ0 a _)^Δ = ↑↑δ0 := 138 | begin 139 | apply lti_incremental, 140 | apply lifting_lti, 141 | apply delta_linear, 142 | end 143 | 144 | lemma sum_vals_linear (s1 s2: stream a) (n: ℕ) : 145 | sum_vals (s1 + s2) n = sum_vals s1 n + sum_vals s2 n := 146 | begin 147 | induction n; simp, 148 | rw n_ih, abel, 149 | end 150 | 151 | lemma sum_zero_after {s1 s2: stream a} 152 | {n1: ℕ} (pf1: zero_after s1 n1) {n2: ℕ} (pf2: zero_after s2 n2) : 153 | zero_after (s1 + s2) (if n1 ≥ n2 then n1 else n2) := 154 | begin 155 | split_ifs, 156 | { intros m hge, simp, 157 | rw pf1, swap, omega, 158 | rw pf2, swap, omega, 159 | simp, 160 | }, 161 | { intros m hge, simp, 162 | rw pf1, swap, omega, 163 | rw pf2, swap, omega, 164 | simp, 165 | }, 166 | end 167 | 168 | lemma sub_zero_after {s1 s2: stream a} 169 | {n1: ℕ} (pf1: zero_after s1 n1) {n2: ℕ} (pf2: zero_after s2 n2) : 170 | zero_after (s1 - s2) (if n1 ≥ n2 then n1 else n2) := 171 | begin 172 | split_ifs, 173 | { intros m hge, simp, 174 | rw pf1, swap, omega, 175 | rw pf2, swap, omega, 176 | simp, 177 | }, 178 | { intros m hge, simp, 179 | rw pf1, swap, omega, 180 | rw pf2, swap, omega, 181 | simp, 182 | }, 183 | end 184 | 185 | theorem stream_elim_linear (s1 s2: stream a) 186 | (n1: ℕ) (pf1: zero_after s1 n1) (n2: ℕ) (pf2: zero_after s2 n2) : 187 | ∫ (s1 + s2) = ∫ s1 + ∫ s2 := 188 | begin 189 | rw (stream_elim_zero_after s1 _ pf1), 190 | rw (stream_elim_zero_after s2 _ pf2), 191 | rw (stream_elim_zero_after _ _ (sum_zero_after pf1 pf2)), 192 | simp, 193 | 194 | generalize hmax : (if n2 ≤ n1 then n1 else n2) = max, 195 | 196 | have hmax1 : max ≥ n1 := by { subst hmax, split_ifs; omega }, 197 | have hmax2 : max ≥ n2 := by { subst hmax, split_ifs; omega }, 198 | rw (sum_vals_zero_ge s1 _ max pf1), swap, omega, 199 | rw (sum_vals_zero_ge s2 _ max pf2), swap, omega, 200 | 201 | apply sum_vals_linear, 202 | end 203 | 204 | lemma stream_elim_time_invariant : 205 | time_invariant ↑↑(@stream_elim a _) := 206 | begin 207 | apply lifting_time_invariant, simp, 208 | end 209 | 210 | lemma integral_zero (s: stream a) (n: ℕ) : 211 | zero_after (I s) n → zero_after s n.succ := 212 | begin 213 | intros hz, 214 | intros m hge, 215 | have hm := hz m (by omega), 216 | rw integral_unfold at hm, simp at hm, 217 | have hm' : z⁻¹ (I s) m = I s (m - 1) := by { 218 | unfold delay, rw if_neg, omega, 219 | }, 220 | rw hm' at hm, 221 | rw (hz (m - 1)) at hm, 222 | abel at hm, assumption, 223 | omega, 224 | end 225 | 226 | lemma integral_nested_unfold (s: stream (stream a)) (t: ℕ) : 227 | 0 < t → 228 | I s t = s t + I s (t-1) := 229 | begin 230 | intros hnz, 231 | conv_lhs { 232 | rw integral_unfold, simp, 233 | }, 234 | simp, 235 | rw delay_sub_1, omega, 236 | end 237 | 238 | lemma integral_zero' (s: stream (stream a)) (t n: ℕ) : 239 | zero_after (I s t) n → 240 | zero_after (I s (t-1)) n → 241 | zero_after (s t) n.succ := 242 | begin 243 | by_cases (t = 0), 244 | { subst t, simp, intros hz _hz', 245 | apply (zero_after_ge hz), omega, }, 246 | intros hz hz', 247 | intros m hge, 248 | transitivity (D (I s) t m), 249 | { simp, }, 250 | unfold D, simp, 251 | rw (hz m), swap, omega, 252 | rw delay_sub_1, swap, omega, 253 | rw (hz' m), swap, omega, 254 | abel, 255 | end 256 | 257 | -- stream_elim_incremental is not provable 258 | example {a: Type} [add_comm_group a] : true := 259 | begin 260 | have h : ↑↑(@stream_elim a _)^Δ = ↑↑stream_elim := by { 261 | unfold incremental, 262 | funext s, 263 | unfold D, 264 | funext t, simp, 265 | by_cases ht : (t = 0), 266 | { subst t, simp, }, 267 | rw delay_sub_1, swap, omega, simp, 268 | -- this is not true: ∫ (I s t) might converge while ∫ (I s (t-1)) diverges and 269 | -- ∫ (s t) converges for example. What does seem true is that if both 270 | -- integrals on the left hand side converge, then the right-hand side 271 | -- converges and the equality holds. 272 | by_cases (∃ n, zero_after (I s t) n), 273 | { cases h with n hz, 274 | sorry, 275 | }, 276 | -- this doesn't seem true 277 | sorry, 278 | }, 279 | trivial, 280 | end 281 | 282 | lemma integral_delta (x:a) : 283 | I (δ0 x) = λ _n, x := 284 | begin 285 | ext t, 286 | induction t, 287 | { simp, }, 288 | { rw integral_unfold, simp, assumption, } 289 | end 290 | 291 | @[simp] 292 | lemma integral_delta_apply (x:a) (n:ℕ) : 293 | I (δ0 x) n = x := 294 | begin 295 | rw integral_delta, 296 | end 297 | 298 | variables {b: Type} [add_comm_group b]. 299 | 300 | lemma nested_zpp (Q: operator a b) : 301 | time_invariant Q → ∫ (Q (δ0 0)) = 0 := 302 | begin 303 | intros hti, 304 | rw δ0_0, 305 | rw time_invariant_zpp _ hti, 306 | rw stream_elim_0, 307 | end 308 | -------------------------------------------------------------------------------- /src/zset.lean: -------------------------------------------------------------------------------- 1 | -- Copyright 2022-2023 VMware, Inc. 2 | -- SPDX-License-Identifier: BSD-2-Clause 3 | 4 | import init.algebra.order 5 | 6 | import algebra.big_operators.basic 7 | import data.dfinsupp.basic 8 | import data.finset 9 | import data.multiset.sort 10 | import data.prod.lex 11 | 12 | import tactic.omega 13 | import tactic.linarith 14 | 15 | /-! 16 | 17 | # Z-sets 18 | 19 | The type `Z[A]` is called a Z-set over elements of type A, which we can think of 20 | as a collection of rows of type A. However, Z-sets are more general in that they 21 | allow *integer multiplicities*; multiplicities greater than 1 correspond to 22 | duplicates, while negative multiplicities correspond to retractions or 23 | deletions. Hence `Z[A]` can be used not only to represent a table with rows of 24 | type A but also changes to such a table. 25 | 26 | Formally `Z[A]` is modeled as a function `A → ℤ` with finite support; that is, 27 | only finitely many elements have non-zero multiplicity. This is necessary to 28 | support well-defined summations over Z-sets. 29 | 30 | `Z[A]` has a group structure that is essentially inherited from ℤ (the 31 | operations are all pointwise). Similarly, it has a partial ordering where `m1 ≤ 32 | m2 := ∀ x, m1 x ≤ m2 x`. 33 | 34 | Note that `Z[A]` is isomorphic to the free abelian group over `A`, so it is in a 35 | formal sense the minimum needed to give `A` a group structure. 36 | 37 | -/ 38 | 39 | variables {A B C: Type}. 40 | variables [decidable_eq A] [decidable_eq B] [decidable_eq C]. 41 | 42 | /-- 43 | A Z-set is a function from A to ℤ with finite support. 44 | 45 | This is implemented using dfinsupp; we use dfinsupp rather than finsupp since 46 | its implementation is computable. 47 | -/ 48 | def zset (A: Type) := Π₀ (_:A), ℤ. 49 | 50 | notation `Z[` T `]` := zset T. 51 | 52 | namespace zset. 53 | 54 | instance zset_group : add_comm_group Z[A] := 55 | by { unfold zset, apply (@dfinsupp.add_comm_group A (λ _, ℤ) _), }. 56 | 57 | instance zset_fun_like : fun_like Z[A] A (λ (_:A), ℤ) := 58 | by { unfold zset, apply_instance }. 59 | 60 | -- this next few definitions do some work to implement printing of Z-sets, which 61 | -- is unused so far. 62 | 63 | def graph (m: Z[A]) : multiset (A × ℤ) := 64 | m.support.val.map (λ a, (a, m a)). 65 | 66 | def graph_list [linear_order A] (m: Z[A]) : list (A ×ₗ ℤ) := 67 | multiset.sort (≤) (graph m). 68 | 69 | def elements [linear_order A] (m: Z[A]) : list A := 70 | multiset.sort (≤) (m.sum (λ a _, {a})). 71 | 72 | @[protected, instance] 73 | meta def has_to_format [has_to_format A] [linear_order A] : has_to_format Z[A] := 74 | {to_format := λ m, (graph_list m).to_format}. 75 | 76 | @[protected] 77 | instance has_to_string [has_to_string A] [linear_order A] : has_to_string Z[A] := 78 | {to_string := λ m, (list.map (λ (xz: A × ℤ), xz) (graph_list m)).to_string}. 79 | 80 | @[simp] 81 | lemma add_apply (m1 m2: Z[A]) (a: A) : (m1 + m2) a = m1 a + m2 a := rfl. 82 | 83 | @[simp] 84 | lemma sub_apply (m1 m2: Z[A]) (a: A) : (m1 - m2) a = m1 a - m2 a := rfl. 85 | 86 | @[simp] 87 | lemma neg_apply (m: Z[A]) (a: A) : (-m) a = -(m a) := rfl. 88 | 89 | lemma add_support (m1 m2: Z[A]) : 90 | (m1 + m2).support = 91 | (m1.support ∪ m2.support).filter (λ a, m1 a + m2 a ≠ 0) := 92 | begin 93 | ext a, simp, 94 | contrapose!, 95 | intros h, cases h with h1 h2, rw [h1, h2], simp, 96 | end 97 | 98 | -- now we do some work so that `{a, b, c}` can be used to construct a Z-set 99 | 100 | protected def empty : Z[A] := dfinsupp.mk ∅ (λ _, 0). 101 | instance : has_emptyc Z[A] := {emptyc := zset.empty}. 102 | 103 | protected def single (a:A) : Z[A] := 104 | dfinsupp.single a 1. 105 | instance : has_singleton A Z[A] := {singleton := zset.single}. 106 | 107 | protected def insert (a:A) (m: Z[A]) : Z[A] := m + {a}. 108 | instance : has_insert A Z[A] := {insert := zset.insert}. 109 | 110 | @[simp] 111 | lemma emptyc_apply (a:A) : (∅ : Z[A]) a = 0 := rfl. 112 | 113 | @[simp] 114 | lemma single_apply (a:A) (a': A) : 115 | ({a} : Z[A]) a' = if a = a' then 1 else 0 := 116 | begin 117 | change ({a} : Z[A]) with (zset.single a), 118 | unfold zset.single, simp, 119 | end 120 | 121 | @[simp] 122 | lemma insert_apply (a: A) (m: Z[A]) (a': A) : 123 | has_insert.insert a m a' = m a' + if a = a' then 1 else 0 := 124 | begin 125 | change (has_insert.insert a m) with (zset.insert a m), 126 | unfold zset.insert, simp, 127 | end 128 | 129 | instance : is_lawful_singleton A Z[A] := 130 | begin 131 | split, 132 | intros x, ext a, simp, 133 | end 134 | 135 | #eval graph ({"alice", "bob"} : Z[string]). 136 | #eval graph ({"alice"} - {"bob"} : Z[string]). 137 | 138 | -- TODO: data.dfinsupp.order does contain a partial_order, but it had some weird 139 | -- behavior 140 | @[protected] 141 | instance po : partial_order Z[A] := 142 | { le := λ m1 m2, ∀ a, m1 a ≤ m2 a, 143 | le_refl := by { intros m a, simp, }, 144 | le_trans := begin 145 | intros m1 m2 m3 h12 h23, intros a, 146 | apply le_trans, apply h12, apply h23, 147 | end, 148 | le_antisymm := begin 149 | intros m1 m2 hle1 hle2, 150 | ext a, 151 | apply le_antisymm, apply hle1, apply hle2, 152 | end, 153 | }. 154 | 155 | -- TODO: how do I define `ordered_add_comm_group Z[A]` by just extending the existing 156 | -- instances? 157 | 158 | @[ext] 159 | lemma zset_le_ext (m1 m2: Z[A]) : m1 ≤ m2 = (∀ a, m1 a ≤ m2 a) := rfl. 160 | 161 | instance zset_mem : has_mem A Z[A] := ⟨λ a m, a ∈ m.support⟩. 162 | lemma elem_eq (a: A) (m: zset A) : (a ∈ m) = (a ∈ m.support) := rfl. 163 | 164 | protected def from_set (s: finset A) : Z[A] := dfinsupp.mk s (λ a, 1). 165 | 166 | @[simp] 167 | lemma from_set_0 : zset.from_set (∅ : finset A) = dfinsupp.mk ∅ (λ a, 1) 168 | := rfl. 169 | 170 | @[simp] 171 | lemma from_set_apply (s: finset A) (a: A) : 172 | zset.from_set s a = if (a ∈ s) then 1 else 0 173 | := rfl. 174 | 175 | @[simp] 176 | lemma from_set_support (s: finset A) : 177 | (zset.from_set s).support = s := by { ext a, simp }. 178 | 179 | protected def to_set (s: Z[A]) : finset A := s.support. 180 | 181 | @[simp] 182 | lemma elem_to_set (a: A) (m: Z[A]) : a ∈ m.to_set ↔ a ∈ m := by refl. 183 | 184 | @[simp] 185 | lemma elem_from_set (a: A) (s: finset A) : a ∈ zset.from_set s ↔ a ∈ s := 186 | begin 187 | rw elem_eq, simp, 188 | end 189 | 190 | lemma to_from_set (s: finset A) [∀ a, decidable (a ∈ s)] : 191 | (zset.from_set s).to_set = s := 192 | begin 193 | ext a, simp, 194 | end 195 | 196 | /- 197 | Unlike the paper, we use [is_bag] for the property on ℤ-sets, [fun_positive] 198 | for the property on functions, [positive] for streams, and [is_positive] for 199 | the property on operators. 200 | -/ 201 | def is_set (m: Z[A]) := ∀ a, a ∈ m → m a = 1. 202 | def is_bag (m: Z[A]) := 0 ≤ m. 203 | def fun_positive (f: Z[A] → Z[B]) := ∀ m, is_bag m → is_bag (f m). 204 | def fun_positive2 (f: Z[A] → Z[B] → Z[C]) := 205 | ∀ m1 m2, is_bag m1 → is_bag m2 → is_bag (f m1 m2). 206 | 207 | -- mp stands for multiplicity, the result of applying a zset to an element 208 | lemma elem_mp (m: Z[A]) (a: A) : a ∈ m ↔ m a ≠ 0 := 209 | by { rw elem_eq, simp }. 210 | lemma not_elem_mp (a: A) (m: Z[A]) : a ∉ m ↔ m a = 0 := 211 | by { rw elem_eq, simp }. 212 | 213 | lemma is_set_or (s: Z[A]) : 214 | is_set s ↔ ∀ a, s a = 0 ∨ s a = 1 := 215 | begin 216 | unfold is_set, 217 | split; intros h a, 218 | { rw<- not_elem_mp, 219 | by_cases (a ∈ s); tauto, }, 220 | { have h' := h a, 221 | rw elem_mp, tauto, } 222 | end 223 | 224 | @[simp] 225 | lemma is_set_0 : is_set (0: Z[A]) := 226 | begin 227 | rw is_set_or, tauto, 228 | end 229 | 230 | lemma set_is_bag (s: Z[A]) : 231 | is_set s -> is_bag s := 232 | begin 233 | intros hset a, 234 | cases ((is_set_or _).mp hset a) with h_a h_a; rw h_a; 235 | simp, 236 | end 237 | 238 | @[simp] 239 | lemma elem_single (a x:A) : 240 | x ∈ ({a} : Z[A]) ↔ a = x := 241 | begin 242 | rw elem_mp, simp, 243 | end 244 | 245 | @[simp] 246 | lemma support_single (a: A) : 247 | ({a} : Z[A]).support = {a} := 248 | begin 249 | ext x, simp, tauto, 250 | end 251 | 252 | def distinct (m: Z[A]) : Z[A] := 253 | dfinsupp.mk (m.support.filter (λ a, m a > 0)) (λ _, 1). 254 | 255 | @[simp] 256 | lemma distinct_apply (m: Z[A]) (a: A) : 257 | distinct m a = if m a > 0 then 1 else 0 := 258 | begin 259 | unfold distinct, simp, 260 | congr' 1, ext, simp, 261 | intros, linarith, 262 | end 263 | 264 | section sum_linear. 265 | 266 | namespace finset. 267 | lemma union_disjoint_l (s1 s2: finset A) : 268 | s1 ∪ s2 = s1.disj_union (s2 \ s1) finset.disjoint_sdiff := 269 | begin 270 | ext a, simp, 271 | end 272 | 273 | lemma filter_filter_comm (p q : A → Prop) [decidable_pred p] [decidable_pred q] (s: finset A) : 274 | finset.filter p (finset.filter q s) = finset.filter q (finset.filter p s) := 275 | begin 276 | repeat { rw finset.filter_filter }, 277 | congr' 1, finish, 278 | end 279 | end finset. 280 | 281 | lemma sum_union_zero_l {α: Type} [add_comm_monoid α] (f: A → α) (s s': finset A) : 282 | (∀ x, x ∈ s' → x ∉ s → f x = 0) → 283 | finset.sum (s ∪ s') f = 284 | finset.sum s f := 285 | begin 286 | intros hz, 287 | rw finset.union_disjoint_l, 288 | rw finset.sum_disj_union, 289 | repeat { rw finset.sum_ite <|> rw finset.sum_add_distrib }, 290 | simp, 291 | rw (@finset.sum_eq_zero _ _ _ _ (s' \ s)), simp, 292 | introv hel, simp at hel, apply hz; finish, 293 | end 294 | 295 | variables {G: Type} [add_comm_group G] (f: A → ℤ → G). 296 | 297 | theorem general_sum_linear (m1 m2: Z[A]) : 298 | (∀ a, f a 0 = 0) → 299 | (∀ a m1 m2, f a (m1 + m2) = f a m1 + f a m2) → 300 | (m1 + m2).support.sum (λ a, f a ((m1 + m2) a)) = 301 | m1.support.sum (λ a, f a (m1 a)) + 302 | m2.support.sum (λ a, f a (m2 a)) := 303 | begin 304 | intros hf0 hflin, 305 | rw add_support, 306 | simp only [ne.def], 307 | rw finset.sum_filter_of_ne, swap, 308 | { intros x, simp, intros h1, contrapose!, 309 | intro hz, rw hz, 310 | apply hf0, 311 | }, 312 | conv_lhs { 313 | congr, skip, 314 | funext, 315 | simp, rw hflin, skip, 316 | }, 317 | rw finset.sum_add_distrib, 318 | congr' 1, 319 | { rw sum_union_zero_l, simp, 320 | introv hnz hz, 321 | rw hz, 322 | apply hf0, }, 323 | { rw finset.union_comm, 324 | rw sum_union_zero_l, simp, 325 | introv hnz hz, 326 | rw hz, 327 | apply hf0, } 328 | end 329 | 330 | end sum_linear. 331 | 332 | -- map is sufficiently complex and specific to the zset representation that we 333 | -- define it here and prove some basic properties, from which it is much easier 334 | -- to reason about it as a relational operator 335 | section flatmap. 336 | 337 | variables (f: A → Z[B]). 338 | 339 | -- the core of flatmap (without the finite support of a real `Z[B]`) 340 | def flatmap_at (m: Z[A]) : B → ℤ := 341 | λ b, (m.support.sum (λ a, f a b * m a)). 342 | 343 | def flatmap (m: Z[A]) : Z[B] := 344 | dfinsupp.mk (m.support.bUnion (λ a, (f a).support)) (λ b, flatmap_at f m b). 345 | 346 | -- This is the function used in the definition of flatmap; the theorem shows that 347 | -- the support chosen is correct; that is, it is an over-approximation (the 348 | -- actual support excludes elements where the sum cancels out and 349 | -- reaches 0) 350 | lemma flatmap_apply (m: Z[A]) : 351 | ∀ b, m.flatmap f b = flatmap_at f m b := 352 | begin 353 | intros, 354 | unfold zset.flatmap flatmap_at, 355 | simp, 356 | intros h, 357 | rw finset.sum_eq_zero, 358 | intros x h'; simp at h', 359 | rw h, simp, assumption, 360 | end 361 | 362 | theorem flatmap_0 : zset.flatmap f 0 = 0 := rfl. 363 | 364 | private lemma ite_cases {c: Prop} [decidable c] (x z: A) (p: A → Prop) : 365 | p z → 366 | p x → 367 | p (ite c x z) := 368 | begin 369 | intros, split_ifs; finish, 370 | end 371 | 372 | theorem flatmap_linear (m1 m2: Z[A]) : 373 | zset.flatmap f (m1 + m2) = zset.flatmap f m1 + zset.flatmap f m2 := 374 | begin 375 | ext b, simp, 376 | repeat { rw flatmap_apply }, unfold flatmap_at, 377 | apply general_sum_linear (λ a m, f a b * m), 378 | { intros, simp, }, 379 | { intros, simp, rw mul_add, }, 380 | end 381 | 382 | lemma flatmap_from_set_card (s: finset A) (b:B) : 383 | (∀ a, (f a).is_set) → 384 | zset.flatmap_at f (zset.from_set s) b = 385 | finset.card (s.filter (λ (x : A), b ∈ f x)) := 386 | begin 387 | intros hset, 388 | unfold flatmap_at, simp, 389 | have hsum_1 : s.sum (λ a, f a b) = s.sum (λ a, if b ∈ f a then 1 else 0) := by { 390 | apply finset.sum_congr, refl, 391 | intros, split_ifs, 392 | { apply hset, assumption, }, 393 | { rw not_elem_mp at h, assumption, }, 394 | }, 395 | rw hsum_1, simp, 396 | end 397 | 398 | lemma map_from_set_card (f: A → B) (s: finset A) (b:B) : 399 | zset.flatmap_at (λ a, {f a}) (zset.from_set s) b = 400 | finset.card (s.filter (λ (x : A), f x = b)) := 401 | begin 402 | rw flatmap_from_set_card, 403 | { simp }, 404 | intros a, 405 | unfold is_set, simp, 406 | end 407 | end flatmap. 408 | 409 | section map. 410 | 411 | variables (f: A → B). 412 | 413 | protected def map (m: Z[A]) : Z[B] := flatmap (λ a, {f a}) m. 414 | 415 | lemma flatmap_map_at (m: Z[A]) (b: B) : 416 | flatmap_at (λ a, {f a}) m b = m.support.sum (λ a, if f a = b then m a else 0) := 417 | begin 418 | unfold flatmap_at, simp, 419 | end 420 | 421 | lemma map_apply (m: Z[A]) (b: B) : 422 | zset.map f m b = m.support.sum (λ a, if f a = b then m a else 0) := 423 | begin 424 | unfold zset.map, rw flatmap_apply, 425 | rw flatmap_map_at, 426 | end 427 | 428 | theorem map_linear (f: A → B) (m1 m2: Z[A]) : 429 | zset.map f (m1 + m2) = zset.map f m1 + zset.map f m2 := 430 | begin 431 | apply flatmap_linear, 432 | end 433 | 434 | lemma map_is_card (s: finset A) : 435 | ∀ b, zset.map f (zset.from_set s) b = 436 | (s.val.map f).count b := 437 | begin 438 | intros, unfold zset.map, 439 | rw flatmap_apply, 440 | rw flatmap_from_set_card, 441 | unfold multiset.count, 442 | rw multiset.countp_map, 443 | simp, 444 | rw finset.card_def, 445 | simp, 446 | congr' 1, 447 | apply multiset.filter_congr, 448 | { finish, }, 449 | { intros a, unfold is_set, simp, }, 450 | end 451 | 452 | namespace finset. 453 | lemma sum_nonneg (s: finset A) (f: A → ℤ) : 454 | (∀ x, x ∈ s → 0 ≤ f x) → 455 | 0 ≤ s.sum f := 456 | begin 457 | intros hnn, 458 | apply finset.sum_induction, 459 | { intros, linarith, }, 460 | { linarith, }, 461 | { assumption, }, 462 | end 463 | 464 | lemma sum_pos (s: finset A) (f: A → ℤ) : 465 | (∃ a, a ∈ s ∧ 0 < f a) → 466 | (∀ x, x ∈ s → 0 ≤ f x) → 467 | 0 < s.sum f := 468 | begin 469 | intros hpos hnn, 470 | cases hpos with a hpos, cases hpos with hel hpos, 471 | rw<- (finset.add_sum_erase s _ hel), 472 | suffices h : 0 ≤ (s.erase a).sum f, 473 | linarith, 474 | apply sum_nonneg, 475 | safe, 476 | end 477 | end finset. 478 | 479 | lemma map_at_nonneg (f: A → B) (m: Z[A]) (b: B) : 480 | is_bag m → 481 | 0 ≤ flatmap_at (λ a, {f a}) m b := 482 | begin 483 | intros hpos, 484 | unfold flatmap_at, 485 | apply finset.sum_nonneg, 486 | intros x, simp, intros, 487 | apply ite_cases, omega, 488 | apply hpos, 489 | end 490 | 491 | lemma map_at_pos (f: A → B) (m: Z[A]) (b: B) : 492 | is_bag m → 493 | (0 < flatmap_at (λ a, {f a}) m b ↔ ∃ a, a ∈ m ∧ f a = b) := 494 | begin 495 | intros hpos, 496 | split, 497 | { unfold flatmap_at, 498 | intros hmap, 499 | by_contra, 500 | rw finset.sum_eq_zero at hmap, 501 | { linarith, }, 502 | { intros x, simp, intros h1 h2, 503 | push_neg at h, 504 | rw<- not_elem_mp at h1, 505 | tauto, 506 | } 507 | }, 508 | { intros hex, 509 | unfold flatmap_at, 510 | apply finset.sum_pos, 511 | { cases hex with a h, cases h with hel hf, 512 | use a, simp, 513 | rw (if_pos hf), 514 | have ha := hpos a, simp at ha, 515 | rw elem_mp at hel, simp at hel, 516 | split, 517 | { tauto }, 518 | { omega, } 519 | }, 520 | { simp, intros, 521 | apply ite_cases, omega, 522 | apply hpos, }, 523 | } 524 | end 525 | 526 | end map. 527 | 528 | end zset. 529 | --------------------------------------------------------------------------------