├── .gitattributes ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENCE.md ├── README.md ├── docs ├── _config.yml └── linear-problem-syntax.md ├── linear-programming-test.asd ├── linear-programming.asd ├── script └── generate-API-docs.ros ├── src ├── all.lisp ├── conditions.lisp ├── expressions.lisp ├── external-formats.lisp ├── problem.lisp ├── simplex.lisp ├── solver.lisp ├── system-info.lisp └── utils.lisp └── t ├── all.lisp ├── base.lisp ├── data ├── advanced-problem.mps ├── simple-problem-crlf.mps └── simple-problem.mps ├── expressions.lisp ├── external-formats.lisp ├── integration.lisp ├── problem.lisp ├── simplex.lisp ├── solver.lisp ├── system-info.lisp ├── test-utils.lisp └── utils.lisp /.gitattributes: -------------------------------------------------------------------------------- 1 | 2 | # ensure line endings are preserved for the mps test files 3 | t/data/simple-problem.mps text eol=lf 4 | t/data/simple-problem-crlf.mps text eol=crlf 5 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | ### Based on example in CI-Utils ### 2 | name: CI 3 | 4 | # Github Actions allows for running jobs on a wide variety of events 5 | on: 6 | push: # Commits pushed to Github 7 | pull_request: # Pull request is update 8 | workflow_dispatch: # Manually dispatched from Github's UI 9 | schedule: # Run at the first day of each month 10 | # This can detect external factors breaking the tests (such as changes to libraries or CL implementations) 11 | # Syntax follows that of cron 12 | - cron: '0 0 1 * *' 13 | 14 | jobs: 15 | test: 16 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 17 | runs-on: ${{ matrix.os }} 18 | strategy: 19 | matrix: 20 | lisp: [sbcl-bin] 21 | os: [windows-latest, ubuntu-latest, macOS-latest] 22 | include: 23 | - lisp: abcl-bin 24 | os: ubuntu-latest 25 | - lisp: allegro 26 | os: ubuntu-latest 27 | # Hanging on GH Actions 28 | #- lisp: ccl-bin 29 | # os: ubuntu-latest 30 | - lisp: ecl 31 | os: ubuntu-latest 32 | # Default version of cmu is broken in roswell 33 | #- lisp: cmu-bin 34 | # os: ubuntu-latest 35 | fail-fast: false 36 | env: 37 | LISP: ${{ matrix.lisp }} 38 | 39 | steps: 40 | # This action checks out our code in the working directory 41 | - uses: actions/checkout@v3 42 | 43 | # Cache roswell - Based on code from 40ants 44 | # broken on Windows due to sudo and paths 45 | - name: Cache setup 46 | if: runner.os != 'Windows' && runner.os != 'macOS' 47 | id: cache-setup 48 | run: | 49 | sudo mkdir -p /usr/local/etc/roswell 50 | sudo chown "${USER}" /usr/local/etc/roswell 51 | # Here the ros binary will be restored: 52 | sudo chown "${USER}" /usr/local/bin 53 | echo "value=$(date -u "+%Y-%m")" >> $GITHUB_OUTPUT 54 | - name: Cache Roswell Setup 55 | if: runner.os != 'Windows' && runner.os != 'macOS' 56 | id: cache 57 | uses: actions/cache@v3 58 | env: 59 | cache-name: cache-roswell 60 | with: 61 | path: | 62 | /usr/local/bin/ros 63 | ~/.cache/common-lisp/ 64 | ~/.roswell 65 | /usr/local/etc/roswell 66 | .qlot 67 | key: "roswell-${{ env.LISP }}-${{ runner.os }}-${{ steps.cache-setup.outputs.value }}-${{ hashFiles('qlfile.lock') }}" 68 | - name: Load Roswell from Cache 69 | run: | 70 | echo $HOME/.roswell/bin >> $GITHUB_PATH 71 | echo .qlot/bin >> $GITHUB_PATH 72 | if: runner.os != 'Windows' && runner.os != 'macOS' && steps.cache.outputs.cache-hit == 'true' 73 | # Install roswell with setup-lisp 74 | - uses: 40ants/setup-lisp@v2 75 | if: runner.os == 'Windows' || runner.os == 'macOS' || steps.cache.outputs.cache-hit != 'true' 76 | 77 | - name: Configure Coverage 78 | # Only gather code coverage on Linux-SBCL 79 | if: matrix.os == 'ubuntu-latest' && matrix.lisp == 'sbcl-bin' 80 | run: | 81 | echo "COVERALLS=true" >> $GITHUB_ENV 82 | echo "COVERALLS_REPO_TOKEN=${{ secrets.COVERALLS_REPO_TOKEN }}" >> $GITHUB_ENV 83 | 84 | 85 | # These steps run our tests 86 | # Windows needs to be run with the msys2 shell due to how roswell is installed 87 | - name: Run tests (Non-Windows) 88 | if: runner.os != 'Windows' 89 | shell: bash 90 | run: | 91 | # Install the roswell script for the test library 92 | ros install neil-lindquist/ci-utils # for run-fiveam 93 | 94 | # Run the tests 95 | run-fiveam -e t -l linear-programming-test linear-programming-test:linear-programming 96 | - name: Run tests (Windows) 97 | if: runner.os == 'Windows' 98 | shell: msys2 {0} 99 | run: | 100 | # Install the roswell script for the test library 101 | ros install neil-lindquist/ci-utils # for run-fiveam 102 | 103 | # Run the tests 104 | run-fiveam -e t -l linear-programming-test linear-programming-test:linear-programming 105 | 106 | # Update website 107 | - name: Build Docs 108 | if: (github.event_name == 'push' || github.event_name == 'workflow_dispatch') && github.ref == 'refs/heads/master' && matrix.os == 'ubuntu-latest' && matrix.lisp == 'sbcl-bin' 109 | run: | 110 | ros install neil-lindquist/doc-site-generator 111 | copy-site-base docs docs-bin 112 | echo 'The documentation page for the linear-programming Common Lisp library."' | make-gh-page README.md docs-bin/index.md 113 | script/generate-API-docs.ros 114 | 115 | - name: Deploy Docs 116 | if: (github.event_name == 'push' || github.event_name == 'workflow_dispatch') && github.ref == 'refs/heads/master' && matrix.os == 'ubuntu-latest' && matrix.lisp == 'sbcl-bin' 117 | uses: crazy-max/ghaction-github-pages@v3 118 | with: 119 | target_branch: gh-pages 120 | build_dir: docs-bin 121 | env: 122 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 123 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | # SLIMA's temp file 3 | repl.lisp-repl 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 2.3.0 2 | * Depreciate < and > in favor of <= and >= due to misleading semantics (#10) 3 | * Fix bug with variable bounds (#11) 4 | * Add support to MPS reader for CRLF line endings 5 | * Fix bug in sexp writer with named objective variables 6 | 7 | ## 2.2.1 8 | * Fix bug with equality constraints in simplex backend (#7) 9 | * Fix handling of artificial variables remaining in the basis for 2-phase simplex 10 | * Fix bounds error in simplex backend (#8) 11 | 12 | ## 2.2.0 13 | * Add support for writing problems in standard format 14 | * Change the default objective variable to be uppercase 15 | * Fix an error when a constraint does not have an explicit constant 16 | * Fix an issue with a specific `parsing-error` being throw incorrectly 17 | * Fix bugs with variables not bounded between 0 and infinity 18 | 19 | ## 2.1.0 20 | * Add configuration for tolerance of floating point round off errors 21 | * Fix some bugs with the handling of floating point round off error tolerances 22 | 23 | ## 2.0.1 24 | * Fix errors when using floats 25 | * Fix infeasible problems not correctly raising errors solver 26 | * Improve performance of parsing and solving problems 27 | 28 | ## 2.0.0 29 | * Modify the use of the term "shadow price" to the correct term "reduced cost" 30 | * Add an interface for replacing the solver backend 31 | * Add file input/output for problems 32 | * Sexp format (as per `make-linear-problem`) 33 | * MPS format 34 | * Add support for specifying linear expressions as alists and plists 35 | * Add support for specifying bounds for specific variables 36 | * Add support in default backend for signed variables 37 | * Fix the documentation generator script being installed by Roswell 38 | * Improve documentation 39 | 40 | ## v1.0.1 41 | * Improve bounding of brand-and-bound integer programming 42 | * Improve tableau readability by switching rows & columns 43 | * Fix typo that prevented inlining `copy-tableau` 44 | -------------------------------------------------------------------------------- /LICENCE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019-2022 Neil Lindquist 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Common Lisp Linear Programming 2 | [![Github Actions Status](https://img.shields.io/github/actions/workflow/status/neil-lindquist/linear-programming/ci.yml?logo=github)](https://github.com/neil-lindquist/linear-programming/actions/workflows/ci.yml) 3 | [![Coverage Status](https://coveralls.io/repos/github/neil-lindquist/linear-programming/badge.svg?branch=master)](https://coveralls.io/github/neil-lindquist/linear-programming?branch=master) 4 | 5 | ![MIT License](https://img.shields.io/github/license/neil-lindquist/linear-programming.svg?color=informational) 6 | [![GitHub release](https://img.shields.io/github/release/neil-lindquist/linear-programming.svg)](https://github.com/neil-lindquist/linear-programming/releases) 7 | [![Current documentation](https://img.shields.io/badge/docs-current-informational.svg)](https://neil-lindquist.github.io/linear-programming/) 8 | 9 | 10 | 11 | This is a Common Lisp library for solving linear programming problems. 12 | It's designed to provide a high-level and ergonomic API for specifying linear programming problems as lisp expressions. 13 | 14 | The core library is implemented purely in Common Lisp with only a few community-standard libraries as dependencies (ASDF, Alexandria, Iterate). 15 | However, the solver is designed to support alternative backends without any change to the user's code. 16 | Currently, there is a [backend for the GNU Linear Programming Kit (GLPK)](https://github.com/neil-lindquist/linear-programming-glpk). 17 | 18 | ## Installation 19 | The linear-programming library is avalible in both the main Quicklisp distribution and Ultralisp, so it can loaded with with `(ql:quickload :linear-programming)`. 20 | You can check that it works by running `(asdf:test-system :linear-programming)`. 21 | 22 | If you are not using Quicklisp, place this repository, Alexandria, and Iterate somewhere where ASDF can find them. 23 | Then, it can be loaded with `(asdf:load-system :linear-programming)` and tested as above. 24 | 25 | 26 | ## Usage 27 | See [neil-lindquist.github.io/linear-programming/](https://neil-lindquist.github.io/linear-programming/) for further documentation. 28 | 29 | Consider the following linear programming problem. 30 | > maximize x + 4y + 3z 31 | > such that 32 | > * 2x + y ≤ 8 33 | > * y + z ≤ 7 34 | > * x, y, z ≥ 0 35 | 36 | First, the problem needs to be specified. 37 | Problems are specified with a simple DSL, as described in the [syntax reference](https://neil-lindquist.github.io/linear-programming/linear-problem-syntax). 38 | ```common-lisp 39 | (use-package :linear-programming) 40 | 41 | (defvar problem (parse-linear-problem '(max (= w (+ x (* 4 y) (* 3 z)))) 42 | '((<= (+ (* 2 x) y) 8) 43 | (<= (+ y z) 7)))) 44 | ``` 45 | Once the problem is created, it can be solved with the simplex method. 46 | ```common-lisp 47 | (defvar solution (solve-problem problem)) 48 | ``` 49 | Finally, the optimal tableau can be inspected to get the resulting objective function, decision variables, and reduced-costs (i.e. the shadow prices for the variable's lower bounds). 50 | ```common-lisp 51 | (format t "Objective value solution: ~A~%" (solution-variable solution 'w)) 52 | (format t "x = ~A (reduced cost: ~A)~%" (solution-variable solution 'x) (solution-reduced-cost solution 'x)) 53 | (format t "y = ~A (reduced cost: ~A)~%" (solution-variable solution 'y) (solution-reduced-cost solution 'y)) 54 | (format t "z = ~A (reduced cost: ~A)~%" (solution-variable solution 'z) (solution-reduced-cost solution 'z)) 55 | 56 | ;; ==> 57 | ;; Objective value solution: 57/2 58 | ;; x = 1/2 (reduced cost: 0) 59 | ;; y = 7 (reduced cost: 0) 60 | ;; z = 0 (reduced cost: 1/2) 61 | ``` 62 | Alternatively, the `with-solution-variables` and `with-solved-problem` macros simplify some steps and binds the solution variables in their bodies. 63 | 64 | ```common-lisp 65 | (with-solution-variables (w x y z) solution 66 | (format t "Objective value solution: ~A~%" w) 67 | (format t "x = ~A (reduced cost: ~A)~%" x (reduced-cost x)) 68 | (format t "y = ~A (reduced cost: ~A)~%" y (reduced-cost y)) 69 | (format t "z = ~A (reduced cost: ~A)~%" z (reduced-cost z))) 70 | 71 | ;; ==> 72 | ;; Objective value solution: 57/2 73 | ;; x = 1/2 (reduced cost: 0) 74 | ;; y = 7 (reduced cost: 0) 75 | ;; z = 0 (reduced cost: 1/2) 76 | 77 | 78 | (with-solved-problem ((max (= w (+ x (* 4 y) (* 3 z)))) 79 | (<= (+ (* 2 x) y) 8) 80 | (<= (+ y z) 7)) 81 | (format t "Objective value solution: ~A~%" w) 82 | (format t "x = ~A (reduced cost: ~A)~%" x (reduced-cost x)) 83 | (format t "y = ~A (reduced cost: ~A)~%" y (reduced-cost y)) 84 | (format t "z = ~A (reduced cost: ~A)~%" z (reduced-cost z))) 85 | 86 | ;; ==> 87 | ;; Objective value solution: 57/2 88 | ;; x = 1/2 (reduced cost: 0) 89 | ;; y = 7 (reduced cost: 0) 90 | ;; z = 0 (reduced cost: 1/2) 91 | ``` 92 | -------------------------------------------------------------------------------- /docs/_config.yml: -------------------------------------------------------------------------------- 1 | # --- General options --- # 2 | 3 | baseurl: "/linear-programming" 4 | 5 | # Name of website 6 | title: linear-programming 7 | 8 | # Short description of your site 9 | description: Documentation for the linear-programming Common Lisp Library 10 | 11 | # --- Navigation bar options --- # 12 | 13 | # List of links in the navigation bar 14 | navbar-links: 15 | API Documentation: "API" 16 | DSL Syntax: "linear-problem-syntax" 17 | 18 | # Image to show in the navigation bar - image must be a square (width = height) 19 | # Remove this parameter if you don't want an image in the navbar 20 | # avatar: "/img/avatar.png" 21 | 22 | # If you want to have an image logo in the top-left corner instead of the title text, 23 | # then specify the following parameter 24 | # title-img: /path/to/image 25 | 26 | # --- Footer options --- # 27 | 28 | # Select your active Social Network Links. 29 | # Uncomment the links you want to show in the footer and add your information to each link. 30 | # You can reorder the items to define the link order. 31 | # If you want to add a new link that isn't here, you'll need to also edit the file _data/SocialNetworks.yml 32 | social-network-links: 33 | email: "neillindquist5@gmail.com" 34 | public-key: "/neil-lindquist-public-key.pgp" 35 | github: neil-lindquist/linear-programming 36 | # linkedin: neil-lindquist 37 | # orcid: 0000-0001-9404-3121 38 | # rss: true 39 | # facebook: daattali 40 | # twitter: daattali 41 | # reddit: yourname 42 | # xing: yourname 43 | # stackoverflow: "3943160/daattali" 44 | # snapchat: deanat78 45 | # instagram: deanat78 46 | # youtube: user/deanat78 47 | # spotify: yourname 48 | # telephone: +14159998888 49 | # steam: deanat78 50 | # twitch: yourname 51 | # yelp: yourname 52 | 53 | 54 | # Exclude these files from production site 55 | exclude: 56 | 57 | # Default YAML values (more information on Jekyll's site) 58 | defaults: 59 | - 60 | scope: 61 | path: "" 62 | type: "posts" 63 | values: 64 | layout: "post" 65 | comments: false # add comments to all blog posts 66 | social-share: false # add social media sharing buttons to all blog posts 67 | - 68 | scope: 69 | path: "" # all files 70 | values: 71 | layout: "page" 72 | show-avatar: false 73 | -------------------------------------------------------------------------------- /docs/linear-problem-syntax.md: -------------------------------------------------------------------------------- 1 | --- 2 | layout: page 3 | show-avatar: false 4 | title: Linear Problem DSL 5 | meta-description: The specification of the Linear Programming Problem DSL 6 | --- 7 | 8 | To effectively describe linear programming problems, `parse-linear-problem` uses a basic DSL. 9 | A linear programming problem is described with an *optimization-function* form, followed by the *constraint* forms, both of which are described by the following grammar. 10 | 11 | By default all variables are assumed to be bounded by zero and positive infinity, but the bounds can be adjusted by *simple-bounds* constraints. 12 | Each entry in a *simple-bounds* constraint is a list of three values: the lower bound, the variable name, and the upper bound; infinity can be represented by either `nil` or by omitting the entry. 13 | However, currently the default solver does not supported negative lower bounds, so such variables must be represented by a difference of the positive and negative components, eg `var` would be replaced with `(- var+ var-)`. 14 | 15 | + *objective-function* → (min\|max *linear-expression*) \| (= *objective-variable* (min\|max *linear-expression*)) \| (min\|max (= *objective-variable* *linear-expression*)) 16 | + *constraint* → *inequality-constraint* \| *integer-constraint* \| *simple-bounds* 17 | + *inequality-constraint* → (<=\|<\|>=\|>\|= *linear-expression*\*) 18 | + *integer-constraint* → (integer *var*\*) \| (binary *var*\*) 19 | + *simple-bounds* → (bounds (*number*? *var* *number*?)\*) 20 | + *linear-expression* → *var* \| *number* \| (\+\|\-\|\*\|/ *linear-expression*\*) \| (:alist (*var* . *number*)\*) \| (:plist {*var* *number*}\*) 21 | 22 | 23 | ### Example 24 | Consider the following linear programming problem. 25 | > maximize w = x + 4y + 3z 26 | > such that 27 | > * 2x + y ≤ 8 28 | > * y + z ≤ 7 29 | > * x, y, z ≥ 0 30 | 31 | This problem can be represented as follows. 32 | ```common-lisp 33 | (parse-linear-problem 34 | '(max (= w (+ x (* 4 y) (* 3 z)))) 35 | '((<= (+ (* 2 x) y) 8) 36 | (<= (+ y z) 7))) 37 | ``` 38 | 39 | 40 | ### Simple Constraints 41 | After a linear problem is parsed, the constraints are stored using a simplified version of the DSL. 42 | The (in)equality constraints are represented by a `<=`, `>=`, or `=` expression with two arguments. 43 | The first argument is an alist mapping the variables with their coefficients for the linear expression. 44 | The second argument is a non-negative constant. 45 | -------------------------------------------------------------------------------- /linear-programming-test.asd: -------------------------------------------------------------------------------- 1 | 2 | (defsystem "linear-programming-test" 3 | :description "The tests for the linear-programming package" 4 | :author "Neil Lindquist " 5 | :licence "MIT" 6 | :class :package-inferred-system 7 | :pathname "t" 8 | :depends-on ((:version "asdf" "3.1.6") 9 | "linear-programming-test/all") 10 | :perform (test-op (o c) (symbol-call '#:fiveam '#:run! (intern "LINEAR-PROGRAMMING" '#:linear-programming-test)))) 11 | -------------------------------------------------------------------------------- /linear-programming.asd: -------------------------------------------------------------------------------- 1 | 2 | (defsystem "linear-programming" 3 | :description "A library for solving linear programming problems" 4 | :version "2.3.0" 5 | :author "Neil Lindquist " 6 | :licence "MIT" 7 | :homepage "https://neil-lindquist.github.io/linear-programming/" 8 | :bug-tracker "https://github.com/neil-lindquist/linear-programming/issues" 9 | :mailto "NeilLindquist5@gmail.com" 10 | :source-control (:git "https://github.com/neil-lindquist/linear-programming.git") 11 | 12 | :class :package-inferred-system 13 | :pathname "src" 14 | :depends-on ((:version "asdf" "3.1.6") 15 | "linear-programming/all") 16 | :in-order-to ((test-op (test-op "linear-programming-test")))) 17 | -------------------------------------------------------------------------------- /script/generate-API-docs.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | 7 | (ql:quickload '(:linear-programming :doc-site-generator)) 8 | (use-package :doc-gen) 9 | 10 | (defun main (&rest argv) 11 | (declare (ignore argv)) 12 | 13 | (with-open-file (stream "docs-bin/API.md" 14 | :direction :output 15 | :external-format :utf-8) 16 | 17 | (format stream "---~%~ 18 | layout: page~%~ 19 | title: API Documentation~%~ 20 | meta-description: The API Documentation for the ~ 21 | linear-programming Common Lisp library.~%~ 22 | ---~%~%~%") 23 | 24 | 25 | (print-documentation 'package 'linear-programming stream) 26 | 27 | (print-package-documentation 'linear-programming/problem stream) 28 | (print-package-documentation 'linear-programming/solver stream) 29 | (print-package-documentation 'linear-programming/external-formats stream) 30 | (print-package-documentation 'linear-programming/conditions stream) 31 | (print-package-documentation 'linear-programming/simplex stream) 32 | (print-package-documentation 'linear-programming/expressions stream))) 33 | -------------------------------------------------------------------------------- /src/all.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming/all 3 | (:nicknames :linear-programming) 4 | (:use-reexport :linear-programming/problem 5 | :linear-programming/solver 6 | :linear-programming/conditions 7 | :linear-programming/external-formats) 8 | (:import-from :linear-programming/simplex 9 | #:simplex-solver) 10 | (:export #:simplex-solver) 11 | (:documentation "The overall package for the linear programming library. It contains only the 12 | reexported symbols of `linear-programming/problem`, `linear-programming/solver`, 13 | `linear-programming/conditioner`, and `linear-programming/external-formats`, 14 | plus `simplex-solver` from `linear-programming/simplex`.")) 15 | -------------------------------------------------------------------------------- /src/conditions.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :linear-programming/conditions 2 | (:use :cl) 3 | (:export #:parsing-error 4 | #:invalid-bounds-error 5 | #:solver-error 6 | #:unsupported-constraint-error 7 | #:infeasible-problem-error 8 | #:infeasible-integer-constraints-error 9 | #:unbounded-problem-error 10 | #:nonlinear-error) 11 | (:documentation "Contains the various conditions used by this library.")) 12 | (in-package :linear-programming/conditions) 13 | 14 | 15 | (define-condition parsing-error (error) 16 | ((description :reader description 17 | :initarg :description)) 18 | (:report (lambda (err stream) (format stream (description err)))) 19 | (:documentation "Indicates an error occured while parsing a linear problem. Includes a textual 20 | description of the issue.")) 21 | 22 | (define-condition nonlinear-error (parsing-error) 23 | ((expression :reader nonlinear-expression 24 | :initarg :expression 25 | :documentation "Contains the problematic expression")) 26 | (:report (lambda (err stream) 27 | (format stream "~S is not a linear expression" (nonlinear-expression err)))) 28 | (:documentation "Indicates a form was not a linear expression. This includes the use of 29 | nonlinear functions and taking the product of multiple variables")) 30 | 31 | (define-condition invalid-bounds-error (parsing-error) 32 | ((var :reader var 33 | :initarg :var) 34 | (ub :reader ub 35 | :initarg :ub) 36 | (lb :reader lb 37 | :initarg :lb)) 38 | (:report (lambda (err stream) 39 | (format stream "The bounds for variable ~A are invalid. Upper bound=~A, Lower bound=~A" 40 | (var err) (ub err) (lb err)))) 41 | (:documentation "Indicates a problem with a variable's bounds.")) 42 | 43 | (define-condition solver-error (error) 44 | () 45 | (:documentation "The base class for errors that occur with the solving algorithm.")) 46 | 47 | (define-condition unbounded-problem-error (solver-error) 48 | () 49 | (:report (lambda (err stream) 50 | (declare (ignore err)) 51 | (format stream "Problem is unbounded"))) 52 | (:documentation "Indicates the feasible region is unbounded such that the optimal objective value 53 | is infinite.")) 54 | 55 | (define-condition infeasible-problem-error (solver-error) 56 | () 57 | (:report (lambda (err stream) 58 | (declare (ignore err)) 59 | (format stream "Problem has no feasible region"))) 60 | (:documentation "Indicates the there is no feasible region.")) 61 | 62 | (define-condition infeasible-integer-constraints-error (infeasible-problem-error) 63 | () 64 | (:report (lambda (err stream) 65 | (declare (ignore err)) 66 | (format stream "Integer constrains could not be satisfied"))) 67 | (:documentation "Indicates that there is no feasible region due to the integer constraints.")) 68 | 69 | (define-condition unsupported-constraint-error (solver-error) 70 | ((constraint :reader constraint 71 | :initarg :constraint) 72 | (solver-name :reader solver-name 73 | :initarg :solver-name)) 74 | (:report (lambda (err stream) 75 | (format stream "~S cannot be handled by the ~A solver" 76 | (constraint err) (solver-name err)))) 77 | (:documentation "Indicates there are unsupported constraints or properties in the given problem.")) 78 | -------------------------------------------------------------------------------- /src/expressions.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming/expressions 3 | (:use :cl 4 | :iterate 5 | :linear-programming/conditions) 6 | (:import-from :alexandria 7 | #:if-let 8 | #:plist-alist) 9 | (:export #:scale-linear-expression 10 | #:sum-linear-expressions 11 | #:parse-linear-expression 12 | #:format-linear-expression 13 | #:+constant+) 14 | (:documentation "Contains functions for processing linear expressions.")) 15 | 16 | (in-package :linear-programming/expressions) 17 | 18 | (declaim (inline linear-constant-p)) 19 | (defun linear-constant-p (expr) 20 | "A predicate for whether a linear expression is constant." 21 | (and (= 1 (length expr)) 22 | (eq (car (first expr)) '+constant+))) 23 | 24 | (declaim (inline sum-linear-expressions)) 25 | (defun sum-linear-expressions (&rest exprs) 26 | "Takes linear expressions and reduces it into a single expression." 27 | (let ((sum (copy-alist (first exprs)))) 28 | (iter (for expr in (rest exprs)) 29 | (iter (for term in expr) 30 | (if-let (pair (assoc (car term) sum)) 31 | (incf (cdr pair) (cdr term)) 32 | (push (cons (car term) (cdr term)) sum)))) 33 | sum)) 34 | 35 | 36 | (declaim (inline scale-linear-expression)) 37 | (defun scale-linear-expression (expr scalar) 38 | "Multiplies the linear expression by the given scalar." 39 | (mapcar #'(lambda (x) (cons (car x) (* scalar (cdr x)))) 40 | expr)) 41 | 42 | 43 | (defun parse-linear-expression (expr) 44 | "Parses the expression into a alist mapping variables to coefficients. Any 45 | constant values are mapped to `+constant+`." 46 | (cond 47 | ; atoms 48 | ((symbolp expr) 49 | (list (cons expr 1))) 50 | ((numberp expr) 51 | (list (cons '+constant+ expr))) 52 | 53 | ; lists 54 | ((listp expr) 55 | (case (first expr) 56 | ; low-level specifiers 57 | ((:alist) 58 | (rest expr)) 59 | ((:plist) 60 | (plist-alist (rest expr))) 61 | 62 | ; arithmetic 63 | ((+) 64 | (apply 'sum-linear-expressions (mapcar 'parse-linear-expression (rest expr)))) 65 | 66 | ((*) 67 | (let ((factors (mapcar #'parse-linear-expression (rest expr))) 68 | (variable nil) 69 | (constant 1)) 70 | (dolist (fact factors) 71 | (cond 72 | ((linear-constant-p fact) 73 | (setf constant (* constant (cdar fact)))) 74 | (variable 75 | (error 'nonlinear-error :expression expr)) 76 | (t 77 | (setf variable fact)))) 78 | (if variable 79 | (scale-linear-expression variable constant) 80 | `((+constant+ . ,constant))))) 81 | 82 | ((-) 83 | (if (= 2 (length expr)) 84 | (scale-linear-expression (parse-linear-expression (second expr)) 85 | -1) 86 | (sum-linear-expressions (parse-linear-expression (second expr)) 87 | (scale-linear-expression 88 | (parse-linear-expression (list* '+ (nthcdr 2 expr))) 89 | -1)))) 90 | 91 | ((/) 92 | (if (= 2 (length expr)) 93 | (let ((val (parse-linear-expression (second expr)))) 94 | (unless (linear-constant-p val) 95 | (error 'nonlinear-error :expression expr)) 96 | `((+constant+ . ,(/ (cdar val))))) 97 | (let ((divisors (mapcar #'parse-linear-expression (nthcdr 2 expr))) 98 | (dividend (parse-linear-expression (second expr)))) 99 | (unless (every #'linear-constant-p divisors) 100 | (error 'nonlinear-error :expression expr)) 101 | (scale-linear-expression dividend (/ (reduce #'* divisors :key #'cdar)))))) 102 | 103 | ; Unknown functions 104 | (t (error 'nonlinear-error :expression expr)))) 105 | 106 | ; Unknown objecects 107 | (t (error 'parsing-error 108 | :description (format nil "~S is not a symbol, number, or an expression" expr))))) 109 | 110 | 111 | (defun format-linear-expression (alist) 112 | "Formats a linear expression as a sexp." 113 | (cons '+ 114 | (mapcar (lambda (pair) 115 | (if (eq (car pair) '+constant+) 116 | (cdr pair) 117 | (list '* (cdr pair) (car pair)))) 118 | alist))) 119 | -------------------------------------------------------------------------------- /src/external-formats.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming/external-formats 3 | (:use :cl 4 | :iterate 5 | :linear-programming/problem) 6 | (:import-from :alexandria 7 | #:curry 8 | #:if-let 9 | #:ensure-gethash) 10 | (:import-from :linear-programming/expressions 11 | #:scale-linear-expression 12 | #:format-linear-expression) 13 | (:import-from :linear-programming/utils 14 | #:validate-bounds 15 | #:lb-max 16 | #:ub-min) 17 | (:export #:read-sexp 18 | #:write-sexp 19 | #:read-mps 20 | #:write-standard-format) 21 | (:documentation "Handles reading and writing problems to external formats.")) 22 | 23 | (in-package :linear-programming/external-formats) 24 | 25 | ;;; utils 26 | (defun read-until (stream test &optional (preview-test (constantly t))) 27 | "Reads the given stream until the condition is true. `test` can either be a 28 | predicate that takes one argument, or a character to be tested using `char=`." 29 | (let ((test (if (characterp test) (curry 'char= test) test)) 30 | (preview-test (if (characterp test) (curry 'char= preview-test) preview-test))) 31 | (with-output-to-string (result) 32 | (iter (for c = (peek-char nil stream nil nil)) 33 | (while (and c (not (and (funcall test c) 34 | (funcall preview-test (peek-char nil stream nil nil)))))) 35 | (write-char (read-char stream) result))))) 36 | 37 | (defun newlinep (c) 38 | "Predicate if the given character is a newline or return" 39 | (or (char= c #\newline) 40 | (char= c #\return))) 41 | 42 | ;;; reader and writer functions 43 | 44 | (defun read-sexp (stream &key allow-read-eval package) 45 | "Loads a problem stored in sexp format. This is a single sexp with the first 46 | element being the objective function and the rest of the elements being the 47 | constraints. Note that normally `*read-eval*` is bound to `nil`, but can be 48 | enabled with `allow-read-eval`; however, this should only be done when 49 | parsing trusted data." 50 | (let* ((problem (with-standard-io-syntax 51 | (let ((*read-eval* allow-read-eval) 52 | (*package* (or (find-package package) *package*))) 53 | (read stream))))) 54 | (parse-linear-problem (first problem) (rest problem)))) 55 | 56 | (defun write-sexp (stream problem &key package) 57 | "Writes the problem as a sexp. The first element is the objective function and 58 | the rest of the elements are the constraints." 59 | (let* ((objective-func (let ((objective `(,(problem-type problem) 60 | ,(format-linear-expression (problem-objective-func problem))))) 61 | (if (symbol-package (problem-objective-var problem)) ; is non uninterned 62 | `(= ,(problem-objective-var problem) ,objective) 63 | objective))) 64 | (eq-constraints (iter (for constraint in (problem-constraints problem)) 65 | (collect (list (first constraint) 66 | (format-linear-expression (second constraint)) 67 | (third constraint))))) 68 | (int-vars (problem-integer-vars problem)) 69 | (bounds (problem-var-bounds problem)) 70 | (constraints (append (when int-vars (list (list* 'integer int-vars))) 71 | (when bounds (list (list* 'bounds bounds))) 72 | eq-constraints)) 73 | (problem-sexp (cons objective-func constraints))) 74 | (with-standard-io-syntax 75 | (let ((*package* (or (find-package package) *package*))) 76 | (format stream "~S~%" problem-sexp))))) 77 | 78 | (defun read-mps (stream problem-type &key package (read-case (readtable-case *readtable*)) (trim-names-p t) (number-type 'rational) rhs-id) 79 | ;; Currently using fixed width format 80 | ;; http://lpsolve.sourceforge.net/5.1/mps-format.htm 81 | ;; http://cgm.cs.mcgill.ca/~avis/courses/567/cplex/reffileformatscplex.pdf 82 | ;; TODO consider adding support for free-format MPS files 83 | "Reads a problem in MPS format from the given stream. Note that a line starting 84 | with `ENDATA` ends the problem, so MPS files can be embedded in streams of other 85 | data. Only the fixed width version of the format is supported, but both the 86 | `OBJSENCE` and `OBJNAME` headers are supported and the `BV`, `LI`, and `UI` 87 | boundaries are supported." 88 | (let ((package (or (find-package package) *package*)) 89 | (current-header nil) 90 | (problem-name nil) 91 | (rows (make-hash-table :test 'equal)) ; table mapping row ID's to (list* row-type rhs range-type linexp) 92 | (objective nil) ; name 93 | (var-info (make-hash-table :test 'eq))) 94 | (labels ((substring (str &optional (start 0) (end (length str))) 95 | "As `(subseq str start (min (length str) end))``" 96 | (subseq str (min (length str) start) (min (length str) end))) 97 | (field (n line &optional (field-type :raw)) 98 | ;; Gets the `n`th field of the line. Note that `n` is 1-based, with `n=0` 99 | ;; representing the entire line, excluding the first character. 100 | (let ((raw (substring line 101 | (aref #(0 1 4 14 24 39 49) n) 102 | (aref #(61 3 12 22 36 47 61) n)))) 103 | (ecase field-type 104 | ;; trim and case-ify names then turn them into symbols in package 105 | (:symbol 106 | (let ((raw (if trim-names-p (string-trim " " raw) raw))) 107 | (intern 108 | (ecase read-case 109 | (:upcase (string-upcase raw)) 110 | (:downcase (string-downcase raw)) 111 | (:preserve raw) 112 | (:invert (cond 113 | ((every #'upper-case-p raw) (string-downcase raw)) 114 | ((every #'lower-case-p raw) (string-upcase raw)) 115 | (t raw)))) 116 | package))) 117 | ;; processes the string like it's a symbol, but doesn't intern it 118 | (:name-string 119 | (let ((raw (if trim-names-p (string-trim " " raw) raw))) 120 | (ecase read-case 121 | (:upcase (string-upcase raw)) 122 | (:downcase (string-downcase raw)) 123 | (:preserve raw) 124 | (:invert (cond 125 | ((every #'upper-case-p raw) (string-downcase raw)) 126 | ((every #'lower-case-p raw) (string-upcase raw)) 127 | (t raw)))))) 128 | ;; Parse numbers of the form 129 | (:number 130 | (let* ((raw (string-trim " " raw)) 131 | (sign (if (char= #\- (aref raw 0)) -1 1)) 132 | (position (if (or (char= #\- (aref raw 0)) (char= #\+ (aref raw 0))) 133 | 1 0)) 134 | (value (coerce 0 number-type))) 135 | (iter (while (< position (length raw))) 136 | (for c = (digit-char-p (aref raw position))) 137 | (while c) 138 | (setf value (+ c (* value 10))) 139 | (incf position)) 140 | (when (and (< position (length raw)) 141 | (char= #\. (aref raw position))) 142 | (incf position) 143 | (let ((fraction 0) 144 | (digits 0)) 145 | (iter (while (< position (length raw))) 146 | (for c = (digit-char-p (aref raw position))) 147 | (while c) 148 | (setf fraction (+ (* c (expt 10 digits)) fraction)) 149 | (incf digits) 150 | (incf position)) 151 | (incf value (/ fraction (expt 10 digits))))) 152 | (when (and (< position (length raw)) 153 | (or (char-equal #\d (aref raw position)) 154 | (char-equal #\e (aref raw position)))) 155 | (let ((exp-sign (if (char= #\- (aref raw 0)) -1 1)) 156 | (exp 0)) 157 | (when (or (char= #\- (aref raw 0)) (char= #\+ (aref raw 0))) 158 | (incf position)) 159 | (iter (while (< position (length raw))) 160 | (for c = (digit-char-p (aref raw position))) 161 | (while c) 162 | (setf value (+ c (* exp 10))) 163 | (incf position)) 164 | (setf value (* value (expt 10 (* exp-sign exp)))))) 165 | (* sign value))) 166 | ;; if it's not a name, just return it 167 | (:raw 168 | raw))))) 169 | 170 | (iter (for line = (string-right-trim '(#\Space #\Return) (read-line stream))) 171 | (if-let (header-card (unless (char= #\space (aref line 0)) 172 | (string-downcase (substring line 0 15)))) 173 | (cond 174 | ;; do nothing on comments 175 | ((char= (aref header-card 0) #\*)) 176 | ;; Take the name of the problem. Note the lack of body section 177 | ((string= header-card "name") 178 | (setf problem-name (field 3 line))) 179 | ;; The end of the problem. Exit the loop 180 | ((string= header-card "endata") 181 | (return)) 182 | ;; Normal section. Mark how to process the body sections 183 | (t 184 | (setf current-header header-card))) 185 | (cond ; else in a section 186 | ;; Name a row and set the type 187 | ((string= current-header "rows") 188 | (let ((row-type (case (char-downcase (aref (field 1 line) 0)) 189 | (#\n 'objective) 190 | (#\g '>=) 191 | (#\l '<=) 192 | (#\ '=))) 193 | (row-name (field 2 line :name-string))) 194 | (when (and (eq 'objective row-type) 195 | (not objective)) 196 | ;; by default, the first `N` row is the objective function 197 | (setf objective row-name)) 198 | (setf (gethash row-name rows) 199 | (list row-type 0 nil)))) 200 | ;; Set the coefficients for a variable in up to 2 rows 201 | ((string= current-header "columns") 202 | (let ((var-name (field 2 line :symbol))) 203 | (ensure-gethash var-name var-info (list 0 nil nil)) 204 | (let ((row-name (field 3 line :name-string)) 205 | (coefficient (field 4 line :number))) 206 | (push (cons var-name coefficient) 207 | (cdddr (gethash row-name rows)))) 208 | (when (/= 0 (length (field 5 line))) 209 | (let ((row-name (field 5 line :name-string)) 210 | (coefficient (field 6 line :number))) 211 | (push (cons var-name coefficient) 212 | (cdddr (gethash row-name rows))))))) 213 | ;; Set the values on the RHS of the rows 214 | ((string= current-header "rhs") 215 | (let ((current-rhs-id (field 2 line :name-string))) 216 | (unless rhs-id 217 | (setf rhs-id current-rhs-id)) 218 | (when (string= rhs-id current-rhs-id) 219 | (let ((row-name (field 3 line :name-string)) 220 | (value (field 4 line :number))) 221 | (setf (second (gethash row-name rows)) 222 | value)) 223 | (when (/= 0 (length (field 5 line))) 224 | (let ((row-name (field 5 line :name-string)) 225 | (value (field 6 line :number))) 226 | (setf (second (gethash row-name rows)) 227 | value)))))) 228 | ;; Ranges turn single constraints into a range 229 | ((string= current-header "ranges") 230 | (let ((current-rhs-id (field 2 line :name-string))) 231 | (unless rhs-id 232 | (setf rhs-id current-rhs-id)) 233 | (setf (third (gethash (field 3 line :symbol) rows)) 234 | (field 4 line :number)) 235 | (when (/= 0 (length (field 5 line))) 236 | (setf (third (gethash (field 5 line :symbol) rows)) 237 | (field 6 line :number))))) 238 | ;; Sets bounds for specific variables & including an extension for integer variables 239 | ((string= current-header "bounds") 240 | (let* ((var (field 3 line :symbol)) 241 | ;; LB UB intp 242 | (attrs (gethash var var-info (list 0 nil nil))) 243 | (bound-type (string-upcase (field 1 line :name-string)))) 244 | (setf (gethash var var-info) 245 | (cond 246 | ((string= bound-type "LO") 247 | (list* (field 4 line :number) (cdr attrs))) 248 | ((string= bound-type "UP") 249 | (list* (first attrs) (field 4 line :number) (cddr attrs))) 250 | ((string= bound-type "FX") 251 | (let ((value (field 4 line :number))) 252 | (list* value value (cddr attrs)))) 253 | ((string= bound-type "FR") 254 | (list* nil nil (cddr attrs))) 255 | ((string= bound-type "MI") 256 | (list* nil (cdr attrs))) 257 | ((string= bound-type "PL") 258 | (list* (first attrs) nil (cddr attrs))) 259 | ((string= bound-type "BV") 260 | (list 0 1 t)) 261 | ((string= bound-type "LI") 262 | (list (field 4 line :number) (second attrs) t)) 263 | ((string= bound-type "UI") 264 | (list (first attrs) (field 4 line :number) t)) 265 | (t (error 'parsing-error :description (format nil "~S is not a know bound type" bound-type))))))) 266 | ;; extension for specifying the problem type 267 | ((string= current-header "objsense") 268 | (setf current-header nil) ; only one record for this header 269 | (let ((type (field 0 line :name-string))) 270 | (cond 271 | ((or (string-equal type "max") 272 | (string-equal type "maximizing")) 273 | (setf problem-type 'max)) 274 | ((or (string-equal type "min") 275 | (string-equal type "minimizing")) 276 | (setf problem-type 'min)) 277 | (t 278 | (error 'parsing-error :description (format nil "~S is not a know problem type" type)))))) 279 | ;; extension that supports selecting the objective function 280 | ((string= current-header "objname") 281 | (setf current-header nil ; only one record for this header 282 | objective (field 0 line :name-string))) 283 | (t (error "Unknown header-card ~A~%" current-header)))))) 284 | (unless (or (eq problem-type 'max) (eq problem-type 'min)) 285 | (error "No valid problem type was specified")) 286 | (let ((vars (make-array (list (hash-table-count var-info)) :element-type 'symbol 287 | :initial-element nil)) 288 | (int-vars nil) 289 | (bounds nil) 290 | (constraints nil) 291 | (objective-func (cdddr (gethash objective rows)))) 292 | (iter (for (row content) in-hashtable rows) 293 | (for op = (first content)) 294 | (unless (eq op 'objective) 295 | (push (list op (cdddr content) (second content)) 296 | constraints) 297 | (when (third content) 298 | (push (cond 299 | ((eq op '<=) 300 | (list '>= (cdddr content) (- (second content) (abs (third content))))) 301 | ((eq op '>=) 302 | (list '<= (cdddr content) (+ (second content) (abs (third content))))) 303 | ;; invariant: (eq op '=) 304 | ((< 0 (third content)) 305 | (list '<= (cdddr content) (+ (second content) (third content)))) 306 | ((< (third content) 0) 307 | (list '>= (cdddr content) (+ (second content) (third content))))) 308 | ;; invariant: (and (eq op '=) (= (third content) 0)) 309 | constraints)))) 310 | (iter (for remaining on constraints) 311 | (for c = (first remaining)) 312 | (cond 313 | ;; simple bound 314 | ((= 1 (length (second c))) 315 | (let* ((var (caar (second c))) 316 | (info (gethash var var-info)) 317 | (bound (/ (third c) (cdar (second c))))) 318 | (ecase (first c) 319 | (<= (setf (second info) (lb-max (second info) bound))) 320 | (>= (setf (third info) (ub-min (third info) bound))) 321 | (= (setf (second info) (lb-max (second info) bound) 322 | (third info) (ub-min (third info) bound)))) 323 | (setf (car remaining) (cadr remaining) ; remove that constraint 324 | (cdr remaining) (cddr remaining)))) 325 | ;; negative rhs 326 | ((< (third c) 0) 327 | (setf (second c) (scale-linear-expression (second c) -1) 328 | (third c) (- (third c)) 329 | (first c) (ecase (first c) 330 | (<= '>=) 331 | (>= '<=) 332 | (= '=)))))) 333 | (iter (for (var info) in-hashtable var-info) 334 | (for i from 0) 335 | (setf (aref vars i) var) 336 | (when (third info) 337 | (push var int-vars)) 338 | (when (or (not (equalp (first info) 0)) 339 | (not (null (second info)))) 340 | (validate-bounds (first info) (second info) var) 341 | (push (cons var (cons (first info) (second info))) bounds))) 342 | (linear-programming/problem::make-problem :type problem-type 343 | :vars vars 344 | :objective-var (make-symbol objective) 345 | :objective-func objective-func 346 | :integer-vars int-vars 347 | :var-bounds bounds 348 | :constraints constraints)))) 349 | 350 | (defun print-linear-expression (stream expression &optional (aesthetic-variable-names-p t)) 351 | (iter (for (var . coef) in expression) 352 | (if (first-iteration-p) 353 | (when (< 0 coef) 354 | (format stream "-")) 355 | (format stream (if (< 0 coef) " - " " + "))) 356 | (unless (or (= coef 1) (= coef -1)) 357 | (format stream "~A*" (abs coef))) 358 | (format stream "~:[~S~;~A~]" aesthetic-variable-names-p var))) 359 | 360 | (defun write-standard-format (stream problem &key (unicodep t) (aesthetic-variable-names-p t)) 361 | "Writes a problem to the given stream in human readable, standard notation. The 362 | `unicodep` argument controls whether to print comparisons as unicode or ascii. 363 | The `aesthetic-variable-names-p` argument controls whether variable names are 364 | printed aesthetically." 365 | ;;; Objective function 366 | (format stream "~A ~:[~S~;~A~] = " 367 | (if (eq 'max (problem-type problem)) "Maximize" "Minimize") 368 | aesthetic-variable-names-p 369 | (problem-objective-var problem)) 370 | (print-linear-expression stream (problem-objective-func problem) aesthetic-variable-names-p) 371 | 372 | ;;; Constraints 373 | (format stream "~%Subject to:") 374 | ;; Basic constraints 375 | (iter (for constraint in (problem-constraints problem)) 376 | (format stream "~12,0T") 377 | (print-linear-expression stream (second constraint) aesthetic-variable-names-p) 378 | (format stream " ~A " 379 | (ecase (first constraint) 380 | (<= (if unicodep "≤" "<")) 381 | (>= (if unicodep "≥" ">")) 382 | (= "="))) 383 | (format stream "~A~%" (third constraint))) 384 | 385 | ;; bounds 386 | (iter (with bounds = (problem-var-bounds problem)) 387 | (for var in-vector (problem-vars problem)) 388 | (for bound = (or (cdr (assoc var bounds)) '(0 . nil))) 389 | (when (car bound) 390 | (if (= 0 (car bound)) 391 | (collect var into non-negative at beginning) 392 | (format stream "~12,0T~:[~S~;~A~] ~:[>~;≥~] ~A~%" 393 | aesthetic-variable-names-p var unicodep (car bound)))) 394 | (when (cdr bound) 395 | (format stream "~12,0T~:[~S~;~A~] ~:[<~;≤~] ~A~%" 396 | aesthetic-variable-names-p var unicodep (cdr bound))) 397 | (finally 398 | (when non-negative 399 | (format stream "~12,0T~:[~{~S~^, ~}~;~{~A~^, ~}~] ~:[>~;≥~] 0~%" 400 | aesthetic-variable-names-p non-negative unicodep)))) 401 | 402 | ;; int constraints 403 | (when (problem-integer-vars problem) 404 | (format stream "~12,0T~:[~{~S~^, ~}~;~{~A~^, ~}~] integer~%" 405 | aesthetic-variable-names-p (problem-integer-vars problem)))) 406 | -------------------------------------------------------------------------------- /src/problem.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming/problem 3 | (:use :cl 4 | :iterate 5 | :linear-programming/conditions 6 | :linear-programming/expressions) 7 | (:import-from :alexandria 8 | #:if-let) 9 | (:import-from :linear-programming/utils 10 | #:validate-bounds 11 | #:lb-max 12 | #:ub-min) 13 | (:export #:make-linear-problem 14 | #:parse-linear-problem 15 | 16 | #:parsing-error 17 | 18 | #:min 19 | #:max 20 | #:integer 21 | #:binary 22 | #:bounds 23 | #:<= 24 | #:>= 25 | #:< 26 | #:> 27 | #:= 28 | #:+ 29 | #:* 30 | 31 | #:problem 32 | #:problem-type 33 | #:problem-vars 34 | #:problem-objective-var 35 | #:problem-objective-func 36 | #:problem-integer-vars 37 | #:problem-var-bounds 38 | #:problem-constraints) 39 | (:documentation "Handles the representation of linear programming problems.")) 40 | 41 | (in-package :linear-programming/problem) 42 | 43 | (defstruct problem 44 | "The representation of a linear programming problem." 45 | (type 'max :read-only t :type (member max min)) 46 | (vars #() :read-only t :type (simple-array symbol (*))) 47 | (objective-var '#:z :read-only t :type symbol) 48 | (objective-func nil :read-only t :type list) 49 | (integer-vars nil :read-only t :type list) 50 | (var-bounds nil :read-only t :type list) 51 | (constraints nil :read-only t :type list)) 52 | 53 | (setf (documentation 'problem-type 'function) "Whether the problem is a `min` or `max` problem." 54 | (documentation 'problem-vars 'function) "An array of the variables specified in the problem." 55 | (documentation 'problem-objective-var 'function) "The name of the objective function." 56 | (documentation 'problem-objective-func 'function) "The objective function as a linear expression alist." 57 | (documentation 'problem-integer-vars 'function) "A list of variables with integer constraints." 58 | (documentation 'problem-var-bounds 'function) "A list of variable bounds, of the form `(var . (lower-bound . upper-bound))`." 59 | (documentation 'problem-constraints 'function) "A list of (in)equality constraints.") 60 | 61 | (defun parse-linear-constraints (exprs) 62 | "Parses the list of constraints and returns a list containing a list of simple 63 | inequalities and a list of integer variables." 64 | (iter expressions-loop 65 | (for expr in exprs) 66 | (case (first expr) 67 | ((<= <) 68 | (when (eq (first expr) '<) 69 | (warn "< constraints are deprecated in favor of <= ones due to misleading semantics.")) 70 | (collect (cons '<= (mapcar 'parse-linear-expression (rest expr))) 71 | into equalities)) 72 | ((>= >) 73 | (when (eq (first expr) '>) 74 | (warn "> constraints are deprecated in favor of >= ones due to misleading semantics.")) 75 | (collect (cons '<= (reverse (mapcar 'parse-linear-expression (rest expr)))) 76 | into equalities)) 77 | ((=) 78 | (collect (cons '= (mapcar 'parse-linear-expression (rest expr))) 79 | into equalities)) 80 | ((integer) 81 | (unioning (rest expr) 82 | into integer)) 83 | ((bounds) 84 | (appending (mapcar (lambda (entry) 85 | (cond 86 | ((symbolp (first entry)) 87 | (unless (and (<= (length entry) 2) 88 | (or (null (second entry)) 89 | (numberp (second entry)))) 90 | (error 'parsing-error :description (format nil "Invalid bounds entry ~S" entry))) 91 | (cons (first entry) (cons nil (second entry)))) 92 | (t 93 | (unless (and (numberp (first entry)) 94 | (symbolp (second entry)) 95 | (or (null (third entry)) 96 | (numberp (third entry)))) 97 | (error 'parsing-error :description (format nil "Invalid bounds entry ~S" entry))) 98 | (cons (second entry) (cons (first entry) (third entry)))))) 99 | (rest expr)) 100 | into bounds)) 101 | ((binary) 102 | (unioning (rest expr) 103 | into integer) 104 | (appending (mapcar (lambda (var) `(,var . (0 . 1))) 105 | (rest expr)) 106 | into bounds)) 107 | (t (error 'parsing-error :description (format nil "~A is not a valid constraint" expr)))) 108 | (finally 109 | (iter equalities-loop 110 | (for constraint in equalities) 111 | (for op = (first constraint)) 112 | (iter (for rhs in (nthcdr 2 constraint)) 113 | (for lhs previous rhs initially (second constraint)) 114 | (let* ((lin-exp (sum-linear-expressions 115 | lhs (scale-linear-expression rhs -1))) 116 | (const (- (cdr (or (assoc '+constant+ lin-exp :test 'eq) '(+constant+ . 0))))) 117 | (sum (delete '+constant+ lin-exp :test 'eq :key 'car))) 118 | (unless const 119 | (setf const 0)) 120 | (in equalities-loop 121 | (cond 122 | ((= 1 (length sum)) 123 | (let* ((var (first (first sum))) 124 | (coef (rest (first sum))) 125 | (const (/ const coef)) 126 | (new-bound (cond 127 | ((eq op '=) (cons const const)) 128 | ((<= coef 0) (cons const nil)) 129 | (t (cons nil const)))) 130 | (match (assoc var bounds)) 131 | (old-bound (cdr match))) 132 | (if match 133 | (setf (cdr match) 134 | (cons (lb-max (car old-bound) (car new-bound)) 135 | (ub-min (cdr old-bound) (cdr new-bound)))) 136 | (collect (cons var 137 | (cons (or (car new-bound) 0) ; if there isn't a previous bound, use the implicit bound 138 | (cdr new-bound))) 139 | into extra-bounds)))) 140 | ((eq op '=) 141 | (collect (list '= sum const) into simple-constraints)) 142 | ((<= 0 const) 143 | (collect (list '<= sum const) into simple-constraints)) 144 | (t 145 | (collect (list '>= (scale-linear-expression sum -1) (- const)) 146 | into simple-constraints)))))) 147 | (finally 148 | (return-from expressions-loop 149 | (list simple-constraints 150 | integer 151 | (reduce (lambda (result next) 152 | (if-let (match (assoc (first next) result)) 153 | (let* ((lb (lb-max (car (cdr next)) (car (cdr match)))) 154 | (ub (ub-min (cdr (cdr next)) (cdr (cdr next))))) 155 | (validate-bounds lb ub (first next)) 156 | (setf (cdr match) (cons lb ub)) 157 | result) 158 | (list* next result))) 159 | (nconc extra-bounds bounds) 160 | :initial-value nil)))))))) 161 | 162 | 163 | 164 | (defun parse-linear-problem (objective-exp constraints) 165 | "Parses the expressions into a linear programming problem" 166 | (let* ((objective-var-p (eq (first objective-exp) '=)) 167 | (objective (if objective-var-p 168 | (third objective-exp) 169 | objective-exp)) 170 | (objective-var (if objective-var-p 171 | (second objective-exp) 172 | (gensym "Z")))) 173 | (when (and (not objective-var-p) 174 | (listp (second objective)) 175 | (eq (first (second objective)) '=)) 176 | (setf objective-var (second (second objective))) 177 | (setf objective (list (first objective) (third (second objective)))) 178 | (setf objective-var-p t)) 179 | (unless (member (first objective) '(min max) :test 'eq) 180 | (error 'parsing-error 181 | :description (format nil "~A is neither min nor max in objective function ~A" 182 | (first objective) objective))) 183 | (let* ((type (first objective)) 184 | (objective-func (parse-linear-expression (second objective))) 185 | (parsed-constraints (parse-linear-constraints constraints)) 186 | (eq-constraints (first parsed-constraints)) 187 | (integer-constraints (second parsed-constraints)) 188 | (bounds (third parsed-constraints)) 189 | ;collect all of the variables referenced 190 | (var-list (remove-duplicates (mapcar #'car objective-func))) 191 | (var-list (union var-list integer-constraints)) 192 | (var-list (union var-list (mapcar #'first bounds))) 193 | (var-list (union var-list 194 | (reduce (lambda (l1 l2) (union l1 (mapcar #'car l2))) 195 | eq-constraints 196 | :key 'second 197 | :initial-value nil))) 198 | (variables (make-array (length var-list) 199 | :initial-contents var-list 200 | :element-type 'symbol))) 201 | (make-problem :type type 202 | :vars variables 203 | :objective-var objective-var 204 | :objective-func objective-func 205 | :integer-vars integer-constraints 206 | :var-bounds bounds 207 | :constraints eq-constraints)))) 208 | 209 | 210 | (defmacro make-linear-problem (objective &rest constraints) 211 | "Creates a linear problem from the expressions in the body" 212 | `(parse-linear-problem ',objective ',constraints)) 213 | -------------------------------------------------------------------------------- /src/simplex.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming/simplex 3 | (:use :cl 4 | :iterate 5 | :linear-programming/conditions 6 | :linear-programming/problem 7 | :linear-programming/utils) 8 | (:import-from :alexandria 9 | #:curry 10 | #:if-let 11 | #:when-let 12 | #:copy-array 13 | #:once-only) 14 | (:export #:tableau 15 | #:tableau-p 16 | #:copy-tableau 17 | #:tableau-problem 18 | #:tableau-instance-problem 19 | #:tableau-matrix 20 | #:tableau-basis-columns 21 | #:tableau-var-count 22 | #:tableau-constraint-count 23 | #:tableau-objective-value 24 | #:tableau-variable 25 | #:tableau-reduced-cost 26 | #:with-tableau-variables 27 | 28 | #:pivot-row 29 | #:n-pivot-row 30 | 31 | #:build-tableau 32 | #:solve-tableau 33 | #:n-solve-tableau 34 | #:simplex-solver) 35 | (:documentation "The actual simplex solver implementation for the default solver backend. This 36 | package should be used through the interface provided by the 37 | `linear-programming/solver` package.")) 38 | 39 | (in-package :linear-programming/simplex) 40 | 41 | 42 | ;;; Tableau representation 43 | 44 | (deftype var-mapping-entry () 45 | "Represents a maping from a problem's variable to a set of columns in the tableau." 46 | '(cons (member positive negative signed) (cons fixnum (or null (cons real null))))) 47 | 48 | (defstruct (tableau (:copier #:shallow-tableau-copy)) 49 | "Contains the necessary information for a simplex tableau." 50 | ; note that two tableaus are stored, which may differ when solving integer problems 51 | (problem nil :read-only t :type problem) ; the overall problem 52 | (instance-problem nil :read-only t :type problem) ; the problem for this specific tableau 53 | (matrix #2A() :read-only t :type (simple-array real 2)) 54 | (basis-columns #() :read-only t :type (simple-array fixnum (*))) 55 | (var-count 0 :read-only t :type (and fixnum unsigned-byte)) 56 | (constraint-count 0 :read-only t :type (and fixnum unsigned-byte)) 57 | (var-mapping (make-hash-table :test #'eq) :read-only t :type hash-table) 58 | (fp-tolerance-factor 1024 :read-only t :type real)) 59 | 60 | (declaim (inline copy-tableau)) 61 | (defun copy-tableau (tableau) 62 | "Copies the given tableau and it's matrix." 63 | (declare (optimize (speed 3))) 64 | (make-tableau :problem (tableau-problem tableau) 65 | :instance-problem (tableau-instance-problem tableau) 66 | :matrix (copy-array (tableau-matrix tableau)) 67 | :basis-columns (copy-array (tableau-basis-columns tableau)) 68 | :var-count (tableau-var-count tableau) 69 | :constraint-count (tableau-constraint-count tableau) 70 | :var-mapping (tableau-var-mapping tableau) 71 | :fp-tolerance-factor (tableau-fp-tolerance-factor tableau))) 72 | 73 | (declaim (inline tableau-objective-value)) 74 | (defun tableau-objective-value (tableau) 75 | "Gets the objective function value in the tableau." 76 | (aref (tableau-matrix tableau) 77 | (tableau-constraint-count tableau) 78 | (tableau-var-count tableau))) 79 | 80 | (declaim (inline tableau-variable)) 81 | (defun tableau-variable (tableau var) 82 | "Gets the value of the given variable from the tableau" 83 | (if (eq var (problem-objective-var (tableau-instance-problem tableau))) 84 | (tableau-objective-value tableau) 85 | (let* ((mapping (gethash var (tableau-var-mapping tableau)))) 86 | (unless mapping 87 | (error "~S is not a variable in the tableau" var)) 88 | (locally 89 | (declare (type var-mapping-entry mapping)) 90 | (ecase (first mapping) 91 | (positive 92 | (+ (third mapping) 93 | (if-let (idx (position (second mapping) (tableau-basis-columns tableau))) 94 | (aref (tableau-matrix tableau) idx (tableau-var-count tableau)) 95 | 0))) 96 | (negative 97 | (+ (third mapping) 98 | (if-let (idx (position (second mapping) (tableau-basis-columns tableau))) 99 | (- (aref (tableau-matrix tableau) idx (tableau-var-count tableau))) 100 | 0))) 101 | (signed 102 | (- (if-let (idx (position (second mapping) (tableau-basis-columns tableau))) 103 | (aref (tableau-matrix tableau) idx (tableau-var-count tableau)) 104 | 0) 105 | (if-let (idx (position (1+ (second mapping)) (tableau-basis-columns tableau))) 106 | (aref (tableau-matrix tableau) idx (tableau-var-count tableau)) 107 | 0)))))))) 108 | 109 | 110 | (declaim (inline tableau-reduced-cost)) 111 | (defun tableau-reduced-cost (tableau var) 112 | "Gets the reduced cost (i.e. the shadow price for the lower bound) for the given 113 | variable from the tableau." 114 | (let* ((mapping (gethash var (tableau-var-mapping tableau)))) 115 | (unless mapping 116 | (error "~S is not a variable in the tableau" var)) 117 | (unless (eq (first mapping) 'positive) 118 | (error "~S has no lower bound" var)) 119 | (aref (tableau-matrix tableau) 120 | (tableau-constraint-count tableau) (the fixnum (second mapping))))) 121 | 122 | ;; TODO implement upper-bound equivalent for reduced-cost 123 | ;; Requires keeping track of which row is the upperbound for positive vars 124 | 125 | (defmacro with-tableau-variables (var-list tableau &body body) 126 | "Evaluates the body with the variables in `var-list` bound to their values from 127 | the tableau." 128 | (once-only (tableau) 129 | (if (typep var-list 'problem) 130 | (let ((problem var-list)) ; for readability 131 | `(let ((,(problem-objective-var problem) (tableau-objective-value ,tableau)) 132 | ,@(iter (for var in-sequence (problem-vars problem)) 133 | (collect `(,var (tableau-variable ,tableau ',var))))) 134 | (declare (ignorable ,(problem-objective-var problem) 135 | ,@(map 'list #'identity (problem-vars problem)))) 136 | ,@body)) 137 | `(let (,@(iter (for var in-sequence var-list) 138 | (collect `(,var (tableau-variable ,tableau ',var))))) 139 | ,@body)))) 140 | 141 | 142 | (defun build-tableau (problem instance-problem &key (fp-tolerance-factor 1024)) 143 | "Creates the tableau from the given linear problem. If the trivial basis is not 144 | feasible, instead a list is returned containing the two tableaus for a two-phase 145 | simplex method." 146 | (let* ((constraints (problem-constraints instance-problem)) 147 | (num-problem-vars (length (problem-vars problem))) 148 | (mappings (make-hash-table :size (ceiling num-problem-vars 7/10) 149 | :rehash-threshold 7/10 150 | :rehash-size 5)) ; only bump up size if our numbers end up slightly off 151 | (num-problem-var-cols num-problem-vars)) ; columns for problem vars 152 | (declare (type fixnum num-problem-var-cols)) 153 | (unless constraints 154 | ;; There aren't any constraints, so simply max/min out each var in a trivial tableau 155 | (return-from build-tableau 156 | (let ((vars (problem-vars problem)) 157 | (matrix (make-array (list (1+ num-problem-vars) (1+ num-problem-vars)) 158 | :element-type 'real 159 | :initial-element 0)) 160 | (objective-value 0) 161 | (basis-cols (make-array (list num-problem-vars) :element-type 'fixnum))) 162 | (iter (with max-problem-p = (eq (problem-type problem) 'max)) 163 | (for i from 0) 164 | (for var in-vector vars) 165 | (for obj-coef = (cdr (assoc var (problem-objective-func problem)))) 166 | (for bound = (assoc var (problem-var-bounds problem))) 167 | (setf (aref basis-cols i) i 168 | (aref matrix i i) 1) 169 | (if (eq (<= 0 obj-coef) max-problem-p) ; XNOR of t/nil values 170 | (if (cddr bound) 171 | (setf (gethash (aref vars i) mappings) (list 'positive i (cddr bound)) 172 | objective-value (+ objective-value (* obj-coef (cddr bound)))) 173 | (error 'unbounded-problem-error)) 174 | (if (cadr bound) 175 | (setf (gethash (aref vars i) mappings) (list 'positive i (cadr bound)) 176 | objective-value (+ objective-value (* obj-coef (cadr bound)))) 177 | (error 'unbounded-problem-error)))) 178 | (setf (aref matrix num-problem-vars num-problem-vars) objective-value) 179 | (make-tableau :problem problem 180 | :instance-problem problem 181 | :matrix matrix 182 | :basis-columns basis-cols 183 | :var-count num-problem-vars 184 | :constraint-count num-problem-vars 185 | :var-mapping mappings 186 | :fp-tolerance-factor fp-tolerance-factor)))) 187 | 188 | 189 | (iter (for var in-vector (problem-vars problem)) 190 | (for bound = (find var (problem-var-bounds problem) :key #'first)) 191 | (for var-id upfrom 0) 192 | (generate column upfrom 0) 193 | (next column) 194 | (setf (gethash var mappings) 195 | (cond 196 | ((null bound) 197 | (list 'positive column 0)) 198 | ((and (cadr bound) (cddr bound)) 199 | (push (if (<= 0 (cddr bound)) 200 | `(<= ((,var . 1)) ,(cddr bound)) 201 | `(>= ((,var . 1)) ,(- (cddr bound)))) 202 | constraints) 203 | (list 'positive column (cadr bound))) 204 | ((cadr bound) 205 | (list 'positive column (cadr bound))) 206 | ((cddr bound) 207 | (list 'negative column (cddr bound))) 208 | (t 209 | (prog1 210 | (list 'signed column) 211 | (next column) 212 | (incf num-problem-var-cols)))))) 213 | 214 | (let* ((num-constraints (length constraints)) 215 | (num-slack (count-if-not (curry #'eq '=) constraints :key #'first)) 216 | (num-cols (+ num-problem-var-cols num-slack 1)) 217 | (matrix (make-array (list (1+ num-constraints) num-cols) 218 | :element-type 'real 219 | :initial-element 0)) 220 | (basis-columns (make-array (list num-constraints) :element-type 'fixnum)) 221 | (artificial-var-rows nil)) 222 | ;; constraint rows 223 | (iter (with col-offset = 0) 224 | (for row from 0 below num-constraints) 225 | (for constraint in constraints) 226 | ;; rhs 227 | (setf (aref matrix row (1- num-cols)) (third constraint)) 228 | ;; variables 229 | (iter (for (var . coef) in (second constraint)) 230 | (for mapping = (gethash var mappings)) 231 | (declare (type (or null var-mapping-entry) mapping)) 232 | (ecase (first mapping) 233 | (positive 234 | (setf (aref matrix row (second mapping)) coef) 235 | (decf (aref matrix row (1- num-cols)) (* coef (third mapping)))) 236 | (negative 237 | (setf (aref matrix row (second mapping)) (- coef)) 238 | (decf (aref matrix row (1- num-cols)) (* coef (third mapping)))) 239 | (signed 240 | (setf (aref matrix row (second mapping)) coef 241 | (aref matrix row (1+ (second mapping))) (- coef))))) 242 | ;; Ensure rhs is positive 243 | (when (and (< (aref matrix row (1- num-cols)) 0)) 244 | (iter (for col from 0 below num-cols) 245 | (setf (aref matrix row col) (- (aref matrix row col)))) 246 | (setf constraint 247 | (cons (case (first constraint) 248 | (<= '>=) 249 | (>= '<=) 250 | (= '=) 251 | (t (first constraint))) 252 | (rest constraint)))) 253 | ;; slack 254 | (case (first constraint) 255 | (<= (setf (aref matrix row (+ num-problem-var-cols col-offset)) 1 256 | (aref basis-columns row) (+ num-problem-var-cols col-offset)) 257 | (incf col-offset)) 258 | (>= (push row artificial-var-rows) 259 | (setf (aref matrix row (+ num-problem-var-cols col-offset)) -1 260 | (aref basis-columns row) num-cols) 261 | (incf col-offset)) 262 | (= (push row artificial-var-rows) 263 | (setf (aref basis-columns row) num-cols)) 264 | (t (error 'parsing-error 265 | :description (format nil "~S is not a valid constraint equation" constraint))))) 266 | ;; objective row 267 | (iter (for (var . coef) in (problem-objective-func problem)) 268 | (for mapping = (gethash var mappings)) 269 | (declare (type (or null var-mapping-entry) mapping)) 270 | (ecase (first mapping) 271 | (positive 272 | (setf (aref matrix num-constraints (second mapping)) (- coef)) 273 | (incf (aref matrix num-constraints (1- num-cols)) (* coef (third mapping)))) 274 | (negative 275 | (setf (aref matrix num-constraints (second mapping)) coef) 276 | (incf (aref matrix num-constraints (1- num-cols)) (* coef (third mapping)))) 277 | (signed 278 | (setf (aref matrix num-constraints (second mapping)) (- coef) 279 | (aref matrix num-constraints (1+ (second mapping))) coef)))) 280 | (let ((main-tableau (make-tableau :problem problem 281 | :instance-problem instance-problem 282 | :matrix matrix 283 | :basis-columns basis-columns 284 | :var-count (1- num-cols) 285 | :constraint-count num-constraints 286 | :var-mapping mappings 287 | :fp-tolerance-factor fp-tolerance-factor)) 288 | (art-tableau (when artificial-var-rows 289 | (let* ((num-art (length artificial-var-rows)) 290 | (num-art-cols (+ num-cols num-art)) 291 | (art-matrix (make-array (list (1+ num-constraints) num-art-cols) 292 | :element-type 'real 293 | :initial-element 0)) 294 | (art-basis-columns (copy-array basis-columns))) 295 | (iter (for row in artificial-var-rows) 296 | (for i from 0) 297 | (setf (aref art-basis-columns row) 298 | (+ num-cols -1 i)) 299 | (setf (aref art-matrix row (+ num-cols -1 i)) 1)) 300 | 301 | ;copy coefficients 302 | (iter (for c from 0 below (1- num-cols)) 303 | (setf (aref art-matrix num-constraints c) 304 | (iter (for r from 0 below num-constraints) 305 | (setf (aref art-matrix r c) (aref matrix r c)) 306 | (when (member r artificial-var-rows) 307 | (sum (aref art-matrix r c)))))) 308 | ;copy rhs 309 | (let ((c (1- num-art-cols))) 310 | (setf (aref art-matrix num-constraints c) 311 | (iter (for r from 0 below num-constraints) 312 | (setf (aref art-matrix r c) 313 | (aref matrix r (1- num-cols))) 314 | (when (member r artificial-var-rows) 315 | (sum (aref art-matrix r c)))))) 316 | (make-tableau :problem problem 317 | :instance-problem (linear-programming/problem::make-problem 318 | :type 'min ;artificial problem 319 | :vars (problem-vars problem)) 320 | :matrix art-matrix 321 | :basis-columns art-basis-columns 322 | :var-count (+ num-cols -1 num-art) 323 | :constraint-count num-constraints 324 | :var-mapping mappings 325 | :fp-tolerance-factor fp-tolerance-factor))))) 326 | (if art-tableau 327 | (list art-tableau main-tableau) 328 | main-tableau))))) 329 | 330 | 331 | ;;; Tableau solver 332 | 333 | (defun pivot-row (tableau entering-col changing-row) 334 | "Non-destructively applies a single pivot to the table." 335 | (n-pivot-row (copy-tableau tableau) entering-col changing-row)) 336 | 337 | (defun n-pivot-row (tableau entering-col changing-row) 338 | "Destructively applies a single pivot to the table." 339 | (declare (optimize (speed 3)) 340 | (type fixnum entering-col changing-row)) 341 | (let* ((matrix (tableau-matrix tableau)) 342 | (row-count (array-dimension matrix 0)) 343 | (col-count (array-dimension matrix 1))) 344 | (let ((row-scale (aref matrix changing-row entering-col))) 345 | (iter (declare (iterate:declare-variables) 346 | (optimize (speed 3) (safety 0))) 347 | (for (the fixnum c) from 0 below col-count) 348 | (setf (aref matrix changing-row c) (/ (aref matrix changing-row c) row-scale)))) 349 | (iter (declare (iterate:declare-variables) 350 | (optimize (speed 3) (safety 0))) 351 | (for (the fixnum r) from 0 below row-count) 352 | (unless (= r changing-row) 353 | (let ((scale (aref matrix r entering-col))) 354 | (iter (declare (iterate:declare-variables) 355 | (optimize (speed 3) (safety 0))) 356 | (for (the fixnum c) from 0 below col-count) 357 | (decf (aref matrix r c) (* scale (aref matrix changing-row c)))))))) 358 | (setf (aref (tableau-basis-columns tableau) changing-row) entering-col) 359 | tableau) 360 | 361 | (declaim (inline find-entering-column)) 362 | (defun find-entering-column (tableau) 363 | "Gets the column to add to the basis." 364 | (let ((num-constraints (tableau-constraint-count tableau))) 365 | (if (eq 'max (problem-type (tableau-instance-problem tableau))) 366 | (iter (for i from 0 below (tableau-var-count tableau)) 367 | (finding i minimizing (aref (tableau-matrix tableau) num-constraints i) 368 | into col) 369 | (finally 370 | (return (when (fp< (aref (tableau-matrix tableau) num-constraints col) 0 371 | (/ (tableau-fp-tolerance-factor tableau) 8)) 372 | col)))) 373 | (iter (for i from 0 below (tableau-var-count tableau)) 374 | (finding i maximizing (aref (tableau-matrix tableau) num-constraints i) 375 | into col) 376 | (finally 377 | (return (when (fp> (aref (tableau-matrix tableau) num-constraints col) 0 378 | (/ (tableau-fp-tolerance-factor tableau) 8)) 379 | col))))))) 380 | 381 | (declaim (inline find-pivoting-row)) 382 | (defun find-pivoting-row (tableau entering-col) 383 | "Gets the column that will leave the basis." 384 | (let ((matrix (tableau-matrix tableau))) 385 | (iter (for i from 0 below (tableau-constraint-count tableau)) 386 | (when (fp< 0 (aref matrix i entering-col) 387 | (/ (tableau-fp-tolerance-factor tableau) 2)) 388 | (finding i minimizing (/ (aref matrix i (tableau-var-count tableau)) 389 | (aref matrix i entering-col))))))) 390 | 391 | (defun solve-tableau (tableau) 392 | "Attempts to solve the tableau using the simplex method. If a list of two 393 | tableaus is given, then a two-phase version is used. The original tableau(s) are 394 | unchanged." 395 | (if (listp tableau) 396 | (n-solve-tableau (mapcar #'copy-tableau tableau)) 397 | (n-solve-tableau (copy-tableau tableau)))) 398 | 399 | (defun n-solve-tableau (tableau) 400 | "A non-consing version of [`solve-tableau`](#function-linear-programming/simplex:solve-tableau)." 401 | (cond 402 | ((listp tableau) 403 | (let ((solved-art-tab (n-solve-tableau (first tableau))) 404 | (main-tab (second tableau))) 405 | (unless (fp= 0 (tableau-objective-value solved-art-tab) 406 | (tableau-fp-tolerance-factor solved-art-tab)) 407 | (error 'infeasible-problem-error)) 408 | 409 | ;; Have starting basis, use solve-art-tab to set main-tab to that basis 410 | (let ((main-matrix (tableau-matrix main-tab)) 411 | (art-matrix (tableau-matrix solved-art-tab)) 412 | (art-basis (tableau-basis-columns solved-art-tab)) 413 | (num-vars (tableau-var-count main-tab)) 414 | (num-art-vars (tableau-var-count solved-art-tab)) 415 | (num-constraints (tableau-constraint-count main-tab))) 416 | 417 | ;; Check that all artificial variables are out of the basis 418 | ;; Degeneracy can allow an artificial variable to be zero, but still in the basis 419 | (iter (for basis-col in-vector (tableau-basis-columns solved-art-tab)) 420 | (for i from 0) 421 | (when (>= basis-col num-vars) 422 | ;; Need to find non-basis variable with a nonzero in this row 423 | (when (/= 0 (aref art-matrix i num-art-vars)) 424 | (error (format nil "Artificial variable ~S still non-zero" basis-col))) 425 | (let ((new-col -1)) 426 | (iter (for j from 0 below num-vars) 427 | (when (and (/= 0 (aref art-matrix i j)) 428 | (iter (for new-col in-vector art-basis) 429 | (always (/= new-col j)))) 430 | (setf new-col j) 431 | (return))) 432 | (when (= new-col -1) 433 | (error "Artificial variable still in basis and cannot be replaced")) 434 | (n-pivot-row solved-art-tab new-col i)))) 435 | 436 | ;; Copy tableau coefficients/RHS 437 | (iter (for row from 0 below num-constraints) 438 | (iter (for col from 0 below num-vars) 439 | (setf (aref main-matrix row col) (aref art-matrix row col))) 440 | (setf (aref main-matrix row num-vars) 441 | (aref art-matrix row num-art-vars))) 442 | 443 | ;; Update basis columns and objective row to match 444 | (iter (for basis-col in-vector art-basis) 445 | (for i from 0) 446 | (setf (aref (tableau-basis-columns main-tab) i) basis-col) 447 | (let ((scale (aref main-matrix num-constraints basis-col))) 448 | (when (/= 0 scale) 449 | (iter (for col from 0 to num-vars) 450 | (decf (aref main-matrix num-constraints col) 451 | (* scale (aref main-matrix i col)))))))) 452 | (n-solve-tableau main-tab))) 453 | ((tableau-p tableau) 454 | (iter (for entering-column = (find-entering-column tableau)) 455 | (while entering-column) 456 | (let ((pivoting-row (find-pivoting-row tableau entering-column))) 457 | (unless pivoting-row 458 | (error 'unbounded-problem-error)) 459 | (n-pivot-row tableau entering-column pivoting-row))) 460 | tableau) 461 | (t (check-type tableau tableau)))) 462 | 463 | 464 | ;;; Branch and Bound solver 465 | 466 | (defun gen-entries (tableau entry) 467 | "Generates new entries to correct one of the integer constraints." 468 | (let* ((split-var (violated-integer-constraint tableau)) 469 | (split-var-val (tableau-variable tableau split-var))) 470 | (list (list* `(<= ((,split-var . 1)) ,(floor split-var-val)) 471 | entry) 472 | (list* `(>= ((,split-var . 1)) ,(ceiling split-var-val)) 473 | entry)))) 474 | 475 | (defun violated-integer-constraint (tableau) 476 | "Gets a variable that is required to be an integer but is currently violating 477 | that constraint." 478 | (iter (for var in (problem-integer-vars (tableau-problem tableau))) 479 | (unless (integerp (tableau-variable tableau var)) 480 | (return var)))) 481 | 482 | 483 | (defun build-and-solve (problem extra-constraints &key (fp-tolerance-factor 1024)) 484 | "Builds and solves a tableau with the extra constrains added to the problem." 485 | ;if problem becomes infeasible, just return :infeasible 486 | (handler-case 487 | (solve-tableau 488 | (build-tableau 489 | problem 490 | (if (null extra-constraints) 491 | problem 492 | (linear-programming/problem::make-problem 493 | :type (problem-type problem) 494 | :vars (problem-vars problem) 495 | :objective-var (problem-objective-var problem) 496 | :objective-func (problem-objective-func problem) 497 | :integer-vars (problem-integer-vars problem) 498 | :var-bounds (problem-var-bounds problem) 499 | :constraints (append extra-constraints 500 | (problem-constraints problem)))) 501 | :fp-tolerance-factor fp-tolerance-factor)) 502 | (infeasible-problem-error () :infeasible))) 503 | 504 | 505 | 506 | (defun simplex-solver (problem &rest args) 507 | "The solver interface function for the simplex backend. The `fp-tolerance` 508 | keyword argument can be used to indicate the tolerance for error on floating 509 | point comparisons (defaults to 1024)." 510 | 511 | (let ((fp-tolerance-factor (getf args :fp-tolerance 1024)) 512 | (current-best nil) 513 | (current-solution nil) 514 | (stack (list '())) 515 | (comparator (if (eq (problem-type problem) 'max) '< '>))) 516 | (iter (while stack) 517 | (let* ((entry (pop stack)) 518 | (tab (build-and-solve problem entry :fp-tolerance-factor fp-tolerance-factor))) 519 | (cond 520 | ; Reached an infeasible leaf. Do nothing 521 | ((eq tab :infeasible)) 522 | 523 | ; This branch can't contain the optimal solution. Do nothing 524 | ((and (violated-integer-constraint tab) 525 | current-best 526 | (not (funcall comparator current-best (tableau-objective-value tab))))) 527 | 528 | ; Not integral, but not suboptimal. Add children to stack 529 | ((violated-integer-constraint tab) 530 | (setf stack (append (gen-entries tab entry) stack))) 531 | 532 | ; Integral. If better than best, save this result. 533 | ((or (not current-best) 534 | (funcall comparator current-best (tableau-objective-value tab))) 535 | (setf current-best (tableau-objective-value tab) 536 | current-solution tab))))) 537 | 538 | ; if it failed to find a solution, raise the appropriate error 539 | ; otherwise, return the found solution 540 | (if current-solution 541 | current-solution 542 | (error 'infeasible-problem-error)))) 543 | -------------------------------------------------------------------------------- /src/solver.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming/solver 3 | (:use :cl 4 | :iterate) 5 | (:import-from :alexandria 6 | #:once-only 7 | #:with-gensyms) 8 | (:import-from :linear-programming/problem 9 | #:problem 10 | #:problem-vars 11 | #:problem-objective-var 12 | #:parse-linear-problem) 13 | (:import-from :linear-programming/simplex 14 | #:simplex-solver 15 | #:tableau 16 | #:tableau-problem 17 | #:tableau-objective-value 18 | #:tableau-variable 19 | #:tableau-reduced-cost) 20 | (:export #:*solver* 21 | #:solve-problem 22 | 23 | #:solution-problem 24 | #:solution-objective-value 25 | #:solution-variable 26 | #:solution-reduced-cost 27 | 28 | #:with-solved-problem 29 | #:with-solution-variables 30 | #:reduced-cost) 31 | (:documentation "The high level linear programming solver interface. This interface is able to 32 | wrap multiple backends. The backend can be adjusted by setting the `*solver*` 33 | variable. The default backend is the `simplex-solver` in the 34 | `linear-programming/simplex` package.")) 35 | 36 | (in-package :linear-programming/solver) 37 | 38 | 39 | (defvar *solver* 'simplex-solver 40 | "The function that should be used by solve-problem (defaults to 41 | `linear-programming/simplex:simplex-solver`). The function should take a 42 | problem, and any backend specific keyword arguments and returns some form of 43 | solution object. The solution object should support the following methods 44 | `solution-problem`, `solution-objective-value`, `solution-variable`, and 45 | `solution-reduced-cost`.") 46 | 47 | ;;; Solution object 48 | 49 | (defun solve-problem (problem &rest args &key &allow-other-keys) 50 | "Solves the given problem using the function stored by `*solver*`. Any keyword 51 | arguments are passed to the solver function." 52 | (apply *solver* problem args)) 53 | 54 | ;; Note that the simplex implementations are here in order to avoid a circlar dependency 55 | (defgeneric solution-problem (solution) 56 | (:documentation "Gets the original problem for the solution.") 57 | (:method ((solution tableau)) 58 | (tableau-problem solution))) 59 | 60 | (defgeneric solution-objective-value (solution) 61 | (:documentation "Gets the value of the objective function.") 62 | (:method ((solution tableau)) 63 | (tableau-objective-value solution))) 64 | 65 | (defgeneric solution-variable (solution variable) 66 | (:documentation "Gets the value of the specified variable.") 67 | (:method ((solution tableau) variable) 68 | (tableau-variable solution variable))) 69 | 70 | (defgeneric solution-reduced-cost (solution variable) 71 | (:documentation "Gets the reduced cost of the specified variable. This is the 72 | amount that the objective coefficient for the variable must increase or 73 | decrease, for maximization and minimization problems respectively, before the 74 | given variable appears in an optimal solution.") 75 | (:method ((solution tableau) variable) 76 | (tableau-reduced-cost solution variable))) 77 | 78 | 79 | 80 | ;;; with-* methods 81 | 82 | (defmacro with-solved-problem ((objective-func &rest constraints) &body body) 83 | "Takes the problem description, and evaluates `body` with the variables of the 84 | problem bound to their solution values. Additionally, the macro `reduced-cost` 85 | is locally bound that takes a variable name and provides it's reduced cost." 86 | (let ((problem (parse-linear-problem objective-func constraints))) 87 | (with-gensyms (solution) 88 | `(let ((,solution (solve-problem ,problem))) 89 | (with-solution-variables ,problem ,solution 90 | ,@body))))) 91 | 92 | (defmacro with-solution-variables (var-list solution &body body) 93 | "Evaluates the body with the variables in `var-list` bound to their values in the 94 | solution. Additionally, the macro `reduced-cost` is locally bound that takes a 95 | variable name and provides it's reduced cost." 96 | (once-only (solution) 97 | (let ((body (list `(macrolet ((reduced-cost (var) 98 | `(solution-reduced-cost ,',solution ',var))) 99 | ,@body)))) 100 | (if (typep var-list 'problem) 101 | (let* ((problem var-list) ;alias for readability 102 | (vars (problem-vars problem))) 103 | `(let ((,(problem-objective-var problem) (solution-objective-value ,solution)) 104 | ,@(iter (for var in-vector vars) 105 | (for i from 0) 106 | (collect `(,var (solution-variable ,solution ',var))))) 107 | (declare (ignorable ,(problem-objective-var problem) ,@(map 'list #'identity vars))) 108 | ,@body)) 109 | `(let (,@(iter (for var in-sequence var-list) 110 | (collect `(,var (solution-variable ,solution ',var))))) 111 | ,@body))))) 112 | -------------------------------------------------------------------------------- /src/system-info.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :linear-programming/system-info 2 | (:use :cl 3 | :iterate) 4 | (:import-from :alexandria 5 | #:define-constant) 6 | (:export #:+supported-floats+ 7 | #:optimization-type 8 | #:float-contagion) 9 | (:documentation "Utilities for inspecting how certain implmenetation-dependant features behave.")) 10 | (in-package :linear-programming/system-info) 11 | 12 | (eval-when (:compile-toplevel :load-toplevel) 13 | (define-constant +supported-floats+ 14 | (let ((floats nil)) 15 | ;; sbcl only supports single and double floats, so some branches are unused 16 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) 17 | ;; types that don't have their own representation will get reported as a different type 18 | (when (eq (type-of 0l0) 'long-float) 19 | (push 'long-float floats)) 20 | (when (eq (type-of 0d0) 'double-float) 21 | (push 'double-float floats)) 22 | (when (eq (type-of 0f0) 'single-float) 23 | (push 'single-float floats)) 24 | (when (eq (type-of 0s0) 'short-float) 25 | (push 'short-float floats)) 26 | floats) 27 | :test 'equal ; lists have to be compared with equal 28 | :documentation "Contains the distinct floating point representations supported.")) 29 | 30 | (declaim (inline optimization-type)) 31 | (defun optimization-type (x) 32 | "Gets the type of `x` to optimize for. If `x` is a rational, returns `rational`. 33 | Otherwise, returns the type of `x`." 34 | (if (typep x 'rational) 35 | 'rational 36 | (type-of x))) 37 | 38 | (declaim (inline float-contagion)) 39 | (defun float-contagion (t1 t2) 40 | "Computes the representation type using the rules for float contagion." 41 | (macrolet ((body () 42 | `(locally 43 | (declare (type (member rational ,@+supported-floats+) t1 t2)) 44 | (cond 45 | ((eq t1 t2) t1) ; if the same, it doesn't matter 46 | ((eq t1 'rational) t2) ; if one is rational, then the type of the other is used 47 | ((eq t2 'rational) t1) 48 | ,@(case (length +supported-floats+) 49 | (1 ; if only 1 float type, then the previous cases are sufficient 50 | nil) 51 | (2 ; if 2 float types, at this point there is one of each type 52 | `((t ',(second +supported-floats+)))) 53 | (3 ; if 3 types, need more checking 54 | `(((eq t1 ',(first +supported-floats+)) t2) 55 | ((eq t2 ',(first +supported-floats+)) t1) 56 | (t ',(third +supported-floats+)))) 57 | (4 ; if 4 types, we don't need to pull from +supported-floats+ 58 | `(((eq t1 'short-float) t2) 59 | ((eq t2 'short-float) t1) 60 | ((eq t1 'single-float) t2) 61 | ((eq t2 'single-float) t1) 62 | (t 'long-float)))))))) 63 | (body))) 64 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming/utils 3 | (:use :cl) 4 | (:import-from :alexandria 5 | #:once-only) 6 | (:import-from :linear-programming/conditions 7 | #:invalid-bounds-error) 8 | (:import-from :linear-programming/system-info 9 | #:optimization-type 10 | #:float-contagion) 11 | (:export #:lb-min 12 | #:lb-max 13 | #:ub-min 14 | #:ub-max 15 | #:validate-bounds 16 | 17 | #:fp= 18 | #:fp<= 19 | #:fp>= 20 | #:fp< 21 | #:fp>) 22 | (:documentation "Various internal utilities")) 23 | 24 | (in-package :linear-programming/utils) 25 | 26 | 27 | 28 | ;;; Boundary management 29 | ;; boundary values are represented as a number, or nil for +/- infinity 30 | 31 | (deftype lb () '(or null real)) 32 | (deftype ub () '(or null real)) 33 | 34 | (declaim (inline lb-min lb-max ub-min ub-max)) 35 | 36 | (defun lb-min (x y) 37 | "Computes the minimum value where nil is negative infinity" 38 | (declare (type lb x y)) 39 | (cond 40 | ((null x) x) 41 | ((null y)y) 42 | (t (min x y)))) 43 | 44 | (defun lb-max (x y) 45 | "Computes the maximum value where nil is negative infinity" 46 | (declare (type lb x y)) 47 | (cond 48 | ((null x) y) 49 | ((null y) x) 50 | (t (max x y)))) 51 | 52 | (defun ub-min (x y) 53 | "Computes the minimum value where nil is positive infinity" 54 | (declare (type (or null real) x y)) 55 | (cond 56 | ((null x) y) 57 | ((null y) x) 58 | (t (min x y)))) 59 | 60 | (defun ub-max (x y) 61 | "Computes the maximum value where nil is positive infinity" 62 | (declare (type lb x y)) 63 | (cond 64 | ((null x) x) 65 | ((null y) y) 66 | (t (max x y)))) 67 | 68 | (declaim (inline validate-bounds)) 69 | (defun validate-bounds (lb ub var) 70 | "Checks that the bounds represent a non empty range" 71 | (declare (type lb lb) (type ub ub)) 72 | (when (and lb ub (< ub lb)) 73 | (error 'invalid-bounds-error 74 | :var var 75 | :ub ub 76 | :lb lb))) 77 | 78 | 79 | 80 | ;;; Floating point (in)equality 81 | 82 | (declaim (inline fp=)) 83 | 84 | (defun fp= (a b &optional (factor 16)) 85 | "Tests for equality taking into account floating point error. `factor` is the 86 | acceptable multiple of unit round off that the two values can differ by." 87 | 88 | (case (float-contagion (optimization-type a) (optimization-type b)) 89 | (rational (= a b)) 90 | (short-float (<= (abs (- a b)) (* factor short-float-epsilon))) 91 | (single-float (<= (abs (- a b)) (* factor single-float-epsilon))) 92 | (double-float (<= (abs (- a b)) (* factor double-float-epsilon))) 93 | (long-float (<= (abs (- a b)) (* factor long-float-epsilon))))) 94 | 95 | 96 | (defmacro fp-inequality (name op eps-mod) 97 | (let ((neg-eps-mod (if (eq eps-mod '+) '- '+))) 98 | `(progn 99 | (declaim (inline ,name)) 100 | (defun ,name (a b &optional (factor 16)) 101 | "Tests for inequality taking into account floating point error. `factor` is the 102 | acceptable multiple of unit round off that the two values can differ by." 103 | (case (float-contagion (optimization-type a) (optimization-type b)) 104 | (rational (,op a b)) 105 | (short-float (,op a (,eps-mod b (* factor short-float-epsilon)))) 106 | (single-float (,op a (,eps-mod b (* factor single-float-epsilon)))) 107 | (double-float (,op a (,eps-mod b (* factor double-float-epsilon)))) 108 | (long-float (,op a (,eps-mod b (* factor long-float-epsilon)))))) 109 | 110 | (define-compiler-macro ,name (&whole form a b &optional (factor 16)) 111 | (if (typep a 'real) 112 | (once-only (b) 113 | `(case (float-contagion ',(optimization-type a) (optimization-type ,b)) 114 | (rational (,',op ,a ,b)) 115 | (short-float (,',op (,',neg-eps-mod ,a (* ,factor short-float-epsilon)) ,b)) 116 | (single-float (,',op (,',neg-eps-mod ,a (* ,factor single-float-epsilon)) ,b)) 117 | (double-float (,',op (,',neg-eps-mod ,a (* ,factor double-float-epsilon)) ,b)) 118 | (long-float (,',op (,',neg-eps-mod ,a (* ,factor long-float-epsilon)) ,b)))) 119 | form))))) 120 | 121 | (fp-inequality fp<= <= +) 122 | (fp-inequality fp>= >= -) 123 | (fp-inequality fp< < -) 124 | (fp-inequality fp> > +) 125 | -------------------------------------------------------------------------------- /t/all.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming-test/all 3 | (:nicknames :linear-programming-test) 4 | (:use-reexport :linear-programming-test/base 5 | :linear-programming-test/system-info 6 | :linear-programming-test/utils 7 | :linear-programming-test/expressions 8 | :linear-programming-test/problem 9 | :linear-programming-test/simplex 10 | :linear-programming-test/solver 11 | :linear-programming-test/external-formats 12 | 13 | :linear-programming-test/integration)) 14 | -------------------------------------------------------------------------------- /t/base.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming-test/base 3 | (:use :cl 4 | :fiveam) 5 | (:export #:linear-programming)) 6 | 7 | (in-package :linear-programming-test/base) 8 | 9 | (def-suite* linear-programming 10 | :description "The base suite for the linear programming library tests") 11 | -------------------------------------------------------------------------------- /t/data/advanced-problem.mps: -------------------------------------------------------------------------------- 1 | *This is a less trivial MPS problem to test the MPS reader 2 | name simple 3 | rows 4 | N obj 5 | L row1 6 | L row2 7 | G row3 8 | columns 9 | w obj -1 row3 1 10 | X obj 1 row1 3 11 | X row3 2 12 | Y obj 4.5 row1 1 13 | Y row2 1 14 | Z obj 8 row2 2 15 | Z row3 -1 16 | RHS 17 | testrhs row1 10 row2 18 18 | testrhs row3 6 19 | rhs1 row1 8 row2 10 20 | rhs1 row3 -1 21 | bounds 22 | BV wbin w 23 | LO z Z 0 24 | UP z Z 4 25 | FR freex X 26 | objsense 27 | min 28 | ENDATA 29 | -------------------------------------------------------------------------------- /t/data/simple-problem-crlf.mps: -------------------------------------------------------------------------------- 1 | *This is a simple MPS problem to test the MPS reader 2 | NAME simple 3 | ROWS 4 | N obj 5 | L row1 6 | L row2 7 | COLUMNS 8 | X obj 1 row1 3 9 | Y obj 4 row1 1 10 | Y row2 1 11 | Z obj 8 row2 2 12 | RHS 13 | rhs1 row1 8 row2 7 14 | ENDATA 15 | -------------------------------------------------------------------------------- /t/data/simple-problem.mps: -------------------------------------------------------------------------------- 1 | *This is a simple MPS problem to test the MPS reader 2 | NAME simple 3 | ROWS 4 | N obj 5 | L row1 6 | L row2 7 | COLUMNS 8 | X obj 1 row1 3 9 | Y obj 4 row1 1 10 | Y row2 1 11 | Z obj 8 row2 2 12 | RHS 13 | rhs1 row1 8 row2 7 14 | ENDATA 15 | -------------------------------------------------------------------------------- /t/expressions.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming-test/expressions 3 | (:use :cl 4 | :fiveam 5 | :linear-programming-test/base 6 | :linear-programming-test/test-utils 7 | :linear-programming/conditions 8 | :linear-programming/expressions) 9 | (:export #:expressions)) 10 | 11 | (in-package :linear-programming-test/expressions) 12 | 13 | (def-suite expressions 14 | :in linear-programming 15 | :description "The suite to test linear-programming/expressions") 16 | (in-suite expressions) 17 | 18 | (test linear-constant-p 19 | (declare (notinline linear-programming/expressions::linear-constant-p)) 20 | (is-true (linear-programming/expressions::linear-constant-p 21 | (parse-linear-expression 5))) 22 | (is-true (linear-programming/expressions::linear-constant-p 23 | (parse-linear-expression 2/3))) 24 | (is-true (linear-programming/expressions::linear-constant-p 25 | (parse-linear-expression -1.0))) 26 | 27 | (is-false (linear-programming/expressions::linear-constant-p 28 | (parse-linear-expression 'x))) 29 | (is-false (linear-programming/expressions::linear-constant-p 30 | (parse-linear-expression '(+ x 5))))) 31 | 32 | (test scale-linear-expression 33 | (declare (notinline scale-linear-expression)) 34 | (is (equal '((a . 24) (b . 7/2) (c . 4.5)) 35 | (scale-linear-expression '((a . 8) (b . 7/6) (c . 1.5)) 36 | 3))) 37 | (is (equal nil 38 | (scale-linear-expression nil 3))) 39 | (is (equal '((a . 4) (b . 7/12) (c . .75)) 40 | (scale-linear-expression '((a . 8) (b . 7/6) (c . 1.5)) 41 | 1/2)))) 42 | 43 | (test sum-linear-expressions 44 | (declare (notinline sum-linear-expressions)) 45 | (is (eq nil (sum-linear-expressions))) 46 | (is (eq nil (sum-linear-expressions nil))) 47 | (is (eq nil (sum-linear-expressions nil nil))) 48 | (is (eq nil (sum-linear-expressions nil nil nil))) 49 | 50 | (is (set-equal '((a . 8) (b . 7/6) (c . 1.5)) 51 | (sum-linear-expressions '((a . 8) (b . 7/6) (c . 1.5))))) 52 | (is (set-equal '((a . 12) (b . 19/6) (c . 2.0) (d . 6) (e . 7/4)) 53 | (sum-linear-expressions '((a . 8) (b . 7/6) (c . 1.5) (d . 6)) 54 | '((a . 4) (b . 2) (c . 1/2) (e . 7/4)))))) 55 | 56 | (test parse-linear-expression 57 | (is (set-equal '((a . 1) (+constant+ . 5) (b . 8) (c . 1)) 58 | (parse-linear-expression '(+ a 5 (* 8 b) (+ c))))) 59 | (is (set-equal '((+constant+ . 6) (x . 2)) 60 | (parse-linear-expression '(+ (* 2 3) (* x 2))))) 61 | (is (set-equal '((x . -1) (y . 1) (z . -3)) 62 | (parse-linear-expression '(+ (- x) (- y (* 3 z)))))) 63 | (is (set-equal '((+constant+ . 116) (x . 14)) 64 | (parse-linear-expression '(+ (* 3 4 5) (* 1 (+ 3 4) 2 (+ x 4)))))) 65 | (is (set-equal '((+constant+ . 1/2)) 66 | (parse-linear-expression '(/ 2)))) 67 | (is (set-equal '((x . 1/2) (+constant+ . 3/2)) 68 | (parse-linear-expression '(/ (+ 3 x) 2)))) 69 | (is (set-equal '((a . 1) (+constant+ . 5) (b . 8) (c . 1)) 70 | (parse-linear-expression '(:alist (a . 1) (+constant+ . 5) (b . 8) (c . 1))))) 71 | (is (set-equal '((a . 1) (+constant+ . 5) (b . 8) (c . 1)) 72 | (parse-linear-expression '(:plist a 1 +constant+ 5 b 8 c 1)))) 73 | (is (set-equal '((+constant+ . 5) (x . 6) (y . 1)) 74 | (parse-linear-expression '(+ (:plist +constant+ 5 x 4) (:alist (x . 2) (y . 1)))))) 75 | (signals nonlinear-error (parse-linear-expression '(* x y))) 76 | (signals nonlinear-error (parse-linear-expression '(/ x))) 77 | (signals nonlinear-error (parse-linear-expression '(/ x y))) 78 | (signals parsing-error (parse-linear-expression '"x + y")) 79 | (signals nonlinear-error (parse-linear-expression '(log 3)))) 80 | 81 | 82 | (test format-linear-expression 83 | (is (equal '(+ (* 5 x) (* 2 y) 5) 84 | (format-linear-expression '((x . 5) (y . 2) (+constant+ . 5)))))) 85 | -------------------------------------------------------------------------------- /t/external-formats.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming-test/external-formats 3 | (:use :cl 4 | :fiveam 5 | :linear-programming-test/base 6 | :linear-programming-test/test-utils 7 | :linear-programming/external-formats 8 | :linear-programming/problem) 9 | (:export #:external-formats)) 10 | 11 | (in-package :linear-programming-test/external-formats) 12 | 13 | (def-suite external-formats 14 | :in linear-programming 15 | :description "The suite to test linear-programming/external-formats") 16 | (in-suite external-formats) 17 | 18 | (def-suite sexp 19 | :in external-formats 20 | :description "The suite to test sexp representation of linear problems") 21 | (in-suite sexp) 22 | 23 | (test read-sexp 24 | (let ((problem (with-input-from-string (stream "((max (+ x (* 4 y) (* 8 z))) 25 | (<= (+ x y) 8) 26 | (<= (+ (* 2 y) z) 7))") 27 | (read-sexp stream)))) 28 | (is (typep problem 'problem)) 29 | (is (eq 'max (problem-type problem))) 30 | (is (typep (problem-vars problem) 'vector)) 31 | (is-true (null (symbol-package (problem-objective-var problem)))) 32 | (is (set-equal '(cl-user::x cl-user::y cl-user::z) 33 | (map 'list #'identity (problem-vars problem)))) 34 | (is (set-equal '((cl-user::x . 1) (cl-user::y . 4) (cl-user::z . 8)) 35 | (problem-objective-func problem))) 36 | (is (set-equal '() 37 | (problem-integer-vars problem))) 38 | (is (set-equal '() 39 | (problem-var-bounds problem))) 40 | (is (simple-linear-constraint-set-equal '((<= ((cl-user::x . 1) (cl-user::y . 1)) 8) (<= ((cl-user::y . 2) (cl-user::z . 1)) 7)) 41 | (problem-constraints problem)))) 42 | 43 | (let ((problem (with-input-from-string (stream "((max (+ x (* 4 y) (* 8 z))) 44 | (<= (+ x y) 8) 45 | (<= (+ y z) 7) 46 | (linear-programming/problem:bounds (y)))") 47 | (read-sexp stream)))) 48 | (is (typep problem 'problem)) 49 | (is (eq 'max (problem-type problem))) 50 | (is (typep (problem-vars problem) 'vector)) 51 | (is-true (null (symbol-package (problem-objective-var problem)))) 52 | (is (set-equal '(cl-user::x cl-user::y cl-user::z) 53 | (map 'list #'identity (problem-vars problem)))) 54 | (is (set-equal '((cl-user::x . 1) (cl-user::y . 4) (cl-user::z . 8)) 55 | (problem-objective-func problem))) 56 | (is (set-equal '() 57 | (problem-integer-vars problem))) 58 | (is (set-equal '((cl-user::y . (nil . nil))) 59 | (problem-var-bounds problem))) 60 | (is (simple-linear-constraint-set-equal '((<= ((cl-user::x . 1) (cl-user::y . 1)) 8) (<= ((cl-user::y . 1) (cl-user::z . 1)) 7)) 61 | (problem-constraints problem)))) 62 | 63 | ;; read eval 64 | (signals error (with-input-from-string (stream "((max (+ x (* 4 y) (* 8 z))) 65 | (<= (+ x y) #.(+ 4 4)) 66 | (<= (+ y z) 7))") 67 | (read-sexp stream))) 68 | (let ((problem (with-input-from-string (stream "((max (+ x (* 4 y) (* 8 z))) 69 | (<= (+ x y) #.(+ 4 4)) 70 | (<= (+ y z) 7))") 71 | (read-sexp stream :allow-read-eval t)))) 72 | (is (typep problem 'problem)) 73 | (is (eq 'max (problem-type problem))) 74 | (is (typep (problem-vars problem) 'vector)) 75 | (is-true (null (symbol-package (problem-objective-var problem)))) 76 | (is (set-equal '(cl-user::x cl-user::y cl-user::z) 77 | (map 'list #'identity (problem-vars problem)))) 78 | (is (set-equal '((cl-user::x . 1) (cl-user::y . 4) (cl-user::z . 8)) 79 | (problem-objective-func problem))) 80 | (is (set-equal '() 81 | (problem-integer-vars problem))) 82 | (is (simple-linear-constraint-set-equal '((<= ((cl-user::x . 1) (cl-user::y . 1)) 8) (<= ((cl-user::y . 1) (cl-user::z . 1)) 7)) 83 | (problem-constraints problem)))) 84 | 85 | ;;specify package 86 | (let ((problem (with-input-from-string (stream "((max (+ x (* 4 y) (* 8 z))) 87 | (<= (+ x y) 8) 88 | (<= (+ y z) 7))") 89 | (read-sexp stream :package :linear-programming-test/external-formats)))) 90 | (is (typep problem 'problem)) 91 | (is (eq 'max (problem-type problem))) 92 | (is (typep (problem-vars problem) 'vector)) 93 | (is-true (null (symbol-package (problem-objective-var problem)))) 94 | (is (set-equal '(x y z) 95 | (map 'list #'identity (problem-vars problem)))) 96 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 97 | (problem-objective-func problem))) 98 | (is (set-equal '() 99 | (problem-integer-vars problem))) 100 | (is (set-equal '() 101 | (problem-var-bounds problem))) 102 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) (<= ((y . 1) (z . 1)) 7)) 103 | (problem-constraints problem))) 104 | 105 | ;;Only read sexp 106 | (let ((problem (with-input-from-string (stream "((max (+ x (* 4 y) (* 8 z))) 107 | (<= (+ x y) 8) 108 | (<= (+ y z) 7))456") 109 | (prog1 110 | (read-sexp stream :package :linear-programming-test/external-formats) 111 | (is (= (read stream) 456)))))) 112 | (is (typep problem 'problem)) 113 | (is (eq 'max (problem-type problem))) 114 | (is (typep (problem-vars problem) 'vector)) 115 | (is-true (null (symbol-package (problem-objective-var problem)))) 116 | (is (set-equal '(x y z) 117 | (map 'list #'identity (problem-vars problem)))) 118 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 119 | (problem-objective-func problem))) 120 | (is (set-equal '() 121 | (problem-integer-vars problem))) 122 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) (<= ((y . 1) (z . 1)) 7)) 123 | (problem-constraints problem)))))) 124 | 125 | 126 | (test write-sexp 127 | (let* ((base-problem (parse-linear-problem '(max (+ x (* 4 y) (* 8 z))) 128 | '((<= (+ x y) 8) 129 | (<= (+ y z) 7)))) 130 | (string (with-output-to-string (stream) 131 | (write-sexp stream base-problem))) 132 | (parsed-problem (with-input-from-string (stream string) 133 | (read-sexp stream)))) 134 | (is (typep parsed-problem 'problem)) 135 | (is (eq 'max (problem-type parsed-problem))) 136 | (is (typep (problem-vars parsed-problem) 'vector)) 137 | (is-true (null (symbol-package (problem-objective-var parsed-problem)))) 138 | (is (set-equal '(x y z) 139 | (map 'list #'identity (problem-vars parsed-problem)))) 140 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 141 | (problem-objective-func parsed-problem))) 142 | (is (set-equal '() 143 | (problem-integer-vars parsed-problem))) 144 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) (<= ((y . 1) (z . 1)) 7)) 145 | (problem-constraints parsed-problem)))) 146 | 147 | (let* ((base-problem (parse-linear-problem '(max (+ x (* 4 y) (* 8 z))) 148 | '((<= (+ x y) 8) 149 | (<= (+ y z) 7) 150 | (bounds (y))))) 151 | (string (with-output-to-string (stream) 152 | (write-sexp stream base-problem))) 153 | (parsed-problem (with-input-from-string (stream string) 154 | (read-sexp stream)))) 155 | (is (typep parsed-problem 'problem)) 156 | (is (eq 'max (problem-type parsed-problem))) 157 | (is (typep (problem-vars parsed-problem) 'vector)) 158 | (is-true (null (symbol-package (problem-objective-var parsed-problem)))) 159 | (is (set-equal '(x y z) 160 | (map 'list #'identity (problem-vars parsed-problem)))) 161 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 162 | (problem-objective-func parsed-problem))) 163 | (is (set-equal '() 164 | (problem-integer-vars parsed-problem))) 165 | (is (set-equal '((y . (nil . nil))) 166 | (problem-var-bounds parsed-problem))) 167 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) (<= ((y . 1) (z . 1)) 7)) 168 | (problem-constraints parsed-problem)))) 169 | 170 | (let* ((base-problem (parse-linear-problem '(min (= w (+ (* 0.2 x) y))) 171 | '((>= (+ x y) 4.2) 172 | (integer x)))) 173 | 174 | (string (with-output-to-string (stream) 175 | (write-sexp stream base-problem))) 176 | (parsed-problem (with-input-from-string (stream string) 177 | (read-sexp stream)))) 178 | (is (typep parsed-problem 'problem)) 179 | (is (eq 'min (problem-type parsed-problem))) 180 | (is (typep (problem-vars parsed-problem) 'vector)) 181 | (is (equal 'w (problem-objective-var parsed-problem))) 182 | (is (set-equal '(x y) 183 | (map 'list #'identity (problem-vars parsed-problem)))) 184 | (is (set-equal '((x . 0.2) (y . 1)) 185 | (problem-objective-func parsed-problem))) 186 | (is (set-equal '(x) 187 | (problem-integer-vars parsed-problem))) 188 | (is (simple-linear-constraint-set-equal '((>= ((x . 1) (y . 1)) 4.2)) 189 | (problem-constraints parsed-problem)))) 190 | 191 | ;;specify package 192 | (let* ((base-problem (parse-linear-problem '(max (+ x (* 4 y) (* 8 z))) 193 | '((<= (+ x y) 8) 194 | (<= (+ y z) 7)))) 195 | (string (with-output-to-string (stream) 196 | (write-sexp stream base-problem :package :linear-programming))) 197 | (parsed-problem (with-input-from-string (stream string) 198 | (read-sexp stream :package (find-package :linear-programming))))) 199 | (is (typep parsed-problem 'problem)) 200 | (is (eq 'max (problem-type parsed-problem))) 201 | (is (typep (problem-vars parsed-problem) 'vector)) 202 | (is-true (null (symbol-package (problem-objective-var parsed-problem)))) 203 | (is (set-equal '(x y z) 204 | (map 'list #'identity (problem-vars parsed-problem)))) 205 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 206 | (problem-objective-func parsed-problem))) 207 | (is (set-equal '() 208 | (problem-integer-vars parsed-problem))) 209 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) (<= ((y . 1) (z . 1)) 7)) 210 | (problem-constraints parsed-problem))))) 211 | 212 | (test read-mps 213 | (with-open-file (stream (merge-pathnames "t/data/simple-problem.mps" 214 | (asdf:system-source-directory :linear-programming-test)) 215 | :direction :input 216 | :external-format :utf-8) 217 | (let ((problem (read-mps stream 'max))) 218 | (is (typep problem 'problem)) 219 | (is (eq 'max (problem-type problem))) 220 | (is-true (null (symbol-package (problem-objective-var problem)))) 221 | (is (set-equal '(x y z) 222 | (map 'list #'identity (problem-vars problem)))) 223 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 224 | (problem-objective-func problem))) 225 | (is (set-equal '() 226 | (problem-integer-vars problem))) 227 | (is (set-equal '() 228 | (problem-var-bounds problem))) 229 | (is (simple-linear-constraint-set-equal '((<= ((x . 3) (y . 1)) 8) (<= ((y . 1) (z . 2)) 7)) 230 | (problem-constraints problem))))) 231 | (with-open-file (stream (merge-pathnames "t/data/advanced-problem.mps" 232 | (asdf:system-source-directory :linear-programming-test)) 233 | :direction :input 234 | :external-format :utf-8) 235 | (let ((problem (read-mps stream nil :read-case :preserve :rhs-id "rhs1"))) 236 | (is (typep problem 'problem)) 237 | (is (eq 'min (problem-type problem))) 238 | (is-true (null (symbol-package (problem-objective-var problem)))) 239 | (is (set-equal '(|w| x y z) 240 | (map 'list #'identity (problem-vars problem)))) 241 | (is (set-equal '((|w| . -1) (x . 1) (y . 9/2) (z . 8)) 242 | (problem-objective-func problem))) 243 | (is (set-equal '(|w|) 244 | (problem-integer-vars problem))) 245 | (is (set-equal '((z . (0 . 4)) (|w| . (0 . 1)) (x . (nil . nil))) 246 | (problem-var-bounds problem))) 247 | (is (simple-linear-constraint-set-equal '((<= ((x . 3) (y . 1)) 8) (<= ((y . 1) (z . 2)) 10) (<= ((|w| . -1) (x . -2) (z . 1)) 1)) 248 | (problem-constraints problem))))) 249 | 250 | ; Test input modes 251 | (with-open-file (stream (merge-pathnames "t/data/advanced-problem.mps" 252 | (asdf:system-source-directory :linear-programming-test)) 253 | :direction :input 254 | :external-format :utf-8) 255 | (let ((problem (read-mps stream nil :read-case :upcase :rhs-id "rhs1"))) 256 | (is (set-equal '(|W| |X| |Y| |Z|) 257 | (map 'list #'identity (problem-vars problem)))))) 258 | (with-open-file (stream (merge-pathnames "t/data/advanced-problem.mps" 259 | (asdf:system-source-directory :linear-programming-test)) 260 | :direction :input 261 | :external-format :utf-8) 262 | (let ((problem (read-mps stream nil :read-case :downcase :rhs-id "rhs1"))) 263 | (is (set-equal '(|w| |x| |y| |z|) 264 | (map 'list #'identity (problem-vars problem)))))) 265 | (with-open-file (stream (merge-pathnames "t/data/advanced-problem.mps" 266 | (asdf:system-source-directory :linear-programming-test)) 267 | :direction :input 268 | :external-format :utf-8) 269 | (let ((problem (read-mps stream nil :read-case :invert :rhs-id "rhs1"))) 270 | (is (set-equal '(|W| |x| |y| |z|) 271 | (map 'list #'identity (problem-vars problem)))))) 272 | 273 | ; Test windows line endings 274 | (with-open-file (stream (merge-pathnames "t/data/simple-problem-crlf.mps" 275 | (asdf:system-source-directory :linear-programming-test)) 276 | :direction :input 277 | :external-format :utf-8) 278 | (let ((problem (read-mps stream 'max))) 279 | (is (typep problem 'problem)) 280 | (is (eq 'max (problem-type problem))) 281 | (is-true (null (symbol-package (problem-objective-var problem)))) 282 | (is (set-equal '(x y z) 283 | (map 'list #'identity (problem-vars problem)))) 284 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 285 | (problem-objective-func problem))) 286 | (is (set-equal '() 287 | (problem-integer-vars problem))) 288 | (is (set-equal '() 289 | (problem-var-bounds problem))) 290 | (is (simple-linear-constraint-set-equal '((<= ((x . 3) (y . 1)) 8) (<= ((y . 1) (z . 2)) 7)) 291 | (problem-constraints problem)))))) 292 | 293 | (test write-standard-format 294 | (let* ((problem (make-linear-problem (max (+ x y)) (<= (+ (* 2 x) y) 5))) 295 | (output (with-output-to-string (stream) 296 | (write-standard-format stream problem)))) 297 | (is (string-equal "Maximize " (subseq output 0 9))) 298 | (is (search "X" output)) 299 | (is (search "Y" output)) 300 | (is (search "≤" output)) 301 | (is (not (search "<" output))) 302 | (is (not (search "integer" output :test #'char-equal)))) 303 | (let* ((problem (make-linear-problem (max (+ x y)) (<= (+ (* 2 x) y) 5))) 304 | (output (with-output-to-string (stream) 305 | (write-standard-format stream problem :unicodep nil)))) 306 | (is (string-equal "Maximize " (subseq output 0 9))) 307 | (is (search "X" output)) 308 | (is (search "Y" output)) 309 | (is (not (search "≤" output))) 310 | (is (search "<" output))) 311 | 312 | (let* ((problem (make-linear-problem (max (+ #:x #:y)) (<= (+ (* 2 #:x) #:y) 5))) 313 | (output (with-output-to-string (stream) 314 | (write-standard-format stream problem :aesthetic-variable-names-p t)))) 315 | (is (string-equal "Maximize " (subseq output 0 9))) 316 | (is (search "X" output)) 317 | (is (not (search "#:X" output))) 318 | (is (search "Y" output)) 319 | (is (not (search "#:Y" output)))) 320 | (let* ((problem (make-linear-problem (max (+ #:x #:y)) (<= (+ (* 2 #:x) #:y) 5))) 321 | (output (with-output-to-string (stream) 322 | (write-standard-format stream problem :aesthetic-variable-names-p nil)))) 323 | (is (string-equal "Maximize " (subseq output 0 9))) 324 | (is (not (search " X" output))) 325 | (is (search "#:X" output)) 326 | (is (not (search " Y" output))) 327 | (is (search "#:Y" output))) 328 | 329 | (let* ((problem (make-linear-problem (max (+ x y)) (<= (+ (* 2 x) y) 5) (integer x y))) 330 | (output (with-output-to-string (stream) 331 | (write-standard-format stream problem)))) 332 | (is (string-equal "Maximize " (subseq output 0 9))) 333 | (is (search "X" output)) 334 | (is (search "Y" output)) 335 | (is (search "≤" output)) 336 | (is (not (search "<" output))) 337 | (is (search "integer" output :test #'char-equal)))) 338 | -------------------------------------------------------------------------------- /t/integration.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming-test/integration 3 | (:use :cl 4 | :fiveam 5 | :linear-programming-test/base 6 | :linear-programming) 7 | (:import-from :linear-programming/utils 8 | #:fp=) 9 | (:export #:integration)) 10 | 11 | (in-package :linear-programming-test/integration) 12 | 13 | (def-suite integration 14 | :in linear-programming 15 | :description "The suite for integration tests") 16 | (in-suite integration) 17 | 18 | (test basic-problem 19 | ; An Assembly-balancing problem 20 | ; "A company has 4 departments. Each department uses a different method to 21 | ; produce components A and B from raw materials 1 and 2. 22 | ; Dept input per run output per run 23 | ; ___ _1_ _2_ _A_ _B_ 24 | ; 1 8 6 7 5 25 | ; 2 5 9 6 9 26 | ; 3 3 8 8 4 27 | ; Finished widgets are assembled from 4 units of A and 3 units of B. 100 28 | ; units of material 1 and 200 units of material 2 are avalible. Maximize the 29 | ; number of widgets produced." 30 | ; Additionally, widgets are sold at $3 per unit to increase the coverage of 31 | ; this test. 32 | (with-solved-problem ((= revenue (max (* 3 widgets))) 33 | ; construction of widgets 34 | (<= (+ (* 4 widgets) (* -7 d1) 35 | (* -6 d2) (* -8 d3)) 36 | 0) 37 | (<= (+ (* 3 widgets) (* -5 d1) 38 | (* -9 d2) (* -4 d3)) 39 | 0) 40 | ; resource constraints 41 | (<= (+ (* 8 d1) (* 5 d2) (* 3 d3)) 100) 42 | (<= (+ (* 6 d1) (* 9 d2) (* 8 d3)) 200)) 43 | 44 | (is (<= 136.08 revenue 136.11) 45 | (format nil "Computed revenue of ~A, instead of 136.08-136.11" 46 | (float revenue))) 47 | (is (<= 45.36 widgets 45.37) 48 | (format nil "Computed ~A widgets, instead of 45.36-45.37" (float widgets))) 49 | (is (= 0 (reduced-cost widgets))) 50 | (is (<= 2.37 d1 2.38) 51 | (format nil "Computed ~A dept 1 runs, instead of 2.37-2.38" (float d1))) 52 | (is (= 0 (reduced-cost d1))) 53 | (is (<= 6.96 d2 6.97) 54 | (format nil "Computed ~A dept 2 runs, instead of 6.96-6.97" (float d2))) 55 | (is (= 0 (reduced-cost d2))) 56 | (is (<= 15.37 d3 15.38) 57 | (format nil "Computed ~A dept 3 runs, instead of 15.37-15.38" (float d3))) 58 | (is (= 0 (reduced-cost d3))))) 59 | 60 | 61 | (test excessive-constraints 62 | ; This problem caused some issues when trying to solve it. 63 | (with-solved-problem ((min a) 64 | (<= 0 (+ 148 (* 49 a)) (* 255 a)) 65 | (<= 0 (+ 135 (* 49 a)) (* 255 a)) 66 | (<= 0 (+ 134 (* 49 a)) (* 255 a)) 67 | (<= 0 a 1)) 68 | (is (= 74/103 a)) 69 | (is (= 0 (reduced-cost a))))) 70 | 71 | 72 | (test numerial-issue 73 | ;; This problem exposed a bug with floating point round off 74 | (with-solved-problem ((= z (min (+ b (* 0.6861807 a)))) 75 | (>= (+ b (* 0.6861807 a)) 0.9372585) 76 | (>= (+ b (* 0.7776901 a)) 0.7461006) 77 | (>= (+ b (* 0.14247864 a)) 0.38555977)) 78 | (is (fp= 0.9372585 z)) 79 | ;; Note that there are multiple solutions 80 | (is (fp= z (+ b (* 0.6861807 a)))))) 81 | 82 | (test ilp-bugs 83 | (with-solved-problem 84 | ((min w) 85 | (INTEGER x T185 E T184 D T183 C T182 B T181 A T180 w) 86 | (bounds (1 x 1)) 87 | (= (+ (* -1 x) (* 1 T185)) 0) (= (+ (* -1 E) (* 1 T184)) 0) 88 | (= (+ (* -1 D) (* 1 T183)) 0) (= (+ (* -1 C) (* 1 T182)) 0) 89 | (= (+ (* -1 B) (* 1 T181)) 0) (= (+ (* -1 A) (* 10 T180)) 0) 90 | (<= (+ (* -1 E) (* 1 T185)) 0) (<= (+ (* -1 D) (* 1 T184)) 0) 91 | (<= (+ (* -1 C) (* 1 T183)) 0) (<= (+ (* -1 B) (* 1 T182)) 0) 92 | (<= (+ (* -1 A) (* 7 T182) (* 7 T183) (* 7 T184) (* 7 T185)) 0) 93 | (<= 94 | (+ (* -1 w) (* 171 T1) (* 114 T3) (* 189 T10) (* 121 T15) (* 156 T18) 95 | (* 185 T52) (* 111 T54) (* 141 T63) (* 156 T72) (* 185 T106) (* 111 T108) 96 | (* 141 T117) (* 156 T126) (* 185 T160) (* 111 T162) (* 141 T171) 97 | (* 10 T180) (* 1 T181)) 98 | 0)) 99 | (is (= 31 w))) 100 | 101 | (with-solved-problem ((min (+ x y z)) 102 | (integer x y z) 103 | (>= (+ x y (* 9 z)) 30/16) 104 | (>= (+ (* 3/2 x) (* 78/64 y) z) 32/11)) 105 | (is (= 2 x)) 106 | (is (= 0 y)) 107 | (is (= 0 z)))) 108 | 109 | (test variable-bounds-bug 110 | ; from https://github.com/neil-lindquist/linear-programming/issues/11 111 | (with-solved-problem 112 | ((min (= w (+ x y))) 113 | (>= x 1.0) 114 | (>= y 1.0) 115 | (>= (+ x (* 2.0 y)) 2.0)) 116 | (is (= 1.0 x)) 117 | (is (= 1.0 y)) 118 | 119 | (with-solved-problem 120 | ((min (= w (+ x y))) 121 | (>= x 1.0) 122 | (>= y 1.0)) 123 | (is (= 1.0 x)) 124 | (is (= 1.0 y))))) 125 | -------------------------------------------------------------------------------- /t/problem.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming-test/problem 3 | (:use :cl 4 | :fiveam 5 | :linear-programming-test/base 6 | :linear-programming-test/test-utils 7 | :linear-programming/problem) 8 | (:export #:problem)) 9 | 10 | (in-package :linear-programming-test/problem) 11 | 12 | (def-suite problem 13 | :in linear-programming 14 | :description "The suite to test linear-programming/problem") 15 | (in-suite problem) 16 | 17 | (test make-linear-problem 18 | (signals parsing-error 19 | (make-linear-problem (avg (+ x (* 4 y) (* 8 z))) 20 | (<= (+ x y) 8) 21 | (<= (+ y z) 7))) 22 | 23 | (signals parsing-error 24 | (make-linear-problem (min (+ x (* 4 y) (* 8 z))) 25 | (& (+ x y) 8) 26 | (<= (+ y z) 7))) 27 | 28 | (signals parsing-error 29 | (make-linear-problem (min (+ x (* 4 y) (* 8 z))) 30 | (<= (+ x y) 8) 31 | (<= (+ y z) 7) 32 | (foobar x))) 33 | 34 | (let ((problem (make-linear-problem (max (+ x (* 4 y) (* 8 z))) 35 | (<= (+ x y) 8) 36 | (<= (+ y z) 7)))) 37 | (is (typep problem 'problem)) 38 | (is (eq 'max (problem-type problem))) 39 | (is (typep (problem-vars problem) 'vector)) 40 | (is-true (null (symbol-package (problem-objective-var problem)))) 41 | (is (set-equal '(x y z) 42 | (map 'list #'identity (problem-vars problem)))) 43 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 44 | (problem-objective-func problem))) 45 | (is (set-equal '() 46 | (problem-integer-vars problem))) 47 | (is (set-equal '() 48 | (problem-var-bounds problem))) 49 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) (<= ((y . 1) (z . 1)) 7)) 50 | (problem-constraints problem)))) 51 | 52 | (let ((problem (make-linear-problem (max (+ x (* 4 y) (* 8 z))) 53 | (<= (+ (* 2 x) y) 8) 54 | (<= (+ y z) 7) 55 | (>= (+ x z) 1) 56 | (<= x y)))) 57 | (is (typep problem 'problem)) 58 | (is (eq 'max (problem-type problem))) 59 | (is (typep (problem-vars problem) 'vector)) 60 | (is-true (null (symbol-package (problem-objective-var problem)))) 61 | (is (set-equal '(x y z) 62 | (map 'list #'identity (problem-vars problem)))) 63 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 64 | (problem-objective-func problem))) 65 | (is (set-equal '() 66 | (problem-integer-vars problem))) 67 | (is (set-equal '() 68 | (problem-var-bounds problem))) 69 | (is (simple-linear-constraint-set-equal '((<= ((x . 2) (y . 1)) 8) 70 | (<= ((y . 1) (z . 1)) 7) 71 | (>= ((x . 1) (z . 1)) 1) 72 | (<= ((x . 1) (y . -1)) 0)) 73 | (problem-constraints problem)))) 74 | 75 | (let ((problem (make-linear-problem (max (+ x (* 4 y) (* 8 z))) 76 | (<= (+ (* 2 x) y) 8) 77 | (<= (+ y z) 7) 78 | (= (+ (* 2 x) y z) 8)))) 79 | (is (typep problem 'problem)) 80 | (is (eq 'max (problem-type problem))) 81 | (is (typep (problem-vars problem) 'vector)) 82 | (is-true (null (symbol-package (problem-objective-var problem)))) 83 | (is (set-equal '(x y z) 84 | (map 'list #'identity (problem-vars problem)))) 85 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 86 | (problem-objective-func problem))) 87 | (is (set-equal '() 88 | (problem-integer-vars problem))) 89 | (is (set-equal '() 90 | (problem-var-bounds problem))) 91 | (is (simple-linear-constraint-set-equal '((<= ((x . 2) (y . 1)) 8) 92 | (<= ((y . 1) (z . 1)) 7) 93 | (= ((x . 2) (y . 1) (z . 1)) 8)) 94 | (problem-constraints problem)))) 95 | 96 | (let ((problem (make-linear-problem (min x) 97 | (<= x 8)))) 98 | (is (typep problem 'problem)) 99 | (is (eq 'min (problem-type problem))) 100 | (is (typep (problem-vars problem) 'vector)) 101 | (is-true (null (symbol-package (problem-objective-var problem)))) 102 | (is (set-equal '(x) 103 | (map 'list #'identity (problem-vars problem)))) 104 | (is (set-equal '((x . 1)) 105 | (problem-objective-func problem))) 106 | (is (set-equal '() 107 | (problem-integer-vars problem))) 108 | (is (set-equal '((x . (0 . 8))) 109 | (problem-var-bounds problem))) 110 | (is (simple-linear-constraint-set-equal '() 111 | (problem-constraints problem)))) 112 | 113 | ; integer constraint 114 | (let ((problem (make-linear-problem (max (= total (+ x (* -4 y) (* 8 z)))) 115 | (<= (+ x y) 8) 116 | (<= (+ (* -1 y) z) 7) 117 | (integer y)))) 118 | (is (typep problem 'problem)) 119 | (is (eq 'max (problem-type problem))) 120 | (is (typep (problem-vars problem) 'vector)) 121 | (is (eq 'total (problem-objective-var problem))) 122 | (is (set-equal '(x y z) 123 | (map 'list #'identity (problem-vars problem)))) 124 | (is (set-equal '((x . 1) (y . -4) (z . 8)) 125 | (problem-objective-func problem))) 126 | (is (set-equal '(y) 127 | (problem-integer-vars problem))) 128 | (is (set-equal '() 129 | (problem-var-bounds problem))) 130 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) (<= ((y . -1) (z . 1)) 7)) 131 | (problem-constraints problem)))) 132 | 133 | ;binary variable 134 | (let ((problem (make-linear-problem (max (= total (+ x (* -4 y) (* 8 z)))) 135 | (<= (+ x y) 8) 136 | (<= (+ (* -1 y) z) 7) 137 | (binary y)))) 138 | (is (typep problem 'problem)) 139 | (is (eq 'max (problem-type problem))) 140 | (is (typep (problem-vars problem) 'vector)) 141 | (is (eq 'total (problem-objective-var problem))) 142 | (is (set-equal '(x y z) 143 | (map 'list #'identity (problem-vars problem)))) 144 | (is (set-equal '((x . 1) (y . -4) (z . 8)) 145 | (problem-objective-func problem))) 146 | (is (set-equal '(y) 147 | (problem-integer-vars problem))) 148 | (is (set-equal '((y . (0 . 1))) 149 | (problem-var-bounds problem))) 150 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) 151 | (<= ((y . -1) (z . 1)) 7)) 152 | (problem-constraints problem)))) 153 | 154 | ; free variable 155 | (signals parsing-error 156 | (make-linear-problem (min (+ x (* 4 y) (* 8 z))) 157 | (<= (+ x y) 8) 158 | (<= (+ y z) 7) 159 | (bounds (x y)))) 160 | (signals parsing-error 161 | (make-linear-problem (min (+ x (* 4 y) (* 8 z))) 162 | (<= (+ x y) 8) 163 | (<= (+ y z) 7) 164 | (bounds (1 x y)))) 165 | (let ((problem (make-linear-problem (max (= total (+ x (* -4 y) (* 8 z)))) 166 | (<= (+ x y) 8) 167 | (<= (+ (* -1 y) z) 7) 168 | (bounds (x) (1 y) (-10 z 5))))) 169 | (is (typep problem 'problem)) 170 | (is (eq 'max (problem-type problem))) 171 | (is (typep (problem-vars problem) 'vector)) 172 | (is (eq 'total (problem-objective-var problem))) 173 | (is (set-equal '(x y z) 174 | (map 'list #'identity (problem-vars problem)))) 175 | (is (set-equal '((x . 1) (y . -4) (z . 8)) 176 | (problem-objective-func problem))) 177 | (is (set-equal '() 178 | (problem-integer-vars problem))) 179 | (is (set-equal '((x . (nil . nil)) (y . (1 . nil)) (z . (-10 . 5))) 180 | (problem-var-bounds problem))) 181 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) 182 | (<= ((y . -1) (z . 1)) 7)) 183 | (problem-constraints problem)))) 184 | (let ((problem (make-linear-problem (max (= total (+ x (* -4 y) (* 8 z)))) 185 | (<= (+ x y) 8) 186 | (<= (+ (* -1 y) z) 7) 187 | (bounds (1 y) (z -5)) 188 | (bounds (y 8))))) 189 | (is (typep problem 'problem)) 190 | (is (eq 'max (problem-type problem))) 191 | (is (typep (problem-vars problem) 'vector)) 192 | (is (eq 'total (problem-objective-var problem))) 193 | (is (set-equal '(x y z) 194 | (map 'list #'identity (problem-vars problem)))) 195 | (is (set-equal '((x . 1) (y . -4) (z . 8)) 196 | (problem-objective-func problem))) 197 | (is (set-equal '() 198 | (problem-integer-vars problem))) 199 | (is (set-equal '((y . (1 . 8)) (z . (nil . -5))) 200 | (problem-var-bounds problem))) 201 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) 202 | (<= ((y . -1) (z . 1)) 7)) 203 | (problem-constraints problem)))) 204 | 205 | ; objective func name within the max 206 | (let ((problem (make-linear-problem (max (= total (+ x (* -4 y) (* 8 z)))) 207 | (<= (+ x y) 8) 208 | (<= (+ (* -1 y) z) 7)))) 209 | (is (typep problem 'problem)) 210 | (is (eq 'max (problem-type problem))) 211 | (is (typep (problem-vars problem) 'vector)) 212 | (is (eq 'total (problem-objective-var problem))) 213 | (is (set-equal '(x y z) 214 | (map 'list #'identity (problem-vars problem)))) 215 | (is (set-equal '((x . 1) (y . -4) (z . 8)) 216 | (problem-objective-func problem))) 217 | (is (set-equal '() 218 | (problem-integer-vars problem))) 219 | (is (set-equal '() 220 | (problem-var-bounds problem))) 221 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) (<= ((y . -1) (z . 1)) 7)) 222 | (problem-constraints problem))) 223 | 224 | 225 | ; Deprecation warnings 226 | ;; > and < are deprecated since they are implemented as alises for >= and <= 227 | ;; which can mislead users. (See issue #10). 228 | (signals warning 229 | (make-linear-problem (min (+ x (* 4 y) (* 8 z))) 230 | (< (+ x y) 8) 231 | (< (+ y z) 7))) 232 | (signals warning 233 | (make-linear-problem (max (+ x (* 4 y))) 234 | (<= (+ (* 2 x) y) 8) 235 | (> (+ x (* 3 y)) 1))))) 236 | 237 | (test parse-linear-problem 238 | (let ((problem (parse-linear-problem '(max (+ x (* 4 y) (* 8 z))) 239 | '((<= (+ x y) 8) 240 | (<= (+ y z) 7))))) 241 | (is (typep problem 'problem)) 242 | (is (eq 'max (problem-type problem))) 243 | (is (typep (problem-vars problem) 'vector)) 244 | (is-true (null (symbol-package (problem-objective-var problem)))) 245 | (is (set-equal '(x y z) 246 | (map 'list #'identity (problem-vars problem)))) 247 | (is (set-equal '((x . 1) (y . 4) (z . 8)) 248 | (problem-objective-func problem))) 249 | (is (set-equal '() 250 | (problem-integer-vars problem))) 251 | (is (simple-linear-constraint-set-equal '((<= ((x . 1) (y . 1)) 8) (<= ((y . 1) (z . 1)) 7)) 252 | (problem-constraints problem))))) 253 | -------------------------------------------------------------------------------- /t/simplex.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming-test/simplex 3 | (:use :cl 4 | :iterate 5 | :fiveam 6 | :linear-programming-test/base 7 | :linear-programming/conditions 8 | :linear-programming/problem 9 | :linear-programming/simplex) 10 | (:export #:simplex)) 11 | 12 | (in-package :linear-programming-test/simplex) 13 | 14 | 15 | (defun tableau-matrix-equal (exp-mat exp-vars act-tab) 16 | (let* ((act-mat (tableau-matrix act-tab)) 17 | (act-vars (problem-vars (tableau-problem act-tab)))) 18 | (if (equalp exp-vars act-vars) 19 | (equalp exp-mat act-mat) 20 | (and 21 | (iter outer 22 | (for var in-vector act-vars) 23 | (for j from 0) 24 | (iter (for i from 0 to (tableau-constraint-count act-tab)) 25 | (in outer (always (= (aref exp-mat i (position var exp-vars)) 26 | (aref act-mat i j)))))) 27 | (iter outer 28 | (for j from (length act-vars) to (tableau-var-count act-tab)) 29 | (iter (for i from 0 to (tableau-constraint-count act-tab)) 30 | (in outer (always (= (aref exp-mat i j) 31 | (aref act-mat i j)))))))))) 32 | 33 | (defun vars-to-cols (vars tab) 34 | (map 'vector (lambda (var) 35 | (if (symbolp var) 36 | (position var (problem-vars (tableau-problem tab))) 37 | var)) 38 | vars)) 39 | 40 | 41 | (def-suite simplex 42 | :in linear-programming 43 | :description "The suite to test linear-programming/simplex") 44 | (in-suite simplex) 45 | 46 | (test build-tableau 47 | (declare (notinline tableau-objective-value)) ; for coverage purposes 48 | 49 | (let* ((problem (linear-programming/problem::make-problem 50 | :type 'max 51 | :vars #(x y) 52 | :objective-var '#:z 53 | :objective-func '((x . 1) (y . 2)) 54 | :integer-vars '() 55 | :constraints '((<= ((x . 5) (y . 1)) 10) 56 | (<= ((x . 1) (y . 7)) 18) 57 | (/= ((x . 1) (y . 1)) 5))))) 58 | (signals parsing-error (build-tableau problem problem))) 59 | 60 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 61 | (<= (+ (* 2 x) y) 8) 62 | (<= (+ y z) 7))) 63 | (tableau (build-tableau problem problem))) 64 | (is-true (tableau-p tableau)) 65 | (is (eq problem (tableau-problem tableau))) 66 | (is (= 5 (tableau-var-count tableau))) 67 | (is (= 2 (tableau-constraint-count tableau))) 68 | (is (tableau-matrix-equal #2A((2 1 0 1 0 8) (0 1 1 0 1 7) (-1 -4 -3 0 0 0)) 69 | #(x y z) 70 | tableau)) 71 | (is (equalp (vars-to-cols #(3 4) tableau) (tableau-basis-columns tableau))) 72 | (is (= 0 (tableau-objective-value tableau)))) 73 | 74 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 75 | (<= (+ (* 2 x) y) 8) 76 | (<= (+ y z) 7) 77 | (= (+ (* 2 x) y z) 8))) 78 | (tableaus (build-tableau problem problem)) 79 | (art-tableau (first tableaus)) 80 | (main-tableau (second tableaus))) 81 | (is (= 2 (length tableaus))) 82 | ; art-tableau 83 | (is-true (tableau-p art-tableau)) 84 | (is (eq problem (tableau-problem art-tableau))) 85 | (is (eq 'min (problem-type (tableau-instance-problem art-tableau)))) 86 | (is (= 6 (tableau-var-count art-tableau))) 87 | (is (= 3 (tableau-constraint-count art-tableau))) 88 | (is (tableau-matrix-equal #2A((2 1 0 1 0 0 8) (0 1 1 0 1 0 7) (2 1 1 0 0 1 8) (2 1 1 0 0 0 8)) 89 | #(x y z) 90 | art-tableau)) 91 | (is (equalp (vars-to-cols #(3 4 5) art-tableau) (tableau-basis-columns art-tableau))) 92 | (is (= 8 (tableau-objective-value art-tableau))) 93 | ; main-tableau 94 | (is-true (tableau-p main-tableau)) 95 | (is (eq problem (tableau-problem main-tableau))) 96 | (is (eq problem (tableau-instance-problem main-tableau))) 97 | (is (= 5 (tableau-var-count main-tableau))) 98 | (is (= 3 (tableau-constraint-count main-tableau))) 99 | (is (tableau-matrix-equal #2A((2 1 0 1 0 8) (0 1 1 0 1 7) (2 1 1 0 0 8) (-1 -4 -3 0 0 0)) 100 | #(x y z) 101 | main-tableau)) 102 | (is (equalp #(3 4 6) (tableau-basis-columns main-tableau))) 103 | (is (= 0 (tableau-objective-value main-tableau)))) 104 | 105 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 106 | (<= (+ (* 2 x) y) 8) 107 | (<= (+ y z) 7) 108 | (>= (+ x z) 1))) 109 | (tableaus (build-tableau problem problem)) 110 | (art-tableau (first tableaus)) 111 | (main-tableau (second tableaus))) 112 | (is (= 2 (length tableaus))) 113 | ; art-tableau 114 | (is-true (tableau-p art-tableau)) 115 | (is (eq problem (tableau-problem art-tableau))) 116 | (is (eq 'min (problem-type (tableau-instance-problem art-tableau)))) 117 | (is (= 7 (tableau-var-count art-tableau))) 118 | (is (= 3 (tableau-constraint-count art-tableau))) 119 | (is (tableau-matrix-equal #2A((2 1 0 1 0 0 0 8) (0 1 1 0 1 0 0 7) (1 0 1 0 0 -1 1 1) (1 0 1 0 0 -1 0 1)) 120 | #(x y z) 121 | art-tableau)) 122 | (is (equalp (vars-to-cols #(3 4 6) art-tableau) (tableau-basis-columns art-tableau))) 123 | (is (= 1 (tableau-objective-value art-tableau))) 124 | ; main-tableau 125 | (is-true (tableau-p main-tableau)) 126 | (is (eq problem (tableau-problem main-tableau))) 127 | (is (= 6 (tableau-var-count main-tableau))) 128 | (is (= 3 (tableau-constraint-count main-tableau))) 129 | (is (tableau-matrix-equal #2A((2 1 0 1 0 0 8) (0 1 1 0 1 0 7) (1 0 1 0 0 -1 1) (-1 -4 -3 0 0 0 0)) 130 | #(x y z) 131 | main-tableau)) 132 | (is (equalp #(3 4 7) (tableau-basis-columns main-tableau))) 133 | (is (= 0 (tableau-objective-value main-tableau))))) 134 | 135 | (test pivot-row 136 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 137 | (<= (+ (* 2 x) y) 8) 138 | (<= (+ y z) 7))) 139 | (tableau (build-tableau problem problem)) 140 | (tableau2 (pivot-row tableau (position 'x (problem-vars problem)) 0))) 141 | (is (not (eq tableau tableau2))) 142 | (is (= 0 (tableau-objective-value tableau))) ;ensure original not mutated 143 | (is (eq tableau (n-pivot-row tableau (position 'x (problem-vars problem)) 0))) 144 | 145 | (is-true (tableau-p tableau2)) 146 | (is (eq problem (tableau-problem tableau2))) 147 | (is (equalp (tableau-matrix tableau) (tableau-matrix tableau2))) 148 | (is (equalp (tableau-basis-columns tableau) (tableau-basis-columns tableau2))) 149 | (is (= 5 (tableau-var-count tableau2))) 150 | (is (= 2 (tableau-constraint-count tableau2))) 151 | 152 | (is (eq problem (tableau-problem tableau))) 153 | (is (equal 5 (tableau-var-count tableau))) 154 | (is (equal 2 (tableau-constraint-count tableau))) 155 | (is (tableau-matrix-equal #2A((1 1/2 0 1/2 0 4) (0 1 1 0 1 7) (0 -7/2 -3 1/2 0 4)) 156 | #(x y z) 157 | tableau)) 158 | (is (equalp (vars-to-cols #(x 4) tableau) (tableau-basis-columns tableau))) 159 | (is (= 4 (tableau-objective-value tableau))))) 160 | 161 | 162 | (def-suite solve-tableau 163 | :in simplex 164 | :description "The suite to test solve-tableau and n-solve-tableau") 165 | (in-suite solve-tableau) 166 | 167 | (test errors 168 | (signals type-error (n-solve-tableau "max x + y st 2x+y <= 5"))) 169 | 170 | (test basic-problem 171 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 172 | (<= (+ (* 2 x) y) 8) 173 | (<= (+ y z) 7))) 174 | (tableau (build-tableau problem problem)) 175 | (tableau2 (solve-tableau tableau))) 176 | (is (not (eq tableau tableau2))) ;ensure a new copy was allocated 177 | (is (= 0 (tableau-objective-value tableau))) ;ensure original not solved 178 | (is (eq tableau (n-solve-tableau tableau))) 179 | 180 | (is-true (tableau-p tableau2)) 181 | (is (eq problem (tableau-problem tableau2))) 182 | (is (equalp (tableau-matrix tableau) (tableau-matrix tableau2))) 183 | (is (equalp (tableau-basis-columns tableau) (tableau-basis-columns tableau2))) 184 | (is (= 5 (tableau-var-count tableau2))) 185 | (is (= 2 (tableau-constraint-count tableau2))) 186 | 187 | (is (eq problem (tableau-problem tableau))) 188 | (is (equal 5 (tableau-var-count tableau))) 189 | (is (equal 2 (tableau-constraint-count tableau))) 190 | (is (tableau-matrix-equal #2A((1 0 -1/2 1/2 -1/2 1/2) (0 1 1 0 1 7) (0 0 1/2 1/2 7/2 57/2)) 191 | #(x y z) 192 | tableau)) 193 | (is (equalp (vars-to-cols #(x y) tableau) (tableau-basis-columns tableau))) 194 | (is (= 57/2 (tableau-objective-value tableau))))) 195 | 196 | (test equality-constraint 197 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 198 | (<= (+ (* 2 x) y) 8) 199 | (<= (+ y z) 7) 200 | (= (+ (* 2 x) y z) 8))) 201 | (tableaus (build-tableau problem problem)) 202 | (art-tab (first tableaus)) 203 | (main-tab (second tableaus)) 204 | (tab2 (solve-tableau tableaus))) 205 | 206 | (is (not (eq art-tab tab2))) 207 | (is (not (eq main-tab tab2))) 208 | 209 | (is (eq main-tab (n-solve-tableau tableaus))) 210 | 211 | (is-true (tableau-p tab2)) 212 | (is (eq problem (tableau-problem tab2))) 213 | (is (equalp (tableau-matrix main-tab) (tableau-matrix tab2))) 214 | (is (equalp (tableau-basis-columns main-tab) (tableau-basis-columns tab2))) 215 | (is (equal 5 (tableau-var-count tab2))) 216 | (is (equal 3 (tableau-constraint-count tab2))) 217 | 218 | ; art-tableau 219 | (is (eq problem (tableau-problem art-tab))) 220 | (is (eq 'min (problem-type (tableau-instance-problem art-tab)))) 221 | (is (equal 6 (tableau-var-count art-tab))) 222 | (is (equal 3 (tableau-constraint-count art-tab))) 223 | (is (tableau-matrix-equal #2A((1 1/2 0 1/2 0 0 4) (0 1 0 1 1 -1 7) (0 0 1 -1 0 1 0) (0 0 0 0 0 -1 0)) 224 | #(x y z) 225 | art-tab)) 226 | (is (equalp (vars-to-cols #(x 4 z) art-tab) (tableau-basis-columns art-tab))) 227 | (is (= 0 (tableau-objective-value art-tab))) 228 | ; main-tableau 229 | (is-true (tableau-p main-tab)) 230 | (is (eq problem (tableau-problem main-tab))) 231 | (is (= 5 (tableau-var-count main-tab))) 232 | (is (= 3 (tableau-constraint-count main-tab))) 233 | (is (tableau-matrix-equal #2A((1 0 0 0 -1/2 1/2) (0 1 0 1 1 7) (0 0 1 -1 0 0) (0 0 0 1 7/2 57/2)) 234 | #(x y z) 235 | main-tab)) 236 | (is (equalp (vars-to-cols #(x y z) main-tab) (tableau-basis-columns main-tab))) 237 | (is (= 57/2 (tableau-objective-value main-tab))))) 238 | 239 | (test leq-constraint 240 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 241 | (<= (+ (* 2 x) y) 8) 242 | (<= (+ y z) 7) 243 | (>= (+ x z) 1))) 244 | (tableaus (build-tableau problem problem)) 245 | (art-tab (first tableaus)) 246 | (main-tab (second tableaus))) 247 | (is (eq main-tab (n-solve-tableau tableaus))) 248 | 249 | ; art-tableau 250 | (is (eq problem (tableau-problem art-tab))) 251 | (is (eq 'min (problem-type (tableau-instance-problem art-tab)))) 252 | (is (equal 7 (tableau-var-count art-tab))) 253 | (is (equal 3 (tableau-constraint-count art-tab))) 254 | (is (or (and (tableau-matrix-equal #2A((0 1 -2 1 0 2 -2 6) (0 1 1 0 1 0 0 7) (1 0 1 0 0 -1 1 1) (0 0 0 0 0 0 -1 0)) 255 | #(x y z) 256 | art-tab) 257 | (equalp (vars-to-cols #(3 4 x) art-tab) (tableau-basis-columns art-tab))) 258 | (and (tableau-matrix-equal #2A((2 1 0 1 0 0 0 8) (-1 1 0 0 1 1 -1 6) (1 0 1 0 0 -1 1 1) (0 0 0 0 0 0 -1 0)) 259 | #(x y z) 260 | art-tab) 261 | (equalp (vars-to-cols #(3 4 z) art-tab) (tableau-basis-columns art-tab))))) 262 | (is (= 0 (tableau-objective-value art-tab))) 263 | ; main-tableau 264 | (is (eq problem (tableau-problem main-tab))) 265 | (is (equal 6 (tableau-var-count main-tab))) 266 | (is (equal 3 (tableau-constraint-count art-tab))) 267 | (is (or (and (tableau-matrix-equal #2A((0 1 0 1/3 2/3 2/3 20/3) (0 0 1 -1/3 1/3 -2/3 1/3) (1 0 0 1/3 -1/3 -1/3 2/3) (0 0 0 2/3 10/3 1/3 85/3)) 268 | #(x y z) 269 | main-tab) 270 | (equalp (vars-to-cols #(y z x) main-tab) (tableau-basis-columns main-tab))) 271 | (and (tableau-matrix-equal #2A((1 0 0 1/3 -1/3 -1/3 2/3) (0 1 0 1/3 2/3 2/3 20/3) (0 0 1 -1/3 1/3 -2/3 1/3) (0 0 0 2/3 10/3 1/3 85/3)) 272 | #(x y z) 273 | main-tab) 274 | (equalp (vars-to-cols #(x y z) main-tab) (tableau-basis-columns main-tab))))) 275 | (is (= 85/3 (tableau-objective-value main-tab))))) 276 | 277 | (test unsolvable-problems 278 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 279 | (<= (+ (* 2 x) y) 4) 280 | (<= (+ y z) 2) 281 | (>= (+ x z) 5))) 282 | (tableau (build-tableau problem problem))) 283 | (signals infeasible-problem-error (solve-tableau tableau))) 284 | 285 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 286 | (<= (+ (* 2 x) y) 4) 287 | (<= (+ y (* -1 z)) 4))) 288 | (tableau (build-tableau problem problem))) 289 | (signals unbounded-problem-error (solve-tableau tableau)))) 290 | 291 | (in-suite simplex) 292 | 293 | (test copy-tableau 294 | (declare (notinline copy-tableau)) 295 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 296 | (<= (+ (* 2 x) y) 8) 297 | (<= (+ y z) 7))) 298 | (tableau1 (build-tableau problem problem)) 299 | (tableau2 (copy-tableau tableau1))) 300 | (is (not (eq tableau1 tableau2))) 301 | (is (eq (tableau-problem tableau1) (tableau-problem tableau2))) 302 | (is (not (eq (tableau-matrix tableau1) (tableau-matrix tableau2)))) 303 | (is (equalp (tableau-matrix tableau1) (tableau-matrix tableau2))) 304 | (is (not (eq (tableau-basis-columns tableau1) (tableau-basis-columns tableau2)))) 305 | (is (equalp (tableau-basis-columns tableau1) (tableau-basis-columns tableau2))) 306 | (is (= (tableau-var-count tableau1) (tableau-var-count tableau2))) 307 | (is (= (tableau-constraint-count tableau1) (tableau-constraint-count tableau2))))) 308 | 309 | (test tableau-variable 310 | (declare (notinline tableau-variable)) 311 | (let* ((problem (make-linear-problem (max (= w (+ x (* 4 y) (* 3 z)))) 312 | (<= (+ (* 2 x) y) 8) 313 | (<= (+ y z) 7))) 314 | (tableau (n-solve-tableau (build-tableau problem problem)))) 315 | (is (= 57/2 (tableau-variable tableau 'w))) 316 | (is (= 1/2 (tableau-variable tableau 'x))) 317 | (is (= 7 (tableau-variable tableau 'y))) 318 | (is (= 0 (tableau-variable tableau 'z))) 319 | (signals error (tableau-variable tableau 'foo))) 320 | 321 | (let* ((problem (make-linear-problem (max (= w (+ x (* 4 y) (* 3 z)))) 322 | (<= (+ (* 2 x) y) 8) 323 | (<= (+ y z) 7) 324 | (bounds (x)))) 325 | (tableau (n-solve-tableau (build-tableau problem problem)))) 326 | (is (= 57/2 (tableau-variable tableau 'w))) 327 | (is (= 1/2 (tableau-variable tableau 'x))) 328 | (is (= 7 (tableau-variable tableau 'y))) 329 | (is (= 0 (tableau-variable tableau 'z)))) 330 | 331 | (let* ((problem (make-linear-problem (max (= w (+ (- x) (* 4 y) (* 3 z)))) 332 | (<= (+ (* -2 x) y) 8) 333 | (<= (+ y z) 7) 334 | (bounds (x)))) 335 | (tableau (n-solve-tableau (build-tableau problem problem)))) 336 | (is (= 57/2 (tableau-variable tableau 'w))) 337 | (is (= -1/2 (tableau-variable tableau 'x))) 338 | (is (= 7 (tableau-variable tableau 'y))) 339 | (is (= 0 (tableau-variable tableau 'z)))) 340 | 341 | (let* ((problem (make-linear-problem (max (= w (+ x (* 4 y) (* 3 z)))) 342 | (<= (+ (* 2 x) y) 8) 343 | (<= (+ y z) 7) 344 | (bounds (x 5)))) 345 | (tableau (n-solve-tableau (build-tableau problem problem)))) 346 | (is (= 57/2 (tableau-variable tableau 'w))) 347 | (is (= 1/2 (tableau-variable tableau 'x))) 348 | (is (= 7 (tableau-variable tableau 'y))) 349 | (is (= 0 (tableau-variable tableau 'z)))) 350 | 351 | (let* ((problem (make-linear-problem (max (= w (+ x (* 4 y) (* 3 z)))) 352 | (<= (+ (* 2 x) y) 8) 353 | (<= (+ y z) 7) 354 | (bounds (1 x)))) 355 | (tableau (n-solve-tableau (build-tableau problem problem)))) 356 | (is (= 28 (tableau-variable tableau 'w))) 357 | (is (= 1 (tableau-variable tableau 'x))) 358 | (is (= 6 (tableau-variable tableau 'y))) 359 | (is (= 1 (tableau-variable tableau 'z)))) 360 | 361 | (let* ((problem (make-linear-problem (max (= w (+ x (* 4 y) (* 3 z)))) 362 | (<= (+ (* 2 x) y) 8) 363 | (<= (+ y z) 7) 364 | (bounds (0 y 5)))) 365 | (tableau (n-solve-tableau (build-tableau problem problem)))) 366 | (is (= 55/2 (tableau-variable tableau 'w))) 367 | (is (= 3/2 (tableau-variable tableau 'x))) 368 | (is (= 5 (tableau-variable tableau 'y))) 369 | (is (= 2 (tableau-variable tableau 'z))))) 370 | 371 | 372 | (test tableau-reduced-cost 373 | (declare (notinline tableau-reduced-cost)) 374 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 375 | (<= (+ (* 2 x) y) 8) 376 | (<= (+ y z) 7))) 377 | (tableau (n-solve-tableau (build-tableau problem problem)))) 378 | (is (= 0 (tableau-reduced-cost tableau 'x))) 379 | (is (= 0 (tableau-reduced-cost tableau 'y))) 380 | (is (= 1/2 (tableau-reduced-cost tableau 'z))) 381 | (signals error (tableau-reduced-cost tableau 'foo))) 382 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 383 | (<= (+ (* 2 x) y) 8) 384 | (<= (+ y z) 7) 385 | (bounds (z)))) 386 | (tableau (n-solve-tableau (build-tableau problem problem)))) 387 | (is (= 1 (tableau-reduced-cost tableau 'x))) 388 | (is (= 0 (tableau-reduced-cost tableau 'y))) 389 | (signals error (tableau-reduced-cost tableau 'z)))) 390 | 391 | (test with-tableau-variables 392 | (let* ((problem (make-linear-problem (= w (max (+ x (* 4 y) (* 3 z)))) 393 | (<= (+ (* 2 x) y) 8) 394 | (<= (+ y z) 7))) 395 | (tableau (n-solve-tableau (build-tableau problem problem)))) 396 | (with-tableau-variables (x y z w) tableau 397 | (is (= 57/2 w)) 398 | (is (= 1/2 x)) 399 | (is (= 7 y)) 400 | (is (= 0 z))) 401 | (eval `(with-tableau-variables ,problem ,tableau 402 | (is (= 57/2 w)) 403 | (is (= 1/2 x)) 404 | (is (= 7 y)) 405 | (is (= 0 z)))))) 406 | -------------------------------------------------------------------------------- /t/solver.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming-test/solver 3 | (:use :cl 4 | :fiveam 5 | :linear-programming-test/base 6 | :linear-programming/problem 7 | :linear-programming/solver) 8 | (:import-from :linear-programming/conditions 9 | #:infeasible-problem-error) 10 | (:export #:solver)) 11 | 12 | (in-package :linear-programming-test/solver) 13 | 14 | (def-suite solver 15 | :in linear-programming 16 | :description "The suite to test linear-programming/solver") 17 | (in-suite solver) 18 | 19 | 20 | (test solve-problem 21 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 22 | (<= (+ (* 2 x) y) 8) 23 | (<= (+ y z) 7))) 24 | (solution (solve-problem problem))) 25 | (is (eq problem (solution-problem solution))) 26 | (is (= 57/2 (solution-objective-value solution))) 27 | (is (= 1/2 (solution-variable solution 'x))) 28 | (is (= 7 (solution-variable solution 'y))) 29 | (is (= 0 (solution-variable solution 'z))) 30 | (is (= 0 (solution-reduced-cost solution 'x))) 31 | (is (= 0 (solution-reduced-cost solution 'y))) 32 | (is (= 1/2 (solution-reduced-cost solution 'z)))) 33 | 34 | ; Integer problem 35 | 36 | (signals infeasible-problem-error (solve-problem 37 | (make-linear-problem (max (+ x y)) 38 | (<= y x) 39 | (>= y (* 1.2 (+ x .9))) 40 | (integer x y)))) 41 | 42 | ; Rock of Gibralter problem 43 | (let* ((problem (make-linear-problem (max (+ (* 240 x) (* 120 y))) 44 | (<= (+ x y) 5) 45 | (<= (+ (* -1 x) y) 0) 46 | (<= (+ (* 6 x) (* 2 y)) 21) 47 | (integer x y))) 48 | (solution (solve-problem problem))) 49 | (is (eq problem (solution-problem solution))) 50 | (is (= 840 (solution-objective-value solution))) 51 | (is (= 3 (solution-variable solution 'x))) 52 | (is (= 1 (solution-variable solution 'y))) 53 | (is (= 0 (solution-reduced-cost solution 'x))) 54 | (is (= 0 (solution-reduced-cost solution 'y)))) 55 | 56 | ; test min problem by making objective coefficients negative 57 | (let* ((problem (make-linear-problem (min (+ (* -240 x) (* -120 y))) 58 | (<= (+ x y) 5) 59 | (<= (+ (* -1 x) y) 0) 60 | (<= (+ (* 6 x) (* 2 y)) 21) 61 | (integer x y))) 62 | (solution (solve-problem problem))) 63 | (is (eq problem (solution-problem solution))) 64 | (is (= -840 (solution-objective-value solution))) 65 | (is (= 3 (solution-variable solution 'x))) 66 | (is (= 1 (solution-variable solution 'y))) 67 | (is (= 0 (solution-reduced-cost solution 'x))) 68 | (is (= 0 (solution-reduced-cost solution 'y))) 69 | 70 | ; test variable bounds 71 | (let* ((problem (make-linear-problem (max (+ x (* 4 y) (* 3 z))) 72 | (<= (+ (* 2 x) y) 8) 73 | (<= (+ y z) 7) 74 | (>= x 1))) 75 | (solution (solve-problem problem))) 76 | (is (eq problem (solution-problem solution))) 77 | (is (= 28 (solution-objective-value solution))) 78 | (is (= 1 (solution-variable solution 'x))) 79 | (is (= 6 (solution-variable solution 'y))) 80 | (is (= 1 (solution-variable solution 'z))) 81 | (is (= 1 (solution-reduced-cost solution 'x))) 82 | (is (= 0 (solution-reduced-cost solution 'y))) 83 | (is (= 0 (solution-reduced-cost solution 'z)))))) 84 | 85 | (test solution-variable 86 | (declare (notinline solution-variable)) 87 | (declare (notinline solution-reduced-cost)) 88 | 89 | (let* ((problem (make-linear-problem (max (= w (+ x (* 4 y) (* 3 z)))) 90 | (<= (+ (* 2 x) y) 8) 91 | (<= (+ y z) 7))) 92 | (solution (solve-problem problem))) 93 | (is (= 57/2 (solution-variable solution 'w))) 94 | (is (= 1/2 (solution-variable solution 'x))) 95 | (is (= 7 (solution-variable solution 'y))) 96 | (is (= 0 (solution-variable solution 'z))) 97 | (signals error (solution-variable solution 'v)) 98 | 99 | (signals error (solution-reduced-cost solution 'w)) 100 | (is (= 0 (solution-reduced-cost solution 'x))) 101 | (is (= 0 (solution-reduced-cost solution 'y))) 102 | (is (= 1/2 (solution-reduced-cost solution 'z))) 103 | (signals error (solution-reduced-cost solution 'v)))) 104 | 105 | (test with-solved-problem 106 | (with-solved-problem ((max (= w (+ x (* 4 y) (* 3 z)))) 107 | (<= (+ (* 2 x) y) 8) 108 | (<= (+ y z) 7)) 109 | (is (= 57/2 w)) 110 | (is (= 1/2 x)) 111 | (is (= 0 (reduced-cost x))) 112 | (is (= 7 y)) 113 | (is (= 0 (reduced-cost y))) 114 | (is (= 0 z)) 115 | (is (= 1/2 (reduced-cost z))))) 116 | 117 | (test with-solution-variables 118 | (let* ((problem (make-linear-problem (max (= w (+ x (* 4 y) (* 3 z)))) 119 | (<= (+ (* 2 x) y) 8) 120 | (<= (+ y z) 7))) 121 | (solution (solve-problem problem))) 122 | (with-solution-variables (w x z) solution 123 | (is (= 57/2 w)) 124 | (is (= 1/2 x)) 125 | (is (= 0 (reduced-cost x))) 126 | (is (= 0 z)) 127 | (is (= 1/2 (reduced-cost z)))))) 128 | -------------------------------------------------------------------------------- /t/system-info.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming-test/system-info 3 | (:use :cl 4 | :fiveam 5 | :linear-programming-test/base 6 | :linear-programming/system-info 7 | :iterate) 8 | (:export #:system-info)) 9 | 10 | (in-package :linear-programming-test/system-info) 11 | 12 | (def-suite system-info 13 | :in linear-programming 14 | :description "The suite to test linear-programming/system-info") 15 | (in-suite system-info) 16 | 17 | (test +supported-floats+ 18 | (is (<= 1 (length +supported-floats+) 4)) 19 | (is (member (type-of 1.0s0) +supported-floats+)) 20 | (is (member (type-of 1.0f0) +supported-floats+)) 21 | (is (member (type-of 1.0d0) +supported-floats+)) 22 | (is (member (type-of 1.0l0) +supported-floats+))) 23 | 24 | (test optimization-type 25 | (declare (notinline optimization-type)) 26 | (is (eq (optimization-type 1) 'rational)) 27 | (is (eq (optimization-type 99) 'rational)) 28 | (is (eq (optimization-type (+ 6 most-positive-fixnum)) 'rational)) 29 | (is (eq (optimization-type 4/5) 'rational)) 30 | 31 | (is (eq (optimization-type 1.0s0) (type-of 1.0s0))) 32 | (is (eq (optimization-type 1.0f0) (type-of 1.0f0))) 33 | (is (eq (optimization-type 1.0d0) (type-of 1.0d0))) 34 | (is (eq (optimization-type 1.0l0) (type-of 1.0l0)))) 35 | 36 | (test float-contagion 37 | (declare (notinline float-contagion)) 38 | (iter (for types on (append +supported-floats+ '(rational))) 39 | (for t1 = (first types)) 40 | (iter (for t2 in types) 41 | (is (float-contagion t1 t2) t1) 42 | (is (float-contagion t2 t1) t1)))) 43 | -------------------------------------------------------------------------------- /t/test-utils.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :linear-programming-test/test-utils 2 | (:use :cl) 3 | (:export #:set-equal 4 | #:simple-linear-constraint-set-equal)) 5 | (in-package :linear-programming-test/test-utils) 6 | 7 | (defun set-equal (s1 s2 &key (test #'equal)) 8 | "Helper method to test for set equality" 9 | (null (set-exclusive-or s1 s2 :test test))) 10 | 11 | 12 | (defun simple-linear-constraint-set-equal (s1 s2) 13 | "Helper method to test that two sets of simplified linear constraints are equal" 14 | (set-equal s1 s2 15 | :test (lambda (c1 c2) 16 | (and (= 3 (length c1) (length c2)) 17 | (eq (first c1) (first c2)) 18 | (set-equal (second c1) (second c2)) 19 | (= (third c1) (third c2)))))) 20 | -------------------------------------------------------------------------------- /t/utils.lisp: -------------------------------------------------------------------------------- 1 | 2 | (uiop:define-package :linear-programming-test/utils 3 | (:use :cl 4 | :fiveam 5 | :linear-programming-test/base 6 | :linear-programming/utils) 7 | (:import-from :linear-programming/conditions 8 | #:invalid-bounds-error) 9 | (:export #:utils)) 10 | 11 | (in-package :linear-programming-test/utils) 12 | 13 | (def-suite utils 14 | :in linear-programming 15 | :description "The suite to test linear-programming/utils") 16 | (in-suite utils) 17 | 18 | 19 | ;;; Boundary management 20 | (test lb-min 21 | (declare (notinline lb-min)) 22 | (is (null (lb-min nil nil))) 23 | (is (null (lb-min nil -5))) 24 | (is (null (lb-min nil 6.78))) 25 | (is (null (lb-min -5 nil))) 26 | (is (null (lb-min 6.78 nil))) 27 | (is (eql -4 (lb-min -4 3))) 28 | (is (eql 6 (lb-min 6 80.0)))) 29 | 30 | (test lb-max 31 | (declare (notinline lb-max)) 32 | (is (null (lb-max nil nil))) 33 | (is (eql -5 (lb-max nil -5))) 34 | (is (eql 6.78 (lb-max nil 6.78))) 35 | (is (eql -5 (lb-max -5 nil))) 36 | (is (eql 6.78 (lb-max 6.78 nil))) 37 | (is (eql 3 (lb-max -4 3))) 38 | (is (eql 80.0 (lb-max 6 80.0)))) 39 | 40 | (test ub-min 41 | (declare (notinline ub-min)) 42 | (is (null (ub-min nil nil))) 43 | (is (eql -5 (ub-min nil -5))) 44 | (is (eql 6.78 (ub-min nil 6.78))) 45 | (is (eql -5 (ub-min -5 nil))) 46 | (is (eql 6.78 (ub-min 6.78 nil))) 47 | (is (eql -4 (ub-min -4 3))) 48 | (is (eql 6 (ub-min 6 80.0)))) 49 | 50 | (test ub-max 51 | (declare (notinline ub-max)) 52 | (is (null (ub-max nil nil))) 53 | (is (null (ub-max nil -5))) 54 | (is (null (ub-max nil 6.78))) 55 | (is (null (ub-max -5 nil))) 56 | (is (null (ub-max 6.78 nil))) 57 | (is (eql 3 (ub-max -4 3))) 58 | (is (eql 80.0 (ub-max 6 80.0)))) 59 | 60 | 61 | (test validate-bounds 62 | (declare (notinline validate-bounds)) 63 | (signals invalid-bounds-error (validate-bounds 5 -4 'x)) 64 | (validate-bounds nil -4 'x) 65 | (fiveam:pass) 66 | (validate-bounds nil nil 'x) 67 | (fiveam:pass) 68 | (validate-bounds 5 nil 'x) 69 | (fiveam:pass) 70 | (validate-bounds 5 6 'x) 71 | (fiveam:pass)) 72 | 73 | 74 | (test fp= 75 | (declare (notinline fp=)) 76 | (is (fp= 0 0)) 77 | (is (fp= 8 8)) 78 | (is (not (fp= 0 1))) 79 | (is (not (fp= 0 (expt 2 -128)))) 80 | 81 | (is (fp= 0.0s0 0.0s0)) 82 | (is (fp= 0.0s0 (* 4 short-float-epsilon))) 83 | (is (not (fp= 0.0s0 (* 4 short-float-epsilon) 1))) 84 | (is (not (fp= (/ 1s0 100) 0.0s0))) 85 | 86 | (is (fp= 0.0f0 0.0f0)) 87 | (is (fp= 0.0f0 (* 4 single-float-epsilon))) 88 | (is (not (fp= 0.0f0 (* 4 single-float-epsilon) 1))) 89 | (is (not (fp= (/ 1f0 100) 0.0f0))) 90 | 91 | (is (fp= 0.0d0 0.0d0)) 92 | (is (fp= 0.0d0 (* 4 double-float-epsilon))) 93 | (is (not (fp= 0.0d0 (* 4 double-float-epsilon) 1))) 94 | (is (not (fp= (/ 1d0 100) 0.0d0))) 95 | 96 | (is (fp= 0.0l0 0.0l0)) 97 | (is (fp= 0.0l0 (* 4 long-float-epsilon))) 98 | (is (not (fp= 0.0l0 (* 4 long-float-epsilon) 1))) 99 | (is (not (fp= (/ 1l0 100) 0.0l0)))) 100 | 101 | 102 | (test fp> 103 | (declare (notinline fp>)) 104 | (is (fp> 0 -1)) 105 | (is (fp> 8 0)) 106 | (is (fp> (expt 2 -128) 0)) 107 | (is (not (fp> 0 0))) 108 | (is (not (fp>= 0 (expt 2 -128)))) 109 | 110 | (is (fp> 0.0s0 -1.0s0)) 111 | (is (not (fp> 0.0s0 0.0s0))) 112 | (is (not (fp> (* 4 short-float-epsilon) 0.0s0))) 113 | (is (fp> (* 4 short-float-epsilon) 0.0s0 1)) 114 | 115 | (is (fp> 0.0f0 -1.0f0)) 116 | (is (not (fp> 0.0f0 0.0f0))) 117 | (is (not (fp> (* 4 single-float-epsilon) 0.0f0))) 118 | (is (fp> (* 4 single-float-epsilon) 0.0f0 1)) 119 | 120 | (is (fp> 0.0d0 -1.0d0)) 121 | (is (not (fp> 0.0d0 0.0d0))) 122 | (is (not (fp> (* 4 double-float-epsilon) 0.0d0))) 123 | (is (fp> (* 4 double-float-epsilon) 0.0d0 1)) 124 | 125 | (is (fp> 0.0l0 -1.0l0)) 126 | (is (not (fp> 0.0l0 0.0l0))) 127 | (is (not (fp> (* 4 long-float-epsilon) 0.0l0))) 128 | (is (fp> (* 4 long-float-epsilon) 0.0l0 1))) 129 | 130 | 131 | (test fp< 132 | (declare (notinline fp<)) 133 | (is (fp< -1 0)) 134 | (is (fp< 0 8)) 135 | (is (fp< 0 (expt 2 -128))) 136 | (is (not (fp< 0 0))) 137 | (is (not (fp< (expt 2 -128) 0))) 138 | 139 | (is (fp< -1.0s0 0.0s0)) 140 | (is (not (fp< 0.0s0 0.0s0))) 141 | (is (not (fp< 0.0s0 (* 4 short-float-epsilon)))) 142 | (is (fp< 0.0s0 (* 4 short-float-epsilon) 1)) 143 | 144 | (is (fp< -1.0f0 0.0f0)) 145 | (is (not (fp< 0.0f0 0.0f0))) 146 | (is (not (fp< 0.0f0 (* 4 single-float-epsilon)))) 147 | (is (fp< 0.0f0 (* 4 single-float-epsilon) 1)) 148 | 149 | (is (fp< -1.0d0 0.0d0)) 150 | (is (not (fp< 0.0d0 0.0d0))) 151 | (is (not (fp< 0.0d0 (* 4 double-float-epsilon)))) 152 | (is (fp< 0.0d0 (* 4 double-float-epsilon) 1)) 153 | 154 | (is (fp< -1.0l0 0.0l0)) 155 | (is (not (fp< 0.0l0 0.0l0))) 156 | (is (not (fp< 0.0l0 (* 4 long-float-epsilon)))) 157 | (is (fp< 0.0l0 (* 4 long-float-epsilon) 1))) 158 | --------------------------------------------------------------------------------