├── .editorconfig ├── .github ├── linters │ └── .ecrc └── workflows │ ├── ci-lib.yml │ └── ci-super-linter.yml ├── .gitignore ├── .idris-version ├── LICENSE ├── README.md ├── docs ├── docs.ipkg └── src │ └── Documentation.md ├── pack.toml ├── prim.ipkg ├── src ├── Algebra │ ├── Monoid.idr │ ├── Ring.idr │ ├── Semigroup.idr │ ├── Semiring.idr │ └── Solver │ │ ├── CommutativeMonoid.idr │ │ ├── Monoid.idr │ │ ├── Prod.idr │ │ ├── Ring.idr │ │ ├── Ring │ │ ├── Expr.idr │ │ ├── Prod.idr │ │ ├── SolvableRing.idr │ │ ├── Sum.idr │ │ └── Util.idr │ │ ├── Semigroup.idr │ │ ├── Semiring.idr │ │ └── Semiring │ │ ├── Expr.idr │ │ ├── Prod.idr │ │ ├── SolvableSemiring.idr │ │ ├── Sum.idr │ │ └── Util.idr └── Data │ ├── Maybe │ ├── NothingMax.idr │ └── NothingMin.idr │ ├── Prim.idr │ ├── Prim │ ├── Bits16.idr │ ├── Bits32.idr │ ├── Bits64.idr │ ├── Bits8.idr │ ├── Char.idr │ ├── Int.idr │ ├── Int16.idr │ ├── Int32.idr │ ├── Int64.idr │ ├── Int8.idr │ ├── Integer.idr │ ├── Integer │ │ └── Extra.idr │ ├── Ord.idr │ └── String.idr │ └── Trichotomy.idr └── test ├── src ├── Bits16.idr ├── Bits32.idr ├── Bits64.idr ├── Bits8.idr ├── Char.idr ├── Int.idr ├── Int16.idr ├── Int32.idr ├── Int64.idr ├── Int8.idr ├── Integer.idr ├── Main.idr ├── RingLaws.idr └── String.idr └── test.ipkg /.editorconfig: -------------------------------------------------------------------------------- 1 | # top-most EditorConfig file 2 | root = true 3 | 4 | # Defaults for every file 5 | [*] 6 | end_of_line = lf 7 | insert_final_newline = true 8 | trim_trailing_whitespace = true 9 | charset = utf-8 10 | 11 | # Idris source files 12 | [*.{idr,ipkg,tex,yaff,lidr}] 13 | indent_style = space 14 | indent_size = 2 15 | 16 | # Various configuration files 17 | [{*.yml,.ecrc}] 18 | indent_style = space 19 | indent_size = 2 20 | 21 | [*.py] 22 | indent_style = space 23 | indent_size = 4 24 | 25 | [*.{c,h}] 26 | indent_style = space 27 | indent_size = 4 28 | 29 | [*.{md,rst}] 30 | indent_style = space 31 | indent_size = 2 32 | 33 | [*.sh] 34 | indent_style = space 35 | indent_size = 4 36 | shell_variant = posix 37 | switch_case_indent = true 38 | 39 | [*.bat] 40 | indent_style = space 41 | indent_size = 4 42 | 43 | [{Makefile,*.mk}] 44 | indent_style = tab 45 | 46 | [*.nix] 47 | indent_style = space 48 | indent_size = 2 49 | 50 | [expected] 51 | trim_trailing_whitespace = false 52 | -------------------------------------------------------------------------------- /.github/linters/.ecrc: -------------------------------------------------------------------------------- 1 | { 2 | "Disable": { 3 | "IndentSize": true 4 | } 5 | } 6 | -------------------------------------------------------------------------------- /.github/workflows/ci-lib.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Build 3 | 4 | on: 5 | push: 6 | branches: 7 | - '**' 8 | tags: 9 | - '**' 10 | pull_request: 11 | branches: 12 | - main 13 | 14 | defaults: 15 | run: 16 | shell: bash 17 | 18 | jobs: 19 | build: 20 | name: Build ${{ github.repository }} with Idris2 latest 21 | runs-on: ubuntu-latest 22 | env: 23 | PACK_DIR: /root/.pack 24 | strategy: 25 | fail-fast: false 26 | container: ghcr.io/stefan-hoeck/idris2-pack:latest 27 | steps: 28 | - name: Checkout 29 | uses: actions/checkout@v2 30 | - name: Build lib 31 | run: pack install prim 32 | - name: Build docs 33 | run: pack install prim-docs 34 | - name: Run test 35 | run: pack run prim-test -n 1000 36 | -------------------------------------------------------------------------------- /.github/workflows/ci-super-linter.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Lint 3 | 4 | on: 5 | push: 6 | branches: 7 | - '*' 8 | tags: 9 | - '*' 10 | pull_request: 11 | branches: 12 | - main 13 | - master 14 | 15 | jobs: 16 | build: 17 | name: Lint Code Base 18 | runs-on: ubuntu-latest 19 | steps: 20 | 21 | - name: Checkout 22 | uses: actions/checkout@v2 23 | with: 24 | # Full git history is needed to get a proper list of changed files within `super-linter` 25 | fetch-depth: 0 26 | 27 | - name: Lint Code Base 28 | uses: github/super-linter/slim@v4 29 | env: 30 | VALIDATE_ALL_CODEBASE: false 31 | DEFAULT_BRANCH: main 32 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 33 | IGNORE_GENERATED_FILES: true 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | build/ 2 | *.*~ 3 | -------------------------------------------------------------------------------- /.idris-version: -------------------------------------------------------------------------------- 1 | v0.5.1-324-g7c5650e9 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2022, Stefan Höck 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # idris2-prim: Axioms and Propositions for Primitive Types in Idris2 2 | 3 | This library is to a large degree based on ideas and techniques 4 | first presented by G. Allais (@gallais) in the Idris2 *contrib* 5 | package. It provides axioms and derived laws for working with 6 | primitive types and functions in Idris2. This should make 7 | it possible for client code to *refine* primitive values 8 | (for instance, by means of `Data.DPair.Subset`) and have the 9 | ability to convert between such refined values. 10 | It also should allow us to safely use primitives in recursive 11 | functions. 12 | 13 | There is a small [tutorial](src/Documentation.md) explaining 14 | some of the things possible with this library. 15 | 16 | ## Total Order 17 | 18 | All primitives with the exception of `Double` and `%World` 19 | come with a total order `<`, so that the following axioms 20 | hold: 21 | 22 | * For all `x`, `y`, exactly one of `x < y`, `x === y`, or 23 | `x > y` holds. 24 | * `<` is transitive. 25 | 26 | Module `Data.Prim.Ord` provides interface `Total`, which encapsulates 27 | these axioms. In addition, it comes with dozens of corollaries following 28 | from the axioms. 29 | 30 | ## Commutative Rings 31 | 32 | All primitive integrals come with operations for addition, 33 | negation, and multiplication, which together form a commutative 34 | ring so that the following axioms hold: 35 | 36 | * Addition is commutative and associative. 37 | * `0` is the neutral element of addition. 38 | * `negate x` is the additive inverse of `x`. 39 | * `x - y` is equivalent to `x + negate y`. 40 | * Multiplication is commutative and associative. 41 | * `1` is the neutral element of multiplication. 42 | * Multiplication is distributive with respect to addition. 43 | 44 | Module `Data.Prim.Ring` provides interface `RingLaws`, which encapsulates 45 | these axioms. In addition, many corollaries following from the axioms are 46 | provided. 47 | 48 | ## Supported Idris Versions 49 | 50 | The latest commit is daily tested to build against the current 51 | HEAD of the Idris compiler. Since Idris2 releases are happening 52 | rather infrequently at the moment, it is suggested to use 53 | a package manager like [pack](https://github.com/stefan-hoeck/idris2-pack) 54 | to install and maintain matching versions of the Idris compiler 55 | and this library. Pack will also automatically install all 56 | required dependencies. 57 | -------------------------------------------------------------------------------- /docs/docs.ipkg: -------------------------------------------------------------------------------- 1 | package prim-docs 2 | version = 0.0.1 3 | authors = "Stefan Höck" 4 | depends = base >= 0.5.1 5 | , prim 6 | 7 | modules = Documentation 8 | 9 | sourcedir = "src" 10 | -------------------------------------------------------------------------------- /docs/src/Documentation.md: -------------------------------------------------------------------------------- 1 | # Documentation and Examples 2 | 3 | This is a literal Idris file, so we first need some 4 | imports: 5 | 6 | ```idris 7 | module Documentation 8 | 9 | import Data.Prim.Bits64 10 | 11 | %default total 12 | ``` 13 | 14 | At the moment, the main focus of this library lies on the 15 | strict total order of most primitive types (with the exception 16 | of `%World` and `Double`). For every primitive type, a 17 | relation `(<)` is defined, with `m < n` being 18 | a witness that `m` is strictly smaller than `n`. From this, we 19 | can define the following aliases: 20 | 21 | * `m > n = n < m` 22 | * `m <= n = Either (m < n) (m === n)` 23 | * `m >= n = n <= m` 24 | * `m /= n = Either (m < n) (m > n)` 25 | 26 | For these relations we implement interface `Data.Prim.Ord.Strict`, 27 | which comes with two axioms we assume (but can't proof in Idris) to hold 28 | for the ordered primitive types: 29 | 30 | 1. `<` is transitive: From `k < m` and `m < n` follows `k < n`. 31 | 2. Trichotomy: For all values `m,n` of the given type, exactly 32 | one of `m < n`, `m === n`, or `m > n` holds. 33 | 34 | Module `Data.Prim.Ord` comes with many corollaries following 35 | from the axioms listed above. We will use these when manually 36 | calculating new proofs from existing ones. 37 | 38 | ## Use Case 1: Safe Division 39 | 40 | As a first example, we want to implement safe integer 41 | division for `Bits64`. In order to do so, we need an 42 | erased proof that the denominator is strictly positive. 43 | 44 | ```idris 45 | safeDiv : (n,d : Bits64) -> (0 prf : 0 < d) => Bits64 46 | safeDiv n d = n `div` d 47 | ``` 48 | 49 | We can conveniently invoke `safeDiv` with denominators 50 | known at compile time: 51 | 52 | ```idris 53 | half : Bits64 -> Bits64 54 | half n = n `safeDiv` 2 55 | 56 | ten : Bits64 57 | ten = safeDiv 100 10 58 | ``` 59 | 60 | If, however, the denominator is only known at runtime, 61 | we first need to *refine* it. For this, we introduce 62 | a new type for strictly positive values of type `Bits64`: 63 | 64 | ```idris 65 | 0 Positive : Type 66 | Positive = Subset Bits64 (> 0) 67 | ``` 68 | 69 | It is convenient to be able to use integer literals with 70 | values of type `Positive`. Although the constructors of `(<)` 71 | and similar predicates are not publicly exported (for safety 72 | reasons, see below), we can still use proof search to create 73 | values of type `(<)` automatically if both arguments are known 74 | at compile time, because function `mkLT`, which can be used 75 | to manually define values of type `(<)`, is annotated with 76 | a `%hint` pragma. 77 | 78 | ```idris 79 | fromInteger : 80 | (n : Integer) 81 | -> {auto 0 prf : cast n > the Bits64 0} 82 | -> Positive 83 | fromInteger n = Element (cast n) prf 84 | 85 | twelve : Positive 86 | twelve = 12 87 | ``` 88 | 89 | We can use `trichotomy` (or `Bits64.comp`) to refine 90 | values only known at runtime. This returns a value of 91 | type `Trichotomy (<) m n`, which holds erased 92 | proofs that exactly one of the following holds: 93 | `m < n`, `m > n`, or `m === n`: 94 | 95 | ```idris 96 | positive : Bits64 -> Maybe Positive 97 | positive x = case trichotomy 0 x of 98 | LT y _ _ => Just (Element x y) 99 | EQ _ _ _ => Nothing 100 | GT _ _ _ => Nothing 101 | ``` 102 | 103 | ## Use Case 2: Converting Values to Strings 104 | 105 | A more interesting use case is the modulo operation. It comes 106 | with the postcondition that if the modulus is positive (the 107 | function's precondition), the result will be strictly smaller 108 | than the modulus. The unsigned integer modules export functions `rmod` 109 | encapsulating this behavior. 110 | 111 | We will implement a small function for converting an 112 | integer to a string in a given base. We accept 113 | bases in the range `[2,16]`: 114 | 115 | ```idris 116 | record Base where 117 | constructor MkBase 118 | value : Bits64 119 | 0 gt1 : value > 1 120 | 0 lte16 : value <= 16 121 | 122 | namespace Base 123 | public export 124 | fromInteger : 125 | (n : Integer) 126 | -> {auto 0 gt1 : cast n > the Bits64 1} 127 | -> {auto 0 lte16 : cast n <= the Bits64 16} 128 | -> Base 129 | fromInteger n = MkBase (cast n) gt1 lte16 130 | ``` 131 | 132 | To convert a digit to a hexadecimal character, 133 | we require the digit to be strictly smaller 134 | than sixteen as a precondition: 135 | 136 | ```idris 137 | hexChar : (d : Bits64) -> (0 prf : d < 16) => Char 138 | hexChar d = case d < 10 of 139 | True => cast $ 48 + d 140 | False => cast $ 87 + d 141 | ``` 142 | 143 | We can now implement a function for converting a value 144 | to a string in the given base. This will require some 145 | manual proof passing: The goal of this library is not 146 | to provide Idris with the functionality to derive all 147 | kinds of proofs automatically. Such a thing would probably 148 | be doomed to fail anyway. As a result, the implementation 149 | is quite verbose. 150 | 151 | ```idris 152 | lit : Bits64 -> Base -> String 153 | lit 0 _ = "0" 154 | lit x (MkBase b gt1 lte16) = go [] x 155 | 156 | where 157 | go : List Char -> Bits64 -> String 158 | go cs 0 = pack cs 159 | go cs v = 160 | let 0 gt0 := the (0 < b) $ trans %search gt1 161 | Element d ltb := rmod v b 162 | v2 := sdiv v b 163 | c := hexChar d {prf = trans_LT_LTE ltb lte16} 164 | in go (c :: cs) (assert_smaller v v2) 165 | ``` 166 | 167 | Functions `rmod` and `sdiv` each require a proof that `b` is larger than zero. 168 | We can construct such a proof from the transitivity of `(<)`: We know that 169 | `b > 1` (value `gt1`), and Idris can figure out on its own that `0 < 1` 170 | (invocation of `%search`). Passing both arguments to `LT.trans` generates 171 | the desired proof. Since this is used twice (in `rmod` and `sdiv`), 172 | I bound it to erased local variable `gt0`. 173 | 174 | In addition, `rmod` returns a proof stating that its result 175 | is strictly smaller than the modules. We use this and 176 | the fact that from `k < m` and `m <= n` follows `k < n` 177 | in the call to `hexChar`. 178 | 179 | Let's give this a go at the REPL: 180 | 181 | ```repl 182 | Documentation> lit 12 2 183 | "1100" 184 | Documentation> lit 12 3 185 | "110" 186 | Documentation> lit 12 5 187 | "22" 188 | Documentation> lit 12 8 189 | "14" 190 | Documentation> lit 12 16 191 | "c" 192 | ``` 193 | 194 | There are several techniques for making such code more concise. 195 | First, we can be clever when choosing our constraints: In `Base` we 196 | stored the lower bound as `b > 1` instead of `b >= 2`. We could also 197 | store additional derived proofs in the `Base` data type. Since they 198 | have zero quantity, they will be erased and have no effect on the runtime 199 | behavior of our application. 200 | We can also try to come up with some custom hints local to our source 201 | files. Here is an example that allows us to get rid of manual proof 202 | passing: 203 | 204 | ```idris 205 | %hint 206 | 0 gt0 : n > 1 -> n > 0 207 | gt0 gt = trans (the (0 < 1) %search) gt 208 | 209 | %hint 210 | 0 lt16 : m < n -> n <= 16 -> m < 16 211 | lt16 = trans_LT_LTE 212 | 213 | lit2 : Bits64 -> Base -> String 214 | lit2 0 _ = "0" 215 | lit2 x (MkBase b geq2 lte16) = go [] x 216 | 217 | where 218 | go : List Char -> Bits64 -> String 219 | go cs 0 = pack cs 220 | go cs v = 221 | let Element d ltb := rmod v b 222 | in go (hexChar d :: cs) (assert_smaller v $ sdiv v b) 223 | ``` 224 | 225 | That looks pretty nice. The only ugly (and unsafe!) piece is the 226 | call to `assert_smaller`, which is needed to satisfy the totality 227 | checker. Alas, there is no way getting rid of that one. 228 | 229 | ## Use Case 3: Well-founded Recursion 230 | 231 | Or is there? What we need is a thing called *well-founded recursion*, 232 | based on the concept of [*well-founded relations*](https://en.wikipedia.org/wiki/Well-founded_relation). 233 | A relation `<` on a set `X` is well founded, if every non-empty subset `S` 234 | of `X` contains a minimal element with respect to `<`, that is, an element 235 | `m`, so that there is no `s` in `S` with `s < m`. 236 | 237 | This can also be stated like so: For every `x` in `X`, any chain 238 | `x1,x2,...xn` of values with `x1 < x2 < ... xn < x` must be finite. 239 | Otherwise, such a chain would be a non-empty subset of `X` with no 240 | minimal element. 241 | 242 | A data type encapsulating these concepts can be found in module 243 | `Control.WellFounded` in the *base* library. There is data type 244 | `Accessible rel x`, a value of which is a proof that every chain 245 | of values related via `rel` and starting from `x` will be finite. 246 | We can construct a value of this type using recursion, but we must make 247 | sure to proof to Idris that this recursion eventually comes to 248 | an end. 249 | 250 | In addition, there is interface `WellFounded a rel`, which allows us 251 | to come up with a value of type `Accessible rel x` for every value 252 | `x` of type `a`. 253 | 254 | An (erased) value of type `Accessible rel x` can be used as the 255 | function argument, which will get strictly smaller in every 256 | recursive function call. All we need to do is pass the current 257 | value a proof that the next function argument `y` is related 258 | to `x` via `rel`, that is, `rel y x` does hold. 259 | 260 | Here is how to do this for `Bits64` and `(<)`: 261 | 262 | ```idris 263 | lit3 : Bits64 -> Base -> String 264 | lit3 0 _ = "0" 265 | lit3 x (MkBase b _ _) = go [] x (accessLT x) 266 | 267 | where 268 | go : List Char -> (n : Bits64) -> (0 _ : Accessible (<) n) -> String 269 | go cs n (Access rec) = case comp 0 n of 270 | LT ngt0 _ _ => 271 | let Element d _ := n `rmod` b 272 | Element n2 ltn := n `rdiv` b 273 | in go (hexChar d :: cs) n2 (rec n2 ltn) 274 | EQ _ _ _ => pack cs 275 | GT _ _ lt0 => void (Not_LT_MinBits64 lt0) 276 | ``` 277 | 278 | Note, how we used `comp` to compare the current value against the 279 | lower bound (which could be any number of type `Bits64`). This 280 | returns a value of type `Trichotomy (<) 0 n`, which encapsulates 281 | the trichotomy of `<`: Exactly one of the three possibilities 282 | of `m < n`, `m === n`, and `n < m` holds. 283 | 284 | Function `rdiv` can be used if `n` is provably greater 285 | than zero (witnessed by value `ngt0`) and `b` is strictly 286 | greater than one. In this case it returns a proof that 287 | its result (`n2`) is strictly smaller than its first argument (`n`). 288 | We pass this proof to function `rec` to get a value of type 289 | `Accessible (<) n2`, which we use as the erased argument in 290 | the recursive function call. Idris know that this must be 291 | strictly smaller than than the previous accessibility proofs, 292 | so the totality checker is satisfied. 293 | 294 | Of course, there must be some call to `assert_smaller` hidden 295 | somewhere: `Bits64` is a primitive after all. Indeed, this was 296 | used in the implementation of `accessLT`, which we used to 297 | create the initial proof of accessibility. 298 | 299 | ## Implementation Details 300 | 301 | Since we are working with primitives, all axioms must be 302 | assumed to hold on all backends, and all values proofing 303 | such axioms must be magically crafted using unsafe primitives 304 | like `believe_me` or `assert_total`. But this means, we have to 305 | be careful when using such proofs during type checking. It's best 306 | to explain the problem at hand in the words of @gallais, who 307 | first came up with a set of laws on the ordering of `Int` in 308 | the *contrib* library: 309 | 310 | > The type `Int` is a primitive type in Idris. The only handle we have on 311 | > it is provided by built-in functions. This is what we are going to use 312 | > to define relations on Int values. For instance, we will declare that 313 | > `a` is strictly less than `b` whenever `a < b` is provably equal to `True`. 314 | > 315 | > These built-in functions only reduce on literals. This means we will not 316 | > be able to rely on their computational behaviour to prove statements in 317 | > open contexts. 318 | > 319 | > For instance, no amount of pattern-matching will help us prove: 320 | > `LT_not_EQ : LT a b -> Not (EQ a b)` 321 | > 322 | > Our solution in this file is to use unsafe primitives to manufacture such 323 | > proofs. This means we are going to essentially postulate some *conditional* 324 | > results. We do not want such conditional results to reduce to canonical 325 | > forms too eagerly. 326 | > 327 | > Indeed the statement `GT 0 1 -> EQ 0 1` should be provable because 0 is not 328 | > greater than 1. But its proof should not reduce to a constant function 329 | > returning the value `Refl` because it is not true that `0` and `1` can be 330 | > unified. If the proof were to behave this way, we could, in an absurd context, 331 | > coerce values from any type to any other and cause segmentation faults. 332 | > 333 | > Our solution is to be extremely wary of proofs that are passed to us 334 | > and to only consider returning a magically-crafted output if we have 335 | > managed to observe that the input is itself in canonical form i.e. to 336 | > have evaluation stuck on open terms. 337 | > 338 | > This is the purpose of the `strictX : X -> Lazy c -> c` functions defined in 339 | > this file. They all will be waiting until their first argument is in canonical 340 | > form before returning their second. 341 | 342 | ## Conclusion 343 | 344 | The interfaces and utility functions provided by this library allow 345 | us to get strong guarantees about the validity of our code 346 | when working with primitive data types. 347 | 348 | Yet, I'm still experimenting with new additions that might be helpful, 349 | and with different designs to get the best compromise in terms of 350 | code reuse, type inference, and expressiveness. 351 | Therefore, this library is still bound to change in breaking ways. 352 | 353 | 355 | -------------------------------------------------------------------------------- /pack.toml: -------------------------------------------------------------------------------- 1 | [custom.all.prim] 2 | type = "local" 3 | path = "." 4 | ipkg = "prim.ipkg" 5 | test = "test/test.ipkg" 6 | 7 | [custom.all.prim-test] 8 | type = "local" 9 | path = "test" 10 | ipkg = "test.ipkg" 11 | 12 | [custom.all.prim-docs] 13 | type = "local" 14 | path = "docs" 15 | ipkg = "docs.ipkg" 16 | 17 | [custom.all.elab-util] 18 | type = "git" 19 | url = "https://github.com/stefan-hoeck/idris2-elab-util" 20 | commit = "latest:main" 21 | ipkg = "elab-util.ipkg" 22 | 23 | [custom.all.sop] 24 | type = "git" 25 | url = "https://github.com/stefan-hoeck/idris2-sop" 26 | commit = "latest:main" 27 | ipkg = "sop.ipkg" 28 | 29 | [custom.all.pretty-show] 30 | type = "git" 31 | url = "https://github.com/stefan-hoeck/idris2-pretty-show" 32 | commit = "latest:main" 33 | ipkg = "pretty-show.ipkg" 34 | 35 | [custom.all.hedgehog] 36 | type = "git" 37 | url = "https://github.com/stefan-hoeck/idris2-hedgehog" 38 | commit = "latest:main" 39 | ipkg = "hedgehog.ipkg" 40 | 41 | [custom.all.elab-pretty] 42 | type = "git" 43 | url = "https://github.com/stefan-hoeck/idris2-elab-util" 44 | commit = "latest:main" 45 | ipkg = "elab-pretty.ipkg" 46 | 47 | [custom.all.parser] 48 | type = "git" 49 | url = "https://github.com/stefan-hoeck/idris2-parser" 50 | commit = "latest:main" 51 | ipkg = "parser.ipkg" 52 | -------------------------------------------------------------------------------- /prim.ipkg: -------------------------------------------------------------------------------- 1 | package prim 2 | 3 | authors = "stefan-hoeck" 4 | brief = "Laws and utilities for working with primitives in Idris2" 5 | version = 0.0.1 6 | readme = "README.md" 7 | license = "BSD-3 Clause" 8 | 9 | sourcedir = "src" 10 | depends = base >= 0.5.1 11 | 12 | modules = Algebra.Semigroup 13 | , Algebra.Semiring 14 | , Algebra.Monoid 15 | , Algebra.Ring 16 | 17 | , Algebra.Solver.CommutativeMonoid 18 | , Algebra.Solver.Monoid 19 | , Algebra.Solver.Prod 20 | , Algebra.Solver.Ring 21 | , Algebra.Solver.Ring.Expr 22 | , Algebra.Solver.Ring.Prod 23 | , Algebra.Solver.Ring.SolvableRing 24 | , Algebra.Solver.Ring.Sum 25 | , Algebra.Solver.Ring.Util 26 | , Algebra.Solver.Semigroup 27 | , Algebra.Solver.Semiring 28 | , Algebra.Solver.Semiring.Expr 29 | , Algebra.Solver.Semiring.Prod 30 | , Algebra.Solver.Semiring.SolvableSemiring 31 | , Algebra.Solver.Semiring.Sum 32 | , Algebra.Solver.Semiring.Util 33 | 34 | , Data.Maybe.NothingMin 35 | , Data.Maybe.NothingMax 36 | , Data.Prim 37 | , Data.Prim.Char 38 | , Data.Prim.Bits8 39 | , Data.Prim.Bits16 40 | , Data.Prim.Bits32 41 | , Data.Prim.Bits64 42 | , Data.Prim.Int8 43 | , Data.Prim.Int16 44 | , Data.Prim.Int32 45 | , Data.Prim.Int64 46 | , Data.Prim.Int 47 | , Data.Prim.Integer 48 | , Data.Prim.Integer.Extra 49 | , Data.Prim.Ord 50 | , Data.Prim.String 51 | , Data.Trichotomy 52 | -------------------------------------------------------------------------------- /src/Algebra/Monoid.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Monoid 2 | 3 | import Data.List 4 | 5 | %default total 6 | 7 | ||| This interface is a witness that for a 8 | ||| type `a` the axioms of a monoid hold: `(<+>)` is associative 9 | ||| with `neutral` being the neutral element. 10 | public export 11 | interface Monoid a => LMonoid a where 12 | 0 appendAssociative : {x,y,z : a} -> x <+> (y <+> z) === (x <+> y) <+> z 13 | 14 | 0 appendLeftNeutral : {x : a} -> Prelude.neutral <+> x === x 15 | 16 | 0 appendRightNeutral : {x : a} -> x <+> Prelude.neutral === x 17 | 18 | export 19 | LMonoid (List a) where 20 | appendAssociative = Data.List.appendAssociative _ _ _ 21 | appendRightNeutral = appendNilRightNeutral _ 22 | appendLeftNeutral = Refl 23 | 24 | unsafeRefl : a === b 25 | unsafeRefl = believe_me (Refl {x = a}) 26 | 27 | export 28 | LMonoid String where 29 | appendAssociative = unsafeRefl 30 | appendRightNeutral = unsafeRefl 31 | appendLeftNeutral = unsafeRefl 32 | 33 | ||| This interface is a witness that for a 34 | ||| type `a` the axioms of a commutative monoid hold: 35 | ||| `(<+>)` is commutative. 36 | public export 37 | interface LMonoid a => CommutativeMonoid a where 38 | 0 appendCommutative : {x,y : a} -> x <+> y === y <+> x 39 | -------------------------------------------------------------------------------- /src/Algebra/Ring.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Ring 2 | 3 | import Syntax.PreorderReasoning 4 | 5 | %default total 6 | 7 | public export %inline %tcinline 8 | neg : Neg a => a -> a 9 | neg = negate 10 | 11 | ||| This interface is a witness that for a (primitive) 12 | ||| integral type `a` the axioms of a commutative ring hold: 13 | ||| 14 | ||| 1. `a` is an abelian group under addition: 15 | ||| 1. `+` is associative: `k + (m + n) = (k + m) + n` for all `k,m,n : a`. 16 | ||| 2. `+` is commutative: `m + n = n + m` for all `m,n : a`. 17 | ||| 3. 0 is the additive identity: `n + 0 = n` for all `n : a`. 18 | ||| 4. `neg n` is the additive inverse of `n`: 19 | ||| `n + neg n = 0` for all `n : a`. 20 | ||| 21 | ||| 2. `a` is a commutative monoid under multiplication: 22 | ||| 1. `*` is associative: `k * (m * n) = (k * m) * n` for all `k,m,n : a`. 23 | ||| 2. `*` is commutative: `m * n = n * m` for all `m,n : a`. 24 | ||| 3. 1 is the multiplicative identity: `n * 1 = n` for all `n : a`. 25 | ||| 26 | ||| 3. Multiplication is distributive with respect to addition: 27 | ||| `k * (m + n) = (k * m) + (k * n)` for all `k,m,n : a`. 28 | ||| 29 | ||| 4. Subtraction syntax: `m - n = m + neg n` for all `m,n : a`. 30 | public export 31 | interface Neg a => Ring a where 32 | ||| Addition is associative. 33 | 0 plusAssociative : {k,m,n : a} -> k + (m + n) === (k + m) + n 34 | 35 | ||| Addition is commutative. 36 | 0 plusCommutative : {m,n : a} -> m + n === n + m 37 | 38 | ||| 0 is the additive identity. 39 | 0 plusZeroLeftNeutral : {n : a} -> 0 + n === n 40 | 41 | ||| `neg n` is the additive inverse of `n`. 42 | 0 plusNegLeftZero : {n : a} -> neg n + n === 0 43 | 44 | ||| Multiplication is associative. 45 | 0 multAssociative : {k,m,n : a} -> k * (m * n) === (k * m) * n 46 | 47 | ||| Multiplication is commutative. 48 | 0 multCommutative : {m,n : a} -> m * n === n * m 49 | 50 | ||| 1 is the multiplicative identity. 51 | 0 multOneLeftNeutral : {n : a} -> 1 * n === n 52 | 53 | ||| Multiplication is distributive with respect to addition. 54 | 0 leftDistributive : {k,m,n : a} -> k * (m + n) === (k * m) + (k * n) 55 | 56 | ||| `m - n` is just "syntactic sugar" for `m + neg n`. 57 | 0 minusIsPlusNeg : {m,n : a} -> m - n === m + neg n 58 | 59 | -------------------------------------------------------------------------------- 60 | -- Proofs on Addition 61 | -------------------------------------------------------------------------------- 62 | 63 | ||| `n + 0 === n` for all `n : a`. 64 | export 65 | 0 plusZeroRightNeutral : Ring a => {n : a} -> n + 0 === n 66 | plusZeroRightNeutral = 67 | Calc $ 68 | |~ n + 0 69 | ~~ 0 + n ... plusCommutative 70 | ~~ n ... plusZeroLeftNeutral 71 | 72 | ||| `n + neg n === 0` for all `n : a`. 73 | export 74 | 0 plusNegRightZero : Ring a => {n : a} -> n + neg n === 0 75 | plusNegRightZero = 76 | Calc $ 77 | |~ n + neg n 78 | ~~ neg n + n ... plusCommutative 79 | ~~ 0 ... plusNegLeftZero 80 | 81 | ||| `n - n === 0` for all `n : a`. 82 | export 83 | 0 minusSelfZero : Ring a => {n : a} -> n - n === 0 84 | minusSelfZero = 85 | Calc $ 86 | |~ n - n 87 | ~~ n + neg n ... minusIsPlusNeg 88 | ~~ 0 ... plusNegRightZero 89 | 90 | ||| Law of associativity for subtraction. 91 | export 92 | 0 plusMinusAssociative : 93 | {auto _ : Ring a} 94 | -> {k,m,n : a} 95 | -> k + (m - n) === (k + m) - n 96 | plusMinusAssociative = 97 | Calc $ 98 | |~ k + (m - n) 99 | ~~ k + (m + neg n) ..> cong (k+) minusIsPlusNeg 100 | ~~ (k + m) + neg n ..> plusAssociative 101 | ~~ (k + m) - n ..< minusIsPlusNeg 102 | 103 | ||| We can solve equations involving addition. 104 | export 105 | 0 solvePlusRight : 106 | {auto _ : Ring a} 107 | -> {k,m,n : a} 108 | -> k + m === n 109 | -> k === n - m 110 | solvePlusRight prf = 111 | Calc $ 112 | |~ k 113 | ~~ k + 0 ..< plusZeroRightNeutral 114 | ~~ k + (m - m) ..< cong (k +) minusSelfZero 115 | ~~ (k + m) - m ..> plusMinusAssociative 116 | ~~ n - m ..> cong (\x => x - m) prf 117 | 118 | ||| We can solve equations involving addition. 119 | export 120 | 0 solvePlusLeft : 121 | {auto _ : Ring a} 122 | -> {k,m,n : a} 123 | -> k + m === n 124 | -> m === n - k 125 | solvePlusLeft prf = 126 | solvePlusRight $ Calc $ 127 | |~ m + k 128 | ~~ k + m ... plusCommutative 129 | ~~ n ... prf 130 | 131 | ||| Addition from the left is injective. 132 | export 133 | 0 plusLeftInjective : Ring a => {k,m,n : a} -> k + n === m + n -> k === m 134 | plusLeftInjective prf = 135 | Calc $ 136 | |~ k 137 | ~~ (m + n) - n ..> solvePlusRight prf 138 | ~~ m + (n - n) ..< plusMinusAssociative 139 | ~~ m + 0 ..> cong (m +) minusSelfZero 140 | ~~ m ..> plusZeroRightNeutral 141 | 142 | ||| Addition from the right is injective. 143 | export 144 | 0 plusRightInjective : Ring a => {k,m,n : a} -> n + k === n + m -> k === m 145 | plusRightInjective prf = 146 | plusLeftInjective $ 147 | Calc $ 148 | |~ k + n 149 | ~~ n + k ... plusCommutative 150 | ~~ n + m ... prf 151 | ~~ m + n ... plusCommutative 152 | 153 | ||| From `m + n === 0` follows that `n` is the 154 | ||| additive inverse of `m`. 155 | export 156 | 0 solvePlusNegRight : 157 | {auto _ : Ring a} 158 | -> {m,n : a} 159 | -> m + n === 0 160 | -> n === neg m 161 | solvePlusNegRight prf = 162 | plusRightInjective (trans prf (sym plusNegRightZero)) 163 | 164 | ||| From `m + n === 0` follows that `m` is the 165 | ||| additive inverse of `n`. 166 | export 167 | 0 solvePlusNegLeft : 168 | {auto _ : Ring a} 169 | -> {m,n : a} 170 | -> m + n === 0 171 | -> m === neg n 172 | solvePlusNegLeft prf = 173 | solvePlusNegRight $ Calc $ 174 | |~ n + m 175 | ~~ m + n ... plusCommutative 176 | ~~ 0 ... prf 177 | 178 | ||| From `m + n === m` follows `n === 0`. 179 | export 180 | 0 solvePlusZeroRight : Ring a => {m,n : a} -> m + n === m -> n === 0 181 | solvePlusZeroRight prf = 182 | Calc $ 183 | |~ n 184 | ~~ m - m ... solvePlusLeft prf 185 | ~~ 0 ... minusSelfZero 186 | 187 | ||| From `n + m === m` follows `n === 0`. 188 | export 189 | 0 solvePlusZeroLeft : Ring a => {m,n : a} -> n + m === m -> n === 0 190 | solvePlusZeroLeft prf = 191 | solvePlusZeroRight $ Calc $ 192 | |~ m + n 193 | ~~ n + m ... plusCommutative 194 | ~~ m ... prf 195 | 196 | ||| Negation is involutory. 197 | export 198 | 0 negInvolutory : Ring a => {n : a} -> neg (neg n) === n 199 | negInvolutory = sym $ solvePlusNegLeft plusNegRightZero 200 | 201 | ||| From `neg n === 0` follows `n === 0`. 202 | export 203 | 0 solveNegZero : Ring a => {n : a} -> neg n === 0 -> n === 0 204 | solveNegZero prf = 205 | Calc $ 206 | |~ n 207 | ~~ n + 0 ..< plusZeroRightNeutral 208 | ~~ n + neg n ..< cong (n +) prf 209 | ~~ 0 ..> plusNegRightZero 210 | 211 | ||| `neg 0 === 0` 212 | export 213 | 0 negZero : Ring a => neg {a} 0 === 0 214 | negZero = solveNegZero negInvolutory 215 | 216 | export 217 | 0 negDistributes : Ring a => {m,n : a} -> neg (m + n) === neg m + neg n 218 | negDistributes = 219 | sym $ solvePlusNegLeft $ Calc $ 220 | |~ (neg m + neg n) + (m + n) 221 | ~~ (neg m + neg n) + (n + m) ... cong ((neg m + neg n) +) plusCommutative 222 | ~~ ((neg m + neg n) + n) + m ... plusAssociative 223 | ~~ (neg m + (neg n + n)) + m ..< cong (+m) plusAssociative 224 | ~~ (neg m + 0) + m ... cong (\x => neg m + x + m) plusNegLeftZero 225 | ~~ neg m + m ... cong (+m) plusZeroRightNeutral 226 | ~~ 0 ... plusNegLeftZero 227 | 228 | -------------------------------------------------------------------------------- 229 | -- Proofs on Multiplication 230 | -------------------------------------------------------------------------------- 231 | 232 | ||| `n * 1 === n` for all `n : a`. 233 | export 234 | 0 multOneRightNeutral : Ring a => {n : a} -> n * 1 === n 235 | multOneRightNeutral = 236 | Calc $ 237 | |~ n * 1 238 | ~~ 1 * n ... multCommutative 239 | ~~ n ... multOneLeftNeutral 240 | 241 | ||| Zero is an absorbing element of multiplication. 242 | export 243 | 0 multZeroRightAbsorbs : Ring a => {n : a} -> n * 0 === 0 244 | multZeroRightAbsorbs = 245 | solvePlusZeroRight $ Calc $ 246 | |~ (n * 0) + (n * 0) 247 | ~~ n * (0 + 0) ..< leftDistributive 248 | ~~ n * 0 ..> cong (n *) plusZeroLeftNeutral 249 | 250 | 251 | ||| Zero is an absorbing element of multiplication. 252 | export 253 | 0 multZeroLeftAbsorbs : Ring a => {n : a} -> 0 * n === 0 254 | multZeroLeftAbsorbs = 255 | Calc $ 256 | |~ 0 * n 257 | ~~ n * 0 ... multCommutative 258 | ~~ 0 ... multZeroRightAbsorbs 259 | 260 | ||| Zero is an absorbing element of multiplication. 261 | export 262 | 0 multZeroAbsorbs : 263 | {auto _ : Ring a} 264 | -> {m,n : a} 265 | -> Either (m === 0) (n === 0) 266 | -> m * n === 0 267 | multZeroAbsorbs (Left rfl) = 268 | Calc $ 269 | |~ m * n 270 | ~~ 0 * n ... cong (*n) rfl 271 | ~~ 0 ... multZeroLeftAbsorbs 272 | 273 | multZeroAbsorbs (Right rfl) = 274 | Calc $ 275 | |~ m * n 276 | ~~ m * 0 ... cong (m*) rfl 277 | ~~ 0 ... multZeroRightAbsorbs 278 | 279 | ||| `m * (-n) = - (m * n)`. 280 | export 281 | 0 multNegRight : Ring a => {m,n : a} -> m * neg n === neg (m * n) 282 | multNegRight = 283 | solvePlusNegRight $ Calc $ 284 | |~ m * n + m * neg n 285 | ~~ m * (n + neg n) ..< leftDistributive 286 | ~~ m * 0 ..> cong (m *) plusNegRightZero 287 | ~~ 0 ..> multZeroRightAbsorbs 288 | 289 | ||| `- (m * (-n)) = m * n`. 290 | export 291 | 0 negMultNegRight : Ring a => {m,n : a} -> neg (m * neg n) === m * n 292 | negMultNegRight = 293 | Calc $ 294 | |~ neg (m * neg n) 295 | ~~ neg (neg (m * n)) ... cong neg multNegRight 296 | ~~ m * n ... negInvolutory 297 | 298 | ||| `(- m) * n = - (m * n)`. 299 | export 300 | 0 multNegLeft : Ring a => {m,n : a} -> neg m * n === neg (m * n) 301 | multNegLeft = 302 | Calc $ 303 | |~ neg m * n 304 | ~~ n * neg m ... multCommutative 305 | ~~ neg (n * m) ... multNegRight 306 | ~~ neg (m * n) ... cong neg multCommutative 307 | 308 | ||| `- ((-m) * n) = m * n`. 309 | export 310 | 0 negMultNegLeft : Ring a => {m,n : a} -> neg (neg m * n) === m * n 311 | negMultNegLeft = 312 | Calc $ 313 | |~ neg (neg m * n) 314 | ~~ neg (neg (m * n)) ... cong neg multNegLeft 315 | ~~ m * n ... negInvolutory 316 | 317 | ||| Multiplication with `(-1)` is negation. 318 | export 319 | 0 multMinusOneRight : Ring a => {n : a} -> n * neg 1 === neg n 320 | multMinusOneRight = 321 | Calc $ 322 | |~ n * neg 1 323 | ~~ neg (n * 1) ... multNegRight 324 | ~~ neg n ... cong neg multOneRightNeutral 325 | 326 | ||| Multiplication with `(-1)` is negation. 327 | export 328 | 0 multMinusOneLeft : Ring a => {n : a} -> neg 1 * n === neg n 329 | multMinusOneLeft = 330 | Calc $ 331 | |~ neg 1 * n 332 | ~~ neg (1 * n) ... multNegLeft 333 | ~~ neg n ... cong neg multOneLeftNeutral 334 | 335 | ||| Multiplication of two negations removes negations. 336 | export 337 | 0 negMultNeg : Ring a => {m,n : a} -> neg m * neg n === m * n 338 | negMultNeg = 339 | Calc $ 340 | |~ neg m * neg n 341 | ~~ neg (m * neg n) ... multNegLeft 342 | ~~ neg (neg (m * n)) ... cong neg multNegRight 343 | ~~ m * n ... negInvolutory 344 | 345 | ||| Multiplication is distributive with respect to addition. 346 | export 347 | 0 rightDistributive : 348 | {auto _ : Ring a} 349 | -> {k,m,n : a} 350 | -> (m + n) * k === m * k + n * k 351 | rightDistributive = 352 | Calc $ 353 | |~ (m + n) * k 354 | ~~ k * (m + n) ... multCommutative 355 | ~~ (k * m) + (k * n) ... leftDistributive 356 | ~~ m * k + k * n ... cong (+ k * n) multCommutative 357 | ~~ m * k + n * k ... cong (m * k +) multCommutative 358 | 359 | export 360 | 0 multPlusSelf : Ring a => {m,n : a} -> m * n + m === m * (n + 1) 361 | multPlusSelf = 362 | Calc $ 363 | |~ m * n + m 364 | ~~ m * n + m * 1 ..< cong (m*n +) multOneRightNeutral 365 | ~~ m * (n + 1) ..< leftDistributive 366 | 367 | -------------------------------------------------------------------------------- 368 | -- Implementations 369 | -------------------------------------------------------------------------------- 370 | 371 | unsafeRefl : a === b 372 | unsafeRefl = believe_me (Refl {x = a}) 373 | 374 | export 375 | Ring Bits8 where 376 | plusAssociative = unsafeRefl 377 | plusCommutative = unsafeRefl 378 | plusZeroLeftNeutral = unsafeRefl 379 | plusNegLeftZero = unsafeRefl 380 | multAssociative = unsafeRefl 381 | multCommutative = unsafeRefl 382 | multOneLeftNeutral = unsafeRefl 383 | leftDistributive = unsafeRefl 384 | minusIsPlusNeg = unsafeRefl 385 | 386 | export 387 | Ring Bits16 where 388 | plusAssociative = unsafeRefl 389 | plusCommutative = unsafeRefl 390 | plusZeroLeftNeutral = unsafeRefl 391 | plusNegLeftZero = unsafeRefl 392 | multAssociative = unsafeRefl 393 | multCommutative = unsafeRefl 394 | multOneLeftNeutral = unsafeRefl 395 | leftDistributive = unsafeRefl 396 | minusIsPlusNeg = unsafeRefl 397 | 398 | export 399 | Ring Bits32 where 400 | plusAssociative = unsafeRefl 401 | plusCommutative = unsafeRefl 402 | plusZeroLeftNeutral = unsafeRefl 403 | plusNegLeftZero = unsafeRefl 404 | multAssociative = unsafeRefl 405 | multCommutative = unsafeRefl 406 | multOneLeftNeutral = unsafeRefl 407 | leftDistributive = unsafeRefl 408 | minusIsPlusNeg = unsafeRefl 409 | 410 | export 411 | Ring Bits64 where 412 | plusAssociative = unsafeRefl 413 | plusCommutative = unsafeRefl 414 | plusZeroLeftNeutral = unsafeRefl 415 | plusNegLeftZero = unsafeRefl 416 | multAssociative = unsafeRefl 417 | multCommutative = unsafeRefl 418 | multOneLeftNeutral = unsafeRefl 419 | leftDistributive = unsafeRefl 420 | minusIsPlusNeg = unsafeRefl 421 | 422 | export 423 | Ring Int8 where 424 | plusAssociative = unsafeRefl 425 | plusCommutative = unsafeRefl 426 | plusZeroLeftNeutral = unsafeRefl 427 | plusNegLeftZero = unsafeRefl 428 | multAssociative = unsafeRefl 429 | multCommutative = unsafeRefl 430 | multOneLeftNeutral = unsafeRefl 431 | leftDistributive = unsafeRefl 432 | minusIsPlusNeg = unsafeRefl 433 | 434 | export 435 | Ring Int16 where 436 | plusAssociative = unsafeRefl 437 | plusCommutative = unsafeRefl 438 | plusZeroLeftNeutral = unsafeRefl 439 | plusNegLeftZero = unsafeRefl 440 | multAssociative = unsafeRefl 441 | multCommutative = unsafeRefl 442 | multOneLeftNeutral = unsafeRefl 443 | leftDistributive = unsafeRefl 444 | minusIsPlusNeg = unsafeRefl 445 | 446 | export 447 | Ring Int32 where 448 | plusAssociative = unsafeRefl 449 | plusCommutative = unsafeRefl 450 | plusZeroLeftNeutral = unsafeRefl 451 | plusNegLeftZero = unsafeRefl 452 | multAssociative = unsafeRefl 453 | multCommutative = unsafeRefl 454 | multOneLeftNeutral = unsafeRefl 455 | leftDistributive = unsafeRefl 456 | minusIsPlusNeg = unsafeRefl 457 | 458 | export 459 | Ring Int64 where 460 | plusAssociative = unsafeRefl 461 | plusCommutative = unsafeRefl 462 | plusZeroLeftNeutral = unsafeRefl 463 | plusNegLeftZero = unsafeRefl 464 | multAssociative = unsafeRefl 465 | multCommutative = unsafeRefl 466 | multOneLeftNeutral = unsafeRefl 467 | leftDistributive = unsafeRefl 468 | minusIsPlusNeg = unsafeRefl 469 | 470 | export 471 | Ring Int where 472 | plusAssociative = unsafeRefl 473 | plusCommutative = unsafeRefl 474 | plusZeroLeftNeutral = unsafeRefl 475 | plusNegLeftZero = unsafeRefl 476 | multAssociative = unsafeRefl 477 | multCommutative = unsafeRefl 478 | multOneLeftNeutral = unsafeRefl 479 | leftDistributive = unsafeRefl 480 | minusIsPlusNeg = unsafeRefl 481 | 482 | export 483 | Ring Integer where 484 | plusAssociative = unsafeRefl 485 | plusCommutative = unsafeRefl 486 | plusZeroLeftNeutral = unsafeRefl 487 | plusNegLeftZero = unsafeRefl 488 | multAssociative = unsafeRefl 489 | multCommutative = unsafeRefl 490 | multOneLeftNeutral = unsafeRefl 491 | leftDistributive = unsafeRefl 492 | minusIsPlusNeg = unsafeRefl 493 | -------------------------------------------------------------------------------- /src/Algebra/Semigroup.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Semigroup 2 | 3 | %default total 4 | 5 | ||| This interface is a witness that for a 6 | ||| type `a` the axioms of a semigroup hold: `(<+>)` is associative. 7 | ||| 8 | ||| Note: If the type is actually a monoid, use `Data.Algebra.LMonoid` instead. 9 | public export 10 | interface Semigroup a => LSemigroup a where 11 | 0 appendAssociative : {x,y,z : a} -> x <+> (y <+> z) === (x <+> y) <+> z 12 | 13 | ||| This interface is a witness that for a 14 | ||| type `a` the axioms of a commutative semigroup hold: 15 | ||| `(<+>)` is commutative. 16 | public export 17 | interface LSemigroup a => CommutativeSemigroup a where 18 | 0 appendCommutative : {x,y : a} -> x <+> y === y <+> x 19 | -------------------------------------------------------------------------------- /src/Algebra/Semiring.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Semiring 2 | 3 | import Data.Nat 4 | import Syntax.PreorderReasoning 5 | 6 | %default total 7 | 8 | ||| This interface is a witness that for a 9 | ||| numeric type `a` the axioms of a commutative semiring hold: 10 | ||| 11 | ||| 1. `a` is a commutative monoid under addition: 12 | ||| 1. `+` is associative: `k + (m + n) = (k + m) + n` for all `k,m,n : a`. 13 | ||| 2. `+` is commutative: `m + n = n + m` for all `m,n : a`. 14 | ||| 3. 0 is the additive identity: `n + 0 = n` for all `n : a`. 15 | ||| 16 | ||| 2. `a` is a commutative monoid under multiplication: 17 | ||| 1. `*` is associative: `k * (m * n) = (k * m) * n` for all `k,m,n : a`. 18 | ||| 2. `*` is commutative: `m * n = n * m` for all `m,n : a`. 19 | ||| 3. 1 is the multiplicative identity: `n * 1 = n` for all `n : a`. 20 | ||| 21 | ||| 3. Multiplication is distributive with respect to addition: 22 | ||| `k * (m + n) = (k * m) + (k * n)` for all `k,m,n : a`. 23 | ||| 24 | public export 25 | interface Num a => Semiring a where 26 | ||| Addition is associative. 27 | 0 plusAssociative : {k,m,n : a} -> k + (m + n) === (k + m) + n 28 | 29 | ||| Addition is commutative. 30 | 0 plusCommutative : {m,n : a} -> m + n === n + m 31 | 32 | ||| 0 is the additive identity. 33 | 0 plusZeroLeftNeutral : {n : a} -> 0 + n === n 34 | 35 | ||| Multiplication is associative. 36 | 0 multAssociative : {k,m,n : a} -> k * (m * n) === (k * m) * n 37 | 38 | ||| Multiplication is commutative. 39 | 0 multCommutative : {m,n : a} -> m * n === n * m 40 | 41 | ||| 1 is the multiplicative identity. 42 | 0 multOneLeftNeutral : {n : a} -> 1 * n === n 43 | 44 | ||| Multiplication is distributive with respect to addition. 45 | 0 leftDistributive : {k,m,n : a} -> k * (m + n) === (k * m) + (k * n) 46 | 47 | ||| Zero is an absorbing element of multiplication. 48 | 0 multZeroLeftAbsorbs : {n : a} -> 0 * n === 0 49 | 50 | -------------------------------------------------------------------------------- 51 | -- Proofs on Addition 52 | -------------------------------------------------------------------------------- 53 | 54 | ||| `n + 0 === n` for all `n : a`. 55 | export 56 | 0 plusZeroRightNeutral : Semiring a => {n : a} -> n + 0 === n 57 | plusZeroRightNeutral = 58 | Calc $ 59 | |~ n + 0 60 | ~~ 0 + n ... plusCommutative 61 | ~~ n ... plusZeroLeftNeutral 62 | 63 | -------------------------------------------------------------------------------- 64 | -- Proofs on Multiplication 65 | -------------------------------------------------------------------------------- 66 | 67 | ||| `n * 1 === n` for all `n : a`. 68 | export 69 | 0 multOneRightNeutral : Semiring a => {n : a} -> n * 1 === n 70 | multOneRightNeutral = 71 | Calc $ 72 | |~ n * 1 73 | ~~ 1 * n ... multCommutative 74 | ~~ n ... multOneLeftNeutral 75 | 76 | ||| Zero is an absorbing element of multiplication. 77 | export 78 | 0 multZeroRightAbsorbs : Semiring a => {n : a} -> n * 0 === 0 79 | multZeroRightAbsorbs = 80 | Calc $ 81 | |~ n * 0 82 | ~~ 0 * n ... multCommutative 83 | ~~ 0 ... multZeroLeftAbsorbs 84 | 85 | ||| Zero is an absorbing element of multiplication. 86 | export 87 | multZeroAbsorbs : 88 | {auto _ : Semiring a} 89 | -> (m,n : a) 90 | -> Either (m === 0) (n === 0) 91 | -> m * n === 0 92 | multZeroAbsorbs m n (Left rfl) = 93 | Calc $ 94 | |~ m * n 95 | ~~ 0 * n ... cong (*n) rfl 96 | ~~ 0 ... multZeroLeftAbsorbs 97 | 98 | multZeroAbsorbs m n (Right rfl) = 99 | Calc $ 100 | |~ m * n 101 | ~~ m * 0 ... cong (m*) rfl 102 | ~~ 0 ... multZeroRightAbsorbs 103 | 104 | ||| Multiplication is distributive with respect to addition. 105 | export 106 | 0 rightDistributive : 107 | {auto _ : Semiring a} 108 | -> {k,m,n : a} 109 | -> (m + n) * k === m * k + n * k 110 | rightDistributive = 111 | Calc $ 112 | |~ (m + n) * k 113 | ~~ k * (m + n) ... multCommutative 114 | ~~ (k * m) + (k * n) ... leftDistributive 115 | ~~ m * k + k * n ... cong (+ k * n) multCommutative 116 | ~~ m * k + n * k ... cong (m * k +) multCommutative 117 | 118 | -------------------------------------------------------------------------------- 119 | -- Implementations 120 | -------------------------------------------------------------------------------- 121 | 122 | export 123 | Semiring Nat where 124 | plusAssociative = Nat.plusAssociative _ _ _ 125 | plusCommutative = Nat.plusCommutative _ _ 126 | plusZeroLeftNeutral = Nat.plusZeroLeftNeutral _ 127 | multAssociative = Nat.multAssociative _ _ _ 128 | multCommutative = Nat.multCommutative _ _ 129 | multOneLeftNeutral = Nat.multOneLeftNeutral _ 130 | leftDistributive = multDistributesOverPlusRight _ _ _ 131 | multZeroLeftAbsorbs = Refl 132 | -------------------------------------------------------------------------------- /src/Algebra/Solver/CommutativeMonoid.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.CommutativeMonoid 2 | 3 | import public Algebra.Monoid 4 | import public Algebra.Solver.Prod 5 | import Syntax.PreorderReasoning 6 | 7 | %default total 8 | 9 | public export 10 | times : CommutativeMonoid a => Nat -> a -> a 11 | times 0 x = neutral 12 | times (S k) x = x <+> times k x 13 | 14 | public export 15 | data Expr : (a : Type) -> (as : List a) -> Type where 16 | Lit : (x : a) -> Expr a as 17 | Var : (x : a) -> Elem x as -> Expr a as 18 | Neutral : Expr a as 19 | Append : Expr a as -> Expr a as -> Expr a as 20 | 21 | public export 22 | FromString a => FromString (Expr a as) where 23 | fromString = Lit . fromString 24 | 25 | public export 26 | Semigroup (Expr a as) where 27 | (<+>) = Append 28 | 29 | public export 30 | Monoid (Expr a as) where 31 | neutral = Neutral 32 | 33 | -------------------------------------------------------------------------------- 34 | -- Normalization 35 | -------------------------------------------------------------------------------- 36 | 37 | public export 38 | record Term (a : Type) (as : List a) where 39 | constructor T 40 | factor : a 41 | prod : Prod a as 42 | 43 | public export 44 | append : CommutativeMonoid a => Term a as -> Term a as -> Term a as 45 | append (T f1 p1) (T f2 p2) = T (f1 <+> f2) (mult p1 p2) 46 | 47 | public export 48 | normalize : CommutativeMonoid a => {as : List a} -> Expr a as -> Term a as 49 | normalize (Lit x) = T x one 50 | normalize (Var x y) = T neutral (fromVar y) 51 | normalize Neutral = T neutral one 52 | normalize (Append x y) = append (normalize x) (normalize y) 53 | 54 | -------------------------------------------------------------------------------- 55 | -- Evaluation 56 | -------------------------------------------------------------------------------- 57 | 58 | public export 59 | eval : CommutativeMonoid a => Expr a as -> a 60 | eval (Lit x) = x 61 | eval (Var x y) = x 62 | eval Neutral = neutral 63 | eval (Append x y) = eval x <+> eval y 64 | 65 | public export 66 | eprod : CommutativeMonoid a => {as : List a} -> Prod a as -> a 67 | eprod [] = neutral 68 | eprod {as = v :: vs} (exp :: x) = times exp v <+> eprod x 69 | 70 | public export 71 | eterm : CommutativeMonoid a => {as : List a} -> Term a as -> a 72 | eterm (T f p) = f <+> eprod p 73 | 74 | -------------------------------------------------------------------------------- 75 | -- Proofs 76 | -------------------------------------------------------------------------------- 77 | 78 | 0 p1324 : 79 | {auto _ : CommutativeMonoid a} 80 | -> {k,l,m,n : a} 81 | -> (k <+> l) <+> (m <+> n) === (k <+> m) <+> (l <+> n) 82 | p1324 = Calc $ 83 | |~ (k <+> l) <+> (m <+> n) 84 | ~~ ((k <+> l) <+> m) <+> n ... appendAssociative 85 | ~~ (k <+> (l <+> m)) <+> n ..< cong (<+>n) appendAssociative 86 | ~~ (k <+> (m <+> l)) <+> n ... cong (\x => (k <+> x) <+> n) appendCommutative 87 | ~~ ((k <+> m) <+> l) <+> n ... cong (<+>n) appendAssociative 88 | ~~ (k <+> m) <+> (l <+> n) ..< appendAssociative 89 | 90 | 0 pone : 91 | {auto _ : CommutativeMonoid a} 92 | -> (as : List a) 93 | -> eprod {as} Prod.one === Prelude.neutral 94 | pone [] = Refl 95 | pone (v :: vs) = Calc $ 96 | |~ neutral <+> eprod {as = vs} one 97 | ~~ neutral <+> neutral ... cong (neutral <+>) (pone vs) 98 | ~~ neutral ... appendLeftNeutral 99 | 100 | export 101 | 0 pvar : 102 | {auto _ : CommutativeMonoid a} 103 | -> (as : List a) 104 | -> (e : Elem x as) 105 | -> eprod (fromVar {as} e) === x 106 | pvar (x :: vs) Here = Calc $ 107 | |~ (x <+> neutral) <+> eprod {as = vs} one 108 | ~~ (x <+> neutral) <+> neutral ... cong ((x <+> neutral) <+>) (pone vs) 109 | ~~ x <+> neutral ... appendRightNeutral 110 | ~~ x ... appendRightNeutral 111 | 112 | pvar (v :: vs) (There y) = Calc $ 113 | |~ neutral <+> eprod (fromVar y) 114 | ~~ eprod (fromVar y) ... appendLeftNeutral 115 | ~~ x ... pvar vs y 116 | 117 | pvar [] Here impossible 118 | pvar [] (There y) impossible 119 | 120 | 0 ptimes : 121 | {auto _ : CommutativeMonoid a} 122 | -> (m,n : Nat) 123 | -> (x : a) 124 | -> times m x <+> times n x === times (m + n) x 125 | ptimes 0 n x = appendLeftNeutral 126 | ptimes (S k) n x = Calc $ 127 | |~ (x <+> times k x) <+> times n x 128 | ~~ x <+> (times k x <+> times n x) ..< appendAssociative 129 | ~~ x <+> times (k + n) x ... cong (x <+>) (ptimes k n x) 130 | 131 | 132 | 0 ppm : 133 | {auto _ : CommutativeMonoid a} 134 | -> (e1,e2 : Prod a as) 135 | -> eprod e1 <+> eprod e2 === eprod (mult e1 e2) 136 | ppm [] [] = appendRightNeutral 137 | ppm {as = v :: vs} (m :: xs) (n :: ys) = Calc $ 138 | |~ (times m v <+> eprod xs) <+> (times n v <+> eprod ys) 139 | ~~ (times m v <+> times n v) <+> (eprod xs <+> eprod ys) 140 | ... p1324 141 | ~~ (times m v <+> times n v) <+> eprod (mult xs ys) 142 | ... cong ((times m v <+> times n v) <+>) (ppm xs ys) 143 | ~~ times (m + n) v <+> eprod (mult xs ys) 144 | ... cong (<+> eprod (mult xs ys)) (ptimes m n v) 145 | 146 | 147 | 0 pappend : 148 | {auto _ : CommutativeMonoid a} 149 | -> (e1,e2 : Term a as) 150 | -> eterm e1 <+> eterm e2 === eterm (append e1 e2) 151 | pappend (T f p) (T g q) = Calc $ 152 | |~ (f <+> eprod p) <+> (g <+> eprod q) 153 | ~~ (f <+> g) <+> (eprod p <+> eprod q) ... p1324 154 | ~~ (f <+> g) <+> eprod (mult p q) ... cong ((f <+> g) <+>) (ppm p q) 155 | 156 | 0 pnorm : 157 | {auto _ : CommutativeMonoid a} 158 | -> (e : Expr a as) 159 | -> eval e === eterm (normalize e) 160 | pnorm (Lit x) = Calc $ 161 | |~ x 162 | ~~ x <+> neutral ..< appendRightNeutral 163 | ~~ x <+> eprod {as} one ..< cong (x <+>) (pone as) 164 | 165 | pnorm (Var x y) = Calc $ 166 | |~ x 167 | ~~ eprod (fromVar y) ..< pvar as y 168 | ~~ neutral <+> eprod (fromVar y) ..< appendLeftNeutral 169 | 170 | pnorm Neutral = Calc $ 171 | |~ neutral 172 | ~~ neutral <+> neutral ..< appendRightNeutral 173 | ~~ neutral <+> eprod {as} one ..< cong (neutral <+>) (pone as) 174 | 175 | pnorm (Append x y) = Calc $ 176 | |~ eval x <+> eval y 177 | ~~ eterm (normalize x) <+> eval y 178 | ... cong (<+> eval y) (pnorm x) 179 | ~~ eterm (normalize x) <+> eterm (normalize y) 180 | ... cong (eterm (normalize x) <+>) (pnorm y) 181 | ~~ eterm (append (normalize x) (normalize y)) 182 | ... pappend (normalize x) (normalize y) 183 | 184 | -------------------------------------------------------------------------------- 185 | -- Solver 186 | -------------------------------------------------------------------------------- 187 | 188 | export 189 | 0 solve : 190 | {auto _ : CommutativeMonoid a} 191 | -> (as : List a) 192 | -> (e1,e2 : Expr a as) 193 | -> {auto prf : normalize e1 === normalize e2} 194 | -> eval e1 === eval e2 195 | solve _ e1 e2 = Calc $ 196 | |~ eval e1 197 | ~~ eterm (normalize e1) ... pnorm e1 198 | ~~ eterm (normalize e2) ... cong eterm prf 199 | ~~ eval e2 ..< pnorm e2 200 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Monoid.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Monoid 2 | 3 | import Algebra.Monoid 4 | import Syntax.PreorderReasoning 5 | 6 | %default total 7 | 8 | public export 9 | data Expr : (a : Type) -> Type where 10 | Var : (x : a) -> Expr a 11 | Neutral : Expr a 12 | Append : Expr a -> Expr a -> Expr a 13 | 14 | public export 15 | Semigroup (Expr a) where 16 | (<+>) = Append 17 | 18 | public export 19 | Monoid (Expr a) where 20 | neutral = Neutral 21 | 22 | public export 23 | eval : LMonoid a => Expr a -> a 24 | eval (Var x) = x 25 | eval Neutral = neutral 26 | eval (Append x y) = eval x <+> eval y 27 | 28 | -------------------------------------------------------------------------------- 29 | -- Sum 30 | -------------------------------------------------------------------------------- 31 | 32 | public export 33 | esum : LMonoid a => List a -> a 34 | esum [] = neutral 35 | esum (h :: t) = h <+> esum t 36 | 37 | public export 38 | normalize : Expr a -> List a 39 | normalize (Var x) = x :: [] 40 | normalize Neutral = [] 41 | normalize (Append x y) = normalize x ++ normalize y 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Proofs 45 | -------------------------------------------------------------------------------- 46 | 47 | 0 psum : 48 | {auto _ : LMonoid a} 49 | -> (xs,ys : List a) 50 | -> esum (xs ++ ys) === esum xs <+> esum ys 51 | psum [] ys = sym appendLeftNeutral 52 | psum (x :: xs) ys = Calc $ 53 | |~ x <+> esum (xs ++ ys) 54 | ~~ x <+> (esum xs <+> esum ys) ... cong (x <+>) (psum xs ys) 55 | ~~ (x <+> esum xs) <+> esum ys ... appendAssociative 56 | 57 | 58 | 0 pnorm : LMonoid a => (e : Expr a) -> eval e === esum (normalize e) 59 | pnorm (Var x) = sym appendRightNeutral 60 | pnorm Neutral = Refl 61 | pnorm (Append x y) = Calc $ 62 | |~ eval x <+> eval y 63 | ~~ esum (normalize x) <+> eval y 64 | ... cong (<+> eval y) (pnorm x) 65 | ~~ esum (normalize x) <+> esum (normalize y) 66 | ... cong (esum (normalize x) <+>) (pnorm y) 67 | ~~ esum (normalize x ++ normalize y) 68 | ..< psum (normalize x) (normalize y) 69 | 70 | -------------------------------------------------------------------------------- 71 | -- Solver 72 | -------------------------------------------------------------------------------- 73 | 74 | export 75 | 0 solve : 76 | {auto _ : LMonoid a} 77 | -> (e1,e2 : Expr a) 78 | -> {auto prf : normalize e1 === normalize e2} 79 | -> eval e1 === eval e2 80 | solve e1 e2 = Calc $ 81 | |~ eval e1 82 | ~~ esum (normalize e1) ... pnorm e1 83 | ~~ esum (normalize e2) ... cong esum prf 84 | ~~ eval e2 ..< pnorm e2 85 | 86 | -------------------------------------------------------------------------------- 87 | -- Example 88 | -------------------------------------------------------------------------------- 89 | 90 | 0 solverExample : {x,y,z : String} 91 | -> x ++ ((y ++ "") ++ z) === ("" ++ x) ++ (y ++ z) 92 | solverExample = 93 | solve 94 | (Var x <+> ((Var y <+> Neutral) <+> Var z)) 95 | ((Neutral <+> Var x) <+> (Var y <+> Var z)) 96 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Prod.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Prod 2 | 3 | import public Data.List.Elem 4 | 5 | %default total 6 | 7 | ||| A product of variables each represented by the exponent, 8 | ||| to which it is raised. 9 | ||| 10 | ||| When normalizing arithmetic expressions, they often 11 | ||| get converted to (sums of) products of variables 12 | ||| (listed in index `as`), each raised to a certain 13 | ||| exponent. This is the case for commutative monoids 14 | ||| (a single product) as well as commutative (semi)rings 15 | ||| (a sum of products). 16 | public export 17 | data Prod : (a : Type) -> (as : List a) -> Type where 18 | Nil : Prod a [] 19 | (::) : (exp : Nat) -> Prod a xs -> Prod a (x :: xs) 20 | 21 | ||| Multiplying two products means adding all 22 | ||| expontents pairwise. 23 | public export 24 | mult : Prod a as -> Prod a as -> Prod a as 25 | mult [] [] = [] 26 | mult (x :: xs) (y :: ys) = (x + y) :: mult xs ys 27 | 28 | ||| We sort products by lexicographically comparing 29 | ||| the exponents. 30 | public export 31 | compProd : Prod a as -> Prod a as -> Ordering 32 | compProd [] [] = EQ 33 | compProd (x :: xs) (y :: ys) = case compare x y of 34 | LT => LT 35 | GT => GT 36 | EQ => compProd xs ys 37 | 38 | ||| The neutral product where all exponents are zero. 39 | public export 40 | one : {as : List a} -> Prod a as 41 | one {as = []} = [] 42 | one {as = x :: xs} = 0 :: one 43 | 44 | ||| Convert a single variable to a product of variables. 45 | public export 46 | fromVar : {as : List a} -> Elem x as -> Prod a as 47 | fromVar {as = x :: xs} Here = 1 :: one 48 | fromVar {as = x :: xs} (There y) = 0 :: fromVar y 49 | fromVar {as = []} Here impossible 50 | fromVar {as = []} (There y) impossible 51 | 52 | -------------------------------------------------------------------------------- 53 | -- Proofs 54 | -------------------------------------------------------------------------------- 55 | 56 | Uninhabited (LT = EQ) where 57 | uninhabited _ impossible 58 | 59 | Uninhabited (GT = EQ) where 60 | uninhabited _ impossible 61 | 62 | export 63 | 0 pcompNat : (x,y : Nat) -> (compare x y === EQ) -> x === y 64 | pcompNat 0 0 prf = Refl 65 | pcompNat (S k) (S j) prf = cong S $ pcompNat k j prf 66 | pcompNat 0 (S k) Refl impossible 67 | pcompNat (S k) 0 Refl impossible 68 | 69 | export 70 | 0 pcompProd : 71 | (x,y : Prod a as) 72 | -> (compProd x y === EQ) 73 | -> x === y 74 | pcompProd [] [] prf = Refl 75 | pcompProd (x :: xs) (y :: ys) prf with (compare x y) proof eq 76 | _ | EQ = cong2 (::) (pcompNat x y eq) (pcompProd xs ys prf) 77 | _ | LT = absurd prf 78 | _ | GT = absurd prf 79 | pcompProd [] (_ :: _) Refl impossible 80 | pcompProd (_ :: _) [] Refl impossible 81 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Ring.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Ring 2 | 3 | import public Algebra.Ring 4 | import public Algebra.Solver.Ring.Expr 5 | import public Algebra.Solver.Ring.Prod 6 | import public Algebra.Solver.Ring.SolvableRing 7 | import public Algebra.Solver.Ring.Sum 8 | 9 | %default total 10 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Ring/Expr.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Ring.Expr 2 | 3 | import public Data.List.Elem 4 | import public Algebra.Ring 5 | import Syntax.PreorderReasoning 6 | 7 | %default total 8 | 9 | -------------------------------------------------------------------------------- 10 | -- Natural Numbers 11 | -------------------------------------------------------------------------------- 12 | 13 | ||| Multiplies a value `n` times with itself. In case of `n` 14 | ||| being zero, this returns `1`. 15 | public export 16 | pow : Ring a => a -> Nat -> a 17 | pow x 0 = 1 18 | pow x (S k) = x * pow x k 19 | 20 | -------------------------------------------------------------------------------- 21 | -- Expression 22 | -------------------------------------------------------------------------------- 23 | 24 | ||| Data type representing expressions in a commutative ring. 25 | ||| 26 | ||| This is used to at compile time compare different forms of 27 | ||| the same expression and proof that they evaluate to 28 | ||| the same result. 29 | ||| 30 | ||| An example: 31 | ||| 32 | ||| ```idris example 33 | ||| 0 binom1 : {x,y : Bits8} -> (x + y) * (x + y) === x * x + 2 * x * y + y * y 34 | ||| binom1 = solve [x,y] 35 | ||| ((x .+. y) * (x .+. y)) 36 | ||| (x .*. x + 2 *. x *. y + y .*. y) 37 | ||| ``` 38 | ||| 39 | ||| @ a the type used in the arithmetic expression 40 | ||| @ as list of variables which don't reduce at compile time 41 | ||| 42 | ||| In the example above, `x` and `y` are variables, while `2` 43 | ||| is a literal known at compile time. To make working with 44 | ||| variables more convenient (the have to be wrapped in data 45 | ||| constructor `Var`, by using function `var` for instance), 46 | ||| additional operators for addition, multiplication, and 47 | ||| subtraction are provided. 48 | ||| 49 | ||| In order to proof that two expressions evaluate to the 50 | ||| same results, the following steps are taken at compile 51 | ||| time: 52 | ||| 53 | ||| 1. Both expressions are converted to a normal form via 54 | ||| `Algebra.Solver.Ring.Sum.normalize`. 55 | ||| 2. The normal forms are compared for being identical. 56 | ||| 3. Since in `Algebra.Solver.Ring.Sum` there is a proof that 57 | ||| converting an expression to its normal form does not 58 | ||| affect the result when evaluating it, if the normal 59 | ||| forms are identical, the two expressions must evaluate 60 | ||| to the same result. 61 | ||| 62 | ||| You can find several examples of making use of this 63 | ||| in `Data.Prim.Integer.Extra`. 64 | public export 65 | data Expr : (a : Type) -> (as : List a) -> Type where 66 | ||| A literal. This should be a value known at compile time 67 | ||| so that it reduces during normalization. 68 | Lit : (v : a) -> Expr a as 69 | 70 | ||| A variabl. This is is for values not known at compile 71 | ||| time. In order to compare and merge variables, we need an 72 | ||| `Elem x as` proof. 73 | Var : (x : a) -> Elem x as -> Expr a as 74 | 75 | ||| Negates and expression. 76 | Neg : Expr a as -> Expr a as 77 | 78 | ||| Addition of two expressions. 79 | Plus : (x,y : Expr a as) -> Expr a as 80 | 81 | ||| Multiplication of two expressions. 82 | Mult : (x,y : Expr a as) -> Expr a as 83 | 84 | ||| Subtraction of two expressions. 85 | Minus : (x,y : Expr a as) -> Expr a as 86 | 87 | ||| While this allows you to use the usual operators 88 | ||| for addition and multiplication, it is often convenient 89 | ||| to use related operators `.*.`, `.+.`, and similar when 90 | ||| working with variables. 91 | public export 92 | Num a => Num (Expr a as) where 93 | (+) = Plus 94 | (*) = Mult 95 | fromInteger = Lit . fromInteger 96 | 97 | public export 98 | Neg a => Neg (Expr a as) where 99 | negate = Neg 100 | (-) = Minus 101 | 102 | ||| Like `Var` but takes the `Elem x as` as an auto implicit 103 | ||| argument. 104 | public export 105 | var : {0 as : List a} -> (x : a) -> Elem x as => Expr a as 106 | var x = Var x %search 107 | 108 | -------------------------------------------------------------------------------- 109 | -- Syntax 110 | -------------------------------------------------------------------------------- 111 | 112 | export infixl 8 .+., .+, +. 113 | 114 | export infixl 8 .-., .-, -. 115 | 116 | export infixl 9 .*., .*, *. 117 | 118 | ||| Addition of variables. This is an alias for 119 | ||| `var x + var y`. 120 | public export 121 | (.+.) : 122 | {0 as : List a} 123 | -> (x,y : a) 124 | -> {auto _ : Elem x as} 125 | -> {auto _ : Elem y as} 126 | -> Expr a as 127 | (.+.) x y = Plus (var x) (var y) 128 | 129 | ||| Addition of variables. This is an alias for 130 | ||| `x + var y`. 131 | public export 132 | (+.) : 133 | {0 as : List a} 134 | -> (x : Expr a as) 135 | -> (y : a) 136 | -> {auto _ : Elem y as} 137 | -> Expr a as 138 | (+.) x y = Plus x (var y) 139 | 140 | ||| Addition of variables. This is an alias for 141 | ||| `var x + y`. 142 | public export 143 | (.+) : 144 | {0 as : List a} 145 | -> (x : a) 146 | -> (y : Expr a as) 147 | -> {auto _ : Elem x as} 148 | -> Expr a as 149 | (.+) x y = Plus (var x) y 150 | 151 | ||| Subtraction of variables. This is an alias for 152 | ||| `var x - var y`. 153 | public export 154 | (.-.) : 155 | {0 as : List a} 156 | -> (x,y : a) 157 | -> {auto _ : Elem x as} 158 | -> {auto _ : Elem y as} 159 | -> Expr a as 160 | (.-.) x y = Minus (var x) (var y) 161 | 162 | ||| Subtraction of variables. This is an alias for 163 | ||| `x - var y`. 164 | public export 165 | (-.) : 166 | {0 as : List a} 167 | -> (x : Expr a as) 168 | -> (y : a) 169 | -> {auto _ : Elem y as} 170 | -> Expr a as 171 | (-.) x y = Minus x (var y) 172 | 173 | ||| Subtraction of variables. This is an alias for 174 | ||| `var x - y`. 175 | public export 176 | (.-) : 177 | {0 as : List a} 178 | -> (x : a) 179 | -> (y : Expr a as) 180 | -> {auto _ : Elem x as} 181 | -> Expr a as 182 | (.-) x y = Minus (var x) y 183 | 184 | ||| Multiplication of variables. This is an alias for 185 | ||| `var x * var y`. 186 | public export 187 | (.*.) : 188 | {0 as : List a} 189 | -> (x,y : a) 190 | -> {auto _ : Elem x as} 191 | -> {auto _ : Elem y as} 192 | -> Expr a as 193 | (.*.) x y = Mult (var x) (var y) 194 | 195 | ||| Multiplication of variables. This is an alias for 196 | ||| `var x * y`. 197 | public export 198 | (*.) : 199 | {0 as : List a} 200 | -> (x : Expr a as) 201 | -> (y : a) 202 | -> {auto _ : Elem y as} 203 | -> Expr a as 204 | (*.) x y = Mult x (var y) 205 | 206 | ||| Multiplication of variables. This is an alias for 207 | ||| `x * var y`. 208 | public export 209 | (.*) : 210 | {0 as : List a} 211 | -> (x : a) 212 | -> (y : Expr a as) 213 | -> {auto _ : Elem x as} 214 | -> Expr a as 215 | (.*) x y = Mult (var x) y 216 | 217 | -------------------------------------------------------------------------------- 218 | -- Evaluation 219 | -------------------------------------------------------------------------------- 220 | 221 | ||| Evaluation of expressions. This keeps the exact 222 | ||| structure of the expression tree. For instance 223 | ||| `eval $ x .*. (y .+. z)` evaluates to `x * (y + z)`. 224 | public export 225 | eval : Ring a => Expr a as -> a 226 | eval (Lit v) = v 227 | eval (Var x y) = x 228 | eval (Neg v) = neg $ eval v 229 | eval (Plus x y) = eval x + eval y 230 | eval (Mult x y) = eval x * eval y 231 | eval (Minus x y) = eval x - eval y 232 | 233 | -------------------------------------------------------------------------------- 234 | -- Proofs 235 | -------------------------------------------------------------------------------- 236 | 237 | ||| Proof that addition of exponents is equivalent to multiplcation 238 | ||| of the two terms. 239 | export 240 | 0 ppow : 241 | {auto _ : Ring a} 242 | -> (m,n : Nat) 243 | -> (x : a) 244 | -> pow x (m + n) === pow x m * pow x n 245 | ppow 0 n x = sym multOneLeftNeutral 246 | ppow (S k) n x = Calc $ 247 | |~ x * pow x (plus k n) 248 | ~~ x * (pow x k * pow x n) ... cong (x*) (ppow k n x) 249 | ~~ (x * pow x k) * pow x n ... multAssociative 250 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Ring/Prod.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Ring.Prod 2 | 3 | import Algebra.Solver.Ring.Expr 4 | import public Algebra.Solver.Prod 5 | import Algebra.Solver.Ring.Util 6 | 7 | %default total 8 | 9 | ||| Evaluate products of variables each raised to 10 | ||| given exponent. 11 | ||| 12 | ||| Every arithmetic expression in a commutative ring 13 | ||| can be represented as a sum of products of the variables 14 | ||| each raised by an exponent and multiplied by a constant 15 | ||| factor. For instance, expression `x + x * (y + z + z)` 16 | ||| gets normalized to `x + x * y + 2 * x * z`. 17 | public export 18 | eprod : Ring a => {as : List a} -> Prod a as -> a 19 | eprod {as = []} [] = 1 20 | eprod {as = x :: xs} (e :: es) = pow x e * eprod es 21 | 22 | -------------------------------------------------------------------------------- 23 | -- Proofs 24 | -------------------------------------------------------------------------------- 25 | 26 | ||| Proof that `one` evaluates to 1. 27 | export 28 | 0 pone : Ring a => (as : List a) -> eprod (one {as}) === 1 29 | pone [] = Refl 30 | pone (x :: xs) = Calc $ 31 | |~ 1 * eprod (one {as = xs}) 32 | ~~ 1 * 1 ... cong (1 * ) (pone xs) 33 | ~~ 1 ... multOneRightNeutral 34 | 35 | ||| Proof that `fromVar x` evaluates to `x`. 36 | export 37 | 0 pvar : 38 | {auto _ : Ring a} 39 | -> (as : List a) 40 | -> (e : Elem x as) 41 | -> eprod (fromVar {as} e) === x 42 | pvar (x :: vs) Here = Calc $ 43 | |~ (x * 1) * eprod (one {as = vs}) 44 | ~~ (x * 1) * 1 ... cong ((x*1) *) (pone vs) 45 | ~~ x * 1 ... multOneRightNeutral 46 | ~~ x ... multOneRightNeutral 47 | 48 | pvar (v :: vs) (There y) = Calc $ 49 | |~ 1 * eprod (fromVar {as = vs} y) 50 | ~~ 1 * x ... cong (1*) (pvar vs y) 51 | ~~ x ... multOneLeftNeutral 52 | 53 | pvar [] Here impossible 54 | pvar [] (There y) impossible 55 | 56 | ||| Proof that evaluation of a multiplication of products 57 | ||| is the same as multiplying the results of evaluating each 58 | ||| of them. 59 | export 60 | 0 pmult : 61 | {auto _ : Ring a} 62 | -> (p,q : Prod a as) 63 | -> eprod (mult p q) === eprod p * eprod q 64 | pmult [] [] = sym multOneLeftNeutral 65 | pmult {as = h :: t} (x :: xs) (y :: ys) = Calc $ 66 | |~ pow h (x + y) * eprod (mult xs ys) 67 | ~~ (pow h x * pow h y) * eprod (mult xs ys) 68 | ... cong (* eprod (mult xs ys)) (ppow x y h) 69 | ~~ (pow h x * pow h y) * (eprod xs * eprod ys) 70 | ... cong ((pow h x * pow h y) *) (pmult xs ys) 71 | ~~ (pow h x * eprod xs) * (pow h y * eprod ys) 72 | ... Util.m1324 73 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Ring/SolvableRing.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Ring.SolvableRing 2 | 3 | import Algebra.Ring 4 | 5 | %default total 6 | 7 | ||| When normalizing arithmetic expressions, we must 8 | ||| make sure that factors that evaluate to zero must 9 | ||| be removed from the sum of products. 10 | ||| 11 | ||| For instance, the following example only works, 12 | ||| if the term `0 * x * y` gets removed before comparing 13 | ||| the normalized sums: 14 | ||| 15 | ||| ```idris example 16 | ||| 0 binom3 : {x,y : Bits8} -> (x + y) * (x - y) === x * x - y * y 17 | ||| binom3 = solve [x,y] ((x .+. y) * (x .-. y)) (x .*. x - y .*. y) 18 | ||| ``` 19 | ||| 20 | ||| Because we cannot directly use a (primitive) pattern match 21 | ||| without having a concrete type, we need this interface. 22 | ||| (We *could* use `DecEq`, but this is not publicly exported 23 | ||| for the primitives; probably for good reasons since it is 24 | ||| implemented using `believe_me`). 25 | public export 26 | interface Ring a => SolvableRing a where 27 | 28 | ||| Checks if a value is propositionally equal to zero. 29 | isZero : (v : a) -> Maybe (v === 0) 30 | 31 | public export 32 | SolvableRing Bits8 where 33 | isZero 0 = Just Refl 34 | isZero _ = Nothing 35 | 36 | public export 37 | SolvableRing Bits16 where 38 | isZero 0 = Just Refl 39 | isZero _ = Nothing 40 | 41 | public export 42 | SolvableRing Bits32 where 43 | isZero 0 = Just Refl 44 | isZero _ = Nothing 45 | 46 | public export 47 | SolvableRing Bits64 where 48 | isZero 0 = Just Refl 49 | isZero _ = Nothing 50 | 51 | public export 52 | SolvableRing Int8 where 53 | isZero 0 = Just Refl 54 | isZero _ = Nothing 55 | 56 | public export 57 | SolvableRing Int16 where 58 | isZero 0 = Just Refl 59 | isZero _ = Nothing 60 | 61 | public export 62 | SolvableRing Int32 where 63 | isZero 0 = Just Refl 64 | isZero _ = Nothing 65 | 66 | public export 67 | SolvableRing Int64 where 68 | isZero 0 = Just Refl 69 | isZero _ = Nothing 70 | 71 | public export 72 | SolvableRing Int where 73 | isZero 0 = Just Refl 74 | isZero _ = Nothing 75 | 76 | public export 77 | SolvableRing Integer where 78 | isZero 0 = Just Refl 79 | isZero _ = Nothing 80 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Ring/Sum.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Ring.Sum 2 | 3 | import Algebra.Solver.Ring.Expr 4 | import Algebra.Solver.Ring.Prod 5 | import Algebra.Solver.Ring.SolvableRing 6 | import Algebra.Solver.Ring.Util 7 | 8 | %default total 9 | 10 | ||| A single term in a normalized arithmetic expressions. 11 | ||| 12 | ||| This is a product of all variables each raised to 13 | ||| a given power, multiplied with a factors (which is supposed 14 | ||| to reduce during elaboration). 15 | public export 16 | record Term (a : Type) (as : List a) where 17 | constructor T 18 | factor : a 19 | prod : Prod a as 20 | 21 | ||| Evaluate a term. 22 | public export 23 | eterm : Ring a => {as : List a} -> Term a as -> a 24 | eterm (T f p) = f * eprod p 25 | 26 | ||| Negate a term. 27 | public export 28 | negTerm : Ring a => Term a as -> Term a as 29 | negTerm (T f p) = T (negate f) p 30 | 31 | ||| Normalized arithmetic expression in a commutative 32 | ||| ring (represented as an (ordered) sum of terms). 33 | public export 34 | data Sum : (a : Type) -> (as : List a) -> Type where 35 | Nil : {0 as : List a} -> Sum a as 36 | (::) : {0 as : List a} -> Term a as -> Sum a as -> Sum a as 37 | 38 | ||| Evaluate a sum of terms. 39 | public export 40 | esum : Ring a => {as : List a} -> Sum a as -> a 41 | esum [] = 0 42 | esum (x :: xs) = eterm x + esum xs 43 | 44 | ||| Negate a sum of terms. 45 | public export 46 | negate : Ring a => Sum a as -> Sum a as 47 | negate [] = [] 48 | negate (x :: y) = negTerm x :: negate y 49 | 50 | 51 | -------------------------------------------------------------------------------- 52 | -- Normalizer 53 | -------------------------------------------------------------------------------- 54 | 55 | ||| Add two sums of terms. 56 | ||| 57 | ||| The order of terms will be kept. If two terms have identical 58 | ||| products of variables, they will be unified by adding their 59 | ||| factors. 60 | public export 61 | add : SolvableRing a => Sum a as -> Sum a as -> Sum a as 62 | add [] ys = ys 63 | add xs [] = xs 64 | add (T m x :: xs) (T n y :: ys) = case compProd x y of 65 | LT => T m x :: add xs (T n y :: ys) 66 | GT => T n y :: add (T m x :: xs) ys 67 | EQ => T (m + n) y :: add xs ys 68 | 69 | ||| Normalize a sum of terms by removing all terms with a 70 | ||| `zero` factor. 71 | public export 72 | normSum : SolvableRing a => Sum a as -> Sum a as 73 | normSum [] = [] 74 | normSum (T f p :: y) = case isZero f of 75 | Just refl => normSum y 76 | Nothing => T f p :: normSum y 77 | 78 | ||| Multiplies a single term with a sum of terms. 79 | public export 80 | mult1 : SolvableRing a => Term a as -> Sum a as -> Sum a as 81 | mult1 (T f p) (T g q :: xs) = T (f * g) (mult p q) :: mult1 (T f p) xs 82 | mult1 _ [] = [] 83 | 84 | ||| Multiplies two sums of terms. 85 | public export 86 | mult : SolvableRing a => Sum a as -> Sum a as -> Sum a as 87 | mult [] ys = [] 88 | mult (x :: xs) ys = add (mult1 x ys) (mult xs ys) 89 | 90 | ||| Normalizes an arithmetic expression to a sum of products. 91 | public export 92 | norm : SolvableRing a => {as : List a} -> Expr a as -> Sum a as 93 | norm (Lit n) = [T n one] 94 | norm (Var x y) = [T 1 $ fromVar y] 95 | norm (Neg x) = negate $ norm x 96 | norm (Plus x y) = add (norm x) (norm y) 97 | norm (Mult x y) = mult (norm x) (norm y) 98 | norm (Minus x y) = add (norm x) (negate $ norm y) 99 | 100 | ||| Like `norm` but removes all `zero` terms. 101 | public export 102 | normalize : SolvableRing a => {as : List a} -> Expr a as -> Sum a as 103 | normalize e = normSum (norm e) 104 | 105 | -------------------------------------------------------------------------------- 106 | -- Proofs 107 | -------------------------------------------------------------------------------- 108 | 109 | -- Adding two sums via `add` preserves the evaluation result. 110 | -- Note: `assert_total` in here is a temporary fix for idris issue #2954 111 | 0 padd : 112 | {auto _ : SolvableRing a} 113 | -> (x,y : Sum a as) 114 | -> esum x + esum y === esum (add x y) 115 | padd [] xs = plusZeroLeftNeutral 116 | padd (x :: xs) [] = plusZeroRightNeutral 117 | padd (T m x :: xs) (T n y :: ys) with (compProd x y) proof eq 118 | _ | LT = Calc $ 119 | |~ (m * eprod x + esum xs) + (n * eprod y + esum ys) 120 | ~~ m * eprod x + (esum xs + (n * eprod y + esum ys)) 121 | ..< plusAssociative 122 | ~~ m * eprod x + esum (add xs (T n y :: ys)) 123 | ... cong (m * eprod x +) (padd xs (T n y :: ys)) 124 | 125 | _ | GT = Calc $ 126 | |~ (m * eprod x + esum xs) + (n * eprod y + esum ys) 127 | ~~ n * eprod y + ((m * eprod x + esum xs) + esum ys) 128 | ..< p213 129 | ~~ n * eprod y + esum (add (T m x :: xs) ys) 130 | ... cong (n * eprod y +) (assert_total $ padd (T m x :: xs) ys) 131 | 132 | _ | EQ = case pcompProd x y eq of 133 | Refl => Calc $ 134 | |~ (m * eprod x + esum xs) + (n * eprod x + esum ys) 135 | ~~ (m * eprod x + n * eprod x) + (esum xs + esum ys) 136 | ... p1324 137 | ~~ (m + n) * eprod x + (esum xs + esum ys) 138 | ..< cong (+ (esum xs + esum ys)) rightDistributive 139 | ~~ (m + n) * eprod x + esum (add xs ys) 140 | ... cong ((m + n) * eprod x +) (padd xs ys) 141 | 142 | -- Small utility lemma 143 | 0 psum0 : 144 | {auto _ : SolvableRing a} 145 | -> {x,y,z : a} 146 | -> x === y 147 | -> x === 0 * z + y 148 | psum0 prf = Calc $ 149 | |~ x 150 | ~~ y ... prf 151 | ~~ 0 + y ..< plusZeroLeftNeutral 152 | ~~ 0 * z + y ..< cong (+ y) multZeroLeftAbsorbs 153 | 154 | -- Multiplying a sum with a term preserves the evaluation result. 155 | 0 pmult1 : 156 | {auto _ : SolvableRing a} 157 | -> (m : a) 158 | -> (p : Prod a as) 159 | -> (s : Sum a as) 160 | -> esum (mult1 (T m p) s) === (m * eprod p) * esum s 161 | pmult1 m p [] = sym multZeroRightAbsorbs 162 | pmult1 m p (T n q :: xs) = Calc $ 163 | |~ (m * n) * (eprod (mult p q)) + esum (mult1 (T m p) xs) 164 | ~~ (m * n) * (eprod p * eprod q) + esum (mult1 (T m p) xs) 165 | ... cong (\x => (m*n) * x + esum (mult1 (T m p) xs)) (pmult p q) 166 | ~~ (m * eprod p) * (n * eprod q) + esum (mult1 (T m p) xs) 167 | ..< cong (+ esum (mult1 (T m p) xs)) m1324 168 | ~~ (m * eprod p) * (n * eprod q) + (m * eprod p) * esum xs 169 | ... cong ((m * eprod p) * (n * eprod q) +) (pmult1 m p xs) 170 | ~~ (m * eprod p) * (n * eprod q + esum xs) 171 | ..< leftDistributive 172 | 173 | -- Multiplying two sums of terms preserves the evaluation result. 174 | 0 pmult : 175 | {auto _ : SolvableRing a} 176 | -> (x,y : Sum a as) 177 | -> esum x * esum y === esum (mult x y) 178 | pmult [] y = multZeroLeftAbsorbs 179 | pmult (T n x :: xs) y = Calc $ 180 | |~ (n * eprod x + esum xs) * esum y 181 | ~~ (n * eprod x) * esum y + esum xs * esum y 182 | ... rightDistributive 183 | ~~ (n * eprod x) * esum y + esum (mult xs y) 184 | ... cong ((n * eprod x) * esum y +) (pmult xs y) 185 | ~~ esum (mult1 (T n x) y) + esum (mult xs y) 186 | ..< cong (+ esum (mult xs y)) (pmult1 n x y) 187 | ~~ esum (add (mult1 (T n x) y) (mult xs y)) 188 | ... padd (mult1 (T n x) y) (mult xs y) 189 | 190 | -- Evaluating a negated term is equivalent to negate the 191 | -- result of evaluating the term. 192 | 0 pnegTerm : 193 | {auto _ : SolvableRing a} 194 | -> (x : Term a as) 195 | -> eterm (negTerm x) === neg (eterm x) 196 | pnegTerm (T f p) = multNegLeft 197 | 198 | -- Evaluating a negated sum of terms is equivalent to negate the 199 | -- result of evaluating the sum of terms. 200 | 0 pneg : 201 | {auto _ : SolvableRing a} 202 | -> (x : Sum a as) 203 | -> esum (negate x) === neg (esum x) 204 | pneg [] = sym $ negZero 205 | pneg (x :: y) = Calc $ 206 | |~ eterm (negTerm x) + esum (negate y) 207 | ~~ neg (eterm x) + esum (negate y) ... cong (+ esum (negate y)) (pnegTerm x) 208 | ~~ neg (eterm x) + neg (esum y) ... cong (neg (eterm x) +) (pneg y) 209 | ~~ neg (eterm x + esum y) ..< negDistributes 210 | 211 | -- Removing zero values from a sum of terms does not 212 | -- affect the evaluation result. 213 | 0 pnormSum : 214 | {auto _ : SolvableRing a} 215 | -> (s : Sum a as) 216 | -> esum (normSum s) === esum s 217 | pnormSum [] = Refl 218 | pnormSum (T f p :: y) with (isZero f) 219 | _ | Nothing = Calc $ 220 | |~ f * eprod p + esum (normSum y) 221 | ~~ f * eprod p + esum y ... cong ((f * eprod p) +) (pnormSum y) 222 | 223 | _ | Just refl = Calc $ 224 | |~ esum (normSum y) 225 | ~~ esum y ... pnormSum y 226 | ~~ 0 + esum y ..< plusZeroLeftNeutral 227 | ~~ 0 * eprod p + esum y ..< cong (+ esum y) multZeroLeftAbsorbs 228 | ~~ f * eprod p + esum y ..< cong (\x => x * eprod p + esum y) refl 229 | 230 | -- Evaluating an expression gives the same result as 231 | -- evaluating its normalized form. 232 | 0 pnorm : 233 | {auto _ : SolvableRing a} 234 | -> (e : Expr a as) 235 | -> eval e === esum (norm e) 236 | pnorm (Lit n) = Calc $ 237 | |~ n 238 | ~~ n * 1 ..< multOneRightNeutral 239 | ~~ n * eprod (one {as}) ..< cong (n *) (pone as) 240 | ~~ n * eprod (one {as}) + 0 ..< plusZeroRightNeutral 241 | 242 | pnorm (Var x y) = Calc $ 243 | |~ x 244 | ~~ eprod (fromVar y) ..< pvar as y 245 | ~~ 1 * eprod (fromVar y) ..< multOneLeftNeutral 246 | ~~ 1 * eprod (fromVar y) + 0 ..< plusZeroRightNeutral 247 | 248 | pnorm (Neg x) = Calc $ 249 | |~ neg (eval x) 250 | ~~ neg (esum (norm x)) ... cong neg (pnorm x) 251 | ~~ esum (negate (norm x)) ..< pneg (norm x) 252 | 253 | pnorm (Plus x y) = Calc $ 254 | |~ eval x + eval y 255 | ~~ esum (norm x) + eval y 256 | ... cong (+ eval y) (pnorm x) 257 | ~~ esum (norm x) + esum (norm y) 258 | ... cong (esum (norm x) +) (pnorm y) 259 | ~~ esum (add (norm x) (norm y)) 260 | ... padd _ _ 261 | 262 | pnorm (Mult x y) = Calc $ 263 | |~ eval x * eval y 264 | ~~ esum (norm x) * eval y 265 | ... cong (* eval y) (pnorm x) 266 | ~~ esum (norm x) * esum (norm y) 267 | ... cong (esum (norm x) *) (pnorm y) 268 | ~~ esum (mult (norm x) (norm y)) 269 | ... Sum.pmult _ _ 270 | 271 | pnorm (Minus x y) = Calc $ 272 | |~ eval x - eval y 273 | ~~ eval x + neg (eval y) 274 | ... minusIsPlusNeg 275 | ~~ esum (norm x) + neg (eval y) 276 | ... cong (+ neg (eval y)) (pnorm x) 277 | ~~ esum (norm x) + neg (esum (norm y)) 278 | ... cong (\v => esum (norm x) + neg v) (pnorm y) 279 | ~~ esum (norm x) + esum (negate (norm y)) 280 | ..< cong (esum (norm x) +) (pneg (norm y)) 281 | ~~ esum (add (norm x) (negate (norm y))) 282 | ... padd _ _ 283 | 284 | -- Evaluating an expression gives the same result as 285 | -- evaluating its normalized form. 286 | 0 pnormalize : 287 | {auto _ : SolvableRing a} 288 | -> (e : Expr a as) 289 | -> eval e === esum (normalize e) 290 | pnormalize e = Calc $ 291 | |~ eval e 292 | ~~ esum (norm e) ... pnorm e 293 | ~~ esum (normSum (norm e)) ..< pnormSum (norm e) 294 | 295 | -------------------------------------------------------------------------------- 296 | -- Solver 297 | -------------------------------------------------------------------------------- 298 | 299 | ||| Given a list `as` of variables and two arithmetic expressions 300 | ||| over these variables, if the expressions are converted 301 | ||| to the same normal form, evaluating them gives the same 302 | ||| result. 303 | ||| 304 | ||| This simple fact allows us to conveniently and quickly 305 | ||| proof arithmetic equalities required in other parts of 306 | ||| our code. For instance: 307 | ||| 308 | ||| ```idris example 309 | ||| 0 binom1 : {x,y : Bits8} 310 | ||| -> (x + y) * (x + y) === x * x + 2 * x * y + y * y 311 | ||| binom1 = solve [x,y] 312 | ||| ((x .+. y) * (x .+. y)) 313 | ||| (x .*. x + 2 *. x *. y + y .*. y) 314 | ||| ``` 315 | export 316 | 0 solve : 317 | {auto _ : SolvableRing a} 318 | -> (as : List a) 319 | -> (e1,e2 : Expr a as) 320 | -> {auto prf : normalize e1 === normalize e2} 321 | -> eval e1 === eval e2 322 | solve _ e1 e2 = Calc $ 323 | |~ eval e1 324 | ~~ esum (normalize e1) ...(pnormalize e1) 325 | ~~ esum (normalize e2) ...(cong esum prf) 326 | ~~ eval e2 ..<(pnormalize e2) 327 | 328 | -------------------------------------------------------------------------------- 329 | -- Examples 330 | -------------------------------------------------------------------------------- 331 | 332 | 0 binom1 : {x,y : Bits8} -> (x + y) * (x + y) === x * x + 2 * x * y + y * y 333 | binom1 = 334 | solve 335 | [x,y] 336 | ((x .+. y) * (x .+. y)) 337 | (x .*. x + 2 *. x *. y + y .*. y) 338 | 339 | 0 binom2 : {x,y : Bits8} -> (x - y) * (x - y) === x * x - 2 * x * y + y * y 340 | binom2 = 341 | solve 342 | [x,y] 343 | ((x .-. y) * (x .-. y)) 344 | (x .*. x - 2 *. x *. y + y .*. y) 345 | 346 | 0 binom3 : {x,y : Bits8} -> (x + y) * (x - y) === x * x - y * y 347 | binom3 = solve [x,y] ((x .+. y) * (x .-. y)) (x .*. x - y .*. y) 348 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Ring/Util.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Ring.Util 2 | 3 | import Algebra.Ring 4 | import public Syntax.PreorderReasoning 5 | 6 | %default total 7 | 8 | export 9 | 0 p213 : Ring a => {k,m,n : a} -> k + (m + n) === m + (k + n) 10 | p213 = Calc $ 11 | |~ k + (m + n) 12 | ~~ (k + m) + n ... plusAssociative 13 | ~~ (m + k) + n ... cong (+n) plusCommutative 14 | ~~ m + (k + n) ..< plusAssociative 15 | 16 | export 17 | 0 p1324 : 18 | {auto _ : Ring a} 19 | -> {k,l,m,n : a} 20 | -> (k + l) + (m + n) === (k + m) + (l + n) 21 | p1324 = Calc $ 22 | |~ (k + l) + (m + n) 23 | ~~ ((k + l) + m) + n ... plusAssociative 24 | ~~ (k + (l + m)) + n ..< cong (+n) plusAssociative 25 | ~~ (k + (m + l)) + n ... cong (\x => (k + x) + n) plusCommutative 26 | ~~ ((k + m) + l) + n ... cong (+n) plusAssociative 27 | ~~ (k + m) + (l + n) ..< plusAssociative 28 | 29 | export 30 | 0 m1324 : 31 | {auto _ : Ring a} 32 | -> {k,l,m,n : a} 33 | -> (k * l) * (m * n) === (k * m) * (l * n) 34 | m1324 = Calc $ 35 | |~ (k * l) * (m * n) 36 | ~~ ((k * l) * m) * n ... multAssociative 37 | ~~ (k * (l * m)) * n ..< cong (*n) multAssociative 38 | ~~ (k * (m * l)) * n ... cong (\x => (k * x) * n) multCommutative 39 | ~~ ((k * m) * l) * n ... cong (*n) multAssociative 40 | ~~ (k * m) * (l * n) ..< multAssociative 41 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Semigroup.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Semigroup 2 | 3 | import Algebra.Semigroup 4 | import Data.List1 5 | import Syntax.PreorderReasoning 6 | 7 | %default total 8 | 9 | public export 10 | data Expr : (a : Type) -> Type where 11 | Var : (x : a) -> Expr a 12 | Append : Expr a -> Expr a -> Expr a 13 | 14 | public export 15 | Semigroup (Expr a) where 16 | (<+>) = Append 17 | 18 | public export 19 | eval : LSemigroup a => Expr a -> a 20 | eval (Var x) = x 21 | eval (Append x y) = eval x <+> eval y 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Sum 25 | -------------------------------------------------------------------------------- 26 | 27 | public export 28 | esum' : LSemigroup a => a -> List a -> a 29 | esum' v [] = v 30 | esum' v (h :: t) = v <+> esum' h t 31 | 32 | public export 33 | esum : LSemigroup a => List1 a -> a 34 | esum (v ::: vs) = esum' v vs 35 | 36 | public export 37 | normalize : Expr a -> List1 a 38 | normalize (Var x) = x ::: [] 39 | normalize (Append x y) = normalize x ++ normalize y 40 | 41 | -------------------------------------------------------------------------------- 42 | -- Proofs 43 | -------------------------------------------------------------------------------- 44 | 45 | 0 psum' : 46 | {auto _ : LSemigroup a} 47 | -> (x,y : a) 48 | -> (xs,ys : List a) 49 | -> esum' x (xs ++ (y :: ys)) === esum' x xs <+> esum' y ys 50 | psum' x y [] ys = Refl 51 | psum' x y (v :: vs) ys = Calc $ 52 | |~ x <+> esum' v (vs ++ (y :: ys)) 53 | ~~ x <+> (esum' v vs <+> esum' y ys) ... cong (x <+>) (psum' v y vs ys) 54 | ~~ (x <+> esum' v vs) <+> esum' y ys ... appendAssociative 55 | 56 | 0 psum : 57 | {auto _ : LSemigroup a} 58 | -> (xs,ys : List1 a) 59 | -> esum (xs ++ ys) === esum xs <+> esum ys 60 | psum (x ::: xs) (y ::: ys) = psum' x y xs ys 61 | 62 | 0 pnorm : LSemigroup a => (e : Expr a) -> eval e === esum (normalize e) 63 | pnorm (Var x) = Refl 64 | pnorm (Append x y) = Calc $ 65 | |~ eval x <+> eval y 66 | ~~ esum (normalize x) <+> eval y 67 | ... cong (<+> eval y) (pnorm x) 68 | ~~ esum (normalize x) <+> esum (normalize y) 69 | ... cong (esum (normalize x) <+>) (pnorm y) 70 | ~~ esum (normalize x ++ normalize y) 71 | ..< psum (normalize x) (normalize y) 72 | 73 | -------------------------------------------------------------------------------- 74 | -- Solver 75 | -------------------------------------------------------------------------------- 76 | 77 | export 78 | 0 solve : 79 | {auto _ : LSemigroup a} 80 | -> (e1,e2 : Expr a) 81 | -> {auto prf : normalize e1 === normalize e2} 82 | -> eval e1 === eval e2 83 | solve e1 e2 = Calc $ 84 | |~ eval e1 85 | ~~ esum (normalize e1) ... pnorm e1 86 | ~~ esum (normalize e2) ... cong esum prf 87 | ~~ eval e2 ..< pnorm e2 88 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Semiring.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Semiring 2 | 3 | import public Algebra.Semiring 4 | import public Algebra.Solver.Semiring.Expr 5 | import public Algebra.Solver.Semiring.Prod 6 | import public Algebra.Solver.Semiring.SolvableSemiring 7 | import public Algebra.Solver.Semiring.Sum 8 | 9 | %default total 10 | 11 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Semiring/Expr.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Semiring.Expr 2 | 3 | import public Data.List.Elem 4 | import public Algebra.Semiring 5 | import Syntax.PreorderReasoning 6 | 7 | %default total 8 | 9 | -------------------------------------------------------------------------------- 10 | -- Natural Numbers 11 | -------------------------------------------------------------------------------- 12 | 13 | ||| Multiplies a value `n` times with itself. In case of `n` 14 | ||| being zero, this returns `1`. 15 | public export 16 | pow : Semiring a => a -> Nat -> a 17 | pow x 0 = 1 18 | pow x (S k) = x * pow x k 19 | 20 | -------------------------------------------------------------------------------- 21 | -- Expression 22 | -------------------------------------------------------------------------------- 23 | 24 | ||| Data type representing expressions in a commutative semiring. 25 | ||| 26 | ||| This is used to at compile time compare different forms of 27 | ||| the same expression and proof that they evaluate to 28 | ||| the same result. 29 | ||| 30 | ||| An example: 31 | ||| 32 | ||| ```idris example 33 | ||| 0 binom1 : {x,y : Bits8} -> (x + y) * (x + y) === x * x + 2 * x * y + y * y 34 | ||| binom1 = solve [x,y] 35 | ||| ((x .+. y) * (x .+. y)) 36 | ||| (x .*. x + 2 *. x *. y + y .*. y) 37 | ||| ``` 38 | ||| 39 | ||| @ a the type used in the arithmetic expression 40 | ||| @ as list of variables which don't reduce at compile time 41 | ||| 42 | ||| In the example above, `x` and `y` are variables, while `2` 43 | ||| is a literal known at compile time. To make working with 44 | ||| variables more convenient (the have to be wrapped in data 45 | ||| constructor `Var`, by using function `var` for instance), 46 | ||| additional operators for addition, multiplication, and 47 | ||| subtraction are provided. 48 | ||| 49 | ||| In order to proof that two expressions evaluate to the 50 | ||| same results, the following steps are taken at compile 51 | ||| time: 52 | ||| 53 | ||| 1. Both expressions are converted to a normal form via 54 | ||| `Algebra.Solver.Semiring.Sum.normalize`. 55 | ||| 2. The normal forms are compared for being identical. 56 | ||| 3. Since in `Algebra.Solver.Semiring.Sum` there is a proof that 57 | ||| converting an expression to its normal form does not 58 | ||| affect the result when evaluating it, if the normal 59 | ||| forms are identical, the two expressions must evaluate 60 | ||| to the same result. 61 | public export 62 | data Expr : (a : Type) -> (as : List a) -> Type where 63 | ||| A literal. This should be a value known at compile time 64 | ||| so that it reduces during normalization. 65 | Lit : (v : a) -> Expr a as 66 | 67 | ||| A variabl. This is is for values not known at compile 68 | ||| time. In order to compare and merge variables, we need an 69 | ||| `Elem x as` proof. 70 | Var : (x : a) -> Elem x as -> Expr a as 71 | 72 | ||| Addition of two expressions. 73 | Plus : (x,y : Expr a as) -> Expr a as 74 | 75 | ||| Multiplication of two expressions. 76 | Mult : (x,y : Expr a as) -> Expr a as 77 | 78 | ||| While this allows you to use the usual operators 79 | ||| for addition and multiplication, it is often convenient 80 | ||| to use related operators `.*.`, `.+.`, and similar when 81 | ||| working with variables. 82 | public export 83 | Num a => Num (Expr a as) where 84 | (+) = Plus 85 | (*) = Mult 86 | fromInteger = Lit . fromInteger 87 | 88 | ||| Like `Var` but takes the `Elem x as` as an auto implicit 89 | ||| argument. 90 | public export 91 | var : {0 as : List a} -> (x : a) -> Elem x as => Expr a as 92 | var x = Var x %search 93 | 94 | -------------------------------------------------------------------------------- 95 | -- Syntax 96 | -------------------------------------------------------------------------------- 97 | 98 | export infixl 8 .+., .+, +. 99 | 100 | export infixl 9 .*., .*, *. 101 | 102 | ||| Addition of variables. This is an alias for 103 | ||| `var x + var y`. 104 | public export 105 | (.+.) : 106 | {0 as : List a} 107 | -> (x,y : a) 108 | -> {auto _ : Elem x as} 109 | -> {auto _ : Elem y as} 110 | -> Expr a as 111 | (.+.) x y = Plus (var x) (var y) 112 | 113 | ||| Addition of variables. This is an alias for 114 | ||| `x + var y`. 115 | public export 116 | (+.) : 117 | {0 as : List a} 118 | -> (x : Expr a as) 119 | -> (y : a) 120 | -> {auto _ : Elem y as} 121 | -> Expr a as 122 | (+.) x y = Plus x (var y) 123 | 124 | ||| Addition of variables. This is an alias for 125 | ||| `var x + y`. 126 | public export 127 | (.+) : 128 | {0 as : List a} 129 | -> (x : a) 130 | -> (y : Expr a as) 131 | -> {auto _ : Elem x as} 132 | -> Expr a as 133 | (.+) x y = Plus (var x) y 134 | 135 | ||| Multiplication of variables. This is an alias for 136 | ||| `var x * var y`. 137 | public export 138 | (.*.) : 139 | {0 as : List a} 140 | -> (x,y : a) 141 | -> {auto _ : Elem x as} 142 | -> {auto _ : Elem y as} 143 | -> Expr a as 144 | (.*.) x y = Mult (var x) (var y) 145 | 146 | ||| Multiplication of variables. This is an alias for 147 | ||| `var x * y`. 148 | public export 149 | (*.) : 150 | {0 as : List a} 151 | -> (x : Expr a as) 152 | -> (y : a) 153 | -> {auto _ : Elem y as} 154 | -> Expr a as 155 | (*.) x y = Mult x (var y) 156 | 157 | ||| Multiplication of variables. This is an alias for 158 | ||| `x * var y`. 159 | public export 160 | (.*) : 161 | {0 as : List a} 162 | -> (x : a) 163 | -> (y : Expr a as) 164 | -> {auto _ : Elem x as} 165 | -> Expr a as 166 | (.*) x y = Mult (var x) y 167 | 168 | -------------------------------------------------------------------------------- 169 | -- Evaluation 170 | -------------------------------------------------------------------------------- 171 | 172 | ||| Evaluation of expressions. This keeps the exact 173 | ||| structure of the expression tree. For instance 174 | ||| `eval $ x .*. (y .+. z)` evaluates to `x * (y + z)`. 175 | public export 176 | eval : Semiring a => Expr a as -> a 177 | eval (Lit v) = v 178 | eval (Var x y) = x 179 | eval (Plus x y) = eval x + eval y 180 | eval (Mult x y) = eval x * eval y 181 | 182 | -------------------------------------------------------------------------------- 183 | -- Proofs 184 | -------------------------------------------------------------------------------- 185 | 186 | ||| Proof that addition of exponents is equivalent to multiplcation 187 | ||| of the two terms. 188 | export 189 | 0 ppow : 190 | {auto _ : Semiring a} 191 | -> (m,n : Nat) 192 | -> (x : a) 193 | -> pow x (m + n) === pow x m * pow x n 194 | ppow 0 n x = sym multOneLeftNeutral 195 | ppow (S k) n x = Calc $ 196 | |~ x * pow x (plus k n) 197 | ~~ x * (pow x k * pow x n) ... cong (x*) (ppow k n x) 198 | ~~ (x * pow x k) * pow x n ... multAssociative 199 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Semiring/Prod.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Semiring.Prod 2 | 3 | import Algebra.Solver.Semiring.Expr 4 | import public Algebra.Solver.Prod 5 | import Algebra.Solver.Semiring.Util 6 | 7 | %default total 8 | 9 | ||| Evaluate products of variables each raised to 10 | ||| given exponent. 11 | ||| 12 | ||| Every arithmetic expression in a commutative ring 13 | ||| can be represented as a sum of products of the variables 14 | ||| each raised by an exponent and multiplied by a constant 15 | ||| factor. For instance, expression `x + x * (y + z + z)` 16 | ||| gets normalized to `x + x * y + 2 * x * z`. 17 | public export 18 | eprod : Semiring a => {as : List a} -> Prod a as -> a 19 | eprod {as = []} [] = 1 20 | eprod {as = x :: xs} (e :: es) = pow x e * eprod es 21 | 22 | -------------------------------------------------------------------------------- 23 | -- Proofs 24 | -------------------------------------------------------------------------------- 25 | 26 | ||| Proof that `one` evaluates to 1. 27 | export 28 | 0 pone : Semiring a => (as : List a) -> eprod (one {as}) === 1 29 | pone [] = Refl 30 | pone (x :: xs) = Calc $ 31 | |~ 1 * eprod (one {as = xs}) 32 | ~~ 1 * 1 ... cong (1 * ) (pone xs) 33 | ~~ 1 ... multOneRightNeutral 34 | 35 | ||| Proof that `fromVar x` evaluates to `x`. 36 | export 37 | 0 pvar : 38 | {auto _ : Semiring a} 39 | -> (as : List a) 40 | -> (e : Elem x as) 41 | -> eprod (fromVar {as} e) === x 42 | pvar (x :: vs) Here = Calc $ 43 | |~ (x * 1) * eprod (one {as = vs}) 44 | ~~ (x * 1) * 1 ... cong ((x*1) *) (pone vs) 45 | ~~ x * 1 ... multOneRightNeutral 46 | ~~ x ... multOneRightNeutral 47 | 48 | pvar (v :: vs) (There y) = Calc $ 49 | |~ 1 * eprod (fromVar {as = vs} y) 50 | ~~ 1 * x ... cong (1*) (pvar vs y) 51 | ~~ x ... multOneLeftNeutral 52 | 53 | pvar [] Here impossible 54 | pvar [] (There y) impossible 55 | 56 | ||| Proof that evaluation of a multiplication of products 57 | ||| is the same as multiplying the results of evaluating each 58 | ||| of them. 59 | export 60 | 0 pmult : 61 | {auto _ : Semiring a} 62 | -> (p,q : Prod a as) 63 | -> eprod (mult p q) === eprod p * eprod q 64 | pmult [] [] = sym multOneLeftNeutral 65 | pmult {as = h :: t} (x :: xs) (y :: ys) = Calc $ 66 | |~ pow h (x + y) * eprod (mult xs ys) 67 | ~~ (pow h x * pow h y) * eprod (mult xs ys) 68 | ... cong (* eprod (mult xs ys)) (ppow x y h) 69 | ~~ (pow h x * pow h y) * (eprod xs * eprod ys) 70 | ... cong ((pow h x * pow h y) *) (pmult xs ys) 71 | ~~ (pow h x * eprod xs) * (pow h y * eprod ys) 72 | ... Util.m1324 73 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Semiring/SolvableSemiring.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Semiring.SolvableSemiring 2 | 3 | import Algebra.Semiring 4 | 5 | %default total 6 | 7 | ||| When normalizing arithmetic expressions, we must 8 | ||| make sure that factors that evaluate to zero must 9 | ||| be removed from the sum of products. 10 | ||| 11 | ||| For instance, the following example only works, 12 | ||| if the term `0 * x * y` gets removed before comparing 13 | ||| the normalized sums: 14 | ||| 15 | ||| ```idris example 16 | ||| 0 binom3 : {x,y : Bits8} -> (x + y) * (x - y) === x * x - y * y 17 | ||| binom3 = solve [x,y] ((x .+. y) * (x .-. y)) (x .*. x - y .*. y) 18 | ||| ``` 19 | ||| 20 | ||| Because we cannot directly use a (primitive) pattern match 21 | ||| without having a concrete type, we need this interface. 22 | ||| (We *could* use `DecEq`, but this is not publicly exported 23 | ||| for the primitives; probably for good reasons since it is 24 | ||| implemented using `believe_me`). 25 | public export 26 | interface Semiring a => SolvableSemiring a where 27 | 28 | ||| Checks if a value is propositionally equal to zero. 29 | isZero : (v : a) -> Maybe (v === 0) 30 | 31 | public export 32 | SolvableSemiring Nat where 33 | isZero Z = Just Refl 34 | isZero _ = Nothing 35 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Semiring/Sum.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Semiring.Sum 2 | 3 | import Algebra.Solver.Semiring.Expr 4 | import Algebra.Solver.Semiring.Prod 5 | import Algebra.Solver.Semiring.SolvableSemiring 6 | import Algebra.Solver.Semiring.Util 7 | 8 | %default total 9 | 10 | ||| A single term in a normalized arithmetic expressions. 11 | ||| 12 | ||| This is a product of all variables each raised to 13 | ||| a given power, multiplied with a factors (which is supposed 14 | ||| to reduce during elaboration). 15 | public export 16 | record Term (a : Type) (as : List a) where 17 | constructor T 18 | factor : a 19 | prod : Prod a as 20 | 21 | ||| Evaluate a term. 22 | public export 23 | eterm : Semiring a => {as : List a} -> Term a as -> a 24 | eterm (T f p) = f * eprod p 25 | 26 | ||| Normalized arithmetic expression in a commutative 27 | ||| ring (represented as an (ordered) sum of terms). 28 | public export 29 | data Sum : (a : Type) -> (as : List a) -> Type where 30 | Nil : {0 as : List a} -> Sum a as 31 | (::) : {0 as : List a} -> Term a as -> Sum a as -> Sum a as 32 | 33 | ||| Evaluate a sum of terms. 34 | public export 35 | esum : Semiring a => {as : List a} -> Sum a as -> a 36 | esum [] = 0 37 | esum (x :: xs) = eterm x + esum xs 38 | 39 | -------------------------------------------------------------------------------- 40 | -- Normalizer 41 | -------------------------------------------------------------------------------- 42 | 43 | ||| Add two sums of terms. 44 | ||| 45 | ||| The order of terms will be kept. If two terms have identical 46 | ||| products of variables, they will be unified by adding their 47 | ||| factors. 48 | public export 49 | add : SolvableSemiring a => Sum a as -> Sum a as -> Sum a as 50 | add [] ys = ys 51 | add xs [] = xs 52 | add (T m x :: xs) (T n y :: ys) = case compProd x y of 53 | LT => T m x :: add xs (T n y :: ys) 54 | GT => T n y :: add (T m x :: xs) ys 55 | EQ => T (m + n) y :: add xs ys 56 | 57 | ||| Normalize a sum of terms by removing all terms with a 58 | ||| `zero` factor. 59 | public export 60 | normSum : SolvableSemiring a => Sum a as -> Sum a as 61 | normSum [] = [] 62 | normSum (T f p :: y) = case isZero f of 63 | Just refl => normSum y 64 | Nothing => T f p :: normSum y 65 | 66 | ||| Multiplies a single term with a sum of terms. 67 | public export 68 | mult1 : SolvableSemiring a => Term a as -> Sum a as -> Sum a as 69 | mult1 (T f p) (T g q :: xs) = T (f * g) (mult p q) :: mult1 (T f p) xs 70 | mult1 _ [] = [] 71 | 72 | ||| Multiplies two sums of terms. 73 | public export 74 | mult : SolvableSemiring a => Sum a as -> Sum a as -> Sum a as 75 | mult [] ys = [] 76 | mult (x :: xs) ys = add (mult1 x ys) (mult xs ys) 77 | 78 | ||| Normalizes an arithmetic expression to a sum of products. 79 | public export 80 | norm : SolvableSemiring a => {as : List a} -> Expr a as -> Sum a as 81 | norm (Lit n) = [T n one] 82 | norm (Var x y) = [T 1 $ fromVar y] 83 | norm (Plus x y) = add (norm x) (norm y) 84 | norm (Mult x y) = mult (norm x) (norm y) 85 | 86 | ||| Like `norm` but removes all `zero` terms. 87 | public export 88 | normalize : SolvableSemiring a => {as : List a} -> Expr a as -> Sum a as 89 | normalize e = normSum (norm e) 90 | 91 | -------------------------------------------------------------------------------- 92 | -- Proofs 93 | -------------------------------------------------------------------------------- 94 | 95 | -- Adding two sums via `add` preserves the evaluation result. 96 | -- Note: `assert_total` in here is a temporary fix for idris issue #2954 97 | 0 padd : 98 | {auto _ : SolvableSemiring a} 99 | -> (x,y : Sum a as) 100 | -> esum x + esum y === esum (add x y) 101 | padd [] xs = plusZeroLeftNeutral 102 | padd (x :: xs) [] = plusZeroRightNeutral 103 | padd (T m x :: xs) (T n y :: ys) with (compProd x y) proof eq 104 | _ | LT = Calc $ 105 | |~ (m * eprod x + esum xs) + (n * eprod y + esum ys) 106 | ~~ m * eprod x + (esum xs + (n * eprod y + esum ys)) 107 | ..< plusAssociative 108 | ~~ m * eprod x + esum (add xs (T n y :: ys)) 109 | ... cong (m * eprod x +) (padd xs (T n y :: ys)) 110 | 111 | _ | GT = Calc $ 112 | |~ (m * eprod x + esum xs) + (n * eprod y + esum ys) 113 | ~~ n * eprod y + ((m * eprod x + esum xs) + esum ys) 114 | ..< p213 115 | ~~ n * eprod y + esum (add (T m x :: xs) ys) 116 | ... cong (n * eprod y +) (assert_total $ padd (T m x :: xs) ys) 117 | 118 | _ | EQ = case pcompProd x y eq of 119 | Refl => Calc $ 120 | |~ (m * eprod x + esum xs) + (n * eprod x + esum ys) 121 | ~~ (m * eprod x + n * eprod x) + (esum xs + esum ys) 122 | ... p1324 123 | ~~ (m + n) * eprod x + (esum xs + esum ys) 124 | ..< cong (+ (esum xs + esum ys)) rightDistributive 125 | ~~ (m + n) * eprod x + esum (add xs ys) 126 | ... cong ((m + n) * eprod x +) (padd xs ys) 127 | 128 | -- Small utility lemma 129 | 0 psum0 : 130 | {auto _ : SolvableSemiring a} 131 | -> {x,y,z : a} 132 | -> x === y 133 | -> x === 0 * z + y 134 | psum0 prf = Calc $ 135 | |~ x 136 | ~~ y ... prf 137 | ~~ 0 + y ..< plusZeroLeftNeutral 138 | ~~ 0 * z + y ..< cong (+ y) multZeroLeftAbsorbs 139 | 140 | -- Multiplying a sum with a term preserves the evaluation result. 141 | 0 pmult1 : 142 | {auto _ : SolvableSemiring a} 143 | -> (m : a) 144 | -> (p : Prod a as) 145 | -> (s : Sum a as) 146 | -> esum (mult1 (T m p) s) === (m * eprod p) * esum s 147 | pmult1 m p [] = sym multZeroRightAbsorbs 148 | pmult1 m p (T n q :: xs) = Calc $ 149 | |~ (m * n) * (eprod (mult p q)) + esum (mult1 (T m p) xs) 150 | ~~ (m * n) * (eprod p * eprod q) + esum (mult1 (T m p) xs) 151 | ... cong (\x => (m*n) * x + esum (mult1 (T m p) xs)) (pmult p q) 152 | ~~ (m * eprod p) * (n * eprod q) + esum (mult1 (T m p) xs) 153 | ..< cong (+ esum (mult1 (T m p) xs)) m1324 154 | ~~ (m * eprod p) * (n * eprod q) + (m * eprod p) * esum xs 155 | ... cong ((m * eprod p) * (n * eprod q) +) (pmult1 m p xs) 156 | ~~ (m * eprod p) * (n * eprod q + esum xs) 157 | ..< leftDistributive 158 | 159 | -- Multiplying two sums of terms preserves the evaluation result. 160 | 0 pmult : 161 | {auto _ : SolvableSemiring a} 162 | -> (x,y : Sum a as) 163 | -> esum x * esum y === esum (mult x y) 164 | pmult [] y = multZeroLeftAbsorbs 165 | pmult (T n x :: xs) y = Calc $ 166 | |~ (n * eprod x + esum xs) * esum y 167 | ~~ (n * eprod x) * esum y + esum xs * esum y 168 | ... rightDistributive 169 | ~~ (n * eprod x) * esum y + esum (mult xs y) 170 | ... cong ((n * eprod x) * esum y +) (pmult xs y) 171 | ~~ esum (mult1 (T n x) y) + esum (mult xs y) 172 | ..< cong (+ esum (mult xs y)) (pmult1 n x y) 173 | ~~ esum (add (mult1 (T n x) y) (mult xs y)) 174 | ... padd (mult1 (T n x) y) (mult xs y) 175 | 176 | -- Removing zero values from a sum of terms does not 177 | -- affect the evaluation result. 178 | 0 pnormSum : 179 | {auto _ : SolvableSemiring a} 180 | -> (s : Sum a as) 181 | -> esum (normSum s) === esum s 182 | pnormSum [] = Refl 183 | pnormSum (T f p :: y) with (isZero f) 184 | _ | Nothing = Calc $ 185 | |~ f * eprod p + esum (normSum y) 186 | ~~ f * eprod p + esum y ... cong ((f * eprod p) +) (pnormSum y) 187 | 188 | _ | Just refl = Calc $ 189 | |~ esum (normSum y) 190 | ~~ esum y ... pnormSum y 191 | ~~ 0 + esum y ..< plusZeroLeftNeutral 192 | ~~ 0 * eprod p + esum y ..< cong (+ esum y) multZeroLeftAbsorbs 193 | ~~ f * eprod p + esum y ..< cong (\x => x * eprod p + esum y) refl 194 | 195 | -- Evaluating an expression gives the same result as 196 | -- evaluating its normalized form. 197 | 0 pnorm : 198 | {auto _ : SolvableSemiring a} 199 | -> (e : Expr a as) 200 | -> eval e === esum (norm e) 201 | pnorm (Lit n) = Calc $ 202 | |~ n 203 | ~~ n * 1 ..< multOneRightNeutral 204 | ~~ n * eprod (one {as}) ..< cong (n *) (pone as) 205 | ~~ n * eprod (one {as}) + 0 ..< plusZeroRightNeutral 206 | 207 | pnorm (Var x y) = Calc $ 208 | |~ x 209 | ~~ eprod (fromVar y) ..< pvar as y 210 | ~~ 1 * eprod (fromVar y) ..< multOneLeftNeutral 211 | ~~ 1 * eprod (fromVar y) + 0 ..< plusZeroRightNeutral 212 | 213 | pnorm (Plus x y) = Calc $ 214 | |~ eval x + eval y 215 | ~~ esum (norm x) + eval y 216 | ... cong (+ eval y) (pnorm x) 217 | ~~ esum (norm x) + esum (norm y) 218 | ... cong (esum (norm x) +) (pnorm y) 219 | ~~ esum (add (norm x) (norm y)) 220 | ... padd _ _ 221 | 222 | pnorm (Mult x y) = Calc $ 223 | |~ eval x * eval y 224 | ~~ esum (norm x) * eval y 225 | ... cong (* eval y) (pnorm x) 226 | ~~ esum (norm x) * esum (norm y) 227 | ... cong (esum (norm x) *) (pnorm y) 228 | ~~ esum (mult (norm x) (norm y)) 229 | ... Sum.pmult _ _ 230 | 231 | -- Evaluating an expression gives the same result as 232 | -- evaluating its normalized form. 233 | 0 pnormalize : 234 | {auto _ : SolvableSemiring a} 235 | -> (e : Expr a as) 236 | -> eval e === esum (normalize e) 237 | pnormalize e = Calc $ 238 | |~ eval e 239 | ~~ esum (norm e) ... pnorm e 240 | ~~ esum (normSum (norm e)) ..< pnormSum (norm e) 241 | 242 | -------------------------------------------------------------------------------- 243 | -- Solver 244 | -------------------------------------------------------------------------------- 245 | 246 | ||| Given a list `as` of variables and two arithmetic expressions 247 | ||| over these variables, if the expressions are converted 248 | ||| to the same normal form, evaluating them gives the same 249 | ||| result. 250 | ||| 251 | ||| This simple fact allows us to conveniently and quickly 252 | ||| proof arithmetic equalities required in other parts of 253 | ||| our code. For instance: 254 | ||| 255 | ||| ```idris example 256 | ||| 0 binom1 : {x,y : Bits8} 257 | ||| -> (x + y) * (x + y) === x * x + 2 * x * y + y * y 258 | ||| binom1 = solve [x,y] 259 | ||| ((x .+. y) * (x .+. y)) 260 | ||| (x .*. x + 2 *. x *. y + y .*. y) 261 | ||| ``` 262 | export 263 | 0 solve : 264 | {auto _ : SolvableSemiring a} 265 | -> (as : List a) 266 | -> (e1,e2 : Expr a as) 267 | -> {auto prf : normalize e1 === normalize e2} 268 | -> eval e1 === eval e2 269 | solve _ e1 e2 = Calc $ 270 | |~ eval e1 271 | ~~ esum (normalize e1) ...(pnormalize e1) 272 | ~~ esum (normalize e2) ...(cong esum prf) 273 | ~~ eval e2 ..<(pnormalize e2) 274 | -------------------------------------------------------------------------------- /src/Algebra/Solver/Semiring/Util.idr: -------------------------------------------------------------------------------- 1 | module Algebra.Solver.Semiring.Util 2 | 3 | import Algebra.Semiring 4 | import public Syntax.PreorderReasoning 5 | 6 | %default total 7 | 8 | export 9 | 0 p213 : Semiring a => {k,m,n : a} -> k + (m + n) === m + (k + n) 10 | p213 = Calc $ 11 | |~ k + (m + n) 12 | ~~ (k + m) + n ... plusAssociative 13 | ~~ (m + k) + n ... cong (+n) plusCommutative 14 | ~~ m + (k + n) ..< plusAssociative 15 | 16 | export 17 | 0 p1324 : 18 | {auto _ : Semiring a} 19 | -> {k,l,m,n : a} 20 | -> (k + l) + (m + n) === (k + m) + (l + n) 21 | p1324 = Calc $ 22 | |~ (k + l) + (m + n) 23 | ~~ ((k + l) + m) + n ... plusAssociative 24 | ~~ (k + (l + m)) + n ..< cong (+n) plusAssociative 25 | ~~ (k + (m + l)) + n ... cong (\x => (k + x) + n) plusCommutative 26 | ~~ ((k + m) + l) + n ... cong (+n) plusAssociative 27 | ~~ (k + m) + (l + n) ..< plusAssociative 28 | 29 | export 30 | 0 m1324 : 31 | {auto _ : Semiring a} 32 | -> {k,l,m,n : a} 33 | -> (k * l) * (m * n) === (k * m) * (l * n) 34 | m1324 = Calc $ 35 | |~ (k * l) * (m * n) 36 | ~~ ((k * l) * m) * n ... multAssociative 37 | ~~ (k * (l * m)) * n ..< cong (*n) multAssociative 38 | ~~ (k * (m * l)) * n ... cong (\x => (k * x) * n) multCommutative 39 | ~~ ((k * m) * l) * n ... cong (*n) multAssociative 40 | ~~ (k * m) * (l * n) ..< multAssociative 41 | -------------------------------------------------------------------------------- /src/Data/Maybe/NothingMax.idr: -------------------------------------------------------------------------------- 1 | module Data.Maybe.NothingMax 2 | 3 | import Control.Function 4 | import Data.Maybe 5 | import Data.Prim.Ord 6 | 7 | %default total 8 | 9 | ||| A total order for `Maybe a` where `a` has a total order 10 | ||| and `Nothing` is the maximal value. 11 | ||| 12 | ||| This is useful, for instance, when implementing provably 13 | ||| sorted (assoc-) lists, indexed by a `Maybe key`, where 14 | ||| the empty list has a `Nothing` index: 15 | ||| 16 | ||| ```idris example 17 | ||| data AssocList : (ix : Maybe Bits8) -> (a : Type) -> Type where 18 | ||| Nil : AssocList Nothing a 19 | ||| (::) : (p : (Bits8, a)) 20 | ||| -> (ps : AssocList ix a) 21 | ||| -> (0 prf : LT (<) (Just $ fst p) ix) 22 | ||| => AssocList (Just $ fst p) a 23 | ||| ``` 24 | public export 25 | data LT : (lt : a -> a -> Type) -> (m1,m2 : Maybe a) -> Type where 26 | LTNothing : LT lt (Just v) Nothing 27 | LTJust : {0 lt : a -> a -> Type} 28 | -> {0 v, w : a} 29 | -> lt v w -> LT lt (Just v) (Just w) 30 | 31 | public export 32 | Uninhabited (LT lt Nothing m) where 33 | uninhabited LTNothing impossible 34 | uninhabited (LTJust _) impossible 35 | 36 | public export 37 | Total a lt => Uninhabited (LT lt (Just k) (Just k)) where 38 | uninhabited LTNothing impossible 39 | uninhabited (LTJust refl) = void (irrefl refl) 40 | 41 | public export 42 | fromLT : LT lt (Just a) (Just b) -> lt a b 43 | fromLT (LTJust x) = x 44 | 45 | ||| Implementation and alias for `trichotomy`. 46 | export 47 | comp : Total a lt => (m1,m2 : Maybe a) -> Trichotomy (LT lt) m1 m2 48 | comp (Just x) (Just y) = case trichotomy {lt} x y of 49 | LT p c1 c2 => LT (LTJust p) (\r => c1 (injective r)) (\x => c2 (fromLT x)) 50 | EQ c1 p c2 => EQ (\x => c1 (fromLT x)) (cong Just p) (\x => c2 (fromLT x)) 51 | GT c1 c2 p => GT (\x => c1 (fromLT x)) (\r => c2 (injective r)) (LTJust p) 52 | comp (Just x) Nothing = LT LTNothing absurd absurd 53 | comp Nothing (Just y) = GT absurd absurd LTNothing 54 | comp Nothing Nothing = EQ absurd Refl absurd 55 | 56 | ||| If `lt` is a total order of `a`, then `LT lt` is a 57 | ||| total order of `Maybe a`. 58 | export %inline 59 | Total a lt => Total (Maybe a) (LT lt) where 60 | trichotomy = comp 61 | 62 | transLT (LTJust x) LTNothing = LTNothing 63 | transLT (LTJust x) (LTJust y) = LTJust $ trans x y 64 | transLT LTNothing y = absurd y 65 | -------------------------------------------------------------------------------- /src/Data/Maybe/NothingMin.idr: -------------------------------------------------------------------------------- 1 | module Data.Maybe.NothingMin 2 | 3 | import Control.Function 4 | import Data.Maybe 5 | import Data.Prim.Ord 6 | 7 | %default total 8 | 9 | ||| A total order for `Maybe a` where `a` has a total order 10 | ||| and `Nothing` is the minimal value. 11 | ||| 12 | ||| This is useful, for instance, when implementing provably 13 | ||| sorted snoc-lists, indexed by a `Maybe key`, where 14 | ||| the empty snoc-list has a `Nothing` index: 15 | ||| 16 | ||| ```idris example 17 | ||| data AssocSnocList : (ix : Maybe Bits8) -> (a : Type) -> Type where 18 | ||| Lin : AssocSnocList Nothing a 19 | ||| (:<) : (ps : AssocSnocList ix a) 20 | ||| -> (p : (Bits8, a)) 21 | ||| -> (0 prf : LT (<) ix (Just $ fst p)) 22 | ||| => AssocSnocList (Just $ fst p) a 23 | ||| ``` 24 | public export 25 | data LT : (lt : a -> a -> Type) -> (m1,m2 : Maybe a) -> Type where 26 | LTNothing : LT lt Nothing (Just v) 27 | LTJust : {0 lt : a -> a -> Type} 28 | -> {0 v, w : a} 29 | -> lt v w -> LT lt (Just v) (Just w) 30 | 31 | public export 32 | Uninhabited (LT lt m Nothing) where 33 | uninhabited LTNothing impossible 34 | uninhabited (LTJust _) impossible 35 | 36 | public export 37 | Total a lt => Uninhabited (LT lt (Just k) (Just k)) where 38 | uninhabited LTNothing impossible 39 | uninhabited (LTJust refl) = void (irrefl refl) 40 | 41 | public export 42 | fromLT : LT lt (Just a) (Just b) -> lt a b 43 | fromLT (LTJust x) = x 44 | 45 | ||| Implementation and alias for `trichotomy`. 46 | export 47 | comp : Total a lt => (m1,m2 : Maybe a) -> Trichotomy (LT lt) m1 m2 48 | comp (Just x) (Just y) = case trichotomy {lt} x y of 49 | LT p c1 c2 => LT (LTJust p) (\r => c1 (injective r)) (\x => c2 (fromLT x)) 50 | EQ c1 p c2 => EQ (\x => c1 (fromLT x)) (cong Just p) (\x => c2 (fromLT x)) 51 | GT c1 c2 p => GT (\x => c1 (fromLT x)) (\r => c2 (injective r)) (LTJust p) 52 | comp Nothing (Just x) = LT LTNothing absurd absurd 53 | comp (Just y) Nothing = GT absurd absurd LTNothing 54 | comp Nothing Nothing = EQ absurd Refl absurd 55 | 56 | ||| If `lt` is a total order of `a`, then `LT lt` is a 57 | ||| total order of `Maybe a`. 58 | export %inline 59 | Total a lt => Total (Maybe a) (LT lt) where 60 | trichotomy = comp 61 | 62 | transLT LTNothing (LTJust y) = LTNothing 63 | transLT (LTJust x) (LTJust y) = LTJust $ trans x y 64 | transLT y LTNothing = absurd y 65 | -------------------------------------------------------------------------------- /src/Data/Prim.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim 2 | 3 | import public Data.Prim.Char 4 | import public Data.Prim.Bits8 5 | import public Data.Prim.Bits16 6 | import public Data.Prim.Bits32 7 | import public Data.Prim.Bits64 8 | import public Data.Prim.Int8 9 | import public Data.Prim.Int16 10 | import public Data.Prim.Int32 11 | import public Data.Prim.Int64 12 | import public Data.Prim.String 13 | -------------------------------------------------------------------------------- /src/Data/Prim/Bits16.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Bits16 2 | 3 | import public Control.WellFounded 4 | import public Data.DPair 5 | import public Data.Prim.Ord 6 | import public Algebra.Solver.Ring 7 | import Syntax.PreorderReasoning 8 | 9 | %default total 10 | 11 | unsafeRefl : a === b 12 | unsafeRefl = believe_me (Refl {x = a}) 13 | 14 | -------------------------------------------------------------------------------- 15 | -- (<) 16 | -------------------------------------------------------------------------------- 17 | 18 | ||| Witness that `m < n === True`. 19 | export 20 | data (<) : (m,n : Bits16) -> Type where 21 | LT : {0 m,n : Bits16} -> (0 prf : (m < n) === True) -> m < n 22 | 23 | ||| Contructor for `(<)`. 24 | ||| 25 | ||| This can only be used in an erased context. 26 | export %hint 27 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 28 | mkLT = LT 29 | 30 | ||| Extractor for `(<)`. 31 | ||| 32 | ||| This can only be used in an erased context. 33 | export 34 | 0 runLT : m < n -> (m < n) === True 35 | runLT (LT prf) = prf 36 | 37 | ||| We don't trust values of type `(<)` too much, 38 | ||| so we use this when creating magical results. 39 | export 40 | strictLT : (0 p : m < n) -> Lazy c -> c 41 | strictLT (LT prf) x = x 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Aliases 45 | -------------------------------------------------------------------------------- 46 | 47 | ||| Flipped version of `(<)`. 48 | public export 49 | 0 (>) : (m,n : Bits16) -> Type 50 | m > n = n < m 51 | 52 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 53 | public export 54 | 0 (<=) : (m,n : Bits16) -> Type 55 | m <= n = Either (m < n) (m === n) 56 | 57 | ||| Flipped version of `(<=)`. 58 | public export 59 | 0 (>=) : (m,n : Bits16) -> Type 60 | m >= n = n <= m 61 | 62 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 63 | public export 64 | 0 (/=) : (m,n : Bits16) -> Type 65 | m /= n = Either (m < n) (m > n) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Order 69 | -------------------------------------------------------------------------------- 70 | 71 | 0 ltNotEQ : m < n -> Not (m === n) 72 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 73 | 74 | 0 ltNotGT : m < n -> Not (n < m) 75 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 76 | 77 | 0 eqNotLT : m === n -> Not (m < n) 78 | eqNotLT = flip ltNotEQ 79 | 80 | export 81 | comp : (m,n : Bits16) -> Trichotomy (<) m n 82 | comp m n = case prim__lt_Bits16 m n of 83 | 0 => case prim__eq_Bits16 m n of 84 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 85 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 86 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 87 | 88 | export 89 | Total Bits16 (<) where 90 | trichotomy = comp 91 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Bounds and Well-Foundedness 95 | -------------------------------------------------------------------------------- 96 | 97 | ||| Lower bound of `Bits16` 98 | public export 99 | MinBits16 : Bits16 100 | MinBits16 = 0 101 | 102 | ||| Upper bound of `Bits16` 103 | public export 104 | MaxBits16 : Bits16 105 | MaxBits16 = 0xffff 106 | 107 | ||| `m >= 0` for all `m` of type `Bits16`. 108 | export 109 | 0 GTE_MinBits16 : (m : Bits16) -> m >= MinBits16 110 | GTE_MinBits16 m = case comp MinBits16 m of 111 | LT x f g => %search 112 | EQ f x g => %search 113 | GT f g x => assert_total $ idris_crash "IMPOSSIBLE: Bits16 smaller than 0" 114 | 115 | ||| Not value of type `Bits16` is less than zero. 116 | export 117 | 0 Not_LT_MinBits16 : m < 0 -> Void 118 | Not_LT_MinBits16 = GTE_not_LT (GTE_MinBits16 m) 119 | 120 | ||| `m <= MaxBits16` for all `m` of type `Bits16`. 121 | export 122 | 0 LTE_MaxBits16 : (m : Bits16) -> m <= MaxBits16 123 | LTE_MaxBits16 m = case comp m MaxBits16 of 124 | LT x f g => %search 125 | EQ f x g => %search 126 | GT f g x => 127 | assert_total $ 128 | idris_crash "IMPOSSIBLE: Bits16 greater than \{show MaxBits16}" 129 | 130 | ||| Not value of type `Bits16` is greater than `MaxBits16` 131 | export 132 | 0 Not_GT_MaxBits16 : m > MaxBits16 -> Void 133 | Not_GT_MaxBits16 = LTE_not_GT (LTE_MaxBits16 m) 134 | 135 | ||| Every value of type `Bits16` is accessible with relation 136 | ||| to `(<)`. 137 | export 138 | accessLT : (m : Bits16) -> Accessible (<) m 139 | accessLT m = Access $ \n,lt => accessLT (assert_smaller m n) 140 | 141 | ||| `(<)` is well founded. 142 | export %inline 143 | WellFounded Bits16 (<) where 144 | wellFounded = accessLT 145 | 146 | ||| Every value of type `Bits16` is accessible with relation 147 | ||| to `(>)`. 148 | export 149 | accessGT : (m : Bits16) -> Accessible (>) m 150 | accessGT m = Access $ \n,gt => accessGT (assert_smaller m n) 151 | 152 | ||| `(>)` is well founded. 153 | export %inline 154 | [GT] WellFounded Bits16 (>) where 155 | wellFounded = accessGT 156 | 157 | -------------------------------------------------------------------------------- 158 | -- Arithmetics 159 | -------------------------------------------------------------------------------- 160 | 161 | ||| Safe division. 162 | ||| 163 | ||| This uses `0 < d` as a constraint instead 164 | ||| of `0 /= d`, because in my experience, the former 165 | ||| is much more useful. 166 | export %inline 167 | sdiv : (n,d : Bits16) -> (0 prf : 0 < d) => Bits16 168 | sdiv n d = n `div` d 169 | 170 | ||| Refined division. 171 | ||| 172 | ||| This comes with a proof that the result is 173 | ||| strictly smaller than `n`. 174 | ||| 175 | ||| This uses `0 < n` as a constraint instead 176 | ||| of `0 /= n`, because in my experience, the former 177 | ||| is much more useful. 178 | export %inline 179 | rdiv : 180 | (n,d : Bits16) 181 | -> {auto 0 dgt1 : 1 < d} 182 | -> {auto 0 ngt0 : 0 < n} 183 | -> Subset Bits16 (< n) 184 | rdiv n d = Element (n `div` d) (LT unsafeRefl) 185 | 186 | ||| Safe modulo. 187 | ||| 188 | ||| This uses `0 < d` as a constraint instead 189 | ||| of `0 /= d`, because in my experience, the former 190 | ||| is much more useful. 191 | ||| 192 | ||| If you need the postcondition that the result is strictly 193 | ||| smaller than `d`, use `rmod` instead. 194 | export %inline 195 | smod : (n,d : Bits16) -> (0 prf : 0 < d) => Bits16 196 | smod n d = n `mod` d 197 | 198 | ||| Refined modulo. 199 | ||| 200 | ||| This comes with a proof that the result is strictly smaller 201 | ||| than `d`. 202 | ||| 203 | ||| It uses `0 < d` as a constraint instead 204 | ||| of `0 /= d`, because in my experience, the former 205 | ||| is much more useful. 206 | export %inline 207 | rmod : (n,d : Bits16) -> (0 prf : 0 < d) => Subset Bits16 (< d) 208 | rmod n d = Element (n `mod` d) (LT unsafeRefl) 209 | -------------------------------------------------------------------------------- /src/Data/Prim/Bits32.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Bits32 2 | 3 | import public Control.WellFounded 4 | import public Data.DPair 5 | import public Data.Prim.Ord 6 | import public Algebra.Solver.Ring 7 | import Syntax.PreorderReasoning 8 | 9 | %default total 10 | 11 | unsafeRefl : a === b 12 | unsafeRefl = believe_me (Refl {x = a}) 13 | 14 | -------------------------------------------------------------------------------- 15 | -- (<) 16 | -------------------------------------------------------------------------------- 17 | 18 | ||| Witness that `m < n === True`. 19 | export 20 | data (<) : (m,n : Bits32) -> Type where 21 | LT : {0 m,n : Bits32} -> (0 prf : (m < n) === True) -> m < n 22 | 23 | ||| Contructor for `(<)`. 24 | ||| 25 | ||| This can only be used in an erased context. 26 | export %hint 27 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 28 | mkLT = LT 29 | 30 | ||| Extractor for `(<)`. 31 | ||| 32 | ||| This can only be used in an erased context. 33 | export 34 | 0 runLT : m < n -> (m < n) === True 35 | runLT (LT prf) = prf 36 | 37 | ||| We don't trust values of type `(<)` too much, 38 | ||| so we use this when creating magical results. 39 | export 40 | strictLT : (0 p : m < n) -> Lazy c -> c 41 | strictLT (LT prf) x = x 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Aliases 45 | -------------------------------------------------------------------------------- 46 | 47 | ||| Flipped version of `(<)`. 48 | public export 49 | 0 (>) : (m,n : Bits32) -> Type 50 | m > n = n < m 51 | 52 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 53 | public export 54 | 0 (<=) : (m,n : Bits32) -> Type 55 | m <= n = Either (m < n) (m === n) 56 | 57 | ||| Flipped version of `(<=)`. 58 | public export 59 | 0 (>=) : (m,n : Bits32) -> Type 60 | m >= n = n <= m 61 | 62 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 63 | public export 64 | 0 (/=) : (m,n : Bits32) -> Type 65 | m /= n = Either (m < n) (m > n) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Order 69 | -------------------------------------------------------------------------------- 70 | 71 | 0 ltNotEQ : m < n -> Not (m === n) 72 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 73 | 74 | 0 ltNotGT : m < n -> Not (n < m) 75 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 76 | 77 | 0 eqNotLT : m === n -> Not (m < n) 78 | eqNotLT = flip ltNotEQ 79 | 80 | export 81 | comp : (m,n : Bits32) -> Trichotomy (<) m n 82 | comp m n = case prim__lt_Bits32 m n of 83 | 0 => case prim__eq_Bits32 m n of 84 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 85 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 86 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 87 | 88 | export 89 | Total Bits32 (<) where 90 | trichotomy = comp 91 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Bounds and Well-Foundedness 95 | -------------------------------------------------------------------------------- 96 | 97 | ||| Lower bound of `Bits32` 98 | public export 99 | MinBits32 : Bits32 100 | MinBits32 = 0 101 | 102 | ||| Upper bound of `Bits32` 103 | public export 104 | MaxBits32 : Bits32 105 | MaxBits32 = 0xffffffff 106 | 107 | ||| `m >= 0` for all `m` of type `Bits32`. 108 | export 109 | 0 GTE_MinBits32 : (m : Bits32) -> m >= MinBits32 110 | GTE_MinBits32 m = case comp MinBits32 m of 111 | LT x f g => %search 112 | EQ f x g => %search 113 | GT f g x => assert_total $ idris_crash "IMPOSSIBLE: Bits32 smaller than 0" 114 | 115 | ||| Not value of type `Bits32` is less than zero. 116 | export 117 | 0 Not_LT_MinBits32 : m < 0 -> Void 118 | Not_LT_MinBits32 = GTE_not_LT (GTE_MinBits32 m) 119 | 120 | ||| `m <= MaxBits32` for all `m` of type `Bits32`. 121 | export 122 | 0 LTE_MaxBits32 : (m : Bits32) -> m <= MaxBits32 123 | LTE_MaxBits32 m = case comp m MaxBits32 of 124 | LT x f g => %search 125 | EQ f x g => %search 126 | GT f g x => 127 | assert_total $ 128 | idris_crash "IMPOSSIBLE: Bits32 greater than \{show MaxBits32}" 129 | 130 | ||| Not value of type `Bits32` is greater than `MaxBits32`. 131 | export 132 | 0 Not_GT_MaxBits32 : m > MaxBits32 -> Void 133 | Not_GT_MaxBits32 = LTE_not_GT (LTE_MaxBits32 m) 134 | 135 | ||| Every value of type `Bits32` is accessible with relation 136 | ||| to `(<)`. 137 | export 138 | accessLT : (m : Bits32) -> Accessible (<) m 139 | accessLT m = Access $ \n,lt => accessLT (assert_smaller m n) 140 | 141 | ||| `(<)` is well founded. 142 | export %inline 143 | WellFounded Bits32 (<) where 144 | wellFounded = accessLT 145 | 146 | ||| Every value of type `Bits32` is accessible with relation 147 | ||| to `(>)`. 148 | export 149 | accessGT : (m : Bits32) -> Accessible (>) m 150 | accessGT m = Access $ \n,gt => accessGT (assert_smaller m n) 151 | 152 | ||| `(>)` is well founded. 153 | export %inline 154 | [GT] WellFounded Bits32 (>) where 155 | wellFounded = accessGT 156 | 157 | -------------------------------------------------------------------------------- 158 | -- Arithmetics 159 | -------------------------------------------------------------------------------- 160 | 161 | ||| Safe division. 162 | ||| 163 | ||| This uses `0 < d` as a constraint instead 164 | ||| of `0 /= d`, because in my experience, the former 165 | ||| is much more useful. 166 | export %inline 167 | sdiv : (n,d : Bits32) -> (0 prf : 0 < d) => Bits32 168 | sdiv n d = n `div` d 169 | 170 | ||| Refined division. 171 | ||| 172 | ||| This comes with a proof that the result is 173 | ||| strictly smaller than `n`. 174 | ||| 175 | ||| This uses `0 < n` as a constraint instead 176 | ||| of `0 /= n`, because in my experience, the former 177 | ||| is much more useful. 178 | export %inline 179 | rdiv : 180 | (n,d : Bits32) 181 | -> {auto 0 dgt1 : 1 < d} 182 | -> {auto 0 ngt0 : 0 < n} 183 | -> Subset Bits32 (< n) 184 | rdiv n d = Element (n `div` d) (LT unsafeRefl) 185 | 186 | ||| Safe modulo. 187 | ||| 188 | ||| This uses `0 < d` as a constraint instead 189 | ||| of `0 /= d`, because in my experience, the former 190 | ||| is much more useful. 191 | ||| 192 | ||| If you need the postcondition that the result is strictly 193 | ||| smaller than `d`, use `rmod` instead. 194 | export %inline 195 | smod : (n,d : Bits32) -> (0 prf : 0 < d) => Bits32 196 | smod n d = n `mod` d 197 | 198 | ||| Refined modulo. 199 | ||| 200 | ||| This comes with a proof that the result is strictly smaller 201 | ||| than `d`. 202 | ||| 203 | ||| It uses `0 < d` as a constraint instead 204 | ||| of `0 /= d`, because in my experience, the former 205 | ||| is much more useful. 206 | export %inline 207 | rmod : (n,d : Bits32) -> (0 prf : 0 < d) => Subset Bits32 (< d) 208 | rmod n d = Element (n `mod` d) (LT unsafeRefl) 209 | -------------------------------------------------------------------------------- /src/Data/Prim/Bits64.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Bits64 2 | 3 | import public Control.WellFounded 4 | import public Data.DPair 5 | import public Data.Prim.Ord 6 | import public Algebra.Solver.Ring 7 | import Syntax.PreorderReasoning 8 | 9 | %default total 10 | 11 | unsafeRefl : a === b 12 | unsafeRefl = believe_me (Refl {x = a}) 13 | 14 | -------------------------------------------------------------------------------- 15 | -- (<) 16 | -------------------------------------------------------------------------------- 17 | 18 | ||| Witness that `m < n === True`. 19 | export 20 | data (<) : (m,n : Bits64) -> Type where 21 | LT : {0 m,n : Bits64} -> (0 prf : (m < n) === True) -> m < n 22 | 23 | ||| Contructor for `(<)`. 24 | ||| 25 | ||| This can only be used in an erased context. 26 | export %hint 27 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 28 | mkLT = LT 29 | 30 | ||| Extractor for `(<)`. 31 | ||| 32 | ||| This can only be used in an erased context. 33 | export 34 | 0 runLT : m < n -> (m < n) === True 35 | runLT (LT prf) = prf 36 | 37 | ||| We don't trust values of type `(<)` too much, 38 | ||| so we use this when creating magical results. 39 | export 40 | strictLT : (0 p : m < n) -> Lazy c -> c 41 | strictLT (LT prf) x = x 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Aliases 45 | -------------------------------------------------------------------------------- 46 | 47 | ||| Flipped version of `(<)`. 48 | public export 49 | 0 (>) : (m,n : Bits64) -> Type 50 | m > n = n < m 51 | 52 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 53 | public export 54 | 0 (<=) : (m,n : Bits64) -> Type 55 | m <= n = Either (m < n) (m === n) 56 | 57 | ||| Flipped version of `(<=)`. 58 | public export 59 | 0 (>=) : (m,n : Bits64) -> Type 60 | m >= n = n <= m 61 | 62 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 63 | public export 64 | 0 (/=) : (m,n : Bits64) -> Type 65 | m /= n = Either (m < n) (m > n) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Order 69 | -------------------------------------------------------------------------------- 70 | 71 | 0 ltNotEQ : m < n -> Not (m === n) 72 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 73 | 74 | 0 ltNotGT : m < n -> Not (n < m) 75 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 76 | 77 | 0 eqNotLT : m === n -> Not (m < n) 78 | eqNotLT = flip ltNotEQ 79 | 80 | export 81 | comp : (m,n : Bits64) -> Trichotomy (<) m n 82 | comp m n = case prim__lt_Bits64 m n of 83 | 0 => case prim__eq_Bits64 m n of 84 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 85 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 86 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 87 | 88 | export 89 | Total Bits64 (<) where 90 | trichotomy = comp 91 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Bounds and Well-Foundedness 95 | -------------------------------------------------------------------------------- 96 | 97 | ||| Lower bound of `Bits64` 98 | public export 99 | MinBits64 : Bits64 100 | MinBits64 = 0 101 | 102 | ||| Upper bound of `Bits64` 103 | public export 104 | MaxBits64 : Bits64 105 | MaxBits64 = 0xffffffffffffffff 106 | 107 | ||| `m >= 0` for all `m` of type `Bits64`. 108 | export 109 | 0 GTE_MinBits64 : (m : Bits64) -> m >= MinBits64 110 | GTE_MinBits64 m = case comp MinBits64 m of 111 | LT x f g => %search 112 | EQ f x g => %search 113 | GT f g x => assert_total $ idris_crash "IMPOSSIBLE: Bits64 smaller than 0" 114 | 115 | ||| Not value of type `Bits64` is less than zero. 116 | export 117 | 0 Not_LT_MinBits64 : m < 0 -> Void 118 | Not_LT_MinBits64 = GTE_not_LT (GTE_MinBits64 m) 119 | 120 | ||| `m <= MaxBits64` for all `m` of type `Bits64`. 121 | export 122 | 0 LTE_MaxBits64 : (m : Bits64) -> m <= MaxBits64 123 | LTE_MaxBits64 m = case comp m MaxBits64 of 124 | LT x f g => %search 125 | EQ f x g => %search 126 | GT f g x => 127 | assert_total $ 128 | idris_crash "IMPOSSIBLE: Bits64 greater than \{show MaxBits64}" 129 | 130 | ||| Not value of type `Bits64` is greater than `MaxBits64`. 131 | export 132 | 0 Not_GT_MaxBits64 : m > MaxBits64 -> Void 133 | Not_GT_MaxBits64 = LTE_not_GT (LTE_MaxBits64 m) 134 | 135 | ||| Every value of type `Bits64` is accessible with relation 136 | ||| to `(<)`. 137 | export 138 | accessLT : (m : Bits64) -> Accessible (<) m 139 | accessLT m = Access $ \n,lt => accessLT (assert_smaller m n) 140 | 141 | ||| `(<)` is well founded. 142 | export %inline 143 | WellFounded Bits64 (<) where 144 | wellFounded = accessLT 145 | 146 | ||| Every value of type `Bits64` is accessible with relation 147 | ||| to `(>)`. 148 | export 149 | accessGT : (m : Bits64) -> Accessible (>) m 150 | accessGT m = Access $ \n,gt => accessGT (assert_smaller m n) 151 | 152 | ||| `(>)` is well founded. 153 | export %inline 154 | [GT] WellFounded Bits64 (>) where 155 | wellFounded = accessGT 156 | 157 | -------------------------------------------------------------------------------- 158 | -- Arithmetics 159 | -------------------------------------------------------------------------------- 160 | 161 | ||| Safe division. 162 | ||| 163 | ||| This uses `0 < d` as a constraint instead 164 | ||| of `0 /= d`, because in my experience, the former 165 | ||| is much more useful. 166 | export %inline 167 | sdiv : (n,d : Bits64) -> (0 prf : 0 < d) => Bits64 168 | sdiv n d = n `div` d 169 | 170 | ||| Refined division. 171 | ||| 172 | ||| This comes with a proof that the result is 173 | ||| strictly smaller than `n`. 174 | ||| 175 | ||| This uses `0 < n` as a constraint instead 176 | ||| of `0 /= n`, because in my experience, the former 177 | ||| is much more useful. 178 | export %inline 179 | rdiv : 180 | (n,d : Bits64) 181 | -> {auto 0 dgt1 : 1 < d} 182 | -> {auto 0 ngt0 : 0 < n} 183 | -> Subset Bits64 (< n) 184 | rdiv n d = Element (n `div` d) (LT unsafeRefl) 185 | 186 | ||| Safe modulo. 187 | ||| 188 | ||| This uses `0 < d` as a constraint instead 189 | ||| of `0 /= d`, because in my experience, the former 190 | ||| is much more useful. 191 | ||| 192 | ||| If you need the postcondition that the result is strictly 193 | ||| smaller than `d`, use `rmod` instead. 194 | export %inline 195 | smod : (n,d : Bits64) -> (0 prf : 0 < d) => Bits64 196 | smod n d = n `mod` d 197 | 198 | ||| Refined modulo. 199 | ||| 200 | ||| This comes with a proof that the result is strictly smaller 201 | ||| than `d`. 202 | ||| 203 | ||| It uses `0 < d` as a constraint instead 204 | ||| of `0 /= d`, because in my experience, the former 205 | ||| is much more useful. 206 | export %inline 207 | rmod : (n,d : Bits64) -> (0 prf : 0 < d) => Subset Bits64 (< d) 208 | rmod n d = Element (n `mod` d) (LT unsafeRefl) 209 | -------------------------------------------------------------------------------- /src/Data/Prim/Bits8.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Bits8 2 | 3 | import public Control.WellFounded 4 | import public Data.DPair 5 | import public Data.Prim.Ord 6 | import public Algebra.Solver.Ring 7 | import Syntax.PreorderReasoning 8 | 9 | %default total 10 | 11 | unsafeRefl : a === b 12 | unsafeRefl = believe_me (Refl {x = a}) 13 | 14 | -------------------------------------------------------------------------------- 15 | -- (<) 16 | -------------------------------------------------------------------------------- 17 | 18 | ||| Witness that `m < n === True`. 19 | export 20 | data (<) : (m,n : Bits8) -> Type where 21 | LT : {0 m,n : Bits8} -> (0 prf : (m < n) === True) -> m < n 22 | 23 | ||| Contructor for `(<)`. 24 | ||| 25 | ||| This can only be used in an erased context. 26 | export %hint 27 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 28 | mkLT = LT 29 | 30 | ||| Extractor for `(<)`. 31 | ||| 32 | ||| This can only be used in an erased context. 33 | export 34 | 0 runLT : m < n -> (m < n) === True 35 | runLT (LT prf) = prf 36 | 37 | ||| We don't trust values of type `(<)` too much, 38 | ||| so we use this when creating magical results. 39 | export 40 | strictLT : (0 p : m < n) -> Lazy c -> c 41 | strictLT (LT prf) x = x 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Aliases 45 | -------------------------------------------------------------------------------- 46 | 47 | ||| Flipped version of `(<)`. 48 | public export 49 | 0 (>) : (m,n : Bits8) -> Type 50 | m > n = n < m 51 | 52 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 53 | public export 54 | 0 (<=) : (m,n : Bits8) -> Type 55 | m <= n = Either (m < n) (m === n) 56 | 57 | ||| Flipped version of `(<=)`. 58 | public export 59 | 0 (>=) : (m,n : Bits8) -> Type 60 | m >= n = n <= m 61 | 62 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 63 | public export 64 | 0 (/=) : (m,n : Bits8) -> Type 65 | m /= n = Either (m < n) (m > n) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Order 69 | -------------------------------------------------------------------------------- 70 | 71 | 0 ltNotEQ : m < n -> Not (m === n) 72 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 73 | 74 | 0 ltNotGT : m < n -> Not (n < m) 75 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 76 | 77 | 0 eqNotLT : m === n -> Not (m < n) 78 | eqNotLT = flip ltNotEQ 79 | 80 | export 81 | comp : (m,n : Bits8) -> Trichotomy (<) m n 82 | comp m n = case prim__lt_Bits8 m n of 83 | 0 => case prim__eq_Bits8 m n of 84 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 85 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 86 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 87 | 88 | export 89 | Total Bits8 (<) where 90 | trichotomy = comp 91 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Bounds and Well-Foundedness 95 | -------------------------------------------------------------------------------- 96 | 97 | ||| Lower bound of `Bits8` 98 | public export 99 | MinBits8 : Bits8 100 | MinBits8 = 0 101 | 102 | ||| Upper bound of `Bits8` 103 | public export 104 | MaxBits8 : Bits8 105 | MaxBits8 = 0xff 106 | 107 | ||| `m >= 0` for all `m` of type `Bits8`. 108 | export 109 | 0 GTE_MinBits8 : (m : Bits8) -> m >= MinBits8 110 | GTE_MinBits8 m = case comp MinBits8 m of 111 | LT x f g => %search 112 | EQ f x g => %search 113 | GT f g x => assert_total $ idris_crash "IMPOSSIBLE: Bits8 smaller than 0" 114 | 115 | ||| Not value of type `Bits8` is less than zero. 116 | export 117 | 0 Not_LT_MinBits8 : m < 0 -> Void 118 | Not_LT_MinBits8 = GTE_not_LT (GTE_MinBits8 m) 119 | 120 | ||| `m <= MaxBits8` for all `m` of type `Bits8`. 121 | export 122 | 0 LTE_MaxBits8 : (m : Bits8) -> m <= MaxBits8 123 | LTE_MaxBits8 m = case comp m MaxBits8 of 124 | LT x f g => %search 125 | EQ f x g => %search 126 | GT f g x => 127 | assert_total $ 128 | idris_crash "IMPOSSIBLE: Bits8 greater than \{show MaxBits8}" 129 | 130 | ||| Not value of type `Bits8` is greater than `MaxBits8`. 131 | export 132 | 0 Not_GT_MaxBits8 : m > MaxBits8 -> Void 133 | Not_GT_MaxBits8 = LTE_not_GT (LTE_MaxBits8 m) 134 | 135 | ||| Every value of type `Bits8` is accessible with relation 136 | ||| to `(<)`. 137 | export 138 | accessLT : (m : Bits8) -> Accessible (<) m 139 | accessLT m = Access $ \n,lt => accessLT (assert_smaller m n) 140 | 141 | ||| `(<)` is well founded. 142 | export %inline 143 | WellFounded Bits8 (<) where 144 | wellFounded = accessLT 145 | 146 | ||| Every value of type `Bits8` is accessible with relation 147 | ||| to `(>)`. 148 | export 149 | accessGT : (m : Bits8) -> Accessible (>) m 150 | accessGT m = Access $ \n,gt => accessGT (assert_smaller m n) 151 | 152 | ||| `(>)` is well founded. 153 | export %inline 154 | [GT] WellFounded Bits8 (>) where 155 | wellFounded = accessGT 156 | 157 | -------------------------------------------------------------------------------- 158 | -- Arithmetics 159 | -------------------------------------------------------------------------------- 160 | 161 | ||| Safe division. 162 | ||| 163 | ||| This uses `0 < d` as a constraint instead 164 | ||| of `0 /= d`, because in my experience, the former 165 | ||| is much more useful. 166 | export %inline 167 | sdiv : (n,d : Bits8) -> (0 prf : 0 < d) => Bits8 168 | sdiv n d = n `div` d 169 | 170 | ||| Refined division. 171 | ||| 172 | ||| This comes with a proof that the result is 173 | ||| strictly smaller than `n`. 174 | ||| 175 | ||| This uses `0 < n` as a constraint instead 176 | ||| of `0 /= n`, because in my experience, the former 177 | ||| is much more useful. 178 | export %inline 179 | rdiv : 180 | (n,d : Bits8) 181 | -> {auto 0 dgt1 : 1 < d} 182 | -> {auto 0 ngt0 : 0 < n} 183 | -> Subset Bits8 (< n) 184 | rdiv n d = Element (n `div` d) (LT unsafeRefl) 185 | 186 | ||| Safe modulo. 187 | ||| 188 | ||| This uses `0 < d` as a constraint instead 189 | ||| of `0 /= d`, because in my experience, the former 190 | ||| is much more useful. 191 | ||| 192 | ||| If you need the postcondition that the result is strictly 193 | ||| smaller than `d`, use `rmod` instead. 194 | export %inline 195 | smod : (n,d : Bits8) -> (0 prf : 0 < d) => Bits8 196 | smod n d = n `mod` d 197 | 198 | ||| Refined modulo. 199 | ||| 200 | ||| This comes with a proof that the result is strictly smaller 201 | ||| than `d`. 202 | ||| 203 | ||| It uses `0 < d` as a constraint instead 204 | ||| of `0 /= d`, because in my experience, the former 205 | ||| is much more useful. 206 | export %inline 207 | rmod : (n,d : Bits8) -> (0 prf : 0 < d) => Subset Bits8 (< d) 208 | rmod n d = Element (n `mod` d) (LT unsafeRefl) 209 | -------------------------------------------------------------------------------- /src/Data/Prim/Char.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Char 2 | 3 | import public Control.WellFounded 4 | import public Data.DPair 5 | import public Data.Prim.Ord 6 | 7 | %default total 8 | 9 | unsafeRefl : a === b 10 | unsafeRefl = believe_me (Refl {x = a}) 11 | 12 | -------------------------------------------------------------------------------- 13 | -- (<) 14 | -------------------------------------------------------------------------------- 15 | 16 | ||| Witness that `m < n === True`. 17 | export 18 | data (<) : (m,n : Char) -> Type where 19 | LT : {0 m,n : Char} -> (0 prf : (m < n) === True) -> m < n 20 | 21 | ||| Contructor for `(<)`. 22 | ||| 23 | ||| This can only be used in an erased context. 24 | export %hint 25 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 26 | mkLT = LT 27 | 28 | ||| Extractor for `(<)`. 29 | ||| 30 | ||| This can only be used in an erased context. 31 | export 32 | 0 runLT : m < n -> (m < n) === True 33 | runLT (LT prf) = prf 34 | 35 | ||| We don't trust values of type `(<)` too much, 36 | ||| so we use this when creating magical results. 37 | export 38 | strictLT : (0 p : m < n) -> Lazy c -> c 39 | strictLT (LT prf) x = x 40 | 41 | -------------------------------------------------------------------------------- 42 | -- Aliases 43 | -------------------------------------------------------------------------------- 44 | 45 | ||| Flipped version of `(<)`. 46 | public export 47 | 0 (>) : (m,n : Char) -> Type 48 | m > n = n < m 49 | 50 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 51 | public export 52 | 0 (<=) : (m,n : Char) -> Type 53 | m <= n = Either (m < n) (m === n) 54 | 55 | ||| Flipped version of `(<=)`. 56 | public export 57 | 0 (>=) : (m,n : Char) -> Type 58 | m >= n = n <= m 59 | 60 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 61 | public export 62 | 0 (/=) : (m,n : Char) -> Type 63 | m /= n = Either (m < n) (m > n) 64 | 65 | -------------------------------------------------------------------------------- 66 | -- Order 67 | -------------------------------------------------------------------------------- 68 | 69 | 0 ltNotEQ : m < n -> Not (m === n) 70 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 71 | 72 | 0 ltNotGT : m < n -> Not (n < m) 73 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 74 | 75 | 0 eqNotLT : m === n -> Not (m < n) 76 | eqNotLT = flip ltNotEQ 77 | 78 | export 79 | comp : (m,n : Char) -> Trichotomy (<) m n 80 | comp m n = case prim__lt_Char m n of 81 | 0 => case prim__eq_Char m n of 82 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 83 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 84 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 85 | 86 | export 87 | Total Char (<) where 88 | trichotomy = comp 89 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 90 | 91 | -------------------------------------------------------------------------------- 92 | -- Bounds and Well-Foundedness 93 | -------------------------------------------------------------------------------- 94 | 95 | ||| Lower bound of `Char` 96 | public export 97 | MinChar : Char 98 | MinChar = '\x0000' 99 | 100 | ||| `m >= MinChar` for all `m` of type `Char`. 101 | export 102 | 0 GTE_MinChar : (m : Char) -> m >= MinChar 103 | GTE_MinChar m = case comp MinChar m of 104 | LT x f g => %search 105 | EQ f x g => %search 106 | GT f g x => assert_total $ idris_crash "IMPOSSIBLE: Char smaller than 0" 107 | 108 | ||| Not value of type `Char` is less than `MinChar`. 109 | export 110 | 0 Not_LT_MinChar : m < MinChar -> Void 111 | Not_LT_MinChar = GTE_not_LT (GTE_MinChar m) 112 | 113 | ||| Every value of type `Char` is accessible with relation 114 | ||| to `(<)`. 115 | export 116 | accessLT : (m : Char) -> Accessible (<) m 117 | accessLT m = Access $ \n,lt => accessLT (assert_smaller m n) 118 | 119 | ||| `(<)` is well founded. 120 | export %inline 121 | WellFounded Char (<) where 122 | wellFounded = accessLT 123 | -------------------------------------------------------------------------------- /src/Data/Prim/Int.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Int 2 | 3 | import public Control.WellFounded 4 | import public Data.DPair 5 | import public Data.Prim.Ord 6 | import public Algebra.Solver.Ring 7 | import Syntax.PreorderReasoning 8 | 9 | %default total 10 | 11 | unsafeRefl : a === b 12 | unsafeRefl = believe_me (Refl {x = a}) 13 | 14 | -------------------------------------------------------------------------------- 15 | -- (<) 16 | -------------------------------------------------------------------------------- 17 | 18 | ||| Witness that `m < n === True`. 19 | export 20 | data (<) : (m,n : Int) -> Type where 21 | LT : {0 m,n : Int} -> (0 prf : (m < n) === True) -> m < n 22 | 23 | ||| Contructor for `(<)`. 24 | ||| 25 | ||| This can only be used in an erased context. 26 | export %hint 27 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 28 | mkLT = LT 29 | 30 | ||| Extractor for `(<)`. 31 | ||| 32 | ||| This can only be used in an erased context. 33 | export 34 | 0 runLT : m < n -> (m < n) === True 35 | runLT (LT prf) = prf 36 | 37 | ||| We don't trust values of type `(<)` too much, 38 | ||| so we use this when creating magical results. 39 | export 40 | strictLT : (0 p : m < n) -> Lazy c -> c 41 | strictLT (LT prf) x = x 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Aliases 45 | -------------------------------------------------------------------------------- 46 | 47 | ||| Flipped version of `(<)`. 48 | public export 49 | 0 (>) : (m,n : Int) -> Type 50 | m > n = n < m 51 | 52 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 53 | public export 54 | 0 (<=) : (m,n : Int) -> Type 55 | m <= n = Either (m < n) (m === n) 56 | 57 | ||| Flipped version of `(<=)`. 58 | public export 59 | 0 (>=) : (m,n : Int) -> Type 60 | m >= n = n <= m 61 | 62 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 63 | public export 64 | 0 (/=) : (m,n : Int) -> Type 65 | m /= n = Either (m < n) (m > n) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Order 69 | -------------------------------------------------------------------------------- 70 | 71 | 0 ltNotEQ : m < n -> Not (m === n) 72 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 73 | 74 | 0 ltNotGT : m < n -> Not (n < m) 75 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 76 | 77 | 0 eqNotLT : m === n -> Not (m < n) 78 | eqNotLT = flip ltNotEQ 79 | 80 | export 81 | comp : (m,n : Int) -> Trichotomy (<) m n 82 | comp m n = case prim__lt_Int m n of 83 | 0 => case prim__eq_Int m n of 84 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 85 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 86 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 87 | 88 | export 89 | Total Int (<) where 90 | trichotomy = comp 91 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Arithmetics 95 | -------------------------------------------------------------------------------- 96 | 97 | ||| Safe division. 98 | export %inline 99 | sdiv : (n,d : Int) -> (0 prf : d /= 0) => Int 100 | sdiv n d = n `div` d 101 | 102 | ||| Safe modulo. 103 | export %inline 104 | smod : (n,d : Int) -> (0 prf : d /= 0) => Int 105 | smod n d = n `mod` d 106 | -------------------------------------------------------------------------------- /src/Data/Prim/Int16.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Int16 2 | 3 | import public Control.WellFounded 4 | import public Data.DPair 5 | import public Data.Prim.Ord 6 | import public Algebra.Solver.Ring 7 | import Syntax.PreorderReasoning 8 | 9 | %default total 10 | 11 | unsafeRefl : a === b 12 | unsafeRefl = believe_me (Refl {x = a}) 13 | 14 | -------------------------------------------------------------------------------- 15 | -- (<) 16 | -------------------------------------------------------------------------------- 17 | 18 | ||| Witness that `m < n === True`. 19 | export 20 | data (<) : (m,n : Int16) -> Type where 21 | LT : {0 m,n : Int16} -> (0 prf : (m < n) === True) -> m < n 22 | 23 | ||| Contructor for `(<)`. 24 | ||| 25 | ||| This can only be used in an erased context. 26 | export %hint 27 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 28 | mkLT = LT 29 | 30 | ||| Extractor for `(<)`. 31 | ||| 32 | ||| This can only be used in an erased context. 33 | export 34 | 0 runLT : m < n -> (m < n) === True 35 | runLT (LT prf) = prf 36 | 37 | ||| We don't trust values of type `(<)` too much, 38 | ||| so we use this when creating magical results. 39 | export 40 | strictLT : (0 p : m < n) -> Lazy c -> c 41 | strictLT (LT prf) x = x 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Aliases 45 | -------------------------------------------------------------------------------- 46 | 47 | ||| Flipped version of `(<)`. 48 | public export 49 | 0 (>) : (m,n : Int16) -> Type 50 | m > n = n < m 51 | 52 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 53 | public export 54 | 0 (<=) : (m,n : Int16) -> Type 55 | m <= n = Either (m < n) (m === n) 56 | 57 | ||| Flipped version of `(<=)`. 58 | public export 59 | 0 (>=) : (m,n : Int16) -> Type 60 | m >= n = n <= m 61 | 62 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 63 | public export 64 | 0 (/=) : (m,n : Int16) -> Type 65 | m /= n = Either (m < n) (m > n) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Order 69 | -------------------------------------------------------------------------------- 70 | 71 | 0 ltNotEQ : m < n -> Not (m === n) 72 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 73 | 74 | 0 ltNotGT : m < n -> Not (n < m) 75 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 76 | 77 | 0 eqNotLT : m === n -> Not (m < n) 78 | eqNotLT = flip ltNotEQ 79 | 80 | export 81 | comp : (m,n : Int16) -> Trichotomy (<) m n 82 | comp m n = case prim__lt_Int16 m n of 83 | 0 => case prim__eq_Int16 m n of 84 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 85 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 86 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 87 | 88 | export 89 | Total Int16 (<) where 90 | trichotomy = comp 91 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Bounds and Well-Foundedness 95 | -------------------------------------------------------------------------------- 96 | 97 | ||| Lower bound of `Int16` 98 | public export 99 | MinInt16 : Int16 100 | MinInt16 = -0x8000 101 | 102 | ||| Upper bound of `Int16` 103 | public export 104 | MaxInt16 : Int16 105 | MaxInt16 = 0x7fff 106 | 107 | ||| `m >= MinInt16` for all `m` of type `Int16`. 108 | export 109 | 0 GTE_MinInt16 : (m : Int16) -> m >= MinInt16 110 | GTE_MinInt16 m = case comp MinInt16 m of 111 | LT x f g => %search 112 | EQ f x g => %search 113 | GT f g x => 114 | assert_total $ 115 | idris_crash "IMPOSSIBLE: Int16 smaller than \{show MinInt16}" 116 | 117 | ||| Not value of type `Int16` is less than zero. 118 | export 119 | 0 Not_LT_MinInt16 : m < MinInt16 -> Void 120 | Not_LT_MinInt16 = GTE_not_LT (GTE_MinInt16 m) 121 | 122 | ||| `m <= MaxInt16` for all `m` of type `Int16`. 123 | export 124 | 0 LTE_MaxInt16 : (m : Int16) -> m <= MaxInt16 125 | LTE_MaxInt16 m = case comp m MaxInt16 of 126 | LT x f g => %search 127 | EQ f x g => %search 128 | GT f g x => 129 | assert_total $ 130 | idris_crash "IMPOSSIBLE: Int16 greater than \{show MaxInt16}" 131 | 132 | ||| Not value of type `Int16` is greater than `MaxInt16`. 133 | export 134 | 0 Not_GT_MaxInt16 : m > MaxInt16 -> Void 135 | Not_GT_MaxInt16 = LTE_not_GT (LTE_MaxInt16 m) 136 | 137 | ||| Every value of type `Int16` is accessible with relation 138 | ||| to `(<)`. 139 | export 140 | accessLT : (m : Int16) -> Accessible (<) m 141 | accessLT m = Access $ \n,lt => accessLT (assert_smaller m n) 142 | 143 | ||| `(<)` is well founded. 144 | export %inline 145 | WellFounded Int16 (<) where 146 | wellFounded = accessLT 147 | 148 | ||| Every value of type `Int16` is accessible with relation 149 | ||| to `(>)`. 150 | export 151 | accessGT : (m : Int16) -> Accessible (>) m 152 | accessGT m = Access $ \n,gt => accessGT (assert_smaller m n) 153 | 154 | ||| `(>)` is well founded. 155 | export %inline 156 | [GT] WellFounded Int16 (>) where 157 | wellFounded = accessGT 158 | 159 | -------------------------------------------------------------------------------- 160 | -- Arithmetics 161 | -------------------------------------------------------------------------------- 162 | 163 | ||| Safe division. 164 | export %inline 165 | sdiv : (n,d : Int16) -> (0 prf : d /= 0) => Int16 166 | sdiv n d = n `div` d 167 | 168 | ||| Safe modulo. 169 | export %inline 170 | smod : (n,d : Int16) -> (0 prf : d /= 0) => Int16 171 | smod n d = n `mod` d 172 | -------------------------------------------------------------------------------- /src/Data/Prim/Int32.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Int32 2 | 3 | import public Control.WellFounded 4 | import public Data.DPair 5 | import public Data.Prim.Ord 6 | import public Algebra.Solver.Ring 7 | import Syntax.PreorderReasoning 8 | 9 | %default total 10 | 11 | unsafeRefl : a === b 12 | unsafeRefl = believe_me (Refl {x = a}) 13 | 14 | -------------------------------------------------------------------------------- 15 | -- (<) 16 | -------------------------------------------------------------------------------- 17 | 18 | ||| Witness that `m < n === True`. 19 | export 20 | data (<) : (m,n : Int32) -> Type where 21 | LT : {0 m,n : Int32} -> (0 prf : (m < n) === True) -> m < n 22 | 23 | ||| Contructor for `(<)`. 24 | ||| 25 | ||| This can only be used in an erased context. 26 | export %hint 27 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 28 | mkLT = LT 29 | 30 | ||| Extractor for `(<)`. 31 | ||| 32 | ||| This can only be used in an erased context. 33 | export 34 | 0 runLT : m < n -> (m < n) === True 35 | runLT (LT prf) = prf 36 | 37 | ||| We don't trust values of type `(<)` too much, 38 | ||| so we use this when creating magical results. 39 | export 40 | strictLT : (0 p : m < n) -> Lazy c -> c 41 | strictLT (LT prf) x = x 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Aliases 45 | -------------------------------------------------------------------------------- 46 | 47 | ||| Flipped version of `(<)`. 48 | public export 49 | 0 (>) : (m,n : Int32) -> Type 50 | m > n = n < m 51 | 52 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 53 | public export 54 | 0 (<=) : (m,n : Int32) -> Type 55 | m <= n = Either (m < n) (m === n) 56 | 57 | ||| Flipped version of `(<=)`. 58 | public export 59 | 0 (>=) : (m,n : Int32) -> Type 60 | m >= n = n <= m 61 | 62 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 63 | public export 64 | 0 (/=) : (m,n : Int32) -> Type 65 | m /= n = Either (m < n) (m > n) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Order 69 | -------------------------------------------------------------------------------- 70 | 71 | 0 ltNotEQ : m < n -> Not (m === n) 72 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 73 | 74 | 0 ltNotGT : m < n -> Not (n < m) 75 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 76 | 77 | 0 eqNotLT : m === n -> Not (m < n) 78 | eqNotLT = flip ltNotEQ 79 | 80 | export 81 | comp : (m,n : Int32) -> Trichotomy (<) m n 82 | comp m n = case prim__lt_Int32 m n of 83 | 0 => case prim__eq_Int32 m n of 84 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 85 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 86 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 87 | 88 | export 89 | Total Int32 (<) where 90 | trichotomy = comp 91 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Bounds and Well-Foundedness 95 | -------------------------------------------------------------------------------- 96 | 97 | ||| Lower bound of `Int32` 98 | public export 99 | MinInt32 : Int32 100 | MinInt32 = -0x80000000 101 | 102 | ||| Upper bound of `Int32` 103 | public export 104 | MaxInt32 : Int32 105 | MaxInt32 = 0x7fffffff 106 | 107 | ||| `m >= MinInt32` for all `m` of type `Int32`. 108 | export 109 | 0 GTE_MinInt32 : (m : Int32) -> m >= MinInt32 110 | GTE_MinInt32 m = case comp MinInt32 m of 111 | LT x f g => %search 112 | EQ f x g => %search 113 | GT f g x => 114 | assert_total $ 115 | idris_crash "IMPOSSIBLE: Int32 smaller than \{show MinInt32}" 116 | 117 | ||| Not value of type `Int32` is less than zero. 118 | export 119 | 0 Not_LT_MinInt32 : m < MinInt32 -> Void 120 | Not_LT_MinInt32 = GTE_not_LT (GTE_MinInt32 m) 121 | 122 | ||| `m <= MaxInt32` for all `m` of type `Int32`. 123 | export 124 | 0 LTE_MaxInt32 : (m : Int32) -> m <= MaxInt32 125 | LTE_MaxInt32 m = case comp m MaxInt32 of 126 | LT x f g => %search 127 | EQ f x g => %search 128 | GT f g x => 129 | assert_total $ 130 | idris_crash "IMPOSSIBLE: Int32 greater than \{show MaxInt32}" 131 | 132 | ||| Not value of type `Int32` is greater than `MaxInt32`. 133 | export 134 | 0 Not_GT_MaxInt32 : m > MaxInt32 -> Void 135 | Not_GT_MaxInt32 = LTE_not_GT (LTE_MaxInt32 m) 136 | 137 | ||| Every value of type `Int32` is accessible with relation 138 | ||| to `(<)`. 139 | export 140 | accessLT : (m : Int32) -> Accessible (<) m 141 | accessLT m = Access $ \n,lt => accessLT (assert_smaller m n) 142 | 143 | ||| `(<)` is well founded. 144 | export %inline 145 | WellFounded Int32 (<) where 146 | wellFounded = accessLT 147 | 148 | ||| Every value of type `Int32` is accessible with relation 149 | ||| to `(>)`. 150 | export 151 | accessGT : (m : Int32) -> Accessible (>) m 152 | accessGT m = Access $ \n,gt => accessGT (assert_smaller m n) 153 | 154 | ||| `(>)` is well founded. 155 | export %inline 156 | [GT] WellFounded Int32 (>) where 157 | wellFounded = accessGT 158 | 159 | -------------------------------------------------------------------------------- 160 | -- Arithmetics 161 | -------------------------------------------------------------------------------- 162 | 163 | ||| Safe division. 164 | export %inline 165 | sdiv : (n,d : Int32) -> (0 prf : d /= 0) => Int32 166 | sdiv n d = n `div` d 167 | 168 | ||| Safe modulo. 169 | export %inline 170 | smod : (n,d : Int32) -> (0 prf : d /= 0) => Int32 171 | smod n d = n `mod` d 172 | -------------------------------------------------------------------------------- /src/Data/Prim/Int64.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Int64 2 | 3 | import public Control.WellFounded 4 | import public Data.DPair 5 | import public Data.Prim.Ord 6 | import public Algebra.Solver.Ring 7 | import Syntax.PreorderReasoning 8 | 9 | %default total 10 | 11 | unsafeRefl : a === b 12 | unsafeRefl = believe_me (Refl {x = a}) 13 | 14 | -------------------------------------------------------------------------------- 15 | -- (<) 16 | -------------------------------------------------------------------------------- 17 | 18 | ||| Witness that `m < n === True`. 19 | export 20 | data (<) : (m,n : Int64) -> Type where 21 | LT : {0 m,n : Int64} -> (0 prf : (m < n) === True) -> m < n 22 | 23 | ||| Contructor for `(<)`. 24 | ||| 25 | ||| This can only be used in an erased context. 26 | export %hint 27 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 28 | mkLT = LT 29 | 30 | ||| Extractor for `(<)`. 31 | ||| 32 | ||| This can only be used in an erased context. 33 | export 34 | 0 runLT : m < n -> (m < n) === True 35 | runLT (LT prf) = prf 36 | 37 | ||| We don't trust values of type `(<)` too much, 38 | ||| so we use this when creating magical results. 39 | export 40 | strictLT : (0 p : m < n) -> Lazy c -> c 41 | strictLT (LT prf) x = x 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Aliases 45 | -------------------------------------------------------------------------------- 46 | 47 | ||| Flipped version of `(<)`. 48 | public export 49 | 0 (>) : (m,n : Int64) -> Type 50 | m > n = n < m 51 | 52 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 53 | public export 54 | 0 (<=) : (m,n : Int64) -> Type 55 | m <= n = Either (m < n) (m === n) 56 | 57 | ||| Flipped version of `(<=)`. 58 | public export 59 | 0 (>=) : (m,n : Int64) -> Type 60 | m >= n = n <= m 61 | 62 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 63 | public export 64 | 0 (/=) : (m,n : Int64) -> Type 65 | m /= n = Either (m < n) (m > n) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Order 69 | -------------------------------------------------------------------------------- 70 | 71 | 0 ltNotEQ : m < n -> Not (m === n) 72 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 73 | 74 | 0 ltNotGT : m < n -> Not (n < m) 75 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 76 | 77 | 0 eqNotLT : m === n -> Not (m < n) 78 | eqNotLT = flip ltNotEQ 79 | 80 | export 81 | comp : (m,n : Int64) -> Trichotomy (<) m n 82 | comp m n = case prim__lt_Int64 m n of 83 | 0 => case prim__eq_Int64 m n of 84 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 85 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 86 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 87 | 88 | export 89 | Total Int64 (<) where 90 | trichotomy = comp 91 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Bounds and Well-Foundedness 95 | -------------------------------------------------------------------------------- 96 | 97 | ||| Lower bound of `Int64` 98 | public export 99 | MinInt64 : Int64 100 | MinInt64 = -0x8000000000000000 101 | 102 | ||| Upper bound of `Int64` 103 | public export 104 | MaxInt64 : Int64 105 | MaxInt64 = 0x7fffffffffffffff 106 | 107 | ||| `m >= MinInt64` for all `m` of type `Int64`. 108 | export 109 | 0 GTE_MinInt64 : (m : Int64) -> m >= MinInt64 110 | GTE_MinInt64 m = case comp MinInt64 m of 111 | LT x f g => %search 112 | EQ f x g => %search 113 | GT f g x => 114 | assert_total $ 115 | idris_crash "IMPOSSIBLE: Int64 smaller than \{show MinInt64}" 116 | 117 | ||| Not value of type `Int64` is less than zero. 118 | export 119 | 0 Not_LT_MinInt64 : m < MinInt64 -> Void 120 | Not_LT_MinInt64 = GTE_not_LT (GTE_MinInt64 m) 121 | 122 | ||| `m <= MaxInt64` for all `m` of type `Int64`. 123 | export 124 | 0 LTE_MaxInt64 : (m : Int64) -> m <= MaxInt64 125 | LTE_MaxInt64 m = case comp m MaxInt64 of 126 | LT x f g => %search 127 | EQ f x g => %search 128 | GT f g x => 129 | assert_total $ 130 | idris_crash "IMPOSSIBLE: Int64 greater than \{show MaxInt64}" 131 | 132 | ||| Not value of type `Int64` is greater than `MaxInt64`. 133 | export 134 | 0 Not_GT_MaxInt64 : m > MaxInt64 -> Void 135 | Not_GT_MaxInt64 = LTE_not_GT (LTE_MaxInt64 m) 136 | 137 | ||| Every value of type `Int64` is accessible with relation 138 | ||| to `(<)`. 139 | export 140 | accessLT : (m : Int64) -> Accessible (<) m 141 | accessLT m = Access $ \n,lt => accessLT (assert_smaller m n) 142 | 143 | ||| `(<)` is well founded. 144 | export %inline 145 | WellFounded Int64 (<) where 146 | wellFounded = accessLT 147 | 148 | ||| Every value of type `Int64` is accessible with relation 149 | ||| to `(>)`. 150 | export 151 | accessGT : (m : Int64) -> Accessible (>) m 152 | accessGT m = Access $ \n,gt => accessGT (assert_smaller m n) 153 | 154 | ||| `(>)` is well founded. 155 | export %inline 156 | [GT] WellFounded Int64 (>) where 157 | wellFounded = accessGT 158 | 159 | -------------------------------------------------------------------------------- 160 | -- Arithmetics 161 | -------------------------------------------------------------------------------- 162 | 163 | ||| Safe division. 164 | export %inline 165 | sdiv : (n,d : Int64) -> (0 prf : d /= 0) => Int64 166 | sdiv n d = n `div` d 167 | 168 | ||| Safe modulo. 169 | export %inline 170 | smod : (n,d : Int64) -> (0 prf : d /= 0) => Int64 171 | smod n d = n `mod` d 172 | -------------------------------------------------------------------------------- /src/Data/Prim/Int8.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Int8 2 | 3 | import public Control.WellFounded 4 | import public Data.DPair 5 | import public Data.Prim.Ord 6 | import public Algebra.Solver.Ring 7 | import Syntax.PreorderReasoning 8 | 9 | %default total 10 | 11 | unsafeRefl : a === b 12 | unsafeRefl = believe_me (Refl {x = a}) 13 | 14 | -------------------------------------------------------------------------------- 15 | -- (<) 16 | -------------------------------------------------------------------------------- 17 | 18 | ||| Witness that `m < n === True`. 19 | export 20 | data (<) : (m,n : Int8) -> Type where 21 | LT : {0 m,n : Int8} -> (0 prf : (m < n) === True) -> m < n 22 | 23 | ||| Contructor for `(<)`. 24 | ||| 25 | ||| This can only be used in an erased context. 26 | export %hint 27 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 28 | mkLT = LT 29 | 30 | ||| Extractor for `(<)`. 31 | ||| 32 | ||| This can only be used in an erased context. 33 | export 34 | 0 runLT : m < n -> (m < n) === True 35 | runLT (LT prf) = prf 36 | 37 | ||| We don't trust values of type `(<)` too much, 38 | ||| so we use this when creating magical results. 39 | export 40 | strictLT : (0 p : m < n) -> Lazy c -> c 41 | strictLT (LT prf) x = x 42 | 43 | -------------------------------------------------------------------------------- 44 | -- Aliases 45 | -------------------------------------------------------------------------------- 46 | 47 | ||| Flipped version of `(<)`. 48 | public export 49 | 0 (>) : (m,n : Int8) -> Type 50 | m > n = n < m 51 | 52 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 53 | public export 54 | 0 (<=) : (m,n : Int8) -> Type 55 | m <= n = Either (m < n) (m === n) 56 | 57 | ||| Flipped version of `(<=)`. 58 | public export 59 | 0 (>=) : (m,n : Int8) -> Type 60 | m >= n = n <= m 61 | 62 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 63 | public export 64 | 0 (/=) : (m,n : Int8) -> Type 65 | m /= n = Either (m < n) (m > n) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Order 69 | -------------------------------------------------------------------------------- 70 | 71 | 0 ltNotEQ : m < n -> Not (m === n) 72 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 73 | 74 | 0 ltNotGT : m < n -> Not (n < m) 75 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 76 | 77 | 0 eqNotLT : m === n -> Not (m < n) 78 | eqNotLT = flip ltNotEQ 79 | 80 | export 81 | comp : (m,n : Int8) -> Trichotomy (<) m n 82 | comp m n = case prim__lt_Int8 m n of 83 | 0 => case prim__eq_Int8 m n of 84 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 85 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 86 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 87 | 88 | export 89 | Total Int8 (<) where 90 | trichotomy = comp 91 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Bounds and Well-Foundedness 95 | -------------------------------------------------------------------------------- 96 | 97 | ||| Lower bound of `Int8` 98 | public export 99 | MinInt8 : Int8 100 | MinInt8 = -0x80 101 | 102 | ||| Upper bound of `Int8` 103 | public export 104 | MaxInt8 : Int8 105 | MaxInt8 = 0x7f 106 | 107 | ||| `m >= MinInt8` for all `m` of type `Int8`. 108 | export 109 | 0 GTE_MinInt8 : (m : Int8) -> m >= MinInt8 110 | GTE_MinInt8 m = case comp MinInt8 m of 111 | LT x f g => %search 112 | EQ f x g => %search 113 | GT f g x => 114 | assert_total $ 115 | idris_crash "IMPOSSIBLE: Int8 smaller than \{show MinInt8}" 116 | 117 | ||| Not value of type `Int8` is less than zero. 118 | export 119 | 0 Not_LT_MinInt8 : m < MinInt8 -> Void 120 | Not_LT_MinInt8 = GTE_not_LT (GTE_MinInt8 m) 121 | 122 | ||| `m <= MaxInt8` for all `m` of type `Int8`. 123 | export 124 | 0 LTE_MaxInt8 : (m : Int8) -> m <= MaxInt8 125 | LTE_MaxInt8 m = case comp m MaxInt8 of 126 | LT x f g => %search 127 | EQ f x g => %search 128 | GT f g x => 129 | assert_total $ 130 | idris_crash "IMPOSSIBLE: Int8 greater than \{show MaxInt8}" 131 | 132 | ||| Not value of type `Int8` is greater than `MaxInt8`. 133 | export 134 | 0 Not_GT_MaxInt8 : m > MaxInt8 -> Void 135 | Not_GT_MaxInt8 = LTE_not_GT (LTE_MaxInt8 m) 136 | 137 | ||| Every value of type `Int8` is accessible with relation 138 | ||| to `(<)`. 139 | export 140 | accessLT : (m : Int8) -> Accessible (<) m 141 | accessLT m = Access $ \n,lt => accessLT (assert_smaller m n) 142 | 143 | ||| `(<)` is well founded. 144 | export %inline 145 | WellFounded Int8 (<) where 146 | wellFounded = accessLT 147 | 148 | ||| Every value of type `Int8` is accessible with relation 149 | ||| to `(>)`. 150 | export 151 | accessGT : (m : Int8) -> Accessible (>) m 152 | accessGT m = Access $ \n,gt => accessGT (assert_smaller m n) 153 | 154 | ||| `(>)` is well founded. 155 | export %inline 156 | [GT] WellFounded Int8 (>) where 157 | wellFounded = accessGT 158 | 159 | -------------------------------------------------------------------------------- 160 | -- Arithmetics 161 | -------------------------------------------------------------------------------- 162 | 163 | ||| Safe division. 164 | export %inline 165 | sdiv : (n,d : Int8) -> (0 prf : d /= 0) => Int8 166 | sdiv n d = n `div` d 167 | 168 | ||| Safe modulo. 169 | export %inline 170 | smod : (n,d : Int8) -> (0 prf : d /= 0) => Int8 171 | smod n d = n `mod` d 172 | -------------------------------------------------------------------------------- /src/Data/Prim/Integer.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.Integer 2 | 3 | import public Control.WellFounded 4 | import public Data.Prim.Ord 5 | import public Algebra.Solver.Ring 6 | import Syntax.PreorderReasoning 7 | 8 | %default total 9 | 10 | unsafeRefl : a === b 11 | unsafeRefl = believe_me (Refl {x = a}) 12 | 13 | -------------------------------------------------------------------------------- 14 | -- (<) 15 | -------------------------------------------------------------------------------- 16 | 17 | ||| Witness that `m < n === True`. 18 | export 19 | data (<) : (m,n : Integer) -> Type where 20 | LT : {0 m,n : Integer} -> (0 prf : (m < n) === True) -> m < n 21 | 22 | ||| Contructor for `(<)`. 23 | ||| 24 | ||| This can only be used in an erased context. 25 | export %hint 26 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 27 | mkLT = LT 28 | 29 | ||| Extractor for `(<)`. 30 | ||| 31 | ||| This can only be used in an erased context. 32 | export 33 | 0 runLT : m < n -> (m < n) === True 34 | runLT (LT prf) = prf 35 | 36 | ||| We don't trust values of type `(<)` too much, 37 | ||| so we use this when creating magical results. 38 | export 39 | strictLT : (0 p : m < n) -> Lazy c -> c 40 | strictLT (LT prf) x = x 41 | 42 | -------------------------------------------------------------------------------- 43 | -- Aliases 44 | -------------------------------------------------------------------------------- 45 | 46 | ||| Flipped version of `(<)`. 47 | public export 48 | 0 (>) : (m,n : Integer) -> Type 49 | m > n = n < m 50 | 51 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 52 | public export 53 | 0 (<=) : (m,n : Integer) -> Type 54 | m <= n = Either (m < n) (m === n) 55 | 56 | ||| Flipped version of `(<=)`. 57 | public export 58 | 0 (>=) : (m,n : Integer) -> Type 59 | m >= n = n <= m 60 | 61 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 62 | public export 63 | 0 (/=) : (m,n : Integer) -> Type 64 | m /= n = Either (m < n) (m > n) 65 | 66 | -------------------------------------------------------------------------------- 67 | -- Order 68 | -------------------------------------------------------------------------------- 69 | 70 | 0 ltNotEQ : m < n -> Not (m === n) 71 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 72 | 73 | 0 ltNotGT : m < n -> Not (n < m) 74 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 75 | 76 | 0 eqNotLT : m === n -> Not (m < n) 77 | eqNotLT = flip ltNotEQ 78 | 79 | export 80 | comp : (m,n : Integer) -> Trichotomy (<) m n 81 | comp m n = case prim__lt_Integer m n of 82 | 0 => case prim__eq_Integer m n of 83 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 84 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 85 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 86 | 87 | export 88 | Total Integer (<) where 89 | trichotomy = comp 90 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 91 | 92 | -------------------------------------------------------------------------------- 93 | -- Arithmetics 94 | -------------------------------------------------------------------------------- 95 | 96 | replace' : (0 p : a -> Type) -> (0 _ : x = y) -> p x -> p y 97 | replace' p prf px = replace {p} prf px 98 | 99 | derive : {0 a,b : Type} 100 | -> (x : a) 101 | -> FastDerivation a b 102 | -> b 103 | derive x z = case Calc z of Refl => x 104 | 105 | --------- 106 | -- Axioms 107 | 108 | ||| This axiom, which only holds for unbounded integers, relates 109 | ||| addition and the ordering of integers: 110 | ||| 111 | ||| From `k < m` follows `n + k < n + m` for all integers `k`, `m`, and `n`. 112 | export 113 | 0 plusGT : (k,m,n : Integer) -> k < m -> n + k < n + m 114 | plusGT k m n x = strictLT x $ mkLT unsafeRefl 115 | 116 | ||| This axiom, which only holds for unbounded integers, relates 117 | ||| multiplication and the ordering of integers: 118 | ||| 119 | ||| From `0 < m` and `0 < n` follows `0 < m * n` for all integers `m` and `n`. 120 | export 121 | 0 multPosPosGT0 : (m,n : Integer) -> 0 < m -> 0 < n -> 0 < m * n 122 | multPosPosGT0 _ _ p1 p2 = strictLT p1 $ strictLT p2 $ mkLT unsafeRefl 123 | 124 | ||| There is no integer between 0 and 1. 125 | export 126 | 0 oneAfterZero : (n : Integer) -> 0 < n -> 1 <= n 127 | oneAfterZero n gt0 = case comp 1 n of 128 | LT x _ _ => Left x 129 | EQ _ x _ => Right x 130 | GT _ _ x => 131 | strictLT gt0 132 | $ strictLT x 133 | $ assert_total 134 | $ idris_crash "IMPOSSIBLE: Integer between 0 and 1" 135 | 136 | ||| For positive `d`, `mod n d` is a non-negative number 137 | ||| strictly smaller than `d`. 138 | export 139 | 0 modLT : (n,d : Integer) -> 0 < d -> (0 <= mod n d, mod n d < d) 140 | modLT n d x with (mod n d) 141 | _ | 0 = (Right Refl, x) 142 | _ | _ = strictLT x (Left $ mkLT unsafeRefl, mkLT unsafeRefl) 143 | 144 | export 145 | 0 modNegEQ : (n,d : Integer) -> d < 0 -> mod n d === mod n (neg d) 146 | modNegEQ n d x = strictLT x unsafeRefl 147 | 148 | export 149 | 0 lawDivMod : (n,d : Integer) -> d /= 0 -> d * div n d + mod n d === n 150 | lawDivMod n d (Left x) = strictLT x unsafeRefl 151 | lawDivMod n d (Right x) = strictLT x unsafeRefl 152 | 153 | ---------------------------- 154 | -- Division 155 | 156 | ||| Safe division. 157 | export %inline 158 | sdiv : (n,d : Integer) -> (0 prf : d /= 0) => Integer 159 | sdiv n d = n `div` d 160 | 161 | ||| Safe modulo. 162 | export %inline 163 | smod : (n,d : Integer) -> (0 prf : d /= 0) => Integer 164 | smod n d = n `mod` d 165 | 166 | -------------------------------------------------------------------------------- 167 | -- Well-Foundedness 168 | -------------------------------------------------------------------------------- 169 | 170 | public export 171 | 0 BoundedLT : (lowerBound : Integer) -> Integer -> Integer -> Type 172 | BoundedLT lowerBound x y = (lowerBound <= x, x < y) 173 | 174 | public export 175 | 0 BoundedGT : (upperBound : Integer) -> Integer -> Integer -> Type 176 | BoundedGT upperBound x y = (upperBound >= x, x > y) 177 | 178 | ||| Every value of type `Integer` with a fixed lower bound 179 | ||| is accessible with relation to `(<)`. 180 | export 181 | accessLT : (m : Integer) -> Accessible (BoundedLT lb) m 182 | accessLT m = Access $ \n,lt => accessLT (assert_smaller m n) 183 | 184 | ||| Every value of type `Integer` with a fixed upper bound 185 | ||| is accessible with relation to `(>)`. 186 | export 187 | accessGT : (m : Integer) -> Accessible (BoundedGT ub) m 188 | accessGT m = Access $ \n,gt => accessGT (assert_smaller m n) 189 | 190 | -------------------------------------------------------------------------------- /src/Data/Prim/Ord.idr: -------------------------------------------------------------------------------- 1 | ||| Axioms and propsitions for primitive types with an 2 | ||| `Ord` implementation. 3 | module Data.Prim.Ord 4 | 5 | import public Data.Trichotomy 6 | 7 | %default total 8 | 9 | ||| Similar to `Either` but with erased fields. 10 | public export 11 | data Either0 : Type -> Type -> Type where 12 | Left0 : (0 v : a) -> Either0 a b 13 | Right0 : (0 v : b) -> Either0 a b 14 | 15 | ||| We often don't trust values of type `a === b`, as they might 16 | ||| have been magically crafted using `believe_me` or `assert_total` 17 | ||| followed by `idris_crash`. If a value of another type follows 18 | ||| from a (potentially) magically crafted one, we only want the 19 | ||| second value to reduce at compile time, if the first value 20 | ||| reduces to `Refl`. Otherwise, we risk blowing up the compiler 21 | ||| in an absurd context. 22 | export 23 | strictRefl : (0 prf : a === b) -> Lazy c -> c 24 | strictRefl Refl x = x 25 | 26 | -------------------------------------------------------------------------------- 27 | -- Interface 28 | -------------------------------------------------------------------------------- 29 | 30 | ||| This interface is a witness that the given primitive type 31 | ||| comes with a relation `lt`, with `lt` being a strict total order. 32 | ||| We typically define the following aliases 33 | ||| (or name the relation accordingly): 34 | ||| 35 | ||| `m < n` := lt m n 36 | ||| `m > n` := lt n m 37 | ||| `m <= n` := Either (lt m n) (m === n) 38 | ||| `m >= n` := Either (lt n m) (n === m) 39 | ||| `m /= n` := Either (lt m n) (lt n m) 40 | ||| 41 | ||| The following axioms must hold: 42 | ||| 1. (<) is transitive: From `k < m` and `m < n` follows `k < n`. 43 | ||| 44 | ||| 2. Trichotomy: For all values `m` and `n` exactly one of the 45 | ||| following holds: `m < n`, `m === n`, or `n < m`. 46 | ||| 47 | ||| It is in the nature of a primitive that we can't proof these axioms 48 | ||| in Idris itself. We must therefore assume that they hold on all backends, 49 | ||| and it is the responsibility of programmers implementing 50 | ||| interface `Total` to make sure that the axioms actually hold. 51 | public export 52 | interface Total (0 a : Type) (0 lt : a -> a -> Type) | lt where 53 | ||| Axiom I: `<` is transitive. 54 | 0 transLT : {k,m,n : a} -> lt k m -> lt m n -> lt k n 55 | 56 | ||| Axiom II: Trichotomy of `<`, `===`, and `>`. 57 | trichotomy : (m,n : a) -> Trichotomy lt m n 58 | 59 | ||| Tests if the first value is strictly less than the second or not 60 | export 61 | testLT : Total a lt => (x,y : a) -> Either0 (lt x y) (Either (lt y x) (y === x)) 62 | testLT x y = case trichotomy {lt} x y of 63 | LT p _ _ => Left0 p 64 | EQ _ p _ => Right0 (Right $ sym p) 65 | GT _ _ p => Right0 (Left p) 66 | 67 | ||| Tests if the first value is strictly greater than the second or not 68 | export 69 | testGT : Total a lt => (x,y : a) -> Either0 (lt y x) (Either (lt x y) (x === y)) 70 | testGT x y = case trichotomy {lt} x y of 71 | GT _ _ p => Left0 p 72 | LT p _ _ => Right0 (Left p) 73 | EQ _ p _ => Right0 (Right p) 74 | 75 | ||| Tests if the two values are provably equal or not 76 | export 77 | testEQ : Total a lt => (x,y : a) -> Either0 (x === y) (Either (lt x y) (lt y x)) 78 | testEQ x y = case trichotomy {lt} x y of 79 | EQ _ p _ => Left0 p 80 | LT p _ _ => Right0 (Left p) 81 | GT _ _ p => Right0 (Right p) 82 | 83 | -------------------------------------------------------------------------------- 84 | -- Corollaries 85 | -------------------------------------------------------------------------------- 86 | 87 | ||| `<` is irreflexive. 88 | export 89 | 0 irrefl : Total a lt => Not (lt m m) 90 | irrefl x = case trichotomy m m of 91 | LT y _ f => f y 92 | EQ f _ _ => f x 93 | GT f _ y => f y 94 | 95 | -------------------------------------------------------------------------------- 96 | -- Transitivities 97 | -------------------------------------------------------------------------------- 98 | 99 | namespace LT 100 | 101 | ||| This is an alias for `transLT` 102 | export 103 | 0 trans : Total a lt => lt k m -> lt m n -> lt k n 104 | trans = transLT 105 | 106 | ||| `k === m` and `m /= n` implies `k /= n`. 107 | export 108 | 0 trans_EQ_NEQ : 109 | {auto _ : Total a lt} 110 | -> k === m 111 | -> Either (lt m n) (lt n m) 112 | -> Either (lt k n) (lt n k) 113 | trans_EQ_NEQ eqv neq = rewrite eqv in neq 114 | 115 | ||| `k === m` and `m /= n` implies `k /= n`. 116 | export 117 | 0 trans_NEQ_EQ : 118 | {auto _ : Total a lt} 119 | -> Either (lt k m) (lt m k) 120 | -> m === n 121 | -> Either (lt k n) (lt n k) 122 | trans_NEQ_EQ neq eqv = rewrite (sym eqv) in neq 123 | 124 | ||| `k < m` and `m === n` implies `k < n` 125 | export 126 | 0 trans_LT_EQ : Total a lt => lt k m -> m === n -> lt k n 127 | trans_LT_EQ p eqv = rewrite sym eqv in p 128 | 129 | ||| `k === m` and `m < n` implies `k < n` 130 | export 131 | 0 trans_EQ_LT : Total a lt => k === m -> lt m n -> lt k n 132 | trans_EQ_LT eqv q = rewrite eqv in q 133 | 134 | ||| `k <= m` and `m < n` implies `k < n` 135 | export 136 | 0 trans_LTE_LT : Total a lt => Either (lt k m) (k === m) -> lt m n -> lt k n 137 | trans_LTE_LT x y = either (`trans` y) (`trans_EQ_LT` y) x 138 | 139 | ||| `k < m` and `m <= n` implies `k < n` 140 | export 141 | 0 trans_LT_LTE : Total a lt => lt k m -> Either (lt m n) (m === n) -> lt k n 142 | trans_LT_LTE x = either (trans x) (trans_LT_EQ x) 143 | 144 | ||| `k > m` and `m === n` implies `k > n` 145 | export 146 | 0 trans_GT_EQ : Total a lt => lt m k -> m === n -> lt n k 147 | trans_GT_EQ p eqv = rewrite sym eqv in p 148 | 149 | ||| `k === m` and `m > n` implies `k > n` 150 | export 151 | 0 trans_EQ_GT : Total a lt => k === m -> lt n m -> lt n k 152 | trans_EQ_GT eqv q = rewrite eqv in q 153 | 154 | ||| `k >= m` and `m > n` implies `k > n` 155 | export 156 | 0 trans_GTE_GT : Total a lt => Either (lt m k) (m === k) -> lt n m -> lt n k 157 | trans_GTE_GT x y = either (trans y) (\v => trans_EQ_GT (sym v) y) x 158 | 159 | ||| `k > m` and `m >= n` implies `k > n` 160 | export 161 | 0 trans_GT_GTE : Total a lt => lt m k -> Either (lt n m) (n === m) -> lt n k 162 | trans_GT_GTE x (Left y) = trans y x 163 | trans_GT_GTE x (Right y) = trans_GT_EQ x (sym y) 164 | 165 | namespace LTE 166 | 167 | ||| `<=` is reflexive. 168 | export 169 | 0 refl : Total a lt => Either (lt m m) (m === m) 170 | refl = Right Refl 171 | 172 | ||| `<=` is transitive. 173 | export 174 | 0 trans : 175 | {auto _ : Total a lt} 176 | -> Either (lt k m) (k === m) 177 | -> Either (lt m n) (m === n) 178 | -> Either (lt k n) (k === n) 179 | trans (Left x) y = Left (trans_LT_LTE x y) 180 | trans (Right x) (Left y) = Left (trans_EQ_LT x y) 181 | trans (Right x) (Right y) = Right (trans x y) 182 | 183 | ||| `<=` is antisymmetric. 184 | export 185 | 0 antisym : 186 | {auto _ : Total a lt} 187 | -> Either (lt m n) (m === n) 188 | -> Either (lt n m) (m === n) 189 | -> m === n 190 | antisym (Right x) _ = x 191 | antisym (Left x) (Right y) = y 192 | antisym (Left x) (Left y) = void (irrefl $ trans x y) 193 | 194 | ||| `k <= m` and `m === n` implies `k <= n` 195 | export 196 | 0 trans_LTE_EQ : 197 | {auto _ : Total a lt} 198 | -> Either (lt k m) (k === m) 199 | -> m === n 200 | -> Either (lt k n) (k === n) 201 | trans_LTE_EQ lte eq = trans lte (Right eq) 202 | 203 | ||| `k === m` and `m <= n` implies `(k <= n)` 204 | export 205 | 0 trans_EQ_LTE : 206 | {auto _ : Total a lt} 207 | -> k === m 208 | -> Either (lt m n) (m === n) 209 | -> Either (lt k n) (k === n) 210 | trans_EQ_LTE eq lte = trans (Right eq) lte 211 | 212 | namespace GTE 213 | 214 | ||| `>=` is transitive. 215 | export 216 | 0 trans : 217 | {auto _ : Total a lt} 218 | -> Either (lt m k) (m === k) 219 | -> Either (lt n m) (n === m) 220 | -> Either (lt n k) (n === k) 221 | trans (Left x) y = Left (trans_GT_GTE x y) 222 | trans (Right x) (Left y) = Left (trans_EQ_GT (sym x) y) 223 | trans (Right x) (Right y) = Right (trans y x) 224 | 225 | ||| `>=` is antisymmetric. 226 | export 227 | 0 antisym : 228 | {auto _ : Total a lt} 229 | -> Either (lt n m) (m === n) 230 | -> Either (lt m n) (m === n) 231 | -> m === n 232 | antisym (Right x) _ = x 233 | antisym (Left x) (Right y) = y 234 | antisym (Left x) (Left y) = void (irrefl $ trans x y) 235 | 236 | ||| `k >= m` and `m === n` implies `k >= n` 237 | export 238 | 0 trans_GTE_EQ : 239 | {auto _ : Total a lt} 240 | -> Either (lt m k) (m === k) 241 | -> m === n 242 | -> Either (lt n k) (n === k) 243 | trans_GTE_EQ gte eq = trans gte (Right $ sym eq) 244 | 245 | ||| `k === m` and `m <= n` implies `(k <= n)` 246 | export 247 | 0 trans_EQ_GTE : 248 | {auto _ : Total a lt} 249 | -> k === m 250 | -> Either (lt n m) (n === m) 251 | -> Either (lt n k) (n === k) 252 | trans_EQ_GTE eq gte = trans (Right $ sym eq) gte 253 | 254 | -------------------------------------------------------------------------------- 255 | -- Conversions 256 | -------------------------------------------------------------------------------- 257 | 258 | ||| `m < n` implies `Not (m > n)`. 259 | export 260 | 0 LT_not_GT : Total a lt => lt m n -> Not (lt n m) 261 | LT_not_GT isLT isGT = case trichotomy m n of 262 | LT _ _ g => g isGT 263 | EQ _ _ g => g isGT 264 | GT f _ _ => f isLT 265 | 266 | ||| `m < n` implies `Not (m === n)`. 267 | export 268 | 0 LT_not_EQ : Total a lt => lt m n -> Not (m === n) 269 | LT_not_EQ isLT isEQ = case trichotomy m n of 270 | LT _ g _ => g isEQ 271 | EQ f _ _ => f isLT 272 | GT _ g _ => g isEQ 273 | 274 | ||| `m < n` implies `Not (m >= n)`. 275 | export 276 | 0 LT_not_GTE : Total a lt => lt m n -> Not (Either (lt n m) (n === m)) 277 | LT_not_GTE l = either (LT_not_GT l) (\e => LT_not_EQ l (sym e)) 278 | 279 | ||| `Not (m < n)` implies `m >= n`. 280 | export 281 | 0 Not_LT_to_GTE : Total a lt => Not (lt m n) -> Either (lt n m) (n === m) 282 | Not_LT_to_GTE f = case trichotomy m n of 283 | LT x _ _ => void (f x) 284 | EQ _ x _ => Right (sym x) 285 | GT _ _ x => Left x 286 | 287 | ||| `m === n` implies `Not (m < n)`. 288 | export 289 | 0 EQ_not_LT : Total a lt => m === n -> Not (lt m n) 290 | EQ_not_LT = flip LT_not_EQ 291 | 292 | ||| `m === n` implies `Not (m > n)`. 293 | export 294 | 0 EQ_not_GT : Total a lt => m === n -> Not (lt n m) 295 | EQ_not_GT isEQ = EQ_not_LT (sym isEQ) 296 | 297 | ||| `m === n` implies `Not (m /= n)`. 298 | export 299 | 0 EQ_not_NEQ : Total a lt => m === n -> Not (Either (lt m n) (lt n m)) 300 | EQ_not_NEQ isEQ = either (EQ_not_LT isEQ) (EQ_not_GT isEQ) 301 | 302 | ||| `Not (m < n)` implies `m /= n`. 303 | export 304 | 0 Not_EQ_to_NEQ : Total a lt => Not (m === n) -> Either (lt m n) (lt n m) 305 | Not_EQ_to_NEQ f = case trichotomy m n of 306 | LT x _ _ => Left x 307 | EQ _ x _ => void (f x) 308 | GT _ _ x => Right x 309 | 310 | ||| `m > n` implies `Not (m < n)`. 311 | export 312 | 0 GT_not_LT : Total a lt => lt n m -> Not (lt m n) 313 | GT_not_LT = LT_not_GT 314 | 315 | ||| `m > n` implies `Not (m === n)`. 316 | export 317 | 0 GT_not_EQ : Total a lt => lt n m -> Not (m === n) 318 | GT_not_EQ = flip EQ_not_GT 319 | 320 | ||| `m > n` implies `Not (m <= n)`. 321 | export 322 | 0 GT_not_LTE : Total a lt => lt n m -> Not (Either (lt m n) (m === n)) 323 | GT_not_LTE gt = either (GT_not_LT gt) (GT_not_EQ gt) 324 | 325 | ||| `Not (m > n)` implies `m <= n`. 326 | export 327 | 0 Not_GT_to_LTE : Total a lt => Not (lt n m) -> Either (lt m n) (m === n) 328 | Not_GT_to_LTE f = case trichotomy m n of 329 | LT x _ _ => Left x 330 | EQ _ x _ => Right x 331 | GT _ _ x => void (f x) 332 | 333 | ||| `m <= n` implies `Not (m > n)`. 334 | export 335 | 0 LTE_not_GT : Total a lt => (Either (lt m n) (m === n)) -> Not (lt n m) 336 | LTE_not_GT = either LT_not_GT EQ_not_GT 337 | 338 | ||| `Not (m <= n)` implies `m > n`. 339 | export 340 | 0 Not_LTE_to_GT : Total a lt => Not (Either (lt m n) (m === n)) -> lt n m 341 | Not_LTE_to_GT f = case trichotomy m n of 342 | LT x _ _ => void (f $ Left x) 343 | EQ _ x _ => void (f $ Right x) 344 | GT _ _ x => x 345 | 346 | ||| `m <= n` and `m >= n` implies `m === n`. 347 | export 348 | 0 LTE_and_GTE_to_EQ : 349 | {auto _ : Total a lt} 350 | -> Either (lt m n) (m === n) 351 | -> Either (lt n m) (n === m) 352 | -> m === n 353 | LTE_and_GTE_to_EQ (Left x) (Right y) = sym y 354 | LTE_and_GTE_to_EQ (Right x) _ = x 355 | LTE_and_GTE_to_EQ (Left x) (Left y) = void (LT_not_GT x y) 356 | 357 | ||| `m <= n` and `m /= n` implies `m < n`. 358 | export 359 | 0 LTE_and_NEQ_to_LT : 360 | {auto _ : Total a lt} 361 | -> Either (lt m n) (m === n) 362 | -> Either (lt m n) (lt n m) 363 | -> lt m n 364 | LTE_and_NEQ_to_LT (Left x) _ = x 365 | LTE_and_NEQ_to_LT (Right _) (Left x) = x 366 | LTE_and_NEQ_to_LT (Right x) (Right y) = void (EQ_not_GT x y) 367 | 368 | ||| `m /= n` implies `Not (m === n)`. 369 | export 370 | 0 NEQ_not_EQ : Total a lt => Either (lt m n) (lt n m) -> Not (m === n) 371 | NEQ_not_EQ = either LT_not_EQ GT_not_EQ 372 | 373 | ||| `Not (m /= n)` implies `m === n`. 374 | export 375 | 0 Not_NEQ_to_EQ : Total a lt => Not (Either (lt m n) (lt n m)) -> m === n 376 | Not_NEQ_to_EQ f = case trichotomy m n of 377 | LT x _ _ => void (f $ Left x) 378 | EQ _ x _ => x 379 | GT _ _ x => void (f $ Right x) 380 | 381 | ||| `m /= n` and `m <= n` implies `m < n`. 382 | export 383 | 0 NEQ_and_LTE_to_LT : 384 | {auto _ : Total a lt} 385 | -> Either (lt m n) (lt n m) 386 | -> Either (lt m n) (m === n) 387 | -> lt m n 388 | NEQ_and_LTE_to_LT = flip LTE_and_NEQ_to_LT 389 | 390 | ||| `m /= n` and `m <= n` implies `m < n`. 391 | export 392 | 0 NEQ_and_GTE_to_GT : 393 | {auto _ : Total a lt} 394 | -> Either (lt m n) (lt n m) 395 | -> Either (lt n m) (n === m) 396 | -> lt n m 397 | NEQ_and_GTE_to_GT (Right x) _ = x 398 | NEQ_and_GTE_to_GT (Left _) (Left y) = y 399 | NEQ_and_GTE_to_GT (Left x) (Right y) = void (GT_not_EQ x y) 400 | 401 | ||| `m >= n` implies `Not (m < n)`. 402 | export 403 | 0 GTE_not_LT : Total a lt => Either (lt n m) (n === m) -> Not (lt m n) 404 | GTE_not_LT = either GT_not_LT EQ_not_GT 405 | 406 | ||| `Not (m >= n)` implies `m < n`. 407 | export 408 | 0 Not_GTE_to_LT : Total a lt => Not (Either (lt n m) (n === m)) -> lt m n 409 | Not_GTE_to_LT f = case trichotomy m n of 410 | LT x _ _ => x 411 | EQ _ x _ => void (f $ Right (sym x)) 412 | GT _ _ x => void (f $ Left x) 413 | 414 | ||| `m >= n` and `m <= n` implies `m === n`. 415 | export 416 | 0 GTE_and_LTE_to_EQ : 417 | {auto _ : Total a lt} 418 | -> Either (lt n m) (n === m) 419 | -> Either (lt m n) (m === n) 420 | -> m === n 421 | GTE_and_LTE_to_EQ = flip LTE_and_GTE_to_EQ 422 | 423 | ||| `m >= n` and `m /= n` implies `m > n`. 424 | export 425 | 0 GTE_and_NEQ_to_GT : 426 | {auto _ : Total a lt} 427 | -> Either (lt n m) (n === m) 428 | -> Either (lt m n) (lt n m) 429 | -> lt n m 430 | GTE_and_NEQ_to_GT = flip NEQ_and_GTE_to_GT 431 | -------------------------------------------------------------------------------- /src/Data/Prim/String.idr: -------------------------------------------------------------------------------- 1 | module Data.Prim.String 2 | 3 | import public Data.DPair 4 | import public Data.Prim.Ord 5 | 6 | %default total 7 | 8 | unsafeRefl : a === b 9 | unsafeRefl = believe_me (Refl {x = a}) 10 | 11 | -------------------------------------------------------------------------------- 12 | -- (<) 13 | -------------------------------------------------------------------------------- 14 | 15 | ||| Witness that `m < n === True`. 16 | export 17 | data (<) : (m,n : String) -> Type where 18 | LT : {0 m,n : String} -> (0 prf : (m < n) === True) -> m < n 19 | 20 | ||| Contructor for `(<)`. 21 | ||| 22 | ||| This can only be used in an erased context. 23 | export %hint 24 | 0 mkLT : (0 prf : (m < n) === True) -> m < n 25 | mkLT = LT 26 | 27 | ||| Extractor for `(<)`. 28 | ||| 29 | ||| This can only be used in an erased context. 30 | export 31 | 0 runLT : m < n -> (m < n) === True 32 | runLT (LT prf) = prf 33 | 34 | ||| We don't trust values of type `(<)` too much, 35 | ||| so we use this when creating magical results. 36 | export 37 | strictLT : (0 p : m < n) -> Lazy c -> c 38 | strictLT (LT prf) x = x 39 | 40 | -------------------------------------------------------------------------------- 41 | -- Aliases 42 | -------------------------------------------------------------------------------- 43 | 44 | ||| Flipped version of `(<)`. 45 | public export 46 | 0 (>) : (m,n : String) -> Type 47 | m > n = n < m 48 | 49 | ||| `m <= n` mean that either `m < n` or `m === n` holds. 50 | public export 51 | 0 (<=) : (m,n : String) -> Type 52 | m <= n = Either (m < n) (m === n) 53 | 54 | ||| Flipped version of `(<=)`. 55 | public export 56 | 0 (>=) : (m,n : String) -> Type 57 | m >= n = n <= m 58 | 59 | ||| `m /= n` mean that either `m < n` or `m > n` holds. 60 | public export 61 | 0 (/=) : (m,n : String) -> Type 62 | m /= n = Either (m < n) (m > n) 63 | 64 | -------------------------------------------------------------------------------- 65 | -- Order 66 | -------------------------------------------------------------------------------- 67 | 68 | 0 ltNotEQ : m < n -> Not (m === n) 69 | ltNotEQ x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and EQ") 70 | 71 | 0 ltNotGT : m < n -> Not (n < m) 72 | ltNotGT x = strictLT x $ assert_total (idris_crash "IMPOSSIBLE: LT and GT") 73 | 74 | 0 eqNotLT : m === n -> Not (m < n) 75 | eqNotLT = flip ltNotEQ 76 | 77 | export 78 | comp : (m,n : String) -> Trichotomy (<) m n 79 | comp m n = case prim__lt_String m n of 80 | 0 => case prim__eq_String m n of 81 | 0 => GT (ltNotGT $ LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (LT unsafeRefl) 82 | x => EQ (eqNotLT unsafeRefl) (unsafeRefl) (eqNotLT unsafeRefl) 83 | x => LT (LT unsafeRefl) (ltNotEQ $ LT unsafeRefl) (ltNotGT $ LT unsafeRefl) 84 | 85 | export 86 | Total String (<) where 87 | trichotomy = comp 88 | transLT p q = strictLT p $ strictLT q $ LT unsafeRefl 89 | 90 | -------------------------------------------------------------------------------- 91 | -- Bounds and Well-Foundedness 92 | -------------------------------------------------------------------------------- 93 | 94 | ||| Lower bound of `String` 95 | public export 96 | MinString : String 97 | MinString = "" 98 | 99 | ||| `m >= MinString` for all `m` of type `String`. 100 | export 101 | 0 GTE_MinString : (m : String) -> m >= MinString 102 | GTE_MinString m = case comp MinString m of 103 | LT x f g => %search 104 | EQ f x g => %search 105 | GT f g x => assert_total $ idris_crash #"IMPOSSIBLE: String smaller than """# 106 | 107 | ||| Not value of type `String` is less than `MinString`. 108 | export 109 | 0 Not_LT_MinString : m < MinString -> Void 110 | Not_LT_MinString = GTE_not_LT (GTE_MinString m) 111 | -------------------------------------------------------------------------------- /src/Data/Trichotomy.idr: -------------------------------------------------------------------------------- 1 | module Data.Trichotomy 2 | 3 | %default total 4 | 5 | ||| Trichotomy formalises the fact that three relations are mutually 6 | ||| exclusive. A value of type `Trichotomy lt m n` proofs, that 7 | ||| exactly one of the relations `lt m n`, `m === n`, or `lt n m` holds. 8 | ||| 9 | ||| All proofs held by a value of type `Trichotomous` are erased, so 10 | ||| at runtime such values get optimized to numbers 0, 1, or 2 11 | ||| respectively. 12 | public export 13 | data Trichotomy : (lt : a -> a -> Type) -> (a -> a -> Type) where 14 | LT : {0 lt : a -> a -> Type} 15 | -> (0 _ : lt v w) 16 | -> (0 _ : Not (v === w)) 17 | -> (0 _ : Not (lt w v)) 18 | -> Trichotomy lt v w 19 | 20 | EQ : {0 lt : a -> a -> Type} 21 | -> (0 _ : Not (lt v w)) 22 | -> (0 _ : v === w) 23 | -> (0 _ : Not (lt w v)) 24 | -> Trichotomy lt v w 25 | 26 | GT : {0 lt : a -> a -> Type} 27 | -> (0 _ : Not (lt v w)) 28 | -> (0 _ : Not (v === w)) 29 | -> (0 _ : lt w v) 30 | -> Trichotomy lt v w 31 | 32 | public export 33 | Eq (Trichotomy lt m n) where 34 | LT _ _ _ == LT _ _ _ = True 35 | EQ _ _ _ == EQ _ _ _ = True 36 | GT _ _ _ == GT _ _ _ = True 37 | _ == _ = False 38 | 39 | public export 40 | Ord (Trichotomy lt m n) where 41 | compare (LT _ _ _) (LT _ _ _) = EQ 42 | compare (LT _ _ _) _ = LT 43 | compare _ (LT _ _ _) = GT 44 | compare (EQ _ _ _) (EQ _ _ _) = EQ 45 | compare (EQ _ _ _) _ = LT 46 | compare _ (EQ _ _ _) = GT 47 | compare (GT _ _ _) (GT _ _ _) = EQ 48 | 49 | public export 50 | Show (Trichotomy lt m n) where 51 | show (LT _ _ _) = "LT" 52 | show (EQ _ _ _) = "EQ" 53 | show (GT _ _ _) = "GT" 54 | 55 | public export 56 | toOrdering : Trichotomy lt m n -> Ordering 57 | toOrdering (LT _ _ _) = LT 58 | toOrdering (EQ _ _ _) = EQ 59 | toOrdering (GT _ _ _) = GT 60 | -------------------------------------------------------------------------------- /test/src/Bits16.idr: -------------------------------------------------------------------------------- 1 | module Bits16 2 | 3 | import Data.Prim.Bits16 4 | import Data.SOP 5 | import Hedgehog 6 | import RingLaws 7 | 8 | allBits16 : Gen Bits16 9 | allBits16 = bits16 (linear 0 0xffff) 10 | 11 | gt0 : Gen Bits16 12 | gt0 = bits16 (linear 1 MaxBits16) 13 | 14 | gt1 : Gen Bits16 15 | gt1 = bits16 (linear 2 MaxBits16) 16 | 17 | prop_ltMax : Property 18 | prop_ltMax = property $ do 19 | b8 <- forAll allBits16 20 | (b8 <= MaxBits16) === True 21 | 22 | prop_ltMin : Property 23 | prop_ltMin = property $ do 24 | b8 <- forAll allBits16 25 | (b8 >= MinBits16) === True 26 | 27 | prop_comp : Property 28 | prop_comp = property $ do 29 | [m,n] <- forAll $ np [allBits16, allBits16] 30 | toOrdering (comp m n) === compare m n 31 | 32 | prop_mod : Property 33 | prop_mod = property $ do 34 | [n,d] <- forAll $ np [allBits16, gt0] 35 | compare (n `mod` d) d === LT 36 | 37 | prop_div : Property 38 | prop_div = property $ do 39 | [n,d] <- forAll $ np [gt0, gt1] 40 | compare (n `div` d) n === LT 41 | 42 | prop_divMod : Property 43 | prop_divMod = property $ do 44 | [n,d] <- forAll $ np [allBits16, gt0] 45 | let x = n `div` d 46 | r = n `mod` d 47 | n === x * d + r 48 | 49 | export 50 | props : Group 51 | props = 52 | MkGroup "Bits16" $ 53 | [ ("prop_ltMax", prop_ltMax) 54 | , ("prop_ltMin", prop_ltMin) 55 | , ("prop_comp", prop_comp) 56 | , ("prop_mod", prop_mod) 57 | , ("prop_div", prop_div) 58 | , ("prop_divMod", prop_divMod) 59 | ] ++ ringProps allBits16 60 | -------------------------------------------------------------------------------- /test/src/Bits32.idr: -------------------------------------------------------------------------------- 1 | module Bits32 2 | 3 | import Data.Prim.Bits32 4 | import Data.SOP 5 | import Hedgehog 6 | import RingLaws 7 | 8 | allBits32 : Gen Bits32 9 | allBits32 = bits32 (linear 0 0xffffffff) 10 | 11 | gt0 : Gen Bits32 12 | gt0 = bits32 (linear 1 MaxBits32) 13 | 14 | gt1 : Gen Bits32 15 | gt1 = bits32 (linear 2 MaxBits32) 16 | 17 | prop_ltMax : Property 18 | prop_ltMax = property $ do 19 | b8 <- forAll allBits32 20 | (b8 <= MaxBits32) === True 21 | 22 | prop_ltMin : Property 23 | prop_ltMin = property $ do 24 | b8 <- forAll allBits32 25 | (b8 >= MinBits32) === True 26 | 27 | prop_comp : Property 28 | prop_comp = property $ do 29 | [m,n] <- forAll $ np [allBits32, allBits32] 30 | toOrdering (comp m n) === compare m n 31 | 32 | prop_mod : Property 33 | prop_mod = property $ do 34 | [n,d] <- forAll $ np [allBits32, gt0] 35 | compare (n `mod` d) d === LT 36 | 37 | prop_div : Property 38 | prop_div = property $ do 39 | [n,d] <- forAll $ np [gt0, gt1] 40 | compare (n `div` d) n === LT 41 | 42 | prop_divMod : Property 43 | prop_divMod = property $ do 44 | [n,d] <- forAll $ np [allBits32, gt0] 45 | let x = n `div` d 46 | r = n `mod` d 47 | n === x * d + r 48 | 49 | export 50 | props : Group 51 | props = 52 | MkGroup "Bits32" $ 53 | [ ("prop_ltMax", prop_ltMax) 54 | , ("prop_ltMin", prop_ltMin) 55 | , ("prop_comp", prop_comp) 56 | , ("prop_mod", prop_mod) 57 | , ("prop_div", prop_div) 58 | , ("prop_divMod", prop_divMod) 59 | ] ++ ringProps allBits32 60 | -------------------------------------------------------------------------------- /test/src/Bits64.idr: -------------------------------------------------------------------------------- 1 | module Bits64 2 | 3 | import Data.Prim.Bits64 4 | import Data.SOP 5 | import Hedgehog 6 | import RingLaws 7 | 8 | allBits64 : Gen Bits64 9 | allBits64 = bits64 (linear 0 0xffffffffffffffff) 10 | 11 | gt0 : Gen Bits64 12 | gt0 = bits64 (linear 1 MaxBits64) 13 | 14 | gt1 : Gen Bits64 15 | gt1 = bits64 (linear 2 MaxBits64) 16 | 17 | prop_ltMax : Property 18 | prop_ltMax = property $ do 19 | b8 <- forAll allBits64 20 | (b8 <= MaxBits64) === True 21 | 22 | prop_ltMin : Property 23 | prop_ltMin = property $ do 24 | b8 <- forAll allBits64 25 | (b8 >= MinBits64) === True 26 | 27 | prop_comp : Property 28 | prop_comp = property $ do 29 | [m,n] <- forAll $ np [allBits64, allBits64] 30 | toOrdering (comp m n) === compare m n 31 | 32 | prop_mod : Property 33 | prop_mod = property $ do 34 | [n,d] <- forAll $ np [allBits64, gt0] 35 | compare (n `mod` d) d === LT 36 | 37 | prop_div : Property 38 | prop_div = property $ do 39 | [n,d] <- forAll $ np [gt0, gt1] 40 | compare (n `div` d) n === LT 41 | 42 | prop_divMod : Property 43 | prop_divMod = property $ do 44 | [n,d] <- forAll $ np [allBits64, gt0] 45 | let x = n `div` d 46 | r = n `mod` d 47 | n === x * d + r 48 | 49 | export 50 | props : Group 51 | props = 52 | MkGroup "Bits64" $ 53 | [ ("prop_ltMax", prop_ltMax) 54 | , ("prop_ltMin", prop_ltMin) 55 | , ("prop_comp", prop_comp) 56 | , ("prop_mod", prop_mod) 57 | , ("prop_div", prop_div) 58 | , ("prop_divMod", prop_divMod) 59 | ] ++ ringProps allBits64 60 | -------------------------------------------------------------------------------- /test/src/Bits8.idr: -------------------------------------------------------------------------------- 1 | module Bits8 2 | 3 | import Data.Prim.Bits8 4 | import Data.SOP 5 | import Hedgehog 6 | import RingLaws 7 | 8 | allBits8 : Gen Bits8 9 | allBits8 = bits8 (linear 0 0xffff) 10 | 11 | gt0 : Gen Bits8 12 | gt0 = bits8 (linear 1 MaxBits8) 13 | 14 | gt1 : Gen Bits8 15 | gt1 = bits8 (linear 2 MaxBits8) 16 | 17 | prop_ltMax : Property 18 | prop_ltMax = property $ do 19 | b8 <- forAll allBits8 20 | (b8 <= MaxBits8) === True 21 | 22 | prop_ltMin : Property 23 | prop_ltMin = property $ do 24 | b8 <- forAll allBits8 25 | (b8 >= MinBits8) === True 26 | 27 | prop_comp : Property 28 | prop_comp = property $ do 29 | [m,n] <- forAll $ np [allBits8, allBits8] 30 | toOrdering (comp m n) === compare m n 31 | 32 | prop_mod : Property 33 | prop_mod = property $ do 34 | [n,d] <- forAll $ np [allBits8, gt0] 35 | compare (n `mod` d) d === LT 36 | 37 | prop_div : Property 38 | prop_div = property $ do 39 | [n,d] <- forAll $ np [gt0, gt1] 40 | compare (n `div` d) n === LT 41 | 42 | prop_divMod : Property 43 | prop_divMod = property $ do 44 | [n,d] <- forAll $ np [allBits8, gt0] 45 | let x = n `div` d 46 | r = n `mod` d 47 | n === x * d + r 48 | 49 | export 50 | props : Group 51 | props = 52 | MkGroup "Bits8" $ 53 | [ ("prop_ltMax", prop_ltMax) 54 | , ("prop_ltMin", prop_ltMin) 55 | , ("prop_comp", prop_comp) 56 | , ("prop_mod", prop_mod) 57 | , ("prop_div", prop_div) 58 | , ("prop_divMod", prop_divMod) 59 | ] ++ ringProps allBits8 60 | -------------------------------------------------------------------------------- /test/src/Char.idr: -------------------------------------------------------------------------------- 1 | module Char 2 | 3 | import Data.Prim.Char 4 | import Data.SOP 5 | import Hedgehog 6 | 7 | allChar : Gen Char 8 | allChar = unicodeAll 9 | 10 | prop_ltMin : Property 11 | prop_ltMin = property $ do 12 | b8 <- forAll allChar 13 | (b8 >= MinChar) === True 14 | 15 | prop_comp : Property 16 | prop_comp = property $ do 17 | [m,n] <- forAll $ np [allChar, allChar] 18 | toOrdering (comp m n) === compare m n 19 | 20 | export 21 | props : Group 22 | props = 23 | MkGroup 24 | "Char" 25 | [ ("prop_ltMin", prop_ltMin) 26 | , ("prop_comp", prop_comp) 27 | ] 28 | -------------------------------------------------------------------------------- /test/src/Int.idr: -------------------------------------------------------------------------------- 1 | module Int 2 | 3 | import Data.Prim.Int 4 | import Data.SOP 5 | import Hedgehog 6 | import RingLaws 7 | 8 | allInt : Gen Int 9 | allInt = int (linear (-0x8000000000000000) 0xffffffffffffffff) 10 | 11 | prop_comp : Property 12 | prop_comp = property $ do 13 | [m,n] <- forAll $ np [allInt, allInt] 14 | toOrdering (comp m n) === compare m n 15 | 16 | export 17 | props : Group 18 | props = 19 | MkGroup "Int16" $ 20 | [ ("prop_comp", prop_comp) 21 | ] ++ ringProps allInt 22 | -------------------------------------------------------------------------------- /test/src/Int16.idr: -------------------------------------------------------------------------------- 1 | module Int16 2 | 3 | import Data.Prim.Int16 4 | import Data.SOP 5 | import Hedgehog 6 | import RingLaws 7 | 8 | allInt16 : Gen Int16 9 | allInt16 = int16 (linear (-0x8000) 0xffff) 10 | 11 | prop_ltMax : Property 12 | prop_ltMax = property $ do 13 | b8 <- forAll allInt16 14 | (b8 <= MaxInt16) === True 15 | 16 | prop_ltMin : Property 17 | prop_ltMin = property $ do 18 | b8 <- forAll allInt16 19 | (b8 >= MinInt16) === True 20 | 21 | prop_comp : Property 22 | prop_comp = property $ do 23 | [m,n] <- forAll $ np [allInt16, allInt16] 24 | toOrdering (comp m n) === compare m n 25 | 26 | export 27 | props : Group 28 | props = 29 | MkGroup "Int16" $ 30 | [ ("prop_ltMax", prop_ltMax) 31 | , ("prop_ltMin", prop_ltMin) 32 | , ("prop_comp", prop_comp) 33 | ] ++ ringProps allInt16 34 | -------------------------------------------------------------------------------- /test/src/Int32.idr: -------------------------------------------------------------------------------- 1 | module Int32 2 | 3 | import Data.Prim.Int32 4 | import Data.SOP 5 | import Hedgehog 6 | import RingLaws 7 | 8 | allInt32 : Gen Int32 9 | allInt32 = int32 (linear (-0x80000000) 0xffffffff) 10 | 11 | prop_ltMax : Property 12 | prop_ltMax = property $ do 13 | b8 <- forAll allInt32 14 | (b8 <= MaxInt32) === True 15 | 16 | prop_ltMin : Property 17 | prop_ltMin = property $ do 18 | b8 <- forAll allInt32 19 | (b8 >= MinInt32) === True 20 | 21 | prop_comp : Property 22 | prop_comp = property $ do 23 | [m,n] <- forAll $ np [allInt32, allInt32] 24 | toOrdering (comp m n) === compare m n 25 | 26 | export 27 | props : Group 28 | props = 29 | MkGroup "Int32" $ 30 | [ ("prop_ltMax", prop_ltMax) 31 | , ("prop_ltMin", prop_ltMin) 32 | , ("prop_comp", prop_comp) 33 | ] ++ ringProps allInt32 34 | -------------------------------------------------------------------------------- /test/src/Int64.idr: -------------------------------------------------------------------------------- 1 | module Int64 2 | 3 | import Data.Prim.Int64 4 | import Data.SOP 5 | import Hedgehog 6 | import RingLaws 7 | 8 | allInt64 : Gen Int64 9 | allInt64 = int64 (linear (-0x8000000000000000) 0xffffffffffffffff) 10 | 11 | prop_ltMax : Property 12 | prop_ltMax = property $ do 13 | b8 <- forAll allInt64 14 | (b8 <= MaxInt64) === True 15 | 16 | prop_ltMin : Property 17 | prop_ltMin = property $ do 18 | b8 <- forAll allInt64 19 | (b8 >= MinInt64) === True 20 | 21 | prop_comp : Property 22 | prop_comp = property $ do 23 | [m,n] <- forAll $ np [allInt64, allInt64] 24 | toOrdering (comp m n) === compare m n 25 | 26 | export 27 | props : Group 28 | props = 29 | MkGroup "Int64" $ 30 | [ ("prop_ltMax", prop_ltMax) 31 | , ("prop_ltMin", prop_ltMin) 32 | , ("prop_comp", prop_comp) 33 | ] ++ ringProps allInt64 34 | -------------------------------------------------------------------------------- /test/src/Int8.idr: -------------------------------------------------------------------------------- 1 | module Int8 2 | 3 | import Data.Prim.Int8 4 | import Data.SOP 5 | import Hedgehog 6 | import RingLaws 7 | 8 | allInt8 : Gen Int8 9 | allInt8 = int8 (linear (-0x80) 0xff) 10 | 11 | prop_ltMax : Property 12 | prop_ltMax = property $ do 13 | b8 <- forAll allInt8 14 | (b8 <= MaxInt8) === True 15 | 16 | prop_ltMin : Property 17 | prop_ltMin = property $ do 18 | b8 <- forAll allInt8 19 | (b8 >= MinInt8) === True 20 | 21 | prop_comp : Property 22 | prop_comp = property $ do 23 | [m,n] <- forAll $ np [allInt8, allInt8] 24 | toOrdering (comp m n) === compare m n 25 | 26 | export 27 | props : Group 28 | props = 29 | MkGroup "Int8" $ 30 | [ ("prop_ltMax", prop_ltMax) 31 | , ("prop_ltMin", prop_ltMin) 32 | , ("prop_comp", prop_comp) 33 | ] ++ ringProps allInt8 34 | -------------------------------------------------------------------------------- /test/src/Integer.idr: -------------------------------------------------------------------------------- 1 | module Integer 2 | 3 | import Data.Prim.Integer 4 | import Data.SOP 5 | import Hedgehog 6 | import RingLaws 7 | 8 | allInteger : Gen Integer 9 | allInteger = integer (linear (-0x8000000000000000) 0xffffffffffffffff) 10 | 11 | prop_comp : Property 12 | prop_comp = property $ do 13 | [m,n] <- forAll $ np [allInteger, allInteger] 14 | toOrdering (comp m n) === compare m n 15 | 16 | export 17 | props : Group 18 | props = 19 | MkGroup "Integer" $ 20 | [ ("prop_comp", prop_comp) 21 | ] ++ ringProps allInteger 22 | -------------------------------------------------------------------------------- /test/src/Main.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Char 4 | import Bits8 5 | import Bits16 6 | import Bits32 7 | import Bits64 8 | import Int8 9 | import Int16 10 | import Int32 11 | import Int64 12 | import Int 13 | import Integer 14 | import String 15 | import Hedgehog 16 | 17 | main : IO () 18 | main = 19 | test 20 | [ Char.props 21 | , Bits8.props 22 | , Bits16.props 23 | , Bits32.props 24 | , Bits64.props 25 | , Int8.props 26 | , Int16.props 27 | , Int32.props 28 | , Int64.props 29 | , Int.props 30 | , Integer.props 31 | , String.props 32 | ] 33 | -------------------------------------------------------------------------------- /test/src/RingLaws.idr: -------------------------------------------------------------------------------- 1 | module RingLaws 2 | 3 | import public Algebra.Ring 4 | import Data.SOP 5 | import Hedgehog 6 | 7 | prop_plusCommutative : Show a => Eq a => Ring a => Gen a -> Property 8 | prop_plusCommutative g = property $ do 9 | [m,n] <- forAll $ np [g,g] 10 | m + n === n + m 11 | 12 | prop_plusAssociative : Show a => Eq a => Ring a => Gen a -> Property 13 | prop_plusAssociative g = property $ do 14 | [k,m,n] <- forAll $ np [g,g,g] 15 | k + (m + n) === k + (n + m) 16 | 17 | prop_plusZeroLeftNeutral : Show a => Eq a => Ring a => Gen a -> Property 18 | prop_plusZeroLeftNeutral g = property $ do 19 | n <- forAll g 20 | 0 + n === n 21 | 22 | prop_plusNegateLeftZero : Show a => Eq a => Ring a => Gen a -> Property 23 | prop_plusNegateLeftZero g = property $ do 24 | n <- forAll g 25 | negate n + n === 0 26 | 27 | prop_multCommutative : Show a => Eq a => Ring a => Gen a -> Property 28 | prop_multCommutative g = property $ do 29 | [m,n] <- forAll $ np [g,g] 30 | m * n === n * m 31 | 32 | prop_multAssociative : Show a => Eq a => Ring a => Gen a -> Property 33 | prop_multAssociative g = property $ do 34 | [k,m,n] <- forAll $ np [g,g,g] 35 | k * (m * n) === k * (n * m) 36 | 37 | prop_multOneLeftNeutral : Show a => Eq a => Ring a => Gen a -> Property 38 | prop_multOneLeftNeutral g = property $ do 39 | n <- forAll g 40 | 1 * n === n 41 | 42 | prop_distributive : Show a => Eq a => Ring a => Gen a -> Property 43 | prop_distributive g = property $ do 44 | [k,m,n] <- forAll $ np [g,g,g] 45 | k * (m + n) === (k * m) + (k * n) 46 | 47 | prop_minusIsPlusNegate : Show a => Eq a => Ring a => Gen a -> Property 48 | prop_minusIsPlusNegate g = property $ do 49 | [m,n] <- forAll $ np [g,g] 50 | m - n === m + negate n 51 | 52 | export 53 | ringProps : 54 | {auto _ : Show a} 55 | -> {auto _ : Eq a} 56 | -> {auto _ : Ring a} 57 | -> Gen a 58 | -> List (PropertyName,Property) 59 | ringProps g = 60 | [ ("prop_plusCommutative", prop_plusCommutative g) 61 | , ("prop_plusAssociative", prop_plusAssociative g) 62 | , ("prop_plusZeroLeftNeutral", prop_plusZeroLeftNeutral g) 63 | , ("prop_plusNegateLeftZero", prop_plusNegateLeftZero g) 64 | , ("prop_multCommutative", prop_multCommutative g) 65 | , ("prop_multAssociative", prop_multAssociative g) 66 | , ("prop_multOneLeftNeutral", prop_multOneLeftNeutral g) 67 | , ("prop_distributive", prop_distributive g) 68 | , ("prop_minusIsPlusNegate", prop_minusIsPlusNegate g) 69 | ] 70 | -------------------------------------------------------------------------------- /test/src/String.idr: -------------------------------------------------------------------------------- 1 | module String 2 | 3 | import Data.Prim.String 4 | import Data.SOP 5 | import Hedgehog 6 | 7 | allString : Gen String 8 | allString = string (linear 0 30) unicodeAll 9 | 10 | prop_ltMin : Property 11 | prop_ltMin = property $ do 12 | b8 <- forAll allString 13 | (b8 >= MinString) === True 14 | 15 | prop_comp : Property 16 | prop_comp = property $ do 17 | [m,n] <- forAll $ np [allString, allString] 18 | toOrdering (comp m n) === compare m n 19 | 20 | export 21 | props : Group 22 | props = 23 | MkGroup 24 | "String" 25 | [ ("prop_ltMin", prop_ltMin) 26 | , ("prop_comp", prop_comp) 27 | ] 28 | 29 | -------------------------------------------------------------------------------- /test/test.ipkg: -------------------------------------------------------------------------------- 1 | package prim-test 2 | 3 | authors = "stefan-hoeck" 4 | version = 0.0.1 5 | readme = "README.md" 6 | license = "BSD-3 Clause" 7 | 8 | sourcedir = "src" 9 | depends = hedgehog 10 | , prim 11 | 12 | main = Main 13 | executable = "runTest" 14 | --------------------------------------------------------------------------------