├── .github └── workflows │ └── lean_action_ci.yml ├── .gitignore ├── .vscode └── settings.json ├── README.md ├── RelationalCalculus.lean ├── RelationalCalculus ├── Applied │ └── Sudoku │ │ ├── Defs.lean │ │ └── Solver.lean ├── Basic.lean ├── Category.lean ├── Element.lean ├── Eq.lean ├── Image.lean ├── Inclusion.lean ├── Intersection.lean ├── Logic │ ├── Basic.lean │ ├── Metalogic.lean │ ├── SimpTheorems.lean │ └── Subrelation.lean ├── NewToSort.lean ├── Order.lean ├── Quotient.lean ├── Residuals.lean ├── Union.lean └── Utility.lean ├── lake-manifest.json ├── lakefile.lean ├── lean-toolchain └── todo.md /.github/workflows/lean_action_ci.yml: -------------------------------------------------------------------------------- 1 | name: Lean Action CI 2 | 3 | on: 4 | push: 5 | pull_request: 6 | workflow_dispatch: 7 | 8 | jobs: 9 | build: 10 | runs-on: ubuntu-latest 11 | 12 | steps: 13 | - uses: actions/checkout@v4 14 | - uses: leanprover/lean-action@v1 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.lake 2 | untracked -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "cSpell.words": ["funext", "rcases", "symm"] 3 | } 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Relational Calculus Library 2 | 3 | This is an open source Lean 4 Library with data structures and theorems for working with the relational calculus. 4 | 5 | The motivation of this is two-fold. 6 | 7 | 1. First as an educational resource for learning about the relational calculus theoretically. 8 | 9 | 2. Second as a formally verified foundation for implementing relational programming techniques in Lean or your own language of choice. 10 | 11 | This is a work in progress. Please don't hesitate to reach out if you are interested in discussing the project or potentially getting involved. 12 | 13 | ## What it is not 14 | I'm not a professional mathematician and this time the library isn't attempting to formalize research-level mathematics. It also isn't meant to be a practical tool for implementing relational programming techniques (at least not directly). Think of more as a formal specification of mathematical ideas that might be useful to inspire/guide the development of more practical libraries in various programming languages. 15 | 16 | ## What is the Relational Calculus? 17 | 18 | The relational calculus is an algebraic theory and logic based on binary relations. It was pioneered by De Morgan, Peirce, Schroder, Tarski, and others. For a good historical and mathematical introduction see [Origins of the Calculus of Binary Relations by Vaughan Pratt](http://boole.stanford.edu/pub/ocbr.pdf). 19 | 20 | ## The Library 21 | 22 | The documentation is just a sketch at this point. I'll work on filling it out over time. 23 | 24 | ### [Basic.lean](https://github.com/AviCraimer/relational-calculus-library-lean4/blob/main/RelationalCalculus/Basic.lean) 25 | - Definition of `Relation` an inductive data type for terms of the relational calculus 26 | - Definition of `eval` to provide a semantic domain and the ability to use it for computation. 27 | - Definition of compositional operations on relations 28 | - Basic simplification theorems for relation expressions 29 | - Various other theorems 30 | 31 | ### [Order.lean](https://github.com/AviCraimer/relational-calculus-library-lean4/blob/main/RelationalCalculus/Order.lean) 32 | - Definition of a $\leq$ relation based on inclusion under evaluation. 33 | - Typeclass instances for Preorder 34 | 35 | ### [Eq.lean](https://github.com/AviCraimer/relational-calculus-library-lean4/blob/main/RelationalCalculus/Eq.lean) 36 | - Defining equivalence between relatiions as R ≤ S ∧ S ≤ R 37 | - Type class instance for Setoid (equivalence relation) 38 | - Instance for HasEquiv type class 39 | - Notation using R ≈ S 40 | - Theorems to go back and forth from R ≈ S to eval R = eval S 41 | 42 | ### [Quotient.lean](https://github.com/AviCraimer/relational-calculus-library-lean4/blob/main/RelationalCalculus/Quotient.lean) 43 | - Definition of RelationQuotient as the type of relation expressions quotiented by equivalence class (≈) 44 | - Definitions of lifted constructors for idR (identity relation) and comp (sequential composition). 45 | - Theorems for identity composition and composition associativity (these are used to define the Category of Relations) 46 | 47 | ### [Category.lean](https://github.com/AviCraimer/relational-calculus-library-lean4/blob/main/RelationalCalculus/Category.lean) 48 | - Definition of the category of relations (Rel) using RelationQuotient for the Hom type. 49 | 50 | ### [Union.lean](https://github.com/AviCraimer/relational-calculus-library-lean4/blob/main/RelationalCalculus/Union.lean) 51 | - Defining `union` operation on relations using relational composition. 52 | - Proof that `eval R ∪ S = eval R ∪ eval S`, i.e., evaluating this `union` is equal to evaluating set-theoretic union after evaluation. 53 | - Properties of union: associativity, transitivity, commutativity. 54 | 55 | ### [Intersection.lean](https://github.com/AviCraimer/relational-calculus-library-lean4/blob/main/RelationalCalculus/Intersection.lean) 56 | - Defining `intersection` operation on relations 57 | - WIP 58 | - Note: Most of these theorems should be derivable from `union` using the DeMorgan equivalence. 59 | 60 | ### [Logic.lean](https://github.com/AviCraimer/relational-calculus-library-lean4/blob/main/RelationalCalculus/Logic.lean) 61 | - Defining Propositions as Relations 62 | - Defining classical propositional connectives using relations 63 | - Defining quantifiers using relations 64 | - Defining sub-relation propositions relationally using linear implication 65 | - Eventually I hope to prove equivalences of logic expressed in relations to ordinary predicate logic, but it's not there yet. 66 | 67 | 68 | ## Connections to Other Topics 69 | 70 | ### Connection with Formal Logic 71 | 72 | Tarski in particular described an influential version of the calculus based on endo-relations. See his very readable [1941 paper](https://www.cl.cam.ac.uk/teaching/1011/Databases/Tarski_1941.pdf) for details. Tarski and others in the 20th Century to explore this calculus as an alternative to traditional logic based on sets and propositions. One advantage of the calculus is that it eliminates the need for variable binding that is found in syntactic calculi such as the lambda calculus. Logical inference within the relational calculus can be accomplished entirely through simple substitution with no backtracking or variable name management. 73 | 74 | However, an incompleteness result appeared to show that logic based on the relational calculus was incomplete relative to classical first-order logic. This result discouraged many from paying attention. However, recent work has demonstrated that full-first order relational logic is possible using an expanded set of primitive relations and operations. See [Diagrammatic Algebra of First Order Logic (2024)](https://arxiv.org/pdf/2401.07055). 75 | 76 | One fascinating discovery is that the full calculus of relations provides one of the most natural interpretations of *linear logic*. 77 | 78 | ### Connection with Relational Databases 79 | 80 | I'm not a database person myself so I don't know as much about this. However, apparently, foundational work in relational databases leading to query languages such as SQL were at least heavily inspired by The Calculus of Relations. 81 | 82 | 83 | ### Connection with Knowledge Representation 84 | 85 | There seems to be a natural cognitive fit between binary relations and knowledge representation. Usefulness of structures such as knowledge graphs can naturally be modeled using binary relations. More complex structures, including higher-order networks can also be modeled with relations although in a somewhat less straightforward way. 86 | 87 | ### Connection with Logic Programming 88 | 89 | Some logic programming languages implement a relational programming model. I don't now if any are explicitly based on the relational calculus. 90 | 91 | -------------------------------------------------------------------------------- /RelationalCalculus.lean: -------------------------------------------------------------------------------- 1 | -- This module serves as the root of the `RelationalCalculus` library. 2 | -- Import modules here that should be built as part of the library. 3 | import RelationalCalculus.Basic 4 | import RelationalCalculus.Order 5 | import RelationalCalculus.Eq 6 | import RelationalCalculus.Quotient 7 | import RelationalCalculus.Category 8 | import RelationalCalculus.Union 9 | import RelationalCalculus.Intersection 10 | import RelationalCalculus.Elements 11 | import RelationalCalculus.Residuals 12 | import RelationalCalculus.Logic 13 | -------------------------------------------------------------------------------- /RelationalCalculus/Applied/Sudoku/Defs.lean: -------------------------------------------------------------------------------- 1 | import Mathlib.Data.Finset.Basic 2 | import Mathlib.Tactic 3 | 4 | 5 | namespace Sudoku 6 | 7 | def Value : Finset Nat := {1,2,3,4,5,6,7,8,9} 8 | 9 | def v (n : Nat) (h : n ∈ Value := by first | decide ) : { x // x ∈ Value } := ⟨n, h⟩ 10 | 11 | -- instance : Coe Nat { x // x ∈ Value } where 12 | -- coe n := toValue n 13 | 14 | def vasdasd : Value := v 1 15 | 16 | def OptionalValue := Option Value 17 | 18 | structure Place where 19 | -- The 3 x 3 square numbered from upper left then left to right in three big rows 20 | sector: Value 21 | -- The row top to bottom 22 | row: Value 23 | -- The column left to right 24 | col: Value 25 | -- If the board position has a fixed value 26 | fixedValue: Option Value 27 | -- If fixed value is non-empty this must match. 28 | assignedValue: Option Value 29 | deriving Repr, DecidableEq 30 | 31 | def Place.empty (sector: Value)(col: Value)(row: Value) := Place.mk sector col row none none 32 | 33 | 34 | def one : Value := ⟨ 1, by decide ⟩ 35 | def two : Value := ⟨ 2, by decide ⟩ 36 | def three : Value := ⟨ 3, by decide ⟩ 37 | set_option diagnostics true 38 | def sector1NoValues : List Place := 39 | let empty := Place.empty one 40 | [ 41 | empty one one, empty one two, empty one three, 42 | empty two one, empty two two, empty two three, 43 | empty three one, empty three two, empty three three, 44 | ] 45 | 46 | #check (· %· : Nat -> Nat -> Nat ) 47 | #eval 1 - (1 % 3) 48 | 49 | def getSector (row: Value) (col: Value) := 50 | let rEdge := row.val - (row.val % 3) 51 | let cEdge := col.val - (col.val % 3) 52 | match cEdge,rEdge with 53 | | 0, 0 => 1 54 | | 3, 0 => 2 55 | | 6, 0 => 3 56 | | 0, 3 => 4 57 | | 3, 3 => 5 58 | | 6, 3 => 6 59 | | 0, 6 => 7 60 | | 3, 6 => 8 61 | | 6, 6 => 9 62 | | _,_ => sorry 63 | 64 | #eval getSector 1 1 65 | 66 | 67 | 68 | def shiftCol (n: Nat)(p: Place) := 69 | let raw := p.col.val + n 70 | match raw with 71 | | m + 10 => p 72 | | v => {p with col := ⟨raw, sorry ⟩ } 73 | 74 | 75 | 76 | 77 | -- def getInitialPlace (sector: Value) (col: ) (n: Value) (l: List Place ) : List Place := 78 | -- match n.val with 79 | -- | m + 1 => 80 | 81 | 82 | 83 | -- A valid {arg} assignment 84 | 85 | 86 | 87 | end Sudoku 88 | -------------------------------------------------------------------------------- /RelationalCalculus/Applied/Sudoku/Solver.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus 2 | -------------------------------------------------------------------------------- /RelationalCalculus/Basic.lean: -------------------------------------------------------------------------------- 1 | import Mathlib.Tactic 2 | set_option pp.coercions false 3 | 4 | universe u v 5 | 6 | 7 | -- This is an extensional (set-like) definition of a relation as a subset of the Cartesian product α × β. The goal of many theorems will be to relate the algebraic structure of relational expressions to the semantics based on subsets of pairs. 8 | abbrev Relation.Pairs (α β : Type u) : Type u := (a:α) → (b:β) → Prop 9 | 10 | -- The Relation inductive type gives the syntactic composition structure of relations. This defines the fundamental objects to be manipulated by the relational calculus. 11 | @[match_pattern] 12 | inductive Relation : (Dom : Type u) → (Cod : Type u) → Type (u+1) 13 | -- atomic forms a relation directly from a set of pairs 14 | | atomic {α β : Type u} (f:Relation.Pairs α β) : Relation α β 15 | 16 | -- pair forms a relation as a pair of two values. This is useful for forming higher-order relations from existing relations. 17 | | pair {α β : Type u} (a : α) (b : β) : Relation α β 18 | 19 | -- comp stands for composition, and it is the sequential composition operation, which is defined analogously to function composition. 20 | | comp {α β γ : Type u} (R : Relation α β) (S :Relation β γ) : Relation α γ 21 | 22 | -- converse is one of the involutions of relations, it reverses the direction of the pairs. 23 | | converse {α β : Type u} (R : Relation α β) : Relation β α 24 | 25 | -- complement is the other involution, it consists of the set theoretic complement of pairs relative to a given relation. 26 | | complement {α β : Type u} (R : Relation α β) : Relation α β 27 | 28 | -- full is the relation which is the full subset of the Cartersian product of domain and codomain. It's complement is an empty relation. 29 | | full (α β : Type u) : Relation α β 30 | 31 | -- product is a monoidal product in the category Rel. It corresponds to one of the conjunction operations in linear logic, usually represented as ⊗. 32 | | product {α β γ δ : Type u} (R : Relation α β) (S : Relation γ δ) : Relation (α × γ) (β × δ) 33 | 34 | -- This is the coproduct in the category Rel. It corresponds to one of the disjunction operations in linear logic, usually represented as ⊕. It is interpreted as a disjoint union of domain, codomain, and relational pairs. 35 | | coproduct {α β γ δ : Type u} (R : Relation α β) (S : Relation γ δ) : Relation (Sum α γ ) (Sum β δ) 36 | 37 | -- Copy is the diagonal relation, connecting each value in the domain to a pair of identical copies in the codomain. The converse of this is a "merge" relation that sents pairs of identicals to a single copy. 38 | | copy (α : Type u) : Relation α (α × α) 39 | 40 | -- Collapse is the categorical dual of copy (a.k.a. cocopy). It relates every left and right values of a sum type α + α to equal values in α. This allows us to collapse the disjoint sets of the sum type into a single set. Among other things, this operation allows us to define a union operation compositonally. The converse is a "split" relation that splits a single value into two parallel copies in the disjoint sets. 41 | | collapse (α: Type u) : Relation (Sum α α) α 42 | 43 | -- First is a projection relation from a pair in the domain to the first member of the pair. The converse inserts a value into all pairs where it occurs in first position. 44 | | first (α β : Type u) : Relation (α × β) α 45 | 46 | -- Second is a projection relation from a pair in the domain to the second member of the pair. The converse inserts a value into all pairs where it occurs in second position. 47 | | second (α β : Type u) : Relation (α × β) β 48 | 49 | -- Left is an injection relation from a value to itself in the left side of a sum type. The converse is a kind of first projection that works with Sum types. 50 | | left (α β : Type u) : Relation α (Sum α β) 51 | 52 | -- Right is an injection relation from a value to itself in the right side of a sum type. The converse is a kind of second projection that works with Sum types. 53 | | right (α β : Type u) : Relation β (Sum α β) 54 | 55 | 56 | 57 | open Relation 58 | namespace Relation 59 | 60 | postfix:80 "ᵒ" => converse -- \^o (hat and then letter) 61 | postfix:80 "⁻" => complement -- \^- (hat dash) 62 | infixl:70 " ⊗ " => product -- \otimes 63 | infixl:60 " ⊕ " => coproduct -- \oplus 64 | infixl:40 " ▹ " => comp -- \trans 65 | 66 | @[simp] 67 | abbrev domain (_: Relation α β) := α 68 | 69 | @[simp] 70 | abbrev codomain (_: Relation α β) := β 71 | 72 | 73 | 74 | -- *** Eval - Semantics for Relations *** 75 | -- eval defines the semantic domain of the Relation inductive type. It allows us to prove that different syntactic Relation are equal under evaluation. 76 | def eval (Rel : Relation α β) : Pairs α β := 77 | match Rel with 78 | -- For atomic relations, we simply return the pair function 79 | | atomic f => f 80 | 81 | -- Pair relations consist of the single pair of elements used in their definition 82 | | pair a b => fun (a': α ) (b': β) => a = a' ∧ b = b' 83 | 84 | -- A sequential composition of relations yeilds pair if there exists a common element in the middle Codomain/Domain. Note that for relations which have the structure of a function (i.e., relations with the properties of totality and determinism) this definition specializes to the standard definition of function composition. 85 | | R ▹ S => fun (a : R.domain) (c : S.codomain) => 86 | ∃ (b : S.domain), Relation.eval R a b ∧ Relation.eval S b c 87 | 88 | -- A full relation has all pairs so returns a constant True proposition. 89 | | full α β => fun _ _ => True 90 | 91 | -- Converse returns an evaluation with the order of the arguments switched. 92 | | Rᵒ => fun a b => (Relation.eval R b a) 93 | 94 | -- Complement returns the negation of evaluated proposition for each pair. 95 | -- TODO: Investigate why pattern matching isn't working with the notation R⁻ 96 | | complement R => fun a b => ¬(Relation.eval R a b) 97 | 98 | -- Product returns true iff the first element of the domain is related by R to the first element of the codomain AND the second element of domain is related by S to the second element of the codomain. 99 | | product R S => fun (a: (R ⊗ S).domain) (b: (R ⊗ S).codomain) => (Relation.eval R a.1 b.1) ∧ (Relation.eval S a.2 b.2) 100 | 101 | -- Coproduct returns true iff a left element of the domain is related by R to a left element of the codomain OR a right element of the domain is related by S to the right element of the codomain. 102 | | coproduct R S => fun (a: (R⊕S).domain) (b: ((R⊕S)).codomain) => 103 | match a, b with 104 | | Sum.inl a', Sum.inl b' => Relation.eval R a' b' 105 | | Sum.inr a', Sum.inr b' => Relation.eval S a' b' 106 | | _, _ => False 107 | 108 | | copy α => fun a (a1, a2) => a = a1 ∧ a = a2 109 | 110 | | collapse α => fun (aa) a => 111 | match aa with 112 | | Sum.inl a' => a' = a 113 | | Sum.inr a' => a' = a 114 | 115 | -- First and second relate the first (second) elements of a pair in domain to itself in codomain. 116 | | first α β => fun pair a => pair.1 = a 117 | | second α β => fun pair b => pair.2 = b 118 | 119 | -- Left and right relate an element of the domain to the corresponding left (right) elements of the codomain. 120 | | left α β => fun a ab => 121 | match ab with 122 | | Sum.inl a' => a = a' 123 | | _ => False 124 | | right α β => fun a ba => 125 | match ba with 126 | | Sum.inr a' => a = a' 127 | | _ => False 128 | 129 | 130 | -- Expresses the evaluation function as a relation 131 | def evalRel {α β : Type u} : Relation (Relation α β) (PLift (Pairs α β)) := 132 | atomic fun (R : Relation α β) (f: PLift (Pairs α β) ) => 133 | let evaluatedR := PLift.up (eval R) 134 | evaluatedR = f 135 | 136 | -- **DEFINED RELATION OPERATIONS** -- 137 | 138 | -- The converse complement of a relation is often refered to as the relative or linear negation of the relation. Note, that this is order invariant, i.e. complement converse = converse complemetn (proof below). 139 | def negation (R : Relation α β) := R⁻ᵒ 140 | abbrev neg (R : Relation α β) := R.negation 141 | postfix: 80 "ᗮ" => Relation.negation -- \^bot 142 | 143 | -- Double converse equals original relation 144 | @[simp] 145 | theorem double_converse (R : Relation α β) : eval (converse (converse R)) = eval R := by 146 | apply funext; intro a; apply funext; intro b 147 | simp [eval, converse] 148 | 149 | -- Double complement equals original relation 150 | @[simp] 151 | theorem double_complement (R : Relation α β) : eval (complement (complement R)) = eval R := by 152 | apply funext; intro a; apply funext; intro b 153 | simp [eval, complement] 154 | 155 | -- Double negation (converse complement) equals original relation 156 | @[simp] 157 | theorem double_neg (R : Relation α β) : eval (neg (neg R)) = eval R := by 158 | apply funext; intro a; apply funext; intro b 159 | simp [eval, neg, complement, converse] 160 | 161 | -- complement-converse equals converse-complement. We simply to the later. 162 | @[simp] 163 | theorem converse_complement_sym (R : Relation α β) : eval (complement (converse R)) = eval (converse ( complement R)) := by 164 | apply funext; intro b; apply funext; intro a; 165 | simp [eval] 166 | 167 | -- Complement-converse simplifies to negation. This is really trival but it helps display the expressions in a more readable way. 168 | @[simp] 169 | theorem complement_converse_to_neg (R : Relation α β) : eval (complement (converse R)) = eval (neg R) := by 170 | apply funext; intro b; apply funext; intro a; 171 | simp [eval, neg] 172 | 173 | 174 | -- Merge is the converse of copy 175 | def merge (α) := (copy α)ᵒ 176 | 177 | -- The identity relation is the composition of copy and merge 178 | def idR (α : Type u) := (copy α)▹(merge α) 179 | 180 | -- Proves evaluation of copy then merge equals identity pairs. 181 | @[simp] 182 | theorem eval_idR {α : Type u}: eval (copy α ▹ merge α) = fun (a b: α ) => a = b := by 183 | simp [merge, eval] 184 | 185 | -- Split is the converse of collapse. It branches α into two disjoint copies relating each element x to both inl x and inr x. 186 | def split (α : Type u) := (collapse α)ᵒ 187 | 188 | -- Proves evaluation of split then collapse is evalutes the same as idR 189 | @[simp] 190 | theorem eval_split_collapse_eq_idR {α : Type u}: eval (split α ▹ collapse α) = eval (Relation.idR α) := by 191 | simp [split, eval] 192 | 193 | -- The complement of identity is a relation consisting of all pairs of elements that are not identical. 194 | def nonId (α : Type u) := (idR α)⁻ 195 | 196 | -- Prove that taking the linear negation of IdR is the same as nonId 197 | theorem nonId_neg_idR {α : Type u}: eval (nonId α) = eval ((idR α)ᗮ) := by 198 | simp [eval] 199 | ext x x_1 : 3 200 | constructor 201 | <;> intro h 202 | <;> apply Aesop.BuiltinRules.not_intro 203 | <;> intro a 204 | <;> subst a 205 | <;> simp_all only [not_true_eq_false] 206 | 207 | -- We need to prove that idR is symetric on its arguments and use this. 208 | 209 | 210 | -- nonId relates two elements iff, they are not equal 211 | theorem eval_nonId_iff {α : Type u} (a a': α ) : eval (nonId α) a a' ↔ a ≠ a' := by simp [nonId, eval] 212 | 213 | --The (linear) negation of copy is a "different" relation that relates pairs in α × α of non-equal elements to every element in α. It relates equal elements (a,a) to every element not equal to a. This is useful for compositionally removing reflexive pairs from a relation. 214 | def different (α: Type u) := (copy α)ᗮ 215 | 216 | -- This is a notion from Peirce/Tarski of a second sequential composition operation that is the logical dual of ordinary composition. It replaces the existential quantifier (∃) in the definition of composition with a universal quantifier (∀) and replaces conjunction (∧) with disjunction (∨). It can be defined by a De Morgan equivalence. 217 | -- Also called "par" 218 | def rSum {α β : Type u} (R : Relation α β) (S :Relation β γ) := (R⁻▹S⁻)⁻ 219 | 220 | infixl:40 " ✦ " => rSum -- shortcut: \st4 221 | 222 | @[simp] 223 | theorem rsum_notation_simp {R : Relation α β} {S :Relation β γ} : (R ✦ S) = (rSum R S) := by rfl 224 | 225 | @[simp] 226 | theorem eval_relative_comp {R: Relation α β }{S :Relation β γ} : eval (rSum R S) = fun (a: α)(c: γ) => ∀(b: β), eval R a b ∨ eval S b c := by 227 | simp [rSum, complement, eval] 228 | funext a b 229 | simp [eval] 230 | constructor <;> intro h ; 231 | · simp [Classical.or_iff_not_imp_left] 232 | exact h 233 | simp [Classical.or_iff_not_imp_left.symm] 234 | exact h 235 | 236 | 237 | -- In linear logic, ar (upside down &) is the DeMorgan dual of product. 238 | -- TODO: Need to check the name, not sure if it's called par. 239 | def par (R : Relation α β) (S : Relation γ δ) : Relation (α × γ) (β × δ) := (Rᗮ⊗Sᗮ)ᗮ 240 | 241 | -- In linear logic, the operation with (&) is the DeMorgan dual of coproduct. 242 | def withR (R : Relation α β) (S : Relation γ δ) := (Rᗮ⊕Sᗮ)ᗮ 243 | 244 | -- An empty relation is the complement of the full relation. 245 | def empty (α β : Type u) := (full α β)⁻ 246 | 247 | 248 | -- Converse distributes over composition 249 | @[simp] 250 | theorem converse_comp_dist (R : Relation α β) (S : Relation β γ) : 251 | eval (converse (comp R S)) = eval (comp (converse S) (converse R)) := by 252 | apply funext; intro c; apply funext; intro a 253 | simp [Relation.eval] 254 | constructor <;> exact fun ⟨b, hab, hbc⟩ => ⟨b, hbc, hab⟩ 255 | 256 | 257 | -- Converse distributes across product 258 | @[simp] 259 | theorem converse_product_dist (R : Relation α β) (S : Relation γ δ) : 260 | eval (converse (product R S)) = eval (product (converse R) (converse S)) := by 261 | apply funext; intro ⟨b, d⟩; apply funext; intro ⟨a, c⟩ 262 | simp [Relation.eval, Relation.product, Relation.converse] 263 | 264 | -- Complement distributes across product 265 | @[simp] 266 | theorem complement_product_dist (R : Relation α β) (S : Relation γ δ) : 267 | eval (complement (product R S)) = eval (par (complement R) (complement S)) := by 268 | apply funext; intro ⟨a, c⟩; apply funext; intro ⟨b, d⟩ 269 | simp [Relation.eval] 270 | 271 | -- Negation distribtes across product 272 | @[simp] 273 | theorem neg_product (R : Relation α β) (S : Relation γ δ) : 274 | eval (neg (product R S)) = eval (par (neg R) (neg S)) := by 275 | apply funext; intro ⟨a, c⟩; apply funext; intro ⟨b, d⟩ 276 | simp [Relation.eval] 277 | 278 | -- Converse distributes across coproduct 279 | @[simp] 280 | theorem converse_coproduct (R : Relation α β) (S : Relation γ δ) : 281 | eval (converse (coproduct R S)) = eval (coproduct (converse R) (converse S)) := by 282 | apply funext; intro ab; apply funext; intro cd 283 | cases ab <;> cases cd <;> simp [Relation.eval] 284 | 285 | -- Complement distributes across coproduct 286 | @[simp] 287 | theorem complement_coproduct (R : Relation α β) (S : Relation γ δ) : 288 | eval (complement (coproduct R S)) = eval (withR (complement R) (complement S)) := by 289 | apply funext; intro ab; apply funext; intro cd 290 | cases ab <;> cases cd <;> simp [Relation.eval] 291 | 292 | -- Composition is associative. 293 | @[simp] 294 | theorem assoc_comp (R : Relation α β) (S : Relation β γ) (T : Relation γ δ) : 295 | eval (comp (comp R S) T) = eval (comp R (comp S T)) := by 296 | apply funext; intro a; apply funext; intro d 297 | simp [Relation.eval] 298 | constructor 299 | . intro ⟨c, ⟨b, hab, hbc⟩, hcd⟩ 300 | exact ⟨b, hab, ⟨c, hbc, hcd⟩⟩ 301 | . intro ⟨b, hab, ⟨c, hbc, hcd⟩⟩ 302 | exact ⟨c, ⟨b, hab, hbc⟩, hcd⟩ 303 | 304 | 305 | 306 | 307 | abbrev EndoRelation (α: Type U) := Relation α α 308 | 309 | end Relation 310 | 311 | 312 | 313 | -- *** Odds and Ends (Very Rough WIP) *** 314 | -- Helper for getArityType. Note that arity' is arity - 1. 315 | def getProduct (α : Type u) (arity': Nat) : Type u := 316 | match arity' with 317 | | n+1 => α × (getProduct α n) 318 | | _ => α 319 | 320 | -- Returns PUnit for arity 0, returns α for arity 1, α × α for arity 2, etc. 321 | def getArityType (α : Type u) (arity: Nat) : Type u := 322 | if arity == 0 then PUnit else getProduct α (arity-1) 323 | 324 | 325 | 326 | 327 | -- theorem Relation.product_coproduct__dist (R : Relation α α) (S : Relation α α) (T : Relation α α) : 328 | -- eval (product (coproduct R S) T) = eval (coproduct (product R T) (product S T)) := sorry 329 | 330 | -- theorem Relation.coproduct_product_dist (R : Relation α β) (S : Relation γ δ) (T : Relation ε ζ) : 331 | -- eval (product (coproduct R S) T) = eval (coproduct (product R T) (product S T)) := by sorry 332 | 333 | -- Equiv.sumProdDistrib is the distributivity equivalence for Sum and Product types. We need to apply this so the types match on either side of the eqution. 334 | -- (R⊕S)⊗T ≅ (R⊗T)⊕(S⊗T) 335 | theorem Relation.coproduct_product_dist (R : Relation α β) (S : Relation γ δ) (T : Relation ε ζ) : 336 | eval (product (coproduct R S) T) = 337 | fun (a :(α ⊕ γ) × ε) (b : (β ⊕ δ) × ζ) => 338 | let prodPlusProd := eval (coproduct (product R T) (product S T)) 339 | let isoDomain := (Equiv.sumProdDistrib α γ ε) 340 | let isoCodomain := (Equiv.sumProdDistrib β δ ζ) 341 | prodPlusProd (isoDomain a) (isoCodomain b) := by 342 | apply funext; intro a; apply funext; intro b 343 | dsimp [Relation.eval, Equiv.sumProdDistrib] 344 | cases a.1 <;> cases b.1 <;> simp 345 | 346 | 347 | -- -- T⊕(R⊗S) = (T⊕R) ⊗ (T⊕S) 348 | -- theorem Relation.product_coproduct_dist (R : Relation α β) (S : Relation γ δ) (T : Relation ε ζ) : 349 | -------------------------------------------------------------------------------- /RelationalCalculus/Category.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Basic 2 | import RelationalCalculus.Eq 3 | import RelationalCalculus.Quotient 4 | import Mathlib.Tactic 5 | import Mathlib.CategoryTheory.Category.Basic 6 | set_option pp.proofs true 7 | 8 | open RelationQuotient 9 | open CategoryTheory 10 | 11 | instance : Category (Type u) where 12 | Hom (α : Type u)(β : Type u):= RelationQuotient α β 13 | id (α : Type u) := idR α 14 | comp {α β γ : Type u} (R : RelationQuotient α β) (S :RelationQuotient β γ) := comp R S 15 | id_comp := id_comp 16 | comp_id := comp_id 17 | assoc := comp_assoc 18 | -------------------------------------------------------------------------------- /RelationalCalculus/Element.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Basic 2 | import RelationalCalculus.Order 3 | import RelationalCalculus.Eq 4 | import RelationalCalculus.Union 5 | import RelationalCalculus.Intersection 6 | import Mathlib.Tactic 7 | 8 | open Relation 9 | universe u 10 | namespace Relation 11 | 12 | def isPartialId {α :Type u} (R: Relation α α) : Prop := R ≤ (idR α) 13 | 14 | def isEmpty {α β :Type u} (R: Relation α β) := R ≈ (empty α β) 15 | 16 | @[simp] 17 | theorem empty_simp {α β :Type u} {R: Relation α β } : isEmpty R = (R ≤ (empty α β)) := by simp [isEmpty, (·≤·), (·≈·), eq, eval] 18 | 19 | def isNonEmpty {α β :Type u} (R: Relation α β ) : Prop := ¬ isEmpty R 20 | -- Define an element relation 21 | 22 | def isMinimal {α β :Type u} (R: Relation α β ) : Prop := R ≈ (R▹(full β α)▹R) 23 | 24 | -- Element relation defined compositionally 25 | def isElement {α :Type u} (R: Relation α α) : Prop := isPartialId R ∧ isNonEmpty R ∧ isMinimal R 26 | 27 | -- An element relation is equivalent to a reflexive pair (a,a) 28 | theorem element_imp_refl_pair {α : Type u} (R : Relation α α) : 29 | (isElement R) → (∃ (a : α), (R ≈ pair a a)) := by 30 | simp [isElement, (·≈·), eq, (·≤·), isPartialId, isNonEmpty, isMinimal, eval, domain, codomain] 31 | -- Forward direction 32 | intro h_id x x₁ nonempty minimal1 minimal2 33 | have minimal : ∀ (a b y : α), R.eval a y → ∀ (x : α), R.eval x b → R.eval a b := by exact minimal2 34 | -- In words: If a is connected to anything y, and anything x is connected to b, then a is connected to b. This the useful bit, minimal1 is trivial. 35 | have xEqx₁ : x = x₁ := h_id x x₁ nonempty 36 | let a := x 37 | have aRa : R.eval a a := by rwa [← xEqx₁] at nonempty 38 | -- We will show that R.eval a₁ b → a₁ = a ∧ b = a 39 | have h_unique : ∀ (a₁ b₁ : α), R.eval a₁ b₁ → (a = a₁) ∧ (a = b₁) := by 40 | intros a₁ b₁ a₁Rb₁ 41 | have a₁Eqb₁ : a₁ = b₁ := h_id a₁ b₁ a₁Rb₁ 42 | have aRb₁ := minimal a b₁ a aRa a₁ a₁Rb₁ 43 | have aRa₁ : R.eval a a₁ := by rwa [a₁Eqb₁.symm] at aRb₁ 44 | have a₁Eqa := ((h_id a a₁) aRa₁).symm 45 | have b₁Eqa : b₁ = a := by rwa [← a₁Eqb₁] 46 | exact ⟨a₁Eqa.symm, b₁Eqa.symm⟩ 47 | use a 48 | 49 | 50 | -- If a relation is equivalent to a reflexive pair, it is an element relation. 51 | theorem refl_pair_imp_element {α : Type u} (R : Relation α α) : 52 | (∃ (a : α), (R ≈ pair a a)) → (isElement R) := by 53 | simp [isElement, (·≈·), eq, (·≤·), isPartialId, isNonEmpty, isMinimal, eval, domain, codomain] 54 | intro a unique aRa 55 | 56 | have partial_id : ∀ (a₁ b : α), R.eval a₁ b → a₁ = b := by 57 | intros a₁ b h_eval 58 | specialize unique a₁ b h_eval 59 | rw [unique.1.symm] 60 | exact unique.2 61 | 62 | have nonempty : ∃ x x₁, R.eval x x₁ := ⟨a, a, aRa⟩ 63 | 64 | -- Prove R ≈ R ▹ full α α ▹ R (minimality) 65 | have minimal : isMinimal R := by 66 | simp [isElement, (·≈·), eq, (·≤·), isPartialId, isNonEmpty, isMinimal, eval, domain, codomain] 67 | constructor 68 | · intro a₁ b a₁Rb 69 | constructor 70 | · use b 71 | · use a₁ 72 | · intro a₁ b y a₁Ry x xRb 73 | have a₁_a : a₁ = a := (unique a₁ y a₁Ry).1.symm 74 | have b_a : b = a := (unique x b xRb).2.symm 75 | rwa [a₁_a, b_a] 76 | 77 | simp [isElement, (·≈·), eq, (·≤·), isPartialId, isNonEmpty, isMinimal, eval, domain, codomain] at minimal 78 | exact ⟨partial_id, nonempty, minimal ⟩ 79 | -------------------------------------------------------------------------------- /RelationalCalculus/Eq.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Basic 2 | import RelationalCalculus.Order 3 | open Relation 4 | 5 | namespace Relation 6 | -- Define custom equality for Relation based on union order (inclusion) 7 | def eq (R S : Relation α β) : Prop := 8 | R ≤ S ∧ S ≤ R 9 | 10 | 11 | -- *** Equivalence Properties *** 12 | -- Reflexivity 13 | @[refl] 14 | theorem eq_refl (R : Relation α β) : eq R R := 15 | ⟨le_refl R, le_refl R⟩ 16 | 17 | -- Symmetry 18 | @[symm] 19 | theorem eq_symm {R S : Relation α β} (h : eq R S) : eq S R := 20 | ⟨h.2, h.1⟩ 21 | 22 | -- Transitivity 23 | @[trans] 24 | theorem eq_trans {R S T : Relation α β} (h₁ : eq R S) (h₂ : eq S T) : eq R T := 25 | ⟨le_trans h₁.1 h₂.1, le_trans h₂.2 h₁.2⟩ 26 | end Relation 27 | 28 | -- Create Setoid instance 29 | -- A Setoid is a set together with an equivalence relation 30 | -- After proving this instance we use ≈ for the equivalence relation between Relations 31 | instance : Setoid (Relation α β) where 32 | r := Relation.eq 33 | iseqv := { 34 | refl := Relation.eq_refl 35 | symm := Relation.eq_symm 36 | trans := Relation.eq_trans 37 | } 38 | 39 | 40 | 41 | 42 | instance : HasEquiv (Relation α β) where 43 | Equiv := Relation.eq 44 | 45 | -- ... and so on for other constructors 46 | 47 | namespace Relation 48 | -- *** Theorems Relating Order Equivalence to Evaluation Equality *** 49 | -- Our equivalence relation defined in terms of ordering actually implies equivalence in terms of evaluation. This is because we defined ordering in terms of evaluation (see Order.lean). 50 | 51 | theorem eq_iff_forall_eval_eq {α β : Type u} {R S : Relation α β} : 52 | (R ≈ S) ↔ (∀ a b, eval R a b ↔ eval S a b) := by 53 | constructor 54 | · intro h 55 | intro a b 56 | exact ⟨fun hr => h.1 a b hr, fun hs => h.2 a b hs⟩ 57 | · intro h 58 | constructor 59 | · intro a b hr 60 | exact (h a b).1 hr 61 | · intro a b hs 62 | exact (h a b).2 hs 63 | 64 | 65 | -- Equivalence is equal to extensional equality 66 | @[simp] 67 | theorem equiv_eq_eval {R S : Relation α β}: (R ≈ S) = (eval R = eval S) := by 68 | simp_all only [eq_iff_forall_eval_eq, eq_iff_iff] 69 | apply Iff.intro 70 | · intro RS 71 | ext x x_1 : 3 72 | simp_all only 73 | · intro a a2 b 74 | simp_all only 75 | 76 | 77 | 78 | 79 | end Relation 80 | 81 | def Relation.instSetoid := @instSetoidRelation 82 | def Relation.instHasEquiv := @instHasEquivRelation 83 | -------------------------------------------------------------------------------- /RelationalCalculus/Image.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Basic 2 | import RelationalCalculus.Utility 3 | import RelationalCalculus.Order 4 | import RelationalCalculus.Eq 5 | import RelationalCalculus.Union 6 | import RelationalCalculus.Intersection 7 | import RelationalCalculus.Residuals 8 | import Mathlib.Tactic 9 | 10 | open Utility 11 | open Relation 12 | 13 | universe u 14 | 15 | 16 | -- Deeply a work in progress. Not useful yet. 17 | namespace Relation 18 | open Relation 19 | -- Gets the image relation of R. That is the subrelation of identity β which includes elements that are second in pairs in R. 20 | def img {α β : Type u} (R : Relation α β) : Relation β β := 21 | (Rᵒ▹ full α α ▹ R) ∩ (idR β ) 22 | 23 | abbrev imgCod {α β : Type u} (R : Relation α β) := img R 24 | 25 | -- Gets the domain image of R. 26 | def imgDom {α β : Type u} (R : Relation α β) : Relation α α := img (Rᵒ) 27 | 28 | 29 | -- We define the evaluation of the image of R as pairs directly. 30 | def img_semantically {α β : Type u} (R : Relation α β) (b1 b2: β ) : Prop := b1 = b2 ∧ ∃(a:α), R.eval a b1 31 | 32 | 33 | theorem img_eval {α β : Type u} (R : Relation α β): (img R).eval = R.img_semantically := by 34 | simp [eval, domain, codomain] 35 | funext b1 b2 36 | simp [img_semantically] 37 | constructor 38 | · intro h 39 | rcases h with ⟨a, ⟨_, h1⟩, h2⟩ 40 | constructor 41 | · exact h1 42 | · let h3 := h2.right 43 | rcases h2 with ⟨b, hb ⟩ 44 | rw [h1.symm] at h3 45 | exact h3 46 | · intro h 47 | rcases h with ⟨heq, ⟨a, ha⟩⟩ 48 | exists b1 49 | constructor 50 | · exact ⟨ rfl,heq ⟩ 51 | · constructor 52 | · exists a 53 | · exists a 54 | rwa [heq.symm] 55 | -------------------------------------------------------------------------------- /RelationalCalculus/Inclusion.lean: -------------------------------------------------------------------------------- 1 | 2 | import RelationalCalculus.Basic 3 | import RelationalCalculus.Order 4 | import RelationalCalculus.Eq 5 | import RelationalCalculus.Element 6 | import Mathlib.Tactic 7 | 8 | namespace Relation 9 | open Relation 10 | 11 | -- This should define the set of pairs in R which are not in S, that is it is R - S. 12 | def subtract {α β :Type u} (R S: Relation α β ) := (copy α)▹(R ⊗ S⁻)▹(merge β) 13 | infixl: 60 "⊖" => subtract -- \ominus 14 | 15 | theorem subtract_eval {α β :Type u} {R S: Relation α β} : eval (R ⊖ S) = fun (a:α ) (b:β) => (R.eval a b) ∧ (¬S.eval a b) := by 16 | simp [eval, domain, codomain] 17 | funext a b 18 | simp 19 | constructor 20 | · intro h 21 | rcases h with ⟨a1,a2,⟨a_a1,a_a2⟩, Ra1b, nSa2b⟩ 22 | constructor 23 | · rwa [a_a1.symm] at Ra1b 24 | · rwa [a_a2.symm] at nSa2b 25 | · intro h 26 | rcases h with ⟨Rab, nSab⟩ 27 | use a, a 28 | 29 | -- If R - S is empty then R is less than or equal to S 30 | theorem rel_inclusion {α β :Type u} {R S: Relation α β} : (R ⊖ S ≈ empty α β) = (R ≤ S) := by 31 | simp [(·≈·), eq, (·≤·), eval, domain, codomain] 32 | 33 | -- We prove that subtracting the difference between R and S form R gives a subrelation of S 34 | theorem difference_subrelation {α β :Type u} (R S: Relation α β) : R⊖(R⊖S) ≤ S := by 35 | simp [(·≤·), eval, domain, codomain] 36 | intro a b Rab RabSab 37 | exact RabSab Rab 38 | 39 | -- theorem sfdsdf {α β :Type u} (R S: Relation α β) :∀ (a:α )(b:β), eval R-S a b → 40 | 41 | -- theorem sdfd {α β :Type u} {R S T: Relation α β} {h1: R ≤ S}{h2: T ≤ S}: 42 | 43 | theorem largest_subrelation {α β :Type u} {R S T: Relation α β} : T ≤ S → (T ≤ R⊖(R⊖S)) := by 44 | have RdiffSubS: R⊖(R⊖S) ≤ S := difference_subrelation R S 45 | simp [(·≤·), eval, domain, codomain] 46 | simp [(·≤·), (·⊖·), merge, eval, domain, codomain] at RdiffSubS 47 | intro TsubS 48 | have h1 : T ⊖ R ≈ empty α β := by 49 | simp [(·≈·), eq, (·≤·), eval, domain, codomain] 50 | intro a b 51 | by_contra nTR 52 | push_neg at nTR 53 | obtain ⟨Tab, nRab⟩ := nTR 54 | specialize TsubS a b 55 | specialize RdiffSubS a b 56 | have Sab := TsubS Tab 57 | -- I should be able to prove a contradition from Sab : S.eval a b, nRab : ¬R.eval a b ... actually not sure... 58 | 59 | 60 | 61 | intro h a b Tab 62 | constructor 63 | · sorry 64 | · 65 | 66 | 67 | def relInclusion {α β :Type u} (R S: Relation α β ) := (R ⊗ S⁻)⁻ 68 | infixl : 50 "⊑" => relInclusion 69 | 70 | def disjunctiveRelInclusion {α β :Type u} (R S: Relation α β ) := (R⁻ ⊕ S)⁻ 71 | 72 | 73 | 74 | 75 | -- This appears not to hold if α or β are empty. 76 | theorem le_then_inclusion {α β :Type u} [hα: Nonempty α] [hβ :Nonempty β] (R S: Relation α β) : R ≤ S → isNonEmpty (R ⊑ S) := by 77 | simp [isNonEmpty, (·⊑·), relInclusion, (· ≤ · ), domain, codomain, eval] 78 | intro h 79 | by_cases hR : ∃ a b, R.eval a b 80 | · rcases hR with ⟨a, b, hRab⟩ 81 | use a, a, b, b 82 | intro _ 83 | exact h a b hRab 84 | · simp at hR 85 | let a := Classical.choice hα 86 | let b := Classical.choice hβ 87 | use a, a, b, b 88 | intro hRab 89 | exfalso 90 | exact hR a b hRab 91 | 92 | 93 | 94 | theorem inclusion_then_le {α β :Type u} [hα: Nonempty α] [hβ :Nonempty β] (R S: Relation α β) : isNonEmpty (R ⊑ S) → R ≤ S := by 95 | simp [isNonEmpty, (·⊑·), relInclusion, (· ≤ · ), domain, codomain, eval] 96 | -- Give friendly names to variables and re-order 97 | intro a1 a2 b1 b2 RS a b hab 98 | revert a b ; revert a2 b2 ; revert a1 b1 99 | 100 | have hImp : (∀ (a1 : α) (b1 : β) (a2 : α) (b2 : β), (R.eval a1 b1 → S.eval a2 b2)) → (∃ (a3: α)(b3: β), eval R a3 b3) → S ≈ (full α β) := by 101 | intro h ex 102 | rcases ex with ⟨a3,b3, Ra3b3⟩ 103 | specialize h a3 b3 104 | have isTrue : R.eval a3 b3 = True := by aesop 105 | rw [isTrue] at h 106 | simp at h 107 | simp [(· ≈·), eq,(· ≤ · ), eval ] 108 | exact h 109 | 110 | have hImpR : (S ≈ (full α β)) → (∀ (a1 : α) (b1 : β) (a2 : α) (b2 : β), (R.eval a1 b1 → S.eval a2 b2)) := by 111 | simp [(· ≈·), eq,(· ≤ · ), eval ] 112 | intro hSab a1 b1 a2 b2 113 | specialize hSab a2 b2 114 | aesop 115 | 116 | have converseHImpR : ¬ (∀ (a1 : α) (b1 : β) (a2 : α) (b2 : β), (R.eval a1 b1 → S.eval a2 b2)) → ¬ (S ≈ (full α β)) := by aesop 117 | 118 | by_cases RImpS : ∀ (a1 : α) (b1 : β) (a2 : α) (b2 : β), (R.eval a1 b1 → S.eval a2 b2) 119 | · by_cases Rab: ∃ (a3: α)(b3: β), eval R a3 b3 120 | · have Sfull := hImp RImpS Rab 121 | aesop 122 | · aesop 123 | · intro a1 b1 a2 b2 124 | have spec : ¬ R.eval a1 b1 → S.eval a2 b2 := by 125 | sorry 126 | sorry 127 | 128 | 129 | -- have SNotFull := converseHImpR RImpS 130 | -- push_neg at RImpS 131 | -- rcases RImpS with ⟨a1,b1,a2, b2,Ra1b1, notSa2b2⟩ 132 | 133 | 134 | -- <;> by_cases Rab: ∃ (a3: α)(b3: β), eval R a3 b3 135 | -- · 136 | 137 | -- have sddf := hImp ⟨RS, Rab⟩ 138 | -------------------------------------------------------------------------------- /RelationalCalculus/Intersection.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Basic 2 | import RelationalCalculus.Order 3 | import RelationalCalculus.Eq 4 | import RelationalCalculus.Union 5 | import Mathlib.Tactic 6 | 7 | namespace Relation 8 | open Relation 9 | -- Compositional definition of intersection of relations. 10 | -- TODO: Maybe I can define this using duality with union. That way I can get theorems for free. 11 | @[match_pattern] 12 | def intersect (R : Relation α β) (S : Relation α β) := comp (comp (copy α) (product R S)) (Relation.merge β) 13 | 14 | infixl: 50 "∩" => intersect 15 | 16 | -- We give the direct set-theoretic definition of an intersection of two relations. 17 | def intersect_pairs_def (R : Relation α β) (S : Relation α β) : Pairs α β := fun a b => (eval R) a b ∧ (eval S) a b 18 | 19 | -- Proof that the compositional definition of intersection is equal to the set theoretic definiton. 20 | theorem intersect_eval_eq_pairs (R : Relation α β) (S : Relation α β) : eval (R ∩ S) = intersect_pairs_def R S := by 21 | simp [eval, intersect, domain, codomain] 22 | funext a b 23 | simp 24 | constructor 25 | · intro Eab 26 | rcases Eab with ⟨a1, a2, ⟨ aEqa1, aEqa2⟩, Ra1b, Ra2b⟩ 27 | rw [aEqa2.symm] at Ra2b 28 | rw [aEqa1.symm] at Ra1b 29 | simp [intersect_pairs_def] 30 | exact ⟨Ra1b, Ra2b⟩ 31 | · intro RinterS 32 | simp [intersect_pairs_def] at RinterS 33 | rcases RinterS with ⟨Rab, Sab⟩ 34 | use a 35 | simp_all only [true_and, exists_eq_left'] 36 | 37 | 38 | 39 | theorem intersect_union_eval {α β : Type u} (R S: Relation α β) : (R ∩ S) ≈ ((R⁻ ∪ S⁻)⁻) := by 40 | simp [(·≈·), eq,(·≤·), eval, domain, codomain] 41 | constructor 42 | · intro a b Rab Sab 43 | simp_all only [and_self] 44 | · intro a b Rab Sab 45 | use a 46 | simp_all only [true_and, exists_eq_left'] 47 | 48 | #check imp_iff_not_or 49 | 50 | theorem union_intersect_eval {α β : Type u} (R S: Relation α β) : (R ∪ S) ≈ ((R⁻ ∩ S⁻)⁻) := by 51 | simp [(·≈·), eq,(·≤·), eval, domain, codomain] 52 | constructor 53 | · intro a b a_1 a_2 54 | simp_all only [false_or] 55 | · intro a b RS 56 | rw [imp_iff_not_or, not_not] at RS 57 | exact RS 58 | 59 | 60 | -- Composition on the leftis monotonic relative to composition 61 | theorem comp_intersect_le_left {α β γ: Type u} (R: Relation α β)(S T: Relation β γ ): (R▹(S ∩ T)) ≤ ((R▹S) ∩ (R▹T)) := by 62 | simp [(·≤·), eval, domain, codomain] 63 | intro a c b Rab Sbc Tbc 64 | use a 65 | simp_all only [true_and, exists_eq_left'] 66 | constructor <;> use b 67 | 68 | -- Composition on the right is monotonic relative to composition 69 | theorem comp_intersect_le_right {α β γ: Type u} (S T: Relation α β ) (R: Relation β γ ): ((S ∩ T)▹R) ≤ ((S▹R) ∩ (T▹R)) := by 70 | simp [(·≤·), eval, domain, codomain] 71 | intro a c b Sab Tab Rbc 72 | use a 73 | use a 74 | constructor 75 | · simp_all 76 | · constructor <;> use b 77 | 78 | -- Relative sum distributes over intersection (both sides) 79 | theorem sum_intersect_dist_left {α β γ: Type u} (R: Relation α β) (S T: Relation β γ): 80 | (R✦(S ∩ T)) ≈ ((R✦S) ∩ (R✦T)) := by 81 | simp_all [eval] 82 | funext a c 83 | simp 84 | constructor 85 | · intro nR_ST 86 | use a 87 | simp_all only [true_and, not_false_eq_true, implies_true, exists_eq_left'] 88 | · intro E b nR 89 | obtain ⟨a2, a3, ⟨a_a2, a_a3 ⟩ , nRS, nRT⟩ := E 90 | subst a_a2 a_a3 91 | simp_all only [not_false_eq_true, and_self] 92 | 93 | 94 | 95 | theorem sum_intersect_dist_right {α β γ: Type u} (S T: Relation α β) (R: Relation β γ): 96 | ((S ∩ T)✦R) ≈ ((S✦R) ∩ (T✦R)) := by 97 | simp_all [eval] 98 | funext a c 99 | simp 100 | constructor 101 | · intro h 102 | use a 103 | simp_all only [true_and, false_implies, implies_true, exists_eq_left', not_false_eq_true] 104 | · intro E 105 | obtain ⟨a2, a3, ⟨a_a2, a_a3 ⟩ , nSR, nTR⟩ := E 106 | subst a_a2 a_a3 107 | intro b S_nT 108 | by_cases h2: S.eval a b 109 | · simp_all only [true_implies, not_false_eq_true] 110 | · simp_all only [false_implies, not_false_eq_true] 111 | 112 | 113 | 114 | 115 | 116 | 117 | -- DeMorgan Equivalence between intersection and union. 118 | -- This lets us translate theorems about union to corresponding theorems about intersection. 119 | theorem intersect_union_demorgan {α β : Type u} {R S: Relation α β} : (R ∩ S) ≈ ((R⁻ ∪ S⁻)⁻) := by 120 | simp_all [eval] 121 | funext a b 122 | simp_all only [eq_iff_iff] 123 | constructor 124 | · intro E 125 | obtain ⟨a2, a3,⟨a_a2, a_a3⟩, Ra2b, Sa3b⟩ := E 126 | subst a_a2 a_a3 127 | simp_all only [and_self] 128 | · intro RS 129 | obtain ⟨Rab, Sab⟩ := RS 130 | use a 131 | simp_all only [true_and, exists_eq_left'] 132 | 133 | 134 | theorem union_intersect_demorgan {α β : Type u} (R S: Relation α β) : (R ∪ S) ≈ ((R⁻ ∩ S⁻)⁻) := by 135 | simp [eval] 136 | funext a b 137 | simp_all only [eq_iff_iff] 138 | constructor 139 | · intro a_1 a_2 140 | simp_all only [false_or] 141 | · intro nRS 142 | by_cases h: R.eval a b 143 | <;> simp_all only [not_true_eq_false, false_implies, true_or] 144 | simp_all only [not_false_eq_true, true_implies, or_true] 145 | 146 | 147 | 148 | -- def union_intersect_convert {α β : Type u} ( U: Relation α β ) : Relation α β := 149 | -- match U with 150 | -- | (union R S) => ((R⁻ ∩ S⁻)⁻) 151 | -- | I' => I' 152 | 153 | -- apply funext 154 | 155 | 156 | -- TODO: I think this might be wrong. Might be better to define subtraction in the Inclusion.lean. 157 | -- -- Compositional Definition of Subtraction one relation from another. 158 | -- def subtract {α β : Type u} (R S : Relation α β) : Relation α β := 159 | -- let D := (R ∩ S)ᗮ 160 | -- let Disconnected := D▹R▹D 161 | -- Disconnectedᵒ 162 | 163 | 164 | -- infixl: 60 "-" => subtract -- 165 | 166 | -- -- TODO: Prove the composition definition of subtraction works as expected under evaluation 167 | -- theorem subtract_eval {α β : Type u} {R S : Relation α β} : ∀(a: α)(b:β),(eval (R-S) a b) = ((eval R a b) → ¬(eval S a b)) := by 168 | -- simp [eval,domain,codomain] 169 | -- intro a b 170 | -- constructor 171 | -- · intro h Rab 172 | -- rcases h with ⟨b1,⟨ a1, ⟨RnSa1b, Ra1b1⟩ ⟩, RnSab1⟩ 173 | -- · sorry 174 | -- · sorry 175 | 176 | 177 | end Relation 178 | -------------------------------------------------------------------------------- /RelationalCalculus/Logic/Basic.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Logic.SimpTheorems 2 | import RelationalCalculus.Basic 3 | import RelationalCalculus.Utility 4 | import RelationalCalculus.Order 5 | import RelationalCalculus.Eq 6 | import RelationalCalculus.Union 7 | import RelationalCalculus.Intersection 8 | import RelationalCalculus.Residuals 9 | import Mathlib.Tactic 10 | import Init.SimpLemmas 11 | 12 | open Utility 13 | open Relation 14 | open Logic 15 | namespace Relation 16 | 17 | 18 | -- To avoid name clashes we use the "R" suffix when naming logical constructs built from relational calculus expressions. 19 | abbrev PropR := Relation {⋆} {⋆} 20 | abbrev TrueR : PropR := full {⋆} {⋆} 21 | abbrev FalseR : PropR := empty {⋆} {⋆} 22 | 23 | theorem excludedMiddleR (R: PropR) : R ≈ TrueR ∨ R ≈ FalseR := by 24 | simp [(·≈·), eq, TrueR, FalseR, (· ≤ ·), eval] 25 | exact em (eval R ⋆ ⋆) 26 | 27 | -- Note: Not sure if this is necessary. 28 | -- theorem bivaluedProps (R S T: PropR) : ¬(R ≈ S) → ((T ≈ R) ∨ (T ≈ S)) := by 29 | -- intro h1 30 | -- simp [(·≈·), eq, (·≤·),eval ] 31 | -- 32 | 33 | 34 | 35 | -- We can prove statements in the logic of relations by showing that a propositional relation is equivalent to TrueR 36 | def proofR (R: PropR): Prop := R ≈ TrueR 37 | 38 | -- This simplification avoids the need to prove both directions of ≤ when proving truth equivalence 39 | -- TODO: Finish proof 40 | @[simp] 41 | theorem simp_proofR_le (P: PropR) : (P ≈ TrueR) = (TrueR ≤ P) := by 42 | simp [(·≈·), eq, TrueR, (·≤·)] 43 | intro _ _ 44 | simp [eval] 45 | 46 | 47 | @[simp] 48 | theorem simp_proofR (P: PropR) : (P ≈ TrueR) = proofR P := by 49 | simp [proofR] 50 | 51 | 52 | @[match_pattern] 53 | def andR (P Q: PropR) : PropR := TrueR ▹ (copy {⋆}) ▹ P ⊗ Q ▹ merge {⋆} 54 | infixl: 90 " ∧ " => andR 55 | 56 | @[match_pattern] 57 | def orR (P Q: PropR) : PropR := TrueR ▹ split {⋆} ▹ P ⊕ Q ▹ collapse {⋆} 58 | infixl: 85 " ∨ " => orR 59 | 60 | @[match_pattern] 61 | def notR (P: PropR) : PropR := P⁻ 62 | prefix: 95 "¬" => notR -- \neg 63 | 64 | -- This is the definition of classical implication (i.e. as opposed to linear implication ⊸) 65 | @[match_pattern] 66 | def impliesR (P Q: PropR) : PropR := (¬P) ∨ Q 67 | infixr : 83 "→" => impliesR -- \imp 68 | 69 | @[simp] 70 | theorem simp_impliesR {P Q: PropR} : ((¬P) ∨ Q) = (P → Q) := by 71 | simp [impliesR] 72 | 73 | @[simp] 74 | theorem simp_not {P : PropR} : P⁻ = ¬P := by 75 | simp [notR] 76 | 77 | 78 | -- Turn any relation into a proposition by unit capping it with full on either side. This is the proposition that R is non-empty, which is also the existential statement that there exists some pair p ∈ R. 79 | @[match_pattern] 80 | def existsR (R : Relation α β) : PropR := full {⋆} α ▹ R ▹ full β {⋆} 81 | prefix: 83 "∃" => existsR 82 | 83 | -- TODO 84 | theorem exists_iff_non_empty (R : Relation α β) : proofR (∃ R) ↔ ¬(R ≈ (empty α β)) := by 85 | sorry 86 | 87 | 88 | -- Uses logical equivalency of ¬∃.¬P 89 | -- Note: To quantify over variables, we need to keep R as a geneneral relation R: α → β ; we don't propositionalize the components of R. Then this construction implicitly quantifies over α × β. 90 | @[match_pattern] 91 | def forAllR (R : Relation α β) := ¬existsR (R⁻) 92 | prefix: 83 "∀" => forAllR 93 | 94 | -- ∀ R if and only if R is equivalent the full relation. 95 | theorem for_all_iff_full (R : Relation α β) : proofR (∀ R) ↔ R ≈ full α β := by sorry 96 | 97 | 98 | 99 | end Relation 100 | -------------------------------------------------------------------------------- /RelationalCalculus/Logic/Metalogic.lean: -------------------------------------------------------------------------------- 1 | -- This is heavily work in progress. Probably not worth looking at yet. 2 | import RelationalCalculus.Logic.SimpTheorems 3 | import RelationalCalculus.Basic 4 | import RelationalCalculus.Utility 5 | import RelationalCalculus.Order 6 | import RelationalCalculus.Eq 7 | import RelationalCalculus.Union 8 | import RelationalCalculus.Intersection 9 | import Mathlib.Tactic 10 | import Init.SimpLemmas 11 | 12 | open Utility 13 | open Relation 14 | open Logic 15 | namespace Logic 16 | 17 | 18 | -- inductive PredCalcSyntax where 19 | -- | atom 20 | -- | negation_ 21 | -- | conjunction 22 | -- | disjunction 23 | -- | implication 24 | -- | universalQ 25 | -- | existentialQ 26 | 27 | -- inductive PredCalc : PredCalcSyntax -> Type (u+1) where 28 | -- | atomPC {α : Type u} (h: α -> Prop)(x: α) : PredCalc atom 29 | -- | negPC (pInd: PredCalc _) : PredCalc negation_ 30 | -- | andPC (left: PredCalc _) (right: PredCalc _): PredCalc conjunction 31 | -- | orPC (left: PredCalc _)(right: PredCalc _) : PredCalc disjunction 32 | -- | impliesPC (left: PredCalc _)(right: PredCalc _) : PredCalc implication 33 | -- | uniPC (α : Type u) (f: α -> PredCalc _) : PredCalc universalQ 34 | -- | exsPC (α : Type u) (f: α -> PredCalc _) : PredCalc existentialQ 35 | 36 | 37 | 38 | -- def PredCalc.predicate {α : Type u} := α → Prop 39 | 40 | 41 | 42 | -- def PredCalc.eval (syn : PredCalcSyntax) (P: (PredCalc _)) : Prop := 43 | -- match syn with 44 | -- | atom => P 45 | -- | sorry 46 | -- | negPC P => ¬(eval P) 47 | -- | andPC P Q => eval P ∧ eval Q 48 | -- | orPC P Q => eval P ∨ eval Q 49 | -- | impliesPC p Q => eval p → eval Q 50 | -- | uniPC α f => ∀(x: α), (eval (f x)) 51 | -- | exsPC α f => ∃(x: α), (eval (f x)) 52 | 53 | namespace Relation 54 | 55 | -- A unary predicate is a selection endorelation. These correspond to subsets of α 56 | 57 | -- structure PredicateR1 (α :Type u) where 58 | -- R: EndoRelation α 59 | -- subset: proofR (R⊑(idR α)) 60 | 61 | 62 | -- theorem rel_calc_pred_calc_atom : := sorry 63 | 64 | 65 | 66 | 67 | -- NOTE: Stuff on higher arity predicates. I actually don't need this to show the correspondance with PredCalc since that uses only unary predicates. 68 | -- structure PredicateR2 (α β :Type u) where 69 | -- R: Relation α β 70 | 71 | -- structure PredicateR3 (α β γ: Type u) where 72 | -- R: Sum (Relation α (β × γ)) (Relation (β × γ) α ) 73 | -- -- Alternatively I can use ⊗ to combine a 1-place and 2-place relation. 74 | 75 | -- structure predicate3' (α β γ: Type u) where 76 | -- R1: PredicateR1 α 77 | -- R2: PredicateR2 β γ 78 | 79 | -- -- Can I generalize this to N-ary. Might need one type for even and one type for Odd. 80 | 81 | -- inductive NaryPredicateR : Nat -> (Type (u + 1)) := 82 | -- | prop (P: PropR) : NaryPredicateR 0 83 | -- | one (R: EndoRelation α) (subset: proofR (R⊑(idR α))) : NaryPredicateR 1 84 | -- | two (R: Relation α β) : NaryPredicateR 2 85 | -- -- TODO: Need to add the relation argument here: 86 | -- -- Maybe use a Vector for the types and then construct the relation type with a function. 87 | -- | nary (n: Nat) (h: n > 2) : NaryPredicateR n 88 | 89 | end Relation 90 | 91 | -- theorem propR_atomPI (P: PropR) : P ≈ TrueR ↔ 92 | -------------------------------------------------------------------------------- /RelationalCalculus/Logic/SimpTheorems.lean: -------------------------------------------------------------------------------- 1 | 2 | namespace Logic 3 | notation "⋆" => PUnit.unit -- \* 4 | notation "{⋆}" => PUnit -- 5 | 6 | @[simp] 7 | theorem forall_punit(P : (a: {⋆}) → Prop) : (∀ (a: {⋆}), P a) = (P ⋆) := by 8 | simp 9 | constructor 10 | · intro h 11 | specialize h ⋆ ; exact h 12 | · intro Pstar a 13 | cases a 14 | exact Pstar 15 | -------------------------------------------------------------------------------- /RelationalCalculus/Logic/Subrelation.lean: -------------------------------------------------------------------------------- 1 | -- Work in progress, not useful yet. 2 | 3 | 4 | -- We define a relational algebraic method of checking if relations are subsets using linear implication. 5 | 6 | -- def subR (S R : Relation α β) : PropR := 7 | -- full {⋆} β ▹ R ⊸ S ▹ full β {⋆} 8 | 9 | -- infixl : 80 "⊑" => subR -- Typed: \squb 10 | 11 | -- theorem sdfdf {α β : Type u} (R S: Relation α β ) : proofR (R ⊑ S) = (R ≤ S) := 12 | -- by 13 | -- -- have h1 : (TrueR ≤ R⊑S) ↔ R ≤ S := by 14 | -- simp [ proofR] 15 | -- simp [(· ≤ ·), proofR, (·⊑·), (·⊸·), eval, domain] 16 | -- sorry 17 | 18 | -- theorem sddfdf {α β : Type u} (R S: Relation α β ) : proofR (S ⊑ R) = (R ≤ S) := 19 | -- by 20 | -- -- have h1 : (TrueR ≤ R⊑S) ↔ R ≤ S := by 21 | -- simp [ proofR] 22 | -- simp [(· ≤ ·), proofR, (·⊑·), (·⊸·), eval, domain] 23 | 24 | 25 | 26 | -- -- rw [simp_proofR_le] at h1 27 | 28 | -- -- , eq, (·⊑·), andR,(·⊸·) ] 29 | 30 | 31 | -- -- Having given a compositional definition of sub-relation we can give a compositional definition of equivalence 32 | -- def equivR (R S: Relation α β) : PropR := andR (subR S R) (subR R S) 33 | -- infixl: 30 "≡" => equivR -- Typed as: \== 34 | 35 | 36 | -- theorem equivR_equiv (R S: Relation α β) : (proofR (R ≡ S)) = (R ≈ S) := by 37 | -- simp [(·≈·), equivR, proofR, eq] 38 | -- constructor 39 | -- · simp 40 | -- intro h1 h2 41 | -- sorry 42 | 43 | -- -- When R is an endoRelation the left selection of R is a subrelation of id. 44 | -- theorem select_left_sub_id {α: Type u} (R: EndoRelation α ) : proofR ((selectLeft R)⊑(idR α)) := by sorry 45 | -- -- simp [selectLeft, (·≈·), eq] 46 | 47 | -- -- When R is an endoRelation the right selection of R is a subrelation of id. 48 | -- theorem select_right_sub_id {α: Type u} (R: EndoRelation α ) : proofR ((selectRight R)⊑(idR α)) := by sorry 49 | 50 | 51 | -- -- TODO 52 | -- -- theorem sub_rel_iff_leq {S R : Relation α β} : S ⊑ R ≈ TrueR ↔ S ≤ R := sorry 53 | 54 | 55 | 56 | -- Forall L, gets left selection and returns subset prop relations for if idR is subset of selection. 57 | -- Recall that a selection is always a subset of idR. 58 | -- def totalImgL (R : Relation α β) : PropR := 59 | -- let Left := selectLeft R 60 | -- idR ⊑ Left 61 | 62 | -- 63 | -- def totalImgR (R : Relation α β) :PropR := 64 | -- let Right := selectRight R 65 | -- idR ⊑ Right 66 | 67 | -- Checks that R is total on right and left images 68 | -- def totalImg (R : Relation α β) :PropR := 69 | -- totalImgR R ∧ totalImgL R 70 | -------------------------------------------------------------------------------- /RelationalCalculus/NewToSort.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Basic 2 | import RelationalCalculus.Order 3 | import RelationalCalculus.Eq 4 | import RelationalCalculus.Element 5 | import Mathlib.Logic.Equiv.Basic 6 | import Mathlib.Tactic 7 | 8 | 9 | -- NOTE: There is some good stuff in here but I need to organize it and figure out which is worth keeping. 10 | 11 | open Relation 12 | 13 | 14 | @[simp] 15 | lemma product_congr {α β γ δ : Type u}{ R R': Relation α β} {S S': Relation γ δ} (hR: R ≈ R') (hS: S ≈ S') : R⊗S ≈ R'⊗S' := by 16 | simp [(· ≈ · ), eq, (· ≤ · ), eval] 17 | constructor <;> intro a c b d Rab Scd 18 | · constructor 19 | · rwa [eq_to_eval hR.symm] 20 | · rwa [eq_to_eval hS.symm] 21 | · constructor 22 | · rwa [eq_to_eval hR] 23 | · rwa [eq_to_eval hS] 24 | 25 | @[simp] 26 | lemma coproduct_congr {α β γ δ : Type u}{ R R': Relation α β} {S S': Relation γ δ} (hR: R ≈ R') (hS: S ≈ S') : (R⊕S) ≈ (R'⊕S') := by 27 | simp [(· ≈ · ), eq, (· ≤ · ), eval] 28 | constructor <;> constructor 29 | · intro a b Rab 30 | rwa [eq_to_eval hR.symm] 31 | · intro c d Scd 32 | rwa [eq_to_eval hS.symm] 33 | · intro a b Rab 34 | rwa [eq_to_eval hR] 35 | · intro c d Scd 36 | rwa [eq_to_eval hS] 37 | 38 | 39 | @[simp] 40 | lemma comp_congr_left {α β γ : Type u}{ R R': Relation α β} {S: Relation β γ } (hR: R ≈ R') : (R▹S) ≈ (R'▹S) := by 41 | simp [(· ≈ · ), eq, (· ≤ · ), eval, domain] 42 | constructor <;> intro a c b Rab Sbc <;> use b 43 | · rw [eq_to_eval hR.symm] 44 | exact ⟨Rab, Sbc⟩ 45 | · rw [eq_to_eval hR.symm] at Rab 46 | exact ⟨Rab, Sbc⟩ 47 | 48 | @[simp] 49 | lemma comp_congr_right {α β γ : Type u}{ R: Relation α β} {S S': Relation β γ } (hS: S ≈ S') : (R▹S) ≈ (R▹S') := by 50 | simp [(· ≈ · ), eq, (· ≤ · ), eval, domain] 51 | constructor <;> intro a c b Rab Sbc <;> use b 52 | · rw [eq_to_eval hS.symm] 53 | exact ⟨Rab, Sbc⟩ 54 | · rw [eq_to_eval hS.symm] at Sbc 55 | exact ⟨Rab, Sbc⟩ 56 | 57 | def coprodFromProd {α β γ δ : Type u} (R: Relation (α × γ) (β × δ)) : Relation (Sum α γ) (Sum β δ) := (first α γᵒ▹R▹first β δ) ⊕ ((second α γᵒ)▹R▹second β δ) 58 | 59 | def prodFromCoprod {α β γ δ : Type u} (R: Relation (Sum α γ) (Sum β δ)) : Relation (α × γ) (β × δ) := (left α γ▹R▹left β δᵒ) ⊗ (right α γ▹R▹right β δᵒ) 60 | 61 | 62 | -- We can only recover R if S is non-empty since otherwise, we have no elemetns in R⊗S. 63 | theorem recover_first_of_prod {α β γ δ : Type u} (R: Relation α β) (S: Relation γ δ) (hNE: isNonEmpty S) : R ≈ (first α γᵒ ▹ (R⊗S) ▹ first β δ) := by 64 | simp [(· ≈ · ), eq, (· ≤ · ), eval] 65 | simp [isNonEmpty,(· ≤ · ), eval] at hNE 66 | 67 | 68 | have hLeft : ∀ (a : α) (b : β), R.eval a b → R.eval a b ∧ ∃ x x_1, S.eval x_1 x := by 69 | intro a b Rab 70 | constructor 71 | · assumption 72 | · obtain ⟨c, h⟩ := hNE 73 | obtain ⟨d, h⟩ := h 74 | use d ; use c 75 | 76 | have hRight : (∀ (a : α) (b : β), R.eval a b → ∀ (x : δ) (x_1 : γ), S.eval x_1 x → R.eval a b) := by 77 | intro a b Rab d c _ ; assumption 78 | 79 | exact ⟨ hLeft, hRight ⟩ 80 | 81 | 82 | 83 | -- We can only recover S if R is non-empty since otherwise, we have no elemetns in R⊗S. 84 | theorem recover_second_of_prod {α β γ δ : Type u} (R: Relation α β) (S: Relation γ δ) (hNE: isNonEmpty R) : S ≈ (second α γᵒ ▹ (R⊗S) ▹ second β δ) := by 85 | simp [(· ≈ · ), eq, (· ≤ · ), eval] 86 | simp [isNonEmpty,(· ≤ · ), eval] at hNE 87 | intro a b Sab; 88 | obtain ⟨a', h⟩ := hNE 89 | obtain ⟨b', h⟩ := h 90 | constructor 91 | · use b' ; use a' 92 | · exact Sab 93 | 94 | 95 | theorem recover_left_of_coprod {α β γ δ : Type u} (R: Relation α β) (S: Relation γ δ) : R ≈ (left α γ ▹ R⊕S ▹ left β δᵒ) := by 96 | simp [(· ≈ · ), eq, (· ≤ · ), prodFromCoprod, eval] 97 | 98 | theorem recover_right_of_coprod {α β γ δ : Type u} (R: Relation α β ) (S: Relation γ δ ) : S ≈ (right α γ ▹ R⊕S ▹ right β δᵒ) := by simp [(· ≈ · ), eq, (· ≤ · ), prodFromCoprod, eval] 99 | 100 | 101 | theorem coproduct_equiv_prod {α β γ δ : Type u} (R: Relation α β ) (S: Relation γ δ ) : (prodFromCoprod (R⊕S)) ≈ (R⊗S) := by 102 | simp [prodFromCoprod] 103 | have h1 := recover_left_of_coprod R S 104 | have h2 := recover_right_of_coprod R S 105 | have h3 := product_congr h1 h2 106 | exact h3.symm 107 | 108 | -- I might not need this 109 | theorem atom_prod_coprod {α β γ δ : Type u} {R: Relation (α × γ) (β × δ)} : eval (coprodFromProd R) = (fun(v1: Sum α γ) => fun ( v2: Sum β δ ) => 110 | match v1, v2 with 111 | | Sum.inl a, Sum.inl b => ∃ c' d', eval R (a, c') (b, d') 112 | | Sum.inr c, Sum.inr d => ∃ a' b', eval R (a', c) (b', d) 113 | | _,_ => False 114 | ) := by 115 | simp [coprodFromProd, eval] 116 | ext x x_1 : 3 117 | cases x with 118 | | inl val => 119 | cases x_1 with 120 | | inl val_1 => 121 | simp_all only 122 | constructor <;> 123 | intro a <;> obtain ⟨d, c, h⟩ := a <;> use c <;> use d 124 | | inr val_2 => simp_all only 125 | | inr val_1 => 126 | cases x_1 with 127 | | inl val => simp_all only 128 | | inr val_2 => 129 | simp_all only 130 | constructor <;> intro a 131 | <;> obtain ⟨b, a, h⟩ := a 132 | <;> use a <;> use b 133 | 134 | -- I might not need this 135 | theorem atom_coprod_prod {α β γ δ : Type u} {R: Relation (Sum α γ) (Sum β δ)} : eval (prodFromCoprod R) = (fun ((a,c): α × γ) ((b,d): β × δ) => 136 | (eval R (Sum.inl a) (Sum.inl b)) ∧ eval R (Sum.inr c) (Sum.inr d)) := by 137 | simp [(· ≈ · ), eq, (· ≤ · ), prodFromCoprod, eval] 138 | 139 | 140 | 141 | 142 | -- coprodFromProd will have R inl a inl b and R inr c inr d iff R has (a, b)(c,d) 143 | 144 | theorem prod_imp_coprod_conjunction {α β γ δ : Type u} {R: Relation α β } {S: Relation γ δ } : ∀ (a: α )(c : γ) (b : β ) (d: δ), ((R⊗S).eval (a,c) (b,d)) → (((coprodFromProd (R⊗S)).eval (Sum.inl a) (Sum.inl b)) ∧ ((coprodFromProd (R⊗S)).eval (Sum.inr c) (Sum.inr d))) := by 145 | intro a c b d 146 | rw [atom_prod_coprod] 147 | simp [eval] 148 | intro Rab Scd 149 | constructor 150 | · constructor 151 | · exact Rab 152 | · use c ; use d 153 | · constructor 154 | · use a ; use b 155 | · exact Scd 156 | 157 | theorem coprod_conjunction_imp_prod {α β γ δ : Type u} {R: Relation α β } {S: Relation γ δ } : ∀ (a: α )(c : γ) (b : β ) (d: δ), (((coprodFromProd (R⊗S)).eval (Sum.inl a) (Sum.inl b)) ∧ ((coprodFromProd (R⊗S)).eval (Sum.inr c) (Sum.inr d))) → ((R⊗S).eval (a,c) (b,d)) := by 158 | intro a c b d 159 | rw [atom_prod_coprod] 160 | simp [eval] 161 | intro Rab c' d' _ a' b' _ Scd 162 | constructor <;> assumption 163 | 164 | 165 | theorem prod_eq_coprod_conjunction {α β γ δ : Type u} {R: Relation α β } {S: Relation γ δ } : ∀ (a: α )(c : γ) (b : β ) (d: δ), ((R⊗S).eval (a,c) (b,d)) = (((coprodFromProd (R⊗S)).eval (Sum.inl a) (Sum.inl b)) ∧ ((coprodFromProd (R⊗S)).eval (Sum.inr c) (Sum.inr d))) := by 166 | intro a b c d 167 | simp 168 | constructor 169 | · exact prod_imp_coprod_conjunction a b c d 170 | · exact coprod_conjunction_imp_prod a b c d 171 | 172 | 173 | -- A product can be converted to a coproduct and back again. 174 | theorem product_inverse {α β γ δ : Type u} {R: Relation α β } {S: Relation γ δ } : R⊗S ≈ prodFromCoprod (coprodFromProd (R⊗S)) := by 175 | simp only [(· ≈ · ), eq, (· ≤ · )] 176 | rw [atom_coprod_prod, atom_prod_coprod] 177 | simp_all 178 | constructor 179 | · intro a c b d RS 180 | constructor 181 | · use c ; use d 182 | · use a ; use b 183 | · intro a c b d c' d' 184 | -- TODO: Modify prod_eq_coprod_conjunction so it works without applying explicit arguments. Maybe I need to make a c b d implicit arguments as well. 185 | have h := @prod_eq_coprod_conjunction α β γ δ R S a c' b d' 186 | rw [h ] 187 | simp [eval] 188 | intro Rab d3 c3 _ b3 a3 _ _ a4 b4 _ Scd 189 | constructor <;> assumption 190 | 191 | 192 | 193 | -- Interesting. So I discovered that you can't recover the coproduct when one of the sides is empty. 194 | theorem coproduct_inverse {α β γ δ : Type u} {R: Relation α β } {S: Relation γ δ } (hNER: isNonEmpty R)(hNES: isNonEmpty S): (R⊕S) ≈ coprodFromProd (prodFromCoprod (R⊕S)) := by 195 | have h : prodFromCoprod (R ⊕ S) ≈ R ⊗ S := coproduct_equiv_prod R S 196 | have hFirst : (first α γᵒ ▹ prodFromCoprod (R ⊕ S) ▹ first β δ) ≈ (first α γᵒ ▹ R⊗S ▹ first β δ) := by 197 | have h4 : (first α γᵒ ▹ prodFromCoprod (R ⊕ S)) ≈ (first α γᵒ ▹ R⊗S) := by exact comp_congr_right h 198 | exact comp_congr_left h4 199 | 200 | have hSecond : (second α γᵒ ▹ prodFromCoprod (R ⊕ S) ▹ second β δ) ≈ (second α γᵒ ▹ R⊗S ▹ second β δ) := by 201 | have h4 : (second α γᵒ ▹ prodFromCoprod (R ⊕ S)) ≈ (second α γᵒ ▹ R⊗S) := by exact comp_congr_right h 202 | exact comp_congr_left h4 203 | simp only [coprodFromProd] 204 | have hEquiv := coproduct_congr hFirst hSecond 205 | apply symm 206 | apply (instSetoid.iseqv.trans hEquiv) 207 | 208 | 209 | have hCoprod : (R ⊕ S) ≈ (first α γᵒ ▹ R ⊗ S ▹ first β δ) ⊕ (second α γᵒ ▹ R ⊗ S ▹ second β δ) := by 210 | have hLeft : R ≈ (first α γᵒ ▹ R ⊗ S ▹ first β δ) := by 211 | exact recover_first_of_prod R S hNES 212 | have hRight : S ≈ (second α γᵒ ▹ R ⊗ S ▹ second β δ) := by 213 | exact recover_second_of_prod R S hNER 214 | exact coproduct_congr hLeft hRight 215 | apply (instSetoid.iseqv.trans hCoprod.symm) 216 | simp_all 217 | rfl 218 | -------------------------------------------------------------------------------- /RelationalCalculus/Order.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Basic 2 | import Mathlib.Tactic 3 | open Relation 4 | 5 | -- Ordering by Inclusion 6 | -- Define the LE instance for Relation 7 | -- Now we can use ≤ notation for relations 8 | 9 | instance : LE (Relation α β) where 10 | le R S := ∀ a b, eval R a b → eval S a b 11 | 12 | namespace Relation 13 | -- R ≤ S if and only if they eval to pair functions that are less than or equal to eachother. 14 | 15 | theorem le_rel_iff_le_eval {α β : Type u} {R S : Relation α β} : 16 | R ≤ S ↔ (eval R ≤ eval S) := by 17 | rfl 18 | 19 | -- Prove that this ordering is reflexive 20 | theorem le_refl (R : Relation α β) : R ≤ R := by 21 | intros _ _ h 22 | exact h 23 | 24 | -- Prove that this ordering is transitive 25 | theorem le_trans {R S T : Relation α β} (h₁ : R ≤ S) (h₂ : S ≤ T) : R ≤ T := by 26 | intros a b hR 27 | exact h₂ a b (h₁ a b hR) 28 | 29 | end Relation 30 | 31 | 32 | -- Create the Preorder instance 33 | -- This automatically enables us to use ≤ notation to indicate ordering of relations. Note that the use of ≤ is essentially a semantic operation since it is defined in terms of evaluation. 34 | instance : Preorder (Relation α β) where 35 | le := (· ≤ ·) 36 | le_refl := Relation.le_refl 37 | le_trans := @Relation.le_trans _ _ 38 | 39 | @[simp] 40 | def le_notation_simp {α β : Type u} {R S: Relation α β } : (R ≤ S) = ∀ (a : α) (b : β), R.eval a b → S.eval a b:= by rfl 41 | 42 | 43 | def Relation.Preorder := @instPreorderRelation 44 | 45 | def Relation.le {α β : Type u} := (@instLERelation α β).le 46 | 47 | 48 | --- ORDER THEOREMS --- 49 | 50 | 51 | -- Left monotonicity: if S ≤ T then (R▹S) ≤ (R▹T) 52 | theorem comp_monotonic_left {α β γ: Type u} (R: Relation α β) (S T: Relation β γ) 53 | (h: S ≤ T): (R▹S) ≤ (R▹T) := by 54 | simp [(·≤·), eval, domain, codomain] 55 | intro a c b Rab Sbc 56 | use b 57 | constructor 58 | · exact Rab 59 | · apply h 60 | simp_all 61 | 62 | -- Right monotonicity: if S ≤ T then (S▹R) ≤ (T▹R) 63 | theorem comp_monotonic_right {α β γ: Type u} (S T: Relation α β) (R: Relation β γ) 64 | (h: S ≤ T): (S▹R) ≤ (T▹R) := by 65 | simp [(·≤·), eval, domain, codomain] 66 | intro a c b Sab Rbc 67 | use b 68 | constructor 69 | · apply h 70 | simp_all 71 | · exact Rbc 72 | 73 | 74 | -- Monotonicity for relative sum 75 | theorem sum_monotonic_left {α β γ: Type u} (R: Relation α β) (S T: Relation β γ) (h: S ≤ T): (R✦S) ≤ (R✦T) := by 76 | simp_all [eval] 77 | 78 | 79 | theorem sum_monotonic_right {α β γ: Type u} (S T: Relation α β) (R: Relation β γ) (h: S ≤ T): (S✦R) ≤ (T✦R) := by 80 | simp_all [eval] 81 | intro a c nS_R b nT 82 | apply nS_R 83 | apply Aesop.BuiltinRules.not_intro 84 | intro Sab 85 | simp_all only [not_true_eq_false] 86 | -------------------------------------------------------------------------------- /RelationalCalculus/Quotient.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Basic 2 | import RelationalCalculus.Order 3 | import RelationalCalculus.Eq 4 | import Mathlib.Tactic 5 | open Relation 6 | 7 | -- Defines the type of relations quotiented by evaluation equivalence. 8 | def RelationQuotient (α β : Type u) := Quotient (@instSetoidRelation α β) 9 | 10 | 11 | namespace RelationQuotient 12 | def atomic {α β : Type u} (f : Relation.Pairs α β) : RelationQuotient α β := 13 | Quotient.mk _ (Relation.atomic f) 14 | 15 | def idR (α : Type u) : RelationQuotient α α := 16 | Quotient.mk _ (Relation.idR α) 17 | #check idR 18 | def pair {α β : Type u} (a : α) (b : β) : RelationQuotient α β := 19 | Quotient.mk _ (Relation.pair a b) 20 | 21 | 22 | def comp {α β γ : Type u} (R : RelationQuotient α β) (S : RelationQuotient β γ) : RelationQuotient α γ := 23 | Quotient.lift₂ (fun R' S' => Quotient.mk _ (Relation.comp R' S')) (fun R S R' S' h1 h2 => Quotient.sound (by 24 | have RR'eval := eq_to_eval h1 25 | have SS'eval := eq_to_eval h2 26 | simp [(·≈·), (·≤·), AntisymmRel] 27 | constructor <;> intro a c <;> 28 | simp [eval, domain] <;> intro b 29 | · intro Reval Seval 30 | use b 31 | rw [RR'eval.symm, SS'eval.symm] 32 | exact ⟨Reval, Seval⟩ 33 | · intro R'eval S'eval 34 | rw [RR'eval, SS'eval] 35 | exact ⟨b, ⟨R'eval, S'eval ⟩⟩ 36 | )) R S 37 | 38 | theorem comp_id {X Y: Type u} : ∀ (Rq : RelationQuotient X Y), comp Rq (idR Y) = Rq := by 39 | apply Quotient.ind 40 | intro R 41 | apply Quotient.sound 42 | simp [(·≈·), AntisymmRel, LE.le,Relation.eval] 43 | 44 | theorem id_comp {X Y: Type u} : ∀ (Rq : RelationQuotient X Y), comp (idR X) Rq = Rq := by 45 | apply Quotient.ind 46 | intro R 47 | apply Quotient.sound 48 | simp [(·≈·), AntisymmRel, LE.le,Relation.eval] 49 | 50 | theorem comp_assoc {W X Y Z : Type u} : 51 | ∀ 52 | (R : RelationQuotient W X) 53 | (S : RelationQuotient X Y) 54 | (T : RelationQuotient Y Z), 55 | (comp (comp R S) T) = (comp R (comp S T)) := by 56 | apply Quotient.ind 57 | intro R 58 | apply Quotient.ind 59 | intro S 60 | apply Quotient.ind 61 | intro T 62 | apply Quotient.sound 63 | simp [(·≈·), AntisymmRel, LE.le,Relation.eval, Relation.domain] 64 | constructor <;> intro a b 65 | · intro y x Re Se Te 66 | use x 67 | constructor 68 | · exact Re 69 | · use y 70 | · intro x Re y Se Te 71 | use y 72 | constructor 73 | · use x 74 | · exact Te 75 | 76 | 77 | end RelationQuotient 78 | -------------------------------------------------------------------------------- /RelationalCalculus/Residuals.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Basic 2 | import RelationalCalculus.Order 3 | import RelationalCalculus.Eq 4 | import Mathlib.Tactic 5 | open Relation 6 | 7 | namespace Relation 8 | 9 | -- A left residual candidate is any relation that solves the inequality (R▹X) ≤ S 10 | -- NOTE: I could call this "residual" and call the other "coresidual" 11 | def leftResidualCandidate {α β : Type u} (R S: Relation α β) := {X: Relation β β | (R▹X) ≤ S } 12 | 13 | --- R ▹ X ≤ S 14 | -- Schroder equialences 15 | -- R▹X ≤ S ≃ X ≤ R⊸S ≃ R ≤ S⟜X 16 | 17 | -- Definitions of (Left??) Residual 18 | -- R⊸S = Rᗮ ▶ S = (Rᵒ▹S⁻)⁻ 19 | 20 | -- Key thing to prove 21 | -- R▹(R⊸S) ≤ S 22 | 23 | -- A left residual is a left residual candidate that is greater or equal to all candidates. 24 | def leftResiduals {α β : Type u} (R S: Relation α β) := {X: Relation β β | X ∈ (leftResidualCandidate R S) ∧ ∀ (Y: (leftResidualCandidate R S)), Y ≤ X } 25 | 26 | -- All left residuals are equivalent under evaluation. 27 | theorem leftResidualsEquiv {α β : Type u} (R S: Relation α β) : 28 | ∀ (X X': ↑(R.leftResiduals S)), (X ≈ X') := by 29 | intro ⟨X, hX⟩ ⟨X', hX'⟩ 30 | constructor 31 | · have h_X : X ∈ leftResidualCandidate R S ∧ 32 | ∀ (Y: leftResidualCandidate R S), Y ≤ X := hX 33 | have h_X' : X' ∈ leftResidualCandidate R S ∧ 34 | ∀ (Y: leftResidualCandidate R S), Y ≤ X' := hX' 35 | have h_X_in_candidate : X ∈ R.leftResidualCandidate S := h_X.left 36 | exact h_X'.right ⟨X, h_X_in_candidate⟩ 37 | · have h_X : X ∈ leftResidualCandidate R S ∧ 38 | ∀ (Y: leftResidualCandidate R S), Y ≤ X := hX 39 | have h_X' : X' ∈ leftResidualCandidate R S ∧ 40 | ∀ (Y: leftResidualCandidate R S), Y ≤ X' := hX' 41 | have h_X'_in_candidate : X' ∈ R.leftResidualCandidate S := h_X'.left 42 | exact h_X.right ⟨X', h_X'_in_candidate⟩ 43 | 44 | def linImp (R S : Relation α β): Relation β β := (Rᵒ▹S⁻)⁻ 45 | abbrev leftResidual (R S : Relation α β) := linImp R S 46 | def rightResidual (R S : Relation α β) := (S⁻▹Rᵒ)⁻ 47 | 48 | --NOTATION FOR Linear Implication 49 | infixr : 50 "⊸" => linImp -- \multi 50 | infixl : 50 "⟜" => rightResidual 51 | 52 | 53 | 54 | 55 | -- The composition ((Rᵒ▹S⁻)⁻) which defines linear implication, gives us a left residual for R and S 56 | theorem lin_imp_left_residual {α β : Type u} (R S: Relation α β): (R ⊸ S) ∈ (leftResiduals R S) := by 57 | let X := ((Rᵒ▹S⁻)⁻) 58 | -- First, show that X ∈ leftResidualCandidate R S 59 | have h1 : (R ▹ X) ≤ S := by 60 | -- Need to show that for all a b, if eval (R ▹ X) a b then eval S a b 61 | intros a b h_eval_R_X 62 | -- h_eval_R_X : eval (R ▹ X) a b 63 | -- So there exists c such that eval R a c ∧ eval X c b 64 | rcases h_eval_R_X with ⟨c, h_eval_Rac, h_eval_Xcb⟩ 65 | -- eval X c b = ¬(eval (Rᵒ▹S⁻) c b) 66 | have h_eval_Xcb_eq : eval X c b = ¬(eval (Rᵒ▹S⁻) c b) := by simp [eval] 67 | -- So h_eval_Xcb = ¬(eval (Rᵒ▹S⁻) c b) 68 | rw [h_eval_Xcb_eq] at h_eval_Xcb 69 | -- Suppose for contradiction that ¬(eval S a b) 70 | by_contra h_not_Sab 71 | -- Now, consider that eval (Rᵒ▹S⁻) c b holds 72 | have h_eval_Ro_Sneg_c_b : eval (Rᵒ▹S⁻) c b := by 73 | -- Need to show ∃ d, eval Rᵒ c d ∧ eval S⁻ d b 74 | exists a 75 | contradiction 76 | -- So (R ▹ X) ≤ S, so X ∈ leftResidualCandidate R S 77 | have h_candidate : X ∈ leftResidualCandidate R S := h1 78 | -- Now, need to show that X is greater than any Y ∈ leftResidualCandidate R S 79 | have h2 : ∀ (Y : R.leftResidualCandidate S), Y ≤ X := by 80 | intros Y a b aYb 81 | -- Since Y ∈ leftResidualCandidate R S, (R ▹ Y) ≤ S 82 | have RY_less_S := Y.property.out 83 | 84 | -- Suppose for contradiction that ¬(eval X a b) 85 | have h_eval_Xab_eq : eval X a b = ¬(eval (Rᵒ▹S⁻) a b) := by simp [eval] 86 | by_contra h_not_Xab 87 | -- Then eval (Rᵒ▹S⁻) a b holds 88 | have h_eval_Ro_Sneg_ab : eval (Rᵒ▹S⁻) a b := by 89 | rw [h_eval_Xab_eq] at h_not_Xab 90 | exact not_not.mp h_not_Xab 91 | -- So there exists c, eval Rᵒ a c ∧ eval S⁻ c b 92 | rcases h_eval_Ro_Sneg_ab with ⟨c, h_eval_Ro_ac, h_eval_Sneg_cb⟩ 93 | -- eval Rᵒ a c = eval R c a 94 | have h_eval_Rca : eval R c a := h_eval_Ro_ac 95 | -- Now, since eval Y a b, and eval R c a, we have eval (R ▹ Y) c b 96 | have h_eval_RY_c_b : eval (R ▹ Y) c b := by 97 | use a 98 | -- Since (R ▹ Y) ≤ S, eval S c b holds 99 | have h_eval_Scb : eval S c b := RY_less_S c b h_eval_RY_c_b 100 | -- Contradicts h_not_Scb 101 | contradiction 102 | -- Therefore, X ∈ leftResiduals R S 103 | exact ⟨h_candidate, h2⟩ 104 | 105 | -- TODO: Prove the analogous theorem for right residual. 106 | 107 | 108 | theorem lin_imp_le {α β : Type u} (R S: Relation α β) : ((R ⊸ S) ≈ full β β) → R ≤ S := by 109 | intro h 110 | have h_neg_empty : eval (Rᵒ ▹ S⁻) = (fun _ _ => False) := by 111 | -- Since (R ⊸ S) ≈ full, its complement is empty. 112 | have h_comp : eval ((Rᵒ ▹ S⁻)) = (eval ((R ⊸ S)⁻)) := by 113 | simp [linImp, eval] 114 | rw [h_comp] 115 | have RSCompEval : (eval ((R ⊸ S)⁻)) = fun b1 b2 => ¬ (eval (full β β) b1 b2) := by 116 | -- Use the fact that (R ⊸ S) ≈ full 117 | rw [(Relation.eq_to_eval h).symm] 118 | simp [eval] 119 | rw [RSCompEval] 120 | simp [eval, full] 121 | 122 | -- Now, to prove R ≤ S, we need to show that for all a b, R.eval a b → S.eval a b. 123 | intros a b Rab 124 | by_contra notSab -- Assume ¬S.eval a b 125 | -- Since R.eval a b and ¬S.eval a b, we have eval R a b ∧ ¬eval S a b 126 | -- Consider eval (Rᵒ ▹ S⁻) b b 127 | have counter : eval (Rᵒ ▹ S⁻) b b := by 128 | exists a 129 | -- But from h_neg_empty, eval (Rᵒ ▹ S⁻) b b = False, which is a contradiction 130 | rw [h_neg_empty] at counter 131 | contradiction 132 | 133 | -- Note: I don't think the inverse theorem follows. I tried proving it false, but could not complete the proof 134 | -- theorem le_lin_imp {α β : Type u} (R S: Relation α β) : ¬ ((R ≤ S) → ((R ⊸ S)) ≈ full β β) := by 135 | -- let R1Pairs := fun (a b: Bool) => 136 | -- match a, b with 137 | -- | false, false => True 138 | -- | _,_ => False 139 | -- let R1 : Relation Bool Bool := atomic R1Pairs 140 | -- let S1 := idR Bool 141 | -- have h1 : R1 ≤ S1 := by 142 | -- simp [(·≤·), eval] 143 | -- have h3 : ¬ (∀ {T: Type (u+1)} {α β : T} (R S : Relation α β), (R ≤ S → (R⊸S) ≈ full β β)) := by 144 | -- by_contra notH3 145 | -- have myCase := @notH3 (Type 1) (Bool:Type) R1 S1 146 | -- I don't understand what is going on with the universe variables here. It seems like it won't infer u. 147 | 148 | 149 | end Relation 150 | -------------------------------------------------------------------------------- /RelationalCalculus/Union.lean: -------------------------------------------------------------------------------- 1 | import RelationalCalculus.Basic 2 | import RelationalCalculus.Order 3 | import RelationalCalculus.Eq 4 | import Mathlib.Tactic 5 | open Relation 6 | 7 | 8 | --- *** Relational Union *** 9 | 10 | -- Compositional definition of union of relations. I should prove that this yeilds the set theoretic definition of union of pairs. 11 | @[match_pattern] 12 | def Relation.union (R : Relation α β) (S : Relation α β) := (split α) ▹ (R⊕S) ▹ (collapse β) 13 | 14 | 15 | namespace Relation 16 | infixl:50 "∪" => Relation.union 17 | end Relation 18 | 19 | -- We give the direct set-theoretic definition of a union of two relations. 20 | def Relation.union_pairs_def (R : Relation α β) (S : Relation α β) : Pairs α β := fun a b => eval R a b ∨ eval S a b 21 | 22 | -- Proof that the compositional definition of union is equal to the set theoretic definiton. 23 | theorem Relation.union_eval_eq_pairs (R : Relation α β) (S : Relation α β) : eval (R ∪ S) = union_pairs_def R S := by 24 | apply funext 25 | intro a 26 | apply funext 27 | intro b 28 | simp [Relation.eval, union_pairs_def, Relation.union] 29 | 30 | theorem Relation.union_assoc {R S T : Relation α β} : 31 | ((R ∪ S) ∪ T) ≈ (R ∪ (S ∪ T)) := by 32 | rw [eq_iff_forall_eval_eq] 33 | simp [union, (·≈·), eval] 34 | intro a b 35 | have assoc := @or_assoc (R.eval a b) (S.eval a b) (T.eval a b) 36 | constructor <;> intro h1 37 | · exact assoc.mp h1 38 | · exact assoc.mpr h1 39 | 40 | -- A left side of a union is less then or equal to the union it is a part of 41 | theorem Relation.union_left_le (R S : Relation α β) : R ≤ Relation.union R S := by 42 | intros a b h 43 | simp [union, eval] 44 | use Or.inl h 45 | 46 | -- -- A right side of a union is less then or equal to the union it is a part of 47 | theorem Relation.union_right_le (R S : Relation α β) : R ≤ Relation.union S R := by 48 | intros a b h 49 | simp [union, eval] 50 | use Or.inr h 51 | 52 | -- Union of two lesser relations is lesser, i.e., union preserves ordering 53 | theorem Relation.union_le {R S T : Relation α β} (hR : R ≤ T) (hS : S ≤ T) : Relation.union R S ≤ T := by 54 | intros a b h 55 | simp [Relation.eval, Relation.union] at h 56 | rcases h with aRb | aSb 57 | · exact hR a b aRb 58 | · exact hS a b aSb 59 | 60 | 61 | -- Proof that union is commutative. 62 | theorem Relation.union_comm {α β : Type u } {R S : Relation α β } : (S ∪ R) ≈ (R ∪ S) := by 63 | simp [(·≈·)] 64 | have RLeft : R ≤ (R ∪ S) := union_left_le R S 65 | have RRight : R ≤ (S ∪ R) := union_right_le R S 66 | have SLeft : S ≤ (S ∪ R) := union_left_le S R 67 | have SRight : S ≤ (R ∪ S) := union_right_le S R 68 | have SR_le_RS := union_le SRight RLeft 69 | have RS_le_SE := union_le RRight SLeft 70 | exact ⟨SR_le_RS, RS_le_SE⟩ 71 | 72 | 73 | -- Composition on the left distributes over union. 74 | theorem comp_intersect_dist_left {α β γ: Type u} (R: Relation α β)(S T: Relation β γ ): (R▹(S ∪ T)) ≈ ((R▹S) ∪ (R▹T)) := by 75 | simp [(·≈· ),eq,(·≤·), eval, domain, codomain] 76 | constructor 77 | · intro a c b Rab S_or_Tbc 78 | cases S_or_Tbc with 79 | | inl Sbc => 80 | apply Or.inl 81 | use b 82 | | inr Tbc => 83 | apply Or.inr 84 | use b 85 | · intro a c h 86 | cases h with 87 | | inl E_RS => 88 | obtain ⟨b, Rab, Sbc⟩ := E_RS 89 | use b 90 | simp_all 91 | | inr E_RT => 92 | obtain ⟨b, Rab, Tbc⟩ := E_RT 93 | use b 94 | simp_all 95 | 96 | 97 | -- Composition on the right distributes over union. 98 | theorem comp_intersect_dist_right {α β γ: Type u} (S T: Relation α β ) (R: Relation β γ ): ((S ∪ T)▹R) ≈ ((S▹R) ∪ (T▹R)) := by 99 | simp [(·≈· ),eq,(·≤·), eval, domain, codomain] 100 | constructor 101 | · intro a c b S_or_Tab Rbc 102 | cases S_or_Tab with 103 | | inl Sab => 104 | apply Or.inl 105 | use b 106 | | inr Tac => 107 | apply Or.inr 108 | use b 109 | · intro a c E__SR_or_TR 110 | cases E__SR_or_TR with 111 | | inl E_SR => 112 | obtain ⟨b, ⟨Sab, Rbc⟩ ⟩ := E_SR 113 | use b 114 | simp_all 115 | | inr E_TR => 116 | obtain ⟨b, ⟨Tab, Rbc⟩ ⟩ := E_TR 117 | use b 118 | simp_all 119 | 120 | 121 | -- TODO: 122 | -- Union is contained in relative sum (both sides) 123 | theorem sum_union_le_left {α β γ: Type u} (R: Relation α β) (S T: Relation β γ): 124 | ((R✦S) ∪ (R✦T)) ≤ (R✦(S ∪ T)) := by 125 | sorry 126 | 127 | 128 | 129 | 130 | theorem sum_union_le_right {α β γ: Type u} (S T: Relation α β) (R: Relation β γ): 131 | ((S✦R) ∪ (T✦R)) ≤ ((S ∪ T)✦R) := by sorry 132 | -------------------------------------------------------------------------------- /RelationalCalculus/Utility.lean: -------------------------------------------------------------------------------- 1 | import Mathlib.Tactic 2 | universe u v 3 | 4 | namespace Utility 5 | 6 | @[reducible] 7 | def typeof {α : Sort u} (_:α) := α 8 | -------------------------------------------------------------------------------- /lake-manifest.json: -------------------------------------------------------------------------------- 1 | {"version": "1.1.0", 2 | "packagesDir": ".lake/packages", 3 | "packages": 4 | [{"url": "https://github.com/leanprover-community/batteries", 5 | "type": "git", 6 | "subDir": null, 7 | "scope": "leanprover-community", 8 | "rev": "46fed98b5cac2b1ea64e363b420c382ed1af0d85", 9 | "name": "batteries", 10 | "manifestFile": "lake-manifest.json", 11 | "inputRev": "main", 12 | "inherited": true, 13 | "configFile": "lakefile.lean"}, 14 | {"url": "https://github.com/leanprover-community/quote4", 15 | "type": "git", 16 | "subDir": null, 17 | "scope": "leanprover-community", 18 | "rev": "2c8ae451ce9ffc83554322b14437159c1a9703f9", 19 | "name": "Qq", 20 | "manifestFile": "lake-manifest.json", 21 | "inputRev": "master", 22 | "inherited": true, 23 | "configFile": "lakefile.lean"}, 24 | {"url": "https://github.com/leanprover-community/aesop", 25 | "type": "git", 26 | "subDir": null, 27 | "scope": "leanprover-community", 28 | "rev": "e5e4f1e9385f5a636cd95f7b5833d9ba7907115c", 29 | "name": "aesop", 30 | "manifestFile": "lake-manifest.json", 31 | "inputRev": "master", 32 | "inherited": true, 33 | "configFile": "lakefile.toml"}, 34 | {"url": "https://github.com/leanprover-community/ProofWidgets4", 35 | "type": "git", 36 | "subDir": null, 37 | "scope": "leanprover-community", 38 | "rev": "eb08eee94098fe530ccd6d8751a86fe405473d4c", 39 | "name": "proofwidgets", 40 | "manifestFile": "lake-manifest.json", 41 | "inputRev": "v0.0.42", 42 | "inherited": true, 43 | "configFile": "lakefile.lean"}, 44 | {"url": "https://github.com/leanprover/lean4-cli", 45 | "type": "git", 46 | "subDir": null, 47 | "scope": "", 48 | "rev": "2cf1030dc2ae6b3632c84a09350b675ef3e347d0", 49 | "name": "Cli", 50 | "manifestFile": "lake-manifest.json", 51 | "inputRev": "main", 52 | "inherited": true, 53 | "configFile": "lakefile.toml"}, 54 | {"url": "https://github.com/leanprover-community/import-graph", 55 | "type": "git", 56 | "subDir": null, 57 | "scope": "leanprover-community", 58 | "rev": "fb7841a6f4fb389ec0e47dd4677844d49906af3c", 59 | "name": "importGraph", 60 | "manifestFile": "lake-manifest.json", 61 | "inputRev": "main", 62 | "inherited": true, 63 | "configFile": "lakefile.toml"}, 64 | {"url": "https://github.com/leanprover-community/mathlib4", 65 | "type": "git", 66 | "subDir": null, 67 | "scope": "leanprover-community", 68 | "rev": "231230030bdeffb80c13c152c817c246a762bb35", 69 | "name": "mathlib", 70 | "manifestFile": "lake-manifest.json", 71 | "inputRev": "master", 72 | "inherited": false, 73 | "configFile": "lakefile.lean"}], 74 | "name": "RelationalCalculus", 75 | "lakeDir": ".lake"} 76 | -------------------------------------------------------------------------------- /lakefile.lean: -------------------------------------------------------------------------------- 1 | import Lake 2 | open Lake DSL 3 | 4 | package "RelationalCalculus" where 5 | -- Settings applied to both builds and interactive editing 6 | leanOptions := #[ 7 | ⟨`pp.unicode.fun, true⟩ -- pretty-prints `fun a ↦ b` 8 | ] 9 | -- add any additional package configuration options here 10 | 11 | require "leanprover-community" / "mathlib" 12 | 13 | @[default_target] 14 | lean_lib «RelationalCalculus» where 15 | -- add any library configuration options here 16 | -------------------------------------------------------------------------------- /lean-toolchain: -------------------------------------------------------------------------------- 1 | leanprover/lean4:v4.12.0-rc1 2 | -------------------------------------------------------------------------------- /todo.md: -------------------------------------------------------------------------------- 1 | 2 | # Refactoring 3 | 4 | []Use Relation namespace in Core.lean 5 | []Define notation co-located with definitions of operations. 6 | []Use notation consistently 7 | []Core.lean 8 | []Order 9 | []Eq 10 | []Union 11 | []Intersection 12 | 13 | 14 | -- Notation 15 | -- Document the notation and track the precedence 16 | 17 | 18 | -- Other Theorems to Possibly Prove 19 | 20 | --Pairs: 21 | -- Prove that every relation is equal to a (possibly infinite) union of pairs. Not sure if my current union definition allows for infinite unions. 22 | 23 | -- Prove that if S ⊆ R and S is non-empty then there is a composition T;R;T' = S such that T and T' are subrelations of Id 24 | 25 | -- Prove demorgan dualities between union and intersection 26 | 27 | -- Prove distributive laws from Tarski paper for union and intersection. 28 | 29 | -- Prove that Types and Relations form a category. 30 | 31 | -- Show that this category forms an allegoy with union. 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | -- TODO: Prove that the so-called "allegory" laws holds for relations. 40 | -- https://en.wikipedia.org/wiki/Allegory_(mathematics) 41 | -- Allegory laws for intersection 42 | -- Prove, intersection is idempotent, associative, commutative 43 | -- Prove, converse distributes over intersection 44 | -- composition is semi-distributive over union 45 | -- modularity law 46 | -- Questions: 47 | -- should complement distribute over union? 48 | -- Does complement form a second allegory structure? 49 | 50 | 51 | 52 | -- def FirstOrderRelation (α : Type u) (arity: Nat) (coarity: Nat) : 53 | 54 | -- Univesally quantified props 55 | -- Implicit free variables 56 | --Existentially quantified props 57 | -- Compose with full at one end or the other to implicity existentially quantify 58 | -- Not, complement 59 | -- And, Intersection 60 | -- Or, Union 61 | -- Evaluate at constant 62 | -- Compose with pair constructor on left or right or both left and right. 63 | -- The whole relation is interpreted as a proposition by asking if there are any pairs in it. If it is empty the associated proposition is false. 64 | -- Arity and co-arity 65 | -- Cartesian product on the right of relation gives arity 66 | -- Cartesian product on the left of relation gives coarity 67 | -- We ignore different bracketings (we can have some cannonical bracketing from top to bottom) 68 | 69 | -- Higher Order Logic 70 | -- Relation Types 71 | -- Base type of individuals 72 | -- Relations built inductively from relations on individuals 73 | -- Could have a version of the inductive type which only takes the base type as a type parameter. This way all higher order relations built on a given base type could live in the same type universe (I think) 74 | -- Use ⊕ and ⊗ instead of union and intersection for or and and. 75 | --------------------------------------------------------------------------------