From 9a6323b03c3907c905d417785b837e28802b5437 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 21 Jun 2025 23:12:23 +0100 Subject: [PATCH 01/17] refactor: add hspec, nix, and switch to cabal + Use hspec with the existing golden tests + Use cabal instead of stack, and give deps some sensible constraints + Use nix flake to get cabal, ghc, etc. --- .github/workflows/haskell.yml | 114 +--- ChangeLog.md | 3 + flake.lock | 633 ++++++++++++++++++ flake.nix | 45 ++ package.yaml | 56 -- simplex-method.cabal | 80 ++- stack.yaml | 68 -- stack.yaml.lock | 12 - .../Simplex/Solver/TwoPhaseSpec.hs} | 48 +- test/Spec.hs | 43 +- 10 files changed, 819 insertions(+), 283 deletions(-) create mode 100644 flake.lock create mode 100644 flake.nix delete mode 100644 package.yaml delete mode 100644 stack.yaml delete mode 100644 stack.yaml.lock rename test/{TestFunctions.hs => Linear/Simplex/Solver/TwoPhaseSpec.hs} (95%) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 92d3748..bbf33cf 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -2,22 +2,18 @@ name: Haskell CI on: push: - branches: - - '*' - pull_request: - branches: [ "master" ] + workflow_dispatch: permissions: contents: read jobs: fourmolu: - runs-on: ubuntu-latest - + steps: - - uses: actions/checkout@v3 - - uses: haskell-actions/run-fourmolu@v9 + - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 + - uses: haskell-actions/run-fourmolu@3b7702b41516aa428dfe6e295dc73476ae58f69e # v11 with: version: "0.14.0.0" build: @@ -27,104 +23,58 @@ jobs: fail-fast: false matrix: os: [windows-latest, macos-latest, ubuntu-latest] - ghc-version: ['9.6', '9.4', '9.2', '9.0'] + ghc-version: ["9.12", "9.10", "9.8", "9.6", "9.4", "9.2"] steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 - name: Set up GHC ${{ matrix.ghc-version }} - uses: haskell/actions/setup@v2 + uses: haskell-actions/setup@96f3dafd067155f32643c2a0757ab71d2910e2c2 # v2.8.0 id: setup with: ghc-version: ${{ matrix.ghc-version }} - enable-stack: true - name: Installed minor versions of GHC, Cabal, and Stack shell: bash run: | GHC_VERSION=$(ghc --numeric-version) CABAL_VERSION=$(cabal --numeric-version) - STACK_VERSION=$(stack --numeric-version) echo "GHC_VERSION=${GHC_VERSION}" >> "${GITHUB_ENV}" echo "CABAL_VERSION=${CABAL_VERSION}" >> "${GITHUB_ENV}" - echo "STACK_VERSION=${STACK_VERSION}" >> "${GITHUB_ENV}" + + - name: Check cabal file + run: cabal check - name: Configure the build run: | - # cabal configure --enable-tests --enable-benchmarks --disable-documentation - # cabal build --dry-run - stack build --test --bench --no-haddock --dry-run - # The last step generates dist-newstyle/cache/plan.json for the cache key. - - - name: Restore .stack-work cache - uses: actions/cache/restore@v3 - id: cache-restore-stack-work - with: - path: .stack-work - key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-work-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }}-${{ hashFiles('**/*.hs') }} - restore-keys: | - ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-work- - - - name: Restore ~/.stack cache (Unix) - uses: actions/cache/restore@v3 - id: cache-restore-stack-global-unix - if: runner.os == 'Linux' || runner.os == 'macOS' - with: - path: ~/.stack - key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }} - restore-keys: | - ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global- - - - name: Restore %APPDATA%\stack, %LOCALAPPDATA%\Programs\stack cache (Windows) - uses: actions/cache/restore@v3 - id: cache-restore-stack-global-windows - if: runner.os == 'Windows' + cabal configure --enable-tests --enable-benchmarks --disable-documentation + cabal build --dry-run + + - name: Restore cached dependencies + uses: actions/cache/restore@5a3ec84eff668545956fd18022155c47e93e2684 # v4.2.3 + id: cache + env: + key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} with: - path: | - ~\AppData\Roaming\stack - ~\AppData\Local\Programs\stack - key: ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }} - restore-keys: | - ${{ runner.os }}-ghc-${{ env.GHC_VERSION }}-stack-${{ env.STACK_VERSION }}-stack-global- + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} + restore-keys: ${{ env.key }}- - name: Build dependencies - run: stack build --only-dependencies + run: cabal build --only-dependencies - - name: Build the package - run: stack build - - - name: Save .stack-work cache - uses: actions/cache/save@v3 - id: cache-save-stack-work - if: steps.cache-restore-stack-work.outputs.cache-hit != 'true' - with: - path: .stack-work - key: ${{ steps.cache-restore-stack-work.outputs.cache-primary-key }} - - - name: Save %APPDATA%\stack, %LOCALAPPDATA%\Programs\stack cache (Windows) - uses: actions/cache/save@v3 - if: runner.os == 'Windows' - && steps.cache-restore-stack-global-windows.outputs.cache-hit != 'true' + - name: Save cached dependencies + uses: actions/cache/save@5a3ec84eff668545956fd18022155c47e93e2684 # v4.2.3 + if: steps.cache.outputs.cache-hit != 'true' with: - path: | - ~\AppData\Roaming\stack - ~\AppData\Local\Programs\stack - key: ${{ steps.cache-restore-stack-global-windows.outputs.cache-primary-key }} - - - name: Save ~/.stack cache (Unix) - uses: actions/cache/save@v3 - id: cache-save-stack-global - if: (runner.os == 'Linux' || runner.os == 'macOS') - && steps.cache-restore-stack-global-unix.outputs.cache-hit != 'true' - with: - path: ~/.stack - key: ${{ steps.cache-restore-stack-global-unix.outputs.cache-primary-key }} + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ steps.cache.outputs.cache-primary-key }} - - name: Run tests - run: stack test + - name: Build the package + run: cabal build all - - name: Check cabal file - run: cabal check + - name: Run tests + run: cabal test all - name: Build documentation - run: stack haddock \ No newline at end of file + run: cabal haddock all --disable-documentation diff --git a/ChangeLog.md b/ChangeLog.md index 5e6fb45..62325e2 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,9 @@ ## Unreleased changes +- Use Hspec for tests +- Add nix flake + ## [v0.2.0.0](https://github.com/rasheedja/LPPaver/tree/v0.2.0.0) - Setup CI diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..7d8c09d --- /dev/null +++ b/flake.lock @@ -0,0 +1,633 @@ +{ + "nodes": { + "HTTP": { + "flake": false, + "locked": { + "lastModified": 1451647621, + "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", + "owner": "phadej", + "repo": "HTTP", + "rev": "9bc0996d412fef1787449d841277ef663ad9a915", + "type": "github" + }, + "original": { + "owner": "phadej", + "repo": "HTTP", + "type": "github" + } + }, + "cabal-32": { + "flake": false, + "locked": { + "lastModified": 1603716527, + "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", + "owner": "haskell", + "repo": "cabal", + "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.2", + "repo": "cabal", + "type": "github" + } + }, + "cabal-34": { + "flake": false, + "locked": { + "lastModified": 1645834128, + "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", + "owner": "haskell", + "repo": "cabal", + "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.4", + "repo": "cabal", + "type": "github" + } + }, + "cabal-36": { + "flake": false, + "locked": { + "lastModified": 1669081697, + "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", + "owner": "haskell", + "repo": "cabal", + "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "3.6", + "repo": "cabal", + "type": "github" + } + }, + "cardano-shell": { + "flake": false, + "locked": { + "lastModified": 1608537748, + "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", + "owner": "input-output-hk", + "repo": "cardano-shell", + "rev": "9392c75087cb9a3d453998f4230930dea3a95725", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "cardano-shell", + "type": "github" + } + }, + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1672831974, + "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", + "owner": "input-output-hk", + "repo": "flake-compat", + "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "hkm/gitlab-fix", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "hackage": { + "flake": false, + "locked": { + "lastModified": 1758846310, + "narHash": "sha256-kVnn9TScof8n41p7LqwvBvoLlfFhLDkjrP+aOAhmQ9k=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "173aca690d454916a2d1ab5a7d13b593240fa0f5", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "hackage-for-stackage": { + "flake": false, + "locked": { + "lastModified": 1758846300, + "narHash": "sha256-uS0e51ny5rGdI5HiOttTYMjGyOqBSoraXDWCY7gFc9g=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "813f87b29c01a70bf479ff7c72b240d7d6a3fe16", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "ref": "for-stackage", + "repo": "hackage.nix", + "type": "github" + } + }, + "hackage-internal": { + "flake": false, + "locked": { + "lastModified": 1750307553, + "narHash": "sha256-iiafNoeLHwlSLQTyvy8nPe2t6g5AV4PPcpMeH/2/DLs=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "f7867baa8817fab296528f4a4ec39d1c7c4da4f3", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, + "haskellNix": { + "inputs": { + "HTTP": "HTTP", + "cabal-32": "cabal-32", + "cabal-34": "cabal-34", + "cabal-36": "cabal-36", + "cardano-shell": "cardano-shell", + "flake-compat": "flake-compat", + "hackage": "hackage", + "hackage-for-stackage": "hackage-for-stackage", + "hackage-internal": "hackage-internal", + "hls": "hls", + "hls-1.10": "hls-1.10", + "hls-2.0": "hls-2.0", + "hls-2.10": "hls-2.10", + "hls-2.11": "hls-2.11", + "hls-2.2": "hls-2.2", + "hls-2.3": "hls-2.3", + "hls-2.4": "hls-2.4", + "hls-2.5": "hls-2.5", + "hls-2.6": "hls-2.6", + "hls-2.7": "hls-2.7", + "hls-2.8": "hls-2.8", + "hls-2.9": "hls-2.9", + "hpc-coveralls": "hpc-coveralls", + "iserv-proxy": "iserv-proxy", + "nixpkgs": [ + "haskellNix", + "nixpkgs-unstable" + ], + "nixpkgs-2305": "nixpkgs-2305", + "nixpkgs-2311": "nixpkgs-2311", + "nixpkgs-2405": "nixpkgs-2405", + "nixpkgs-2411": "nixpkgs-2411", + "nixpkgs-2505": "nixpkgs-2505", + "nixpkgs-unstable": "nixpkgs-unstable", + "old-ghc-nix": "old-ghc-nix", + "stackage": "stackage" + }, + "locked": { + "lastModified": 1758847890, + "narHash": "sha256-rGX7RF8Au5ZJJSqlQivsl4seyEslI/K3OnEC9ulLwNM=", + "owner": "input-output-hk", + "repo": "haskell.nix", + "rev": "46abef90b4101ff9253a574cf6fbdc74b78a5863", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "haskell.nix", + "type": "github" + } + }, + "hls": { + "flake": false, + "locked": { + "lastModified": 1741604408, + "narHash": "sha256-tuq3+Ip70yu89GswZ7DSINBpwRprnWnl6xDYnS4GOsc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "682d6894c94087da5e566771f25311c47e145359", + "type": "github" + }, + "original": { + "owner": "haskell", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-1.10": { + "flake": false, + "locked": { + "lastModified": 1680000865, + "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "1.10.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.0": { + "flake": false, + "locked": { + "lastModified": 1687698105, + "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "783905f211ac63edf982dd1889c671653327e441", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.0.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.10": { + "flake": false, + "locked": { + "lastModified": 1743069404, + "narHash": "sha256-q4kDFyJDDeoGqfEtrZRx4iqMVEC2MOzCToWsFY+TOzY=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "2318c61db3a01e03700bd4b05665662929b7fe8b", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.10.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.11": { + "flake": false, + "locked": { + "lastModified": 1747306193, + "narHash": "sha256-/MmtpF8+FyQlwfKHqHK05BdsxC9LHV70d/FiMM7pzBM=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "46ef4523ea4949f47f6d2752476239f1c6d806fe", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.11.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.2": { + "flake": false, + "locked": { + "lastModified": 1693064058, + "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.2.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.3": { + "flake": false, + "locked": { + "lastModified": 1695910642, + "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.3.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.4": { + "flake": false, + "locked": { + "lastModified": 1699862708, + "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.4.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.5": { + "flake": false, + "locked": { + "lastModified": 1701080174, + "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.5.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.6": { + "flake": false, + "locked": { + "lastModified": 1705325287, + "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.6.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.7": { + "flake": false, + "locked": { + "lastModified": 1708965829, + "narHash": "sha256-LfJ+TBcBFq/XKoiNI7pc4VoHg4WmuzsFxYJ3Fu+Jf+M=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "50322b0a4aefb27adc5ec42f5055aaa8f8e38001", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.7.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.8": { + "flake": false, + "locked": { + "lastModified": 1715153580, + "narHash": "sha256-Vi/iUt2pWyUJlo9VrYgTcbRviWE0cFO6rmGi9rmALw0=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "dd1be1beb16700de59e0d6801957290bcf956a0a", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.8.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.9": { + "flake": false, + "locked": { + "lastModified": 1719993701, + "narHash": "sha256-wy348++MiMm/xwtI9M3vVpqj2qfGgnDcZIGXw8sF1sA=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "90319a7e62ab93ab65a95f8f2bcf537e34dae76a", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.9.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hpc-coveralls": { + "flake": false, + "locked": { + "lastModified": 1607498076, + "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", + "type": "github" + }, + "original": { + "owner": "sevanspowell", + "repo": "hpc-coveralls", + "type": "github" + } + }, + "iserv-proxy": { + "flake": false, + "locked": { + "lastModified": 1755243078, + "narHash": "sha256-GLbl1YaohKdpzZVJFRdcI1O1oE3F3uBer4lFv3Yy0l8=", + "owner": "stable-haskell", + "repo": "iserv-proxy", + "rev": "150605195cb7183a6fb7bed82f23fedf37c6f52a", + "type": "github" + }, + "original": { + "owner": "stable-haskell", + "ref": "iserv-syms", + "repo": "iserv-proxy", + "type": "github" + } + }, + "nixpkgs-2305": { + "locked": { + "lastModified": 1705033721, + "narHash": "sha256-K5eJHmL1/kev6WuqyqqbS1cdNnSidIZ3jeqJ7GbrYnQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "a1982c92d8980a0114372973cbdfe0a307f1bdea", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2311": { + "locked": { + "lastModified": 1719957072, + "narHash": "sha256-gvFhEf5nszouwLAkT9nWsDzocUTqLWHuL++dvNjMp9I=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "7144d6241f02d171d25fba3edeaf15e0f2592105", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-23.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2405": { + "locked": { + "lastModified": 1735564410, + "narHash": "sha256-HB/FA0+1gpSs8+/boEavrGJH+Eq08/R2wWNph1sM1Dg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "1e7a8f391f1a490460760065fa0630b5520f9cf8", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-24.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2411": { + "locked": { + "lastModified": 1748037224, + "narHash": "sha256-92vihpZr6dwEMV6g98M5kHZIttrWahb9iRPBm1atcPk=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "f09dede81861f3a83f7f06641ead34f02f37597f", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-24.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-2505": { + "locked": { + "lastModified": 1754477006, + "narHash": "sha256-suIgZZHXdb4ca9nN4MIcmdjeN+ZWsTwCtYAG4HExqAo=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "4896699973299bffae27d0d9828226983544d9e9", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-25.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-unstable": { + "locked": { + "lastModified": 1754393734, + "narHash": "sha256-fbnmAwTQkuXHKBlcL5Nq1sMAzd3GFqCOQgEQw6Hy0Ak=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "a683adc19ff5228af548c6539dbc3440509bfed3", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "old-ghc-nix": { + "flake": false, + "locked": { + "lastModified": 1631092763, + "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", + "owner": "angerman", + "repo": "old-ghc-nix", + "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", + "type": "github" + }, + "original": { + "owner": "angerman", + "ref": "master", + "repo": "old-ghc-nix", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "haskellNix": "haskellNix", + "nixpkgs": [ + "haskellNix", + "nixpkgs-2505" + ] + } + }, + "stackage": { + "flake": false, + "locked": { + "lastModified": 1758845522, + "narHash": "sha256-SgkvlWF9a+Qrkn791ZOiUVt3wuZXRJ06YjpTZMRy+R8=", + "owner": "input-output-hk", + "repo": "stackage.nix", + "rev": "e2f097d435e38fb6e649efa4a95e214a506a1da5", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "stackage.nix", + "type": "github" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..69be272 --- /dev/null +++ b/flake.nix @@ -0,0 +1,45 @@ +{ + inputs = { + haskellNix.url = "github:input-output-hk/haskell.nix"; + nixpkgs.follows = "haskellNix/nixpkgs-2505"; + flake-utils.url = "github:numtide/flake-utils"; + }; + + outputs = { self, nixpkgs, flake-utils, haskellNix }: + flake-utils.lib.eachDefaultSystem (system: + let + overlays = [ haskellNix.overlay ]; + pkgs = import nixpkgs { + inherit system overlays; + inherit (haskellNix) config; + }; + + project = pkgs.haskell-nix.cabalProject' { + src = ./.; + compiler-nix-name = "ghc967"; + shell = { + tools = { + cabal = "3.16.0.0"; + hlint = "3.8"; + haskell-language-server = "2.11.0.0"; + fourmolu = "0.17.0.0"; + }; + buildInputs = with pkgs; [ + # system dependencies go here + ]; + }; + }; + + flake = project.flake {}; + in flake); + + # --- Flake Local Nix Configuration --- + nixConfig = { + # This sets the flake to use the IOG nix cache. + # Nix should ask for permission before using it, + # but remove it here if you do not want it to. + extra-substituters = ["https://cache.iog.io"]; + extra-trusted-public-keys = ["hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ="]; + allow-import-from-derivation = "true"; + }; +} diff --git a/package.yaml b/package.yaml deleted file mode 100644 index f4ba4bc..0000000 --- a/package.yaml +++ /dev/null @@ -1,56 +0,0 @@ -name: simplex-method -version: 0.2.0.0 -github: "rasheedja/simplex-method" -license: BSD3 -author: "Junaid Rasheed" -maintainer: "jrasheed178@gmail.com" -copyright: "BSD-3" - -extra-source-files: -- README.md -- ChangeLog.md - -# Metadata used when publishing your package -synopsis: Implementation of the two-phase simplex method in exact rational arithmetic -category: Math, Maths, Mathematics, Optimisation, Optimization, Linear Programming - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at - -dependencies: -- base >= 4.14 && < 5 -- containers >= 0.6.5.1 && < 0.7 -- generic-lens >= 2.2.0 && < 2.3 -- lens >= 5.2.2 && < 5.3 -- monad-logger >= 0.3.40 && < 0.4 -- text >= 2.0.2 && < 2.1 -- time >= 1.12.2 && < 1.13 - -default-extensions: - DataKinds - DeriveFunctor - DeriveGeneric - DisambiguateRecordFields - DuplicateRecordFields - FlexibleContexts - LambdaCase - OverloadedLabels - OverloadedRecordDot - OverloadedStrings - RecordWildCards - TemplateHaskell - TupleSections - TypeApplications - NamedFieldPuns - -library: - source-dirs: src - -tests: - simplex-haskell-test: - main: Spec.hs - source-dirs: test - dependencies: - - simplex-method diff --git a/simplex-method.cabal b/simplex-method.cabal index 3078198..f3e9673 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -1,9 +1,3 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.36.0. --- --- see: https://github.com/sol/hpack - name: simplex-method version: 0.2.0.0 synopsis: Implementation of the two-phase simplex method in exact rational arithmetic @@ -16,6 +10,7 @@ maintainer: jrasheed178@gmail.com copyright: BSD-3 license: BSD3 license-file: LICENSE +cabal-version: 1.12 build-type: Simple extra-source-files: README.md @@ -36,34 +31,77 @@ library hs-source-dirs: src default-extensions: - DataKinds DeriveFunctor DeriveGeneric DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications NamedFieldPuns + DataKinds + DeriveFunctor + DeriveGeneric + DerivingStrategies + DisambiguateRecordFields + DuplicateRecordFields + ExtendedDefaultRules + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + RecordWildCards + TemplateHaskell + TupleSections + TypeApplications + QuasiQuotes build-depends: base >=4.14 && <5 - , containers >=0.6.5.1 && <0.7 - , generic-lens >=2.2.0 && <2.3 - , lens >=5.2.2 && <5.3 - , monad-logger >=0.3.40 && <0.4 - , text >=2.0.2 && <2.1 - , time >=1.12.2 && <1.13 + , containers >= 0.6.5.1 && < 0.8 + , generic-lens >= 2.2 && < 2.3 + , lens >= 5.2.2 && < 5.4 + , text >= 2.0.2 && < 2.2 + , time >= 1.12.2 && < 1.15 + , monad-logger >= 0.3.40 && < 0.4 + , QuickCheck >= 2.16.0 && < 2.17 default-language: Haskell2010 test-suite simplex-haskell-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - TestFunctions + Linear.Simplex.Solver.TwoPhaseSpec Paths_simplex_method hs-source-dirs: test default-extensions: - DataKinds DeriveFunctor DeriveGeneric DisambiguateRecordFields DuplicateRecordFields FlexibleContexts LambdaCase OverloadedLabels OverloadedRecordDot OverloadedStrings RecordWildCards TemplateHaskell TupleSections TypeApplications NamedFieldPuns + DataKinds + DeriveFunctor + DeriveGeneric + DerivingStrategies + DisambiguateRecordFields + DuplicateRecordFields + ExtendedDefaultRules + FlexibleContexts + GeneralizedNewtypeDeriving + LambdaCase + NamedFieldPuns + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + RecordWildCards + TemplateHaskell + TupleSections + TypeApplications + QuasiQuotes build-depends: base >=4.14 && <5 - , containers >=0.6.5.1 && <0.7 - , generic-lens >=2.2.0 && <2.3 - , lens >=5.2.2 && <5.3 - , monad-logger >=0.3.40 && <0.4 , simplex-method - , text >=2.0.2 && <2.1 - , time >=1.12.2 && <1.13 + , containers >= 0.6.5.1 && < 0.8 + , generic-lens >= 2.2 && < 2.3 + , lens >= 5.2.2 && < 5.4 + , text >= 2.0.2 && < 2.2 + , time >= 1.12.2 && < 1.15 + , monad-logger >= 0.3.40 && < 0.4 + , QuickCheck >= 2.16.0 && < 2.17 + , hspec >= 2.11.12 && < 2.12 + , hspec-expectations >= 0.8.3 && < 0.9 + , interpolatedstring-perl6 >= 1.0.2 && < 1.1 + build-tool-depends: + hspec-discover:hspec-discover >= 2.11.12 && < 2.12 default-language: Haskell2010 diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index eab5650..0000000 --- a/stack.yaml +++ /dev/null @@ -1,68 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-21.22 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: {} - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.5" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor - -system-ghc: true diff --git a/stack.yaml.lock b/stack.yaml.lock deleted file mode 100644 index e8d3cc7..0000000 --- a/stack.yaml.lock +++ /dev/null @@ -1,12 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: [] -snapshots: -- completed: - sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea - size: 640060 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml - original: lts-21.22 diff --git a/test/TestFunctions.hs b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs similarity index 95% rename from test/TestFunctions.hs rename to test/Linear/Simplex/Solver/TwoPhaseSpec.hs index b2af317..06b98d9 100644 --- a/test/TestFunctions.hs +++ b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs @@ -1,9 +1,21 @@ -module TestFunctions where +module Linear.Simplex.Solver.TwoPhaseSpec where +import Prelude hiding (EQ) + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger import qualified Data.Map as M import Data.Ratio +import Text.InterpolatedString.Perl6 + +import Test.Hspec +import Test.Hspec.Expectations.Contrib (annotate) + +import Linear.Simplex.Prettify +import Linear.Simplex.Solver.TwoPhase import Linear.Simplex.Types -import Prelude hiding (EQ) +import Linear.Simplex.Util testsList :: [((ObjectiveFunction, [PolyConstraint]), Maybe Result)] testsList = @@ -1046,3 +1058,35 @@ testQuickCheck3 = , GEQ (M.fromList [(1, -5), (2, -1), (2, 1)]) (-5) ] ) + +spec :: Spec +spec = describe "twoPhaseSimplex" $ do + it "Check golden tests" $ do + forM_ testsList $ + \((obj, constraints), expectedResult) -> do + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex obj constraints + let prettyObj = prettyShowObjectiveFunction obj + prettyConstraints = map prettyShowPolyConstraint constraints + + expectedObjVal = extractObjectiveValue expectedResult + actualObjVal = extractObjectiveValue actualResult + annotate + [qc| + +Objective Function (Non-prettified): {obj} +Constraints (Non-prettified): {constraints} +==================================== +Objective Function (Prettified): {prettyObj} +Constraints (Prettified): {prettyConstraints} +==================================== +Expected Solution (Full): {expectedResult} +Actual Solution (Full): {actualResult} +Expected Solution (Objective): {expectedObjVal} +Actual Solution (Objective): {actualObjVal} + + |] + $ do + actualResult `shouldBe` expectedResult diff --git a/test/Spec.hs b/test/Spec.hs index 4a8ad55..a824f8c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,42 +1 @@ -module Main where - -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Logger - -import Linear.Simplex.Prettify -import Linear.Simplex.Solver.TwoPhase -import Linear.Simplex.Types -import Linear.Simplex.Util - -import TestFunctions - -main :: IO () -main = runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ runTests testsList - -runTests :: (MonadLogger m, MonadFail m, MonadIO m) => [((ObjectiveFunction, [PolyConstraint]), Maybe Result)] -> m () -runTests [] = do - liftIO $ putStrLn "All tests passed" - pure () -runTests (((testObjective, testConstraints), expectedResult) : tests) = - do - testResult <- twoPhaseSimplex testObjective testConstraints - if testResult == expectedResult - then runTests tests - else do - let msg = - "\nThe following test failed: " - <> ("\nObjective Function (Non-prettified): " ++ show testObjective) - <> ("\nConstraints (Non-prettified): " ++ show testConstraints) - <> "\n====================================" - <> ("\nObjective Function (Prettified): " ++ prettyShowObjectiveFunction testObjective) - <> "\nConstraints (Prettified): " - <> "\n" - <> concatMap (\c -> "\t" ++ prettyShowPolyConstraint c ++ "\n") testConstraints - <> "\n====================================" - <> ("\nExpected Solution (Full): " ++ show expectedResult) - <> ("\nActual Solution (Full): " ++ show testResult) - <> ("\nExpected Solution (Objective): " ++ show (extractObjectiveValue expectedResult)) - <> ("\nActual Solution (Objective): " ++ show (extractObjectiveValue testResult)) - <> "\n" - fail msg +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} From f48f135272d47785225c431a3678dea2512e29c4 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Fri, 5 Dec 2025 18:43:58 +0000 Subject: [PATCH 02/17] feat: support non-negative and unbounded lower bounds in systems --- src/Linear/Simplex/Solver/TwoPhase.hs | 219 ++- src/Linear/Simplex/Types.hs | 35 + test/Linear/Simplex/Solver/TwoPhaseSpec.hs | 1783 ++++++++------------ 3 files changed, 973 insertions(+), 1064 deletions(-) diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index c7dfe83..97cbae3 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -6,11 +6,12 @@ -- Maintainer : jrasheed178@gmail.com -- Stability : experimental -- --- Module implementing the two-phase simplex method. +-- | Module implementing the two-phase simplex method. -- 'findFeasibleSolution' performs phase one of the two-phase simplex method. -- 'optimizeFeasibleSystem' performs phase two of the two-phase simplex method. -- 'twoPhaseSimplex' performs both phases of the two-phase simplex method. -module Linear.Simplex.Solver.TwoPhase (findFeasibleSolution, optimizeFeasibleSystem, twoPhaseSimplex) where +-- 'twoPhaseSimplex'' performs both phases with variable domain support. +module Linear.Simplex.Solver.TwoPhase (findFeasibleSolution, optimizeFeasibleSystem, twoPhaseSimplex, twoPhaseSimplex') where import Prelude hiding (EQ) @@ -24,6 +25,8 @@ import qualified Data.Map as M import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Ratio (denominator, numerator, (%)) import qualified Data.Text as Text +import Data.Set (Set) +import qualified Data.Set as Set import GHC.Real (Ratio) import Linear.Simplex.Types import Linear.Simplex.Util @@ -403,6 +406,218 @@ twoPhaseSimplex objFunction unsimplifiedSystem = do logMsg LevelInfo $ "twoPhaseSimplex: Phase 1 gives infeasible result for " <> showT unsimplifiedSystem pure Nothing +-- | Perform the two phase simplex method with variable domain information. +-- Variables not in the VarDomainMap are assumed to be Unbounded (no lower bound). +-- This function applies necessary transformations before solving and unapplies them after. +twoPhaseSimplex' :: (MonadIO m, MonadLogger m) => VarDomainMap -> ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result) +twoPhaseSimplex' domainMap objFunction constraints = do + logMsg LevelInfo $ + "twoPhaseSimplex': Solving system with domain map " <> showT domainMap + let (transformedObj, transformedConstraints, transforms) = preprocess objFunction domainMap constraints + logMsg LevelInfo $ + "twoPhaseSimplex': Applied transforms " <> showT transforms + <> "; Transformed objective: " <> showT transformedObj + <> "; Transformed constraints: " <> showT transformedConstraints + mResult <- twoPhaseSimplex transformedObj transformedConstraints + case mResult of + Nothing -> do + logMsg LevelInfo "twoPhaseSimplex': No solution found" + pure Nothing + Just result -> do + let finalResult = unapplyTransforms transforms result + logMsg LevelInfo $ + "twoPhaseSimplex': Unapplied transforms, final result: " <> showT finalResult + pure (Just finalResult) + +-- | Preprocess the system by applying variable transformations based on domain information. +-- Returns the transformed objective, constraints, and the list of transforms applied. +preprocess :: ObjectiveFunction + -> VarDomainMap + -> [PolyConstraint] + -> (ObjectiveFunction, [PolyConstraint], [VarTransform]) +preprocess objFunction (VarDomainMap domainMap) constraints = + let -- Collect all variables in the system + allVars = collectAllVars objFunction constraints + -- Find the maximum variable to generate fresh variables + maxVar = if Set.null allVars then 0 else Set.findMax allVars + -- Generate transforms for each variable based on its domain + -- Variables not in domainMap are treated as Unbounded + (transforms, _) = foldr (generateTransform domainMap) ([], maxVar) (Set.toList allVars) + -- Apply transforms to get the transformed system + (transformedObj, transformedConstraints) = applyTransforms transforms objFunction constraints + in (transformedObj, transformedConstraints, transforms) + +-- | Collect all variables appearing in the objective function and constraints +collectAllVars :: ObjectiveFunction -> [PolyConstraint] -> Set Var +collectAllVars objFunction constraints = + let objVars = case objFunction of + Max m -> M.keysSet m + Min m -> M.keysSet m + constraintVars = Set.unions $ map getConstraintVars constraints + in Set.union objVars constraintVars + where + getConstraintVars :: PolyConstraint -> Set Var + getConstraintVars (LEQ m _) = M.keysSet m + getConstraintVars (GEQ m _) = M.keysSet m + getConstraintVars (EQ m _) = M.keysSet m + +-- | Generate a transform for a variable based on its domain. +-- Takes the domain map, the variable, and the current (transforms, nextFreshVar). +-- Returns updated (transforms, nextFreshVar). +generateTransform :: M.Map Var VarDomain -> Var -> ([VarTransform], Var) -> ([VarTransform], Var) +generateTransform domainMap var (transforms, nextFreshVar) = + let domain = M.findWithDefault Unbounded var domainMap + in case getTransform nextFreshVar var domain of + Nothing -> (transforms, nextFreshVar) + Just t@(AddLowerBound {}) -> (t : transforms, nextFreshVar) + Just t@(Shift {}) -> (t : transforms, nextFreshVar + 1) + Just t@(Split {}) -> (t : transforms, nextFreshVar + 2) + +-- | Determine what transform (if any) is needed for a variable given its domain. +getTransform :: Var -> Var -> VarDomain -> Maybe VarTransform +getTransform nextFreshVar var domain = + case domain of + NonNegative -> Nothing + + LowerBound l + | l == 0 -> Nothing + | l > 0 -> Just $ AddLowerBound var l + | otherwise -> Just $ Shift var nextFreshVar l -- l < 0, need to shift + + Unbounded -> + Just $ Split var nextFreshVar (nextFreshVar + 1) + +-- | Apply all transforms to the objective function and constraints. +applyTransforms :: [VarTransform] -> ObjectiveFunction -> [PolyConstraint] -> (ObjectiveFunction, [PolyConstraint]) +applyTransforms transforms objFunction constraints = + foldr applyTransform (objFunction, constraints) transforms + +-- | Apply a single transform to the objective function and constraints. +applyTransform :: VarTransform -> (ObjectiveFunction, [PolyConstraint]) -> (ObjectiveFunction, [PolyConstraint]) +applyTransform transform (objFunction, constraints) = + case transform of + -- AddLowerBound: Add a GEQ constraint for the variable + AddLowerBound v bound -> + (objFunction, GEQ (M.singleton v 1) bound : constraints) + + -- Shift: originalVar = shiftedVar + shiftBy (where shiftBy < 0) + -- Substitute: wherever we see originalVar, replace with shiftedVar + -- and adjust the RHS by -coeff * shiftBy + Shift origVar shiftedVar shiftBy -> + ( applyShiftToObjective origVar shiftedVar shiftBy objFunction + , map (applyShiftToConstraint origVar shiftedVar shiftBy) constraints + ) + + -- Split: originalVar = posVar - negVar + -- Substitute: wherever we see originalVar with coeff c, + -- replace with posVar with coeff c and negVar with coeff -c + Split origVar posVar negVar -> + ( applySplitToObjective origVar posVar negVar objFunction + , map (applySplitToConstraint origVar posVar negVar) constraints + ) + +-- | Apply shift transformation to objective function. +-- originalVar = shiftedVar + shiftBy +-- So coefficient of originalVar becomes coefficient of shiftedVar. +-- The constant term changes but objectives don't have constants that affect optimization. +applyShiftToObjective :: Var -> Var -> SimplexNum -> ObjectiveFunction -> ObjectiveFunction +applyShiftToObjective origVar shiftedVar _shiftBy objFunction = + case objFunction of + Max m -> Max (substituteVar origVar shiftedVar m) + Min m -> Min (substituteVar origVar shiftedVar m) + where + substituteVar :: Var -> Var -> VarLitMapSum -> VarLitMapSum + substituteVar oldVar newVar m = + case M.lookup oldVar m of + Nothing -> m + Just coeff -> M.insert newVar coeff (M.delete oldVar m) + +-- | Apply shift transformation to a constraint. +-- originalVar = shiftedVar + shiftBy +-- For constraint: sum(c_i * x_i) REL rhs +-- If x_j = originalVar with coeff c_j: +-- c_j * originalVar = c_j * (shiftedVar + shiftBy) = c_j * shiftedVar + c_j * shiftBy +-- So new constraint: (replace originalVar with shiftedVar) REL (rhs - c_j * shiftBy) +applyShiftToConstraint :: Var -> Var -> SimplexNum -> PolyConstraint -> PolyConstraint +applyShiftToConstraint origVar shiftedVar shiftBy constraint = + case constraint of + LEQ m rhs -> + let (newMap, rhsAdjust) = substituteVarInMap origVar shiftedVar shiftBy m + in LEQ newMap (rhs - rhsAdjust) + GEQ m rhs -> + let (newMap, rhsAdjust) = substituteVarInMap origVar shiftedVar shiftBy m + in GEQ newMap (rhs - rhsAdjust) + EQ m rhs -> + let (newMap, rhsAdjust) = substituteVarInMap origVar shiftedVar shiftBy m + in EQ newMap (rhs - rhsAdjust) + where + substituteVarInMap :: Var -> Var -> SimplexNum -> VarLitMapSum -> (VarLitMapSum, SimplexNum) + substituteVarInMap oldVar newVar shift m = + case M.lookup oldVar m of + Nothing -> (m, 0) + Just coeff -> (M.insert newVar coeff (M.delete oldVar m), coeff * shift) + +-- | Apply split transformation to objective function. +-- originalVar = posVar - negVar +-- coefficient c of originalVar becomes c for posVar and -c for negVar +applySplitToObjective :: Var -> Var -> Var -> ObjectiveFunction -> ObjectiveFunction +applySplitToObjective origVar posVar negVar objFunction = + case objFunction of + Max m -> Max (splitVar origVar posVar negVar m) + Min m -> Min (splitVar origVar posVar negVar m) + where + splitVar :: Var -> Var -> Var -> VarLitMapSum -> VarLitMapSum + splitVar oldVar pVar nVar m = + case M.lookup oldVar m of + Nothing -> m + Just coeff -> M.insert pVar coeff (M.insert nVar (-coeff) (M.delete oldVar m)) + +-- | Apply split transformation to a constraint. +-- originalVar = posVar - negVar +-- coefficient c of originalVar becomes c for posVar and -c for negVar +applySplitToConstraint :: Var -> Var -> Var -> PolyConstraint -> PolyConstraint +applySplitToConstraint origVar posVar negVar constraint = + case constraint of + LEQ m rhs -> LEQ (splitVarInMap origVar posVar negVar m) rhs + GEQ m rhs -> GEQ (splitVarInMap origVar posVar negVar m) rhs + EQ m rhs -> EQ (splitVarInMap origVar posVar negVar m) rhs + where + splitVarInMap :: Var -> Var -> Var -> VarLitMapSum -> VarLitMapSum + splitVarInMap oldVar pVar nVar m = + case M.lookup oldVar m of + Nothing -> m + Just coeff -> M.insert pVar coeff (M.insert nVar (-coeff) (M.delete oldVar m)) + +-- | Unapply transforms to convert the result back to original variables. +unapplyTransforms :: [VarTransform] -> Result -> Result +unapplyTransforms transforms result = + -- Apply transforms in reverse order (since we applied them with foldr) + foldl (flip unapplyTransform) result transforms + +-- | Unapply a single transform to convert result back to original variable. +unapplyTransform :: VarTransform -> Result -> Result +unapplyTransform transform result@(Result {varValMap = valMap, ..}) = + case transform of + -- AddLowerBound: No variable substitution was done, nothing to unapply + AddLowerBound {} -> result + + -- Shift: originalVar = shiftedVar + shiftBy + -- So originalVar's value = shiftedVar's value + shiftBy + Shift origVar shiftedVar shiftBy -> + let shiftedVal = M.findWithDefault 0 shiftedVar valMap + origVal = shiftedVal + shiftBy + newMap = M.insert origVar origVal (M.delete shiftedVar valMap) + in result { varValMap = newMap } + + -- Split: originalVar = posVar - negVar + -- So originalVar's value = posVar's value - negVar's value + Split origVar posVar negVar -> + let posVal = M.findWithDefault 0 posVar valMap + negVal = M.findWithDefault 0 negVar valMap + origVal = posVal - negVal + newMap = M.insert origVar origVal (M.delete posVar (M.delete negVar valMap)) + in result { varValMap = newMap } + -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. simplexPivot :: (MonadIO m, MonadLogger m) => PivotObjective -> Dict -> m (Maybe Dict) simplexPivot objective@(PivotObjective {variable = objectiveVar, function = objectiveFunc, constant = objectiveConstant}) dictionary = do diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 15e5d1f..c688aaf 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -121,3 +121,38 @@ data PivotObjective = PivotObjective , constant :: SimplexNum } deriving (Show, Read, Eq, Generic) + +-- | Domain specification for a variable's lower bound. +-- Note: This only concerns lower bounds. Upper bounds are handled via constraints. +-- Variables not in the VarDomainMap are assumed to be Unbounded. +data VarDomain + = NonNegative -- ^ var >= 0 (standard simplex assumption, no transformation needed) + | LowerBound SimplexNum -- ^ var >= L for some L (if L < 0: shift, if L > 0: add constraint) + | Unbounded -- ^ No lower bound (split into difference of two non-negative vars) + deriving stock (Show, Read, Eq, Generic) + +-- | Map from variables to their domain specifications. +-- Variables not in this map are assumed to be Unbounded. +newtype VarDomainMap = VarDomainMap { unVarDomainMap :: M.Map Var VarDomain } + deriving stock (Show, Read, Eq, Generic) + +-- | Transformations applied to variables to ensure they satisfy the non-negativity requirement. +data VarTransform + = AddLowerBound + { var :: !Var + , bound :: !SimplexNum + } -- ^ var >= bound where bound > 0. Adds GEQ constraint to system. + | Shift + { originalVar :: !Var + , shiftedVar :: !Var + , shiftBy :: !SimplexNum + } -- ^ originalVar = shiftedVar + shiftBy, where shiftBy < 0. After solving: originalVar = shiftedVar + shiftBy + | Split + { originalVar :: !Var + , posVar :: !Var + , negVar :: !Var + } -- ^ originalVar = posVar - negVar, both posVar and negVar >= 0 + deriving stock (Show, Read, Eq, Generic) + + + diff --git a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs index 06b98d9..d3cd2a1 100644 --- a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs +++ b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs @@ -2,7 +2,6 @@ module Linear.Simplex.Solver.TwoPhaseSpec where import Prelude hiding (EQ) -import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger import qualified Data.Map as M @@ -17,1065 +16,20 @@ import Linear.Simplex.Solver.TwoPhase import Linear.Simplex.Types import Linear.Simplex.Util -testsList :: [((ObjectiveFunction, [PolyConstraint]), Maybe Result)] -testsList = - [ (test1, Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)]))) - , (test2, Just (Result 7 (M.fromList [(7, 0)]))) - , (test3, Nothing) - , (test4, Just (Result 11 (M.fromList [(11, 237 % 7), (1, 24 % 7), (2, 33 % 7)]))) - , (test5, Just (Result 9 (M.fromList [(9, 3 % 5), (2, 14 % 5), (3, 17 % 5)]))) - , (test6, Nothing) - , (test7, Just (Result 8 (M.fromList [(8, 1), (2, 2), (1, 3)]))) - , (test8, Just (Result 8 (M.fromList [(8, (-1) % 4), (2, 9 % 2), (1, 17 % 4)]))) - , (test9, Just (Result 7 (M.fromList [(7, 5), (3, 2), (4, 1)]))) - , (test10, Just (Result 7 (M.fromList [(7, 8), (1, 2), (2, 6)]))) - , (test11, Just (Result 8 (M.fromList [(8, 20), (4, 16), (3, 6)]))) - , (test12, Just (Result 8 (M.fromList [(8, 6), (4, 2), (5, 2)]))) - , (test13, Just (Result 6 (M.fromList [(6, 150), (2, 150)]))) - , (test14, Just (Result 6 (M.fromList [(6, 40 % 3), (2, 40 % 3)]))) - , (test15, Nothing) - , (test16, Just (Result 6 (M.fromList [(6, 75), (1, 75 % 2)]))) - , (test17, Just (Result 7 (M.fromList [(7, (-120)), (1, 20)]))) - , (test18, Just (Result 7 (M.fromList [(7, 10), (3, 5)]))) - , (test19, Nothing) - , (test20, Nothing) - , (test21, Just (Result 7 (M.fromList [(7, 250), (2, 50)]))) - , (test22, Just (Result 7 (M.fromList [(7, 0)]))) - , (test23, Nothing) - , (test24, Just (Result 10 (M.fromList [(10, 300), (3, 150)]))) - , (test25, Just (Result 3 (M.fromList [(3, 15), (1, 15)]))) - , (test26, Just (Result 6 (M.fromList [(6, 20), (1, 10), (2, 10)]))) - , (test27, Just (Result 3 (M.fromList [(3, 0)]))) - , (test28, Just (Result 6 (M.fromList [(6, 0), (2, 10)]))) - , (test29, Nothing) - , (test30, Nothing) - , (test31, Just (Result 5 (M.fromList [(2, 1 % 1), (5, 0 % 1)]))) - , (test32, Nothing) - , (testPolyPaver1, Just (Result 12 (M.fromList [(12, 7 % 4), (2, 5 % 2), (1, 7 % 4), (3, 0)]))) - , (testPolyPaver2, Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) - , (testPolyPaver3, Just (Result 12 (M.fromList [(12, 5 % 3), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) - , (testPolyPaver4, Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 2), (1, 5 % 2), (3, 0)]))) - , (testPolyPaver5, Nothing) - , (testPolyPaver6, Nothing) - , (testPolyPaver7, Nothing) - , (testPolyPaver8, Nothing) - , (testPolyPaver9, Just (Result 12 (M.fromList [(12, 7 % 2), (2, 5 % 9), (1, 7 % 2), (3, 0)]))) - , (testPolyPaver10, Just (Result 12 (M.fromList [(12, 17 % 20), (2, 7 % 2), (1, 17 % 20), (3, 0)]))) - , (testPolyPaver11, Just (Result 12 (M.fromList [(12, 7 % 2), (2, 7 % 2), (1, 22 % 9)]))) - , (testPolyPaver12, Just (Result 12 (M.fromList [(12, 5 % 9), (2, 5 % 9), (1, 7 % 2), (3, 0)]))) - , (testPolyPaverTwoFs1, Nothing) - , (testPolyPaverTwoFs2, Nothing) - , (testPolyPaverTwoFs3, Nothing) - , (testPolyPaverTwoFs4, Nothing) - , (testPolyPaverTwoFs5, Just (Result 17 (M.fromList [(17, 5 % 2), (2, 45 % 22), (1, 5 % 2), (4, 0)]))) - , (testPolyPaverTwoFs6, Just (Result 17 (M.fromList [(17, 45 % 22), (2, 5 % 2), (1, 45 % 22), (4, 0)]))) - , (testPolyPaverTwoFs7, Just (Result 17 (M.fromList [(17, 5 % 2), (2, 5 % 2), (1, 5 % 2), (4, 0)]))) - , (testPolyPaverTwoFs8, Just (Result 17 (M.fromList [(17, 45 % 22), (2, 45 % 22), (1, 5 % 2), (4, 0)]))) - , (testLeqGeqBugMin1, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) - , (testLeqGeqBugMax1, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) - , (testLeqGeqBugMin2, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) - , (testLeqGeqBugMax2, Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) - , (testQuickCheck1, Just (Result 10 (M.fromList [(10, (-370)), (2, 26), (1, 5 % 3)]))) - , (testQuickCheck2, Just (Result 8 (M.fromList [(8, (-2) % 9), (1, 14 % 9), (2, 8 % 9)]))) - , (testQuickCheck3, Just (Result 7 (M.fromList [(7, (-8)), (2, 2)]))) - ] - -testLeqGeqBugMin1 :: (ObjectiveFunction, [PolyConstraint]) -testLeqGeqBugMin1 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - -testLeqGeqBugMax1 :: (ObjectiveFunction, [PolyConstraint]) -testLeqGeqBugMax1 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - -testLeqGeqBugMin2 :: (ObjectiveFunction, [PolyConstraint]) -testLeqGeqBugMin2 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - -testLeqGeqBugMax2 :: (ObjectiveFunction, [PolyConstraint]) -testLeqGeqBugMax2 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - --- From page 50 of 'Linear and Integer Programming Made Easy' --- Solution: obj = 29, 1 = 3, 2 = 4, -test1 :: (ObjectiveFunction, [PolyConstraint]) -test1 = - ( Max (M.fromList [(1, 3), (2, 5)]) - , - [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 - , LEQ (M.fromList [(1, 1), (2, 1)]) 7 - , LEQ (M.fromList [(2, 1)]) 4 - , LEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - -test2 :: (ObjectiveFunction, [PolyConstraint]) -test2 = - ( Min (M.fromList [(1, 3), (2, 5)]) - , - [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 - , LEQ (M.fromList [(1, 1), (2, 1)]) 7 - , LEQ (M.fromList [(2, 1)]) 4 - , LEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - -test3 :: (ObjectiveFunction, [PolyConstraint]) -test3 = - ( Max (M.fromList [(1, 3), (2, 5)]) - , - [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 - , GEQ (M.fromList [(1, 1), (2, 1)]) 7 - , GEQ (M.fromList [(2, 1)]) 4 - , GEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - -test4 :: (ObjectiveFunction, [PolyConstraint]) -test4 = - ( Min (M.fromList [(1, 3), (2, 5)]) - , - [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 - , GEQ (M.fromList [(1, 1), (2, 1)]) 7 - , GEQ (M.fromList [(2, 1)]) 4 - , GEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - --- From https://www.eng.uwaterloo.ca/~syde05/phase1.pdf --- Solution: obj = 3/5, 2 = 14/5, 3 = 17/5 --- requires two phases -test5 :: (ObjectiveFunction, [PolyConstraint]) -test5 = - ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - -test6 :: (ObjectiveFunction, [PolyConstraint]) -test6 = - ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - -test7 :: (ObjectiveFunction, [PolyConstraint]) -test7 = - ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - -test8 :: (ObjectiveFunction, [PolyConstraint]) -test8 = - ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - --- From page 49 of 'Linear and Integer Programming Made Easy' --- Solution: obj = -5, 3 = 2, 4 = 1, objVar was negated so actual val is 5 wa --- requires two phases -test9 :: (ObjectiveFunction, [PolyConstraint]) -test9 = - ( Min (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) - , - [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 - , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 - ] - ) - -test10 :: (ObjectiveFunction, [PolyConstraint]) -test10 = - ( Max (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) - , - [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 - , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 - ] - ) - --- Adapted from page 52 of 'Linear and Integer Programming Made Easy' --- Removed variables which do not appear in the system (these should be artificial variables) --- Solution: obj = 20, 3 = 6, 4 = 16 wq -test11 :: (ObjectiveFunction, [PolyConstraint]) -test11 = - ( Max (M.fromList [(3, -2), (4, 2), (5, 1)]) - , - [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 - , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 - ] - ) - -test12 :: (ObjectiveFunction, [PolyConstraint]) -test12 = - ( Min (M.fromList [(3, -2), (4, 2), (5, 1)]) - , - [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 - , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 - ] - ) - --- From page 59 of 'Linear and Integer Programming Made Easy' --- Solution: obj = 150, 1 = 0, 2 = 150 --- requires two phases -test13 :: (ObjectiveFunction, [PolyConstraint]) -test13 = - ( Max (M.fromList [(1, 2), (2, 1)]) - , - [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - -test14 :: (ObjectiveFunction, [PolyConstraint]) -test14 = - ( Min (M.fromList [(1, 2), (2, 1)]) - , - [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - -test15 :: (ObjectiveFunction, [PolyConstraint]) -test15 = - ( Max (M.fromList [(1, 2), (2, 1)]) - , - [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - -test16 :: (ObjectiveFunction, [PolyConstraint]) -test16 = - ( Min (M.fromList [(1, 2), (2, 1)]) - , - [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - --- From page 59 of 'Linear and Integer Programming Made Easy' --- Solution: obj = 120, 1 = 20, 2 = 0, 3 = 0, objVar was negated so actual val is -120 -test17 :: (ObjectiveFunction, [PolyConstraint]) -test17 = - ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , LEQ (M.fromList [(2, -5), (3, 5)]) 100 - , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - -test18 :: (ObjectiveFunction, [PolyConstraint]) -test18 = - ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , LEQ (M.fromList [(2, -5), (3, 5)]) 100 - , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - -test19 :: (ObjectiveFunction, [PolyConstraint]) -test19 = - ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , GEQ (M.fromList [(2, -5), (3, 5)]) 100 - , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - -test20 :: (ObjectiveFunction, [PolyConstraint]) -test20 = - ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , GEQ (M.fromList [(2, -5), (3, 5)]) 100 - , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - --- From page 59 of 'Linear and Integer Programming Made Easy' --- Solution: obj = 250, 1 = 0, 2 = 50, 3 = 0 -test21 :: (ObjectiveFunction, [PolyConstraint]) -test21 = - ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - -test22 :: (ObjectiveFunction, [PolyConstraint]) -test22 = - ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - -test23 :: (ObjectiveFunction, [PolyConstraint]) -test23 = - ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - -test24 :: (ObjectiveFunction, [PolyConstraint]) -test24 = - ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - -test25 :: (ObjectiveFunction, [PolyConstraint]) -test25 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - ] - ) - -test26 :: (ObjectiveFunction, [PolyConstraint]) -test26 = - ( Max (M.fromList [(1, 2)]) - , - [ LEQ (M.fromList [(1, 2)]) 20 - , GEQ (M.fromList [(2, 1)]) 10 - ] - ) - -test27 :: (ObjectiveFunction, [PolyConstraint]) -test27 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - ] - ) - -test28 :: (ObjectiveFunction, [PolyConstraint]) -test28 = - ( Min (M.fromList [(1, 2)]) - , - [ LEQ (M.fromList [(1, 2)]) 20 - , GEQ (M.fromList [(2, 1)]) 10 - ] - ) - -test29 :: (ObjectiveFunction, [PolyConstraint]) -test29 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - , GEQ (M.fromList [(1, 1)]) 15.01 - ] - ) - -test30 :: (ObjectiveFunction, [PolyConstraint]) -test30 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - , GEQ (M.fromList [(1, 1)]) 15.01 - , GEQ (M.fromList [(2, 1)]) 10 - ] - ) - -test31 :: (ObjectiveFunction, [PolyConstraint]) -test31 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1)]) 1 - , GEQ (M.fromList [(1, 1), (2, 1)]) 1 - ] - ) - -test32 :: (ObjectiveFunction, [PolyConstraint]) -test32 = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1)]) 2 - , LEQ (M.fromList [(1, 1), (2, 1)]) 1 - ] - ) - --- Tests for systems similar to those from PolyPaver2 -testPolyPaver1 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver1 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver2 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver2 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver3 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver3 = - ( Min (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver4 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver4 = - ( Max (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver5 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver5 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 1.5 - x2l = 0.0 - x2r = 1.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver6 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver6 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 1.5 - x2l = 0.0 - x2r = 1.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver7 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver7 = - ( Max (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 1.5 - x2l = 0.0 - x2r = 1.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver8 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver8 = - ( Min (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 1.5 - x2l = 0.0 - x2r = 1.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver9 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver9 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 3.5 - x2l = 0.0 - x2r = 3.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver10 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver10 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 3.5 - x2l = 0.0 - x2r = 3.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver11 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver11 = - ( Max (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 3.5 - x2l = 0.0 - x2r = 3.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaver12 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaver12 = - ( Min (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) - , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 3.5 - x2l = 0.0 - x2r = 3.5 - dx1l = -1 - dx1r = -0.9 - dx2l = -0.9 - dx2r = -0.8 - yl = 4 - yr = 5 - -testPolyPaverTwoFs1 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs1 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -1 - f2dx1r = -0.9 - f2dx2l = -0.9 - f2dx2r = -0.8 - f2yl = 1 - f2yr = 2 - -testPolyPaverTwoFs2 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs2 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -1 - f2dx1r = -0.9 - f2dx2l = -0.9 - f2dx2r = -0.8 - f2yl = 1 - f2yr = 2 - -testPolyPaverTwoFs3 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs3 = - ( Max (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -1 - f2dx1r = -0.9 - f2dx2l = -0.9 - f2dx2r = -0.8 - f2yl = 1 - f2yr = 2 - -testPolyPaverTwoFs4 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs4 = - ( Min (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -1 - f2dx1r = -0.9 - f2dx2l = -0.9 - f2dx2r = -0.8 - f2yl = 1 - f2yr = 2 - -testPolyPaverTwoFs5 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs5 = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -0.66 - f2dx1r = -0.66 - f2dx2l = -0.66 - f2dx2r = -0.66 - f2yl = 3 - f2yr = 4 - -testPolyPaverTwoFs6 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs6 = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -0.66 - f2dx1r = -0.66 - f2dx2l = -0.66 - f2dx2r = -0.66 - f2yl = 3 - f2yr = 4 - -testPolyPaverTwoFs7 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs7 = - ( Max (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -0.66 - f2dx1r = -0.66 - f2dx2l = -0.66 - f2dx2r = -0.66 - f2yl = 3 - f2yr = 4 - -testPolyPaverTwoFs8 :: (ObjectiveFunction, [PolyConstraint]) -testPolyPaverTwoFs8 = - ( Min (M.fromList [(2, 1)]) - , - [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) - , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) - , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) - , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) - , GEQ (M.fromList [(1, 1)]) x1l - , LEQ (M.fromList [(1, 1)]) x1r - , GEQ (M.fromList [(2, 1)]) x2l - , LEQ (M.fromList [(2, 1)]) x2r - , LEQ (M.fromList [(3, 1)]) 0 - , LEQ (M.fromList [(4, 1)]) 0 - ] - ) - where - x1l = 0.0 - x1r = 2.5 - x2l = 0.0 - x2r = 2.5 - f1dx1l = -1 - f1dx1r = -0.9 - f1dx2l = -0.9 - f1dx2r = -0.8 - f1yl = 4 - f1yr = 5 - f2dx1l = -0.66 - f2dx1r = -0.66 - f2dx2l = -0.66 - f2dx2r = -0.66 - f2yl = 3 - f2yr = 4 - --- Test cases produced by old simplex-haskell/SoPlex QuickCheck prop - -testQuickCheck1 :: (ObjectiveFunction, [PolyConstraint]) -testQuickCheck1 = - ( Max (M.fromList [(1, 12), (2, -15)]) - , - [ EQ (M.fromList [(1, 24), (2, -2)]) (-12) - , GEQ (M.fromList [(1, -20), (2, 11)]) (-7) - , GEQ (M.fromList [(1, -28), (2, 5)]) (-8) - , GEQ (M.fromList [(1, 3), (2, 0)]) 5 - , LEQ (M.fromList [(1, -48)]) (-1) - ] - ) - --- Correct solution is -2/9 -testQuickCheck2 :: (ObjectiveFunction, [PolyConstraint]) -testQuickCheck2 = - ( Max (M.fromList [(1, -3), (2, 5)]) - , - [ LEQ (M.fromList [(1, -6), (2, 6)]) 4 - , LEQ (M.fromList [(1, 1), (2, -4), (3, 3)]) (-2) - , LEQ (M.fromList [(2, 7), (1, -4)]) 0 - ] - ) - --- This test will fail if the objective function is not simplified -testQuickCheck3 :: (ObjectiveFunction, [PolyConstraint]) -testQuickCheck3 = - ( Min (M.fromList [(2, 0), (2, -4)]) - , - [ GEQ (M.fromList [(1, 5), (2, 4)]) (-4) - , LEQ (M.fromList [(1, -1), (2, -1)]) 2 - , LEQ (M.fromList [(2, 1)]) 2 - , GEQ (M.fromList [(1, -5), (2, -1), (2, 1)]) (-5) - ] - ) +-- | Helper to run a test case and check result +runTest :: (ObjectiveFunction, [PolyConstraint]) -> Maybe Result -> IO () +runTest (obj, constraints) expectedResult = do + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex obj constraints + let prettyObj = prettyShowObjectiveFunction obj + prettyConstraints = map prettyShowPolyConstraint constraints + expectedObjVal = extractObjectiveValue expectedResult + actualObjVal = extractObjectiveValue actualResult + annotate + [qc| -spec :: Spec -spec = describe "twoPhaseSimplex" $ do - it "Check golden tests" $ do - forM_ testsList $ - \((obj, constraints), expectedResult) -> do - actualResult <- - runStdoutLoggingT $ - filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex obj constraints - let prettyObj = prettyShowObjectiveFunction obj - prettyConstraints = map prettyShowPolyConstraint constraints - - expectedObjVal = extractObjectiveValue expectedResult - actualObjVal = extractObjectiveValue actualResult - annotate - [qc| - Objective Function (Non-prettified): {obj} Constraints (Non-prettified): {constraints} ==================================== @@ -1087,6 +41,711 @@ Actual Solution (Full): {actualResult} Expected Solution (Objective): {expectedObjVal} Actual Solution (Objective): {actualObjVal} - |] - $ do - actualResult `shouldBe` expectedResult + |] + $ do + actualResult `shouldBe` expectedResult + +spec :: Spec +spec = do + describe "twoPhaseSimplex" $ do + -- From page 50 of 'Linear and Integer Programming Made Easy' + describe "From 'Linear and Integer Programming Made Easy' (page 50)" $ do + it "Max 3x₁ + 5x₂ with LEQ constraints: obj=29, x₁=3, x₂=4" $ do + let testCase = + ( Max (M.fromList [(1, 3), (2, 5)]) + , [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 + , LEQ (M.fromList [(1, 1), (2, 1)]) 7 + , LEQ (M.fromList [(2, 1)]) 4 + , LEQ (M.fromList [(1, -1), (2, 2)]) 6 + ] + ) + runTest testCase (Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)]))) + + it "Min 3x₁ + 5x₂ with LEQ constraints: obj=0" $ do + let testCase = + ( Min (M.fromList [(1, 3), (2, 5)]) + , [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 + , LEQ (M.fromList [(1, 1), (2, 1)]) 7 + , LEQ (M.fromList [(2, 1)]) 4 + , LEQ (M.fromList [(1, -1), (2, 2)]) 6 + ] + ) + runTest testCase (Just (Result 7 (M.fromList [(7, 0)]))) + + it "Max 3x₁ + 5x₂ with GEQ constraints: infeasible" $ do + let testCase = + ( Max (M.fromList [(1, 3), (2, 5)]) + , [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 + , GEQ (M.fromList [(1, 1), (2, 1)]) 7 + , GEQ (M.fromList [(2, 1)]) 4 + , GEQ (M.fromList [(1, -1), (2, 2)]) 6 + ] + ) + runTest testCase Nothing + + it "Min 3x₁ + 5x₂ with GEQ constraints: obj=237/7, x₁=24/7, x₂=33/7" $ do + let testCase = + ( Min (M.fromList [(1, 3), (2, 5)]) + , [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 + , GEQ (M.fromList [(1, 1), (2, 1)]) 7 + , GEQ (M.fromList [(2, 1)]) 4 + , GEQ (M.fromList [(1, -1), (2, 2)]) 6 + ] + ) + runTest testCase (Just (Result 11 (M.fromList [(11, 237 % 7), (1, 24 % 7), (2, 33 % 7)]))) + + -- From https://www.eng.uwaterloo.ca/~syde05/phase1.pdf (requires two phases) + describe "From eng.uwaterloo.ca phase1.pdf (requires two phases)" $ do + it "Max x₁ - x₂ + x₃ with LEQ constraints: obj=3/5, x₂=14/5, x₃=17/5" $ do + let testCase = + ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) + , [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) + ] + ) + runTest testCase (Just (Result 9 (M.fromList [(9, 3 % 5), (2, 14 % 5), (3, 17 % 5)]))) + + it "Min x₁ - x₂ + x₃ with LEQ constraints: infeasible" $ do + let testCase = + ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) + , [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) + ] + ) + runTest testCase Nothing + + it "Max x₁ - x₂ + x₃ with GEQ constraints: obj=1, x₁=3, x₂=2" $ do + let testCase = + ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) + , [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) + ] + ) + runTest testCase (Just (Result 8 (M.fromList [(8, 1), (2, 2), (1, 3)]))) + + it "Min x₁ - x₂ + x₃ with GEQ constraints: obj=-1/4, x₁=17/4, x₂=9/2" $ do + let testCase = + ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) + , [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) + ] + ) + runTest testCase (Just (Result 8 (M.fromList [(8, (-1) % 4), (2, 9 % 2), (1, 17 % 4)]))) + + -- From page 49 of 'Linear and Integer Programming Made Easy' (requires two phases) + describe "From 'Linear and Integer Programming Made Easy' (page 49, requires two phases)" $ do + it "Min x₁ + x₂ + 2x₃ + x₄ with EQ constraints: obj=5, x₃=2, x₄=1" $ do + let testCase = + ( Min (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) + , [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 + , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 + ] + ) + runTest testCase (Just (Result 7 (M.fromList [(7, 5), (3, 2), (4, 1)]))) + + it "Max x₁ + x₂ + 2x₃ + x₄ with EQ constraints: obj=8, x₁=2, x₂=6" $ do + let testCase = + ( Max (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) + , [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 + , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 + ] + ) + runTest testCase (Just (Result 7 (M.fromList [(7, 8), (1, 2), (2, 6)]))) + + -- From page 52 of 'Linear and Integer Programming Made Easy' + describe "From 'Linear and Integer Programming Made Easy' (page 52)" $ do + it "Max -2x₃ + 2x₄ + x₅ with EQ constraints: obj=20, x₃=6, x₄=16" $ do + let testCase = + ( Max (M.fromList [(3, -2), (4, 2), (5, 1)]) + , [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 + , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 + ] + ) + runTest testCase (Just (Result 8 (M.fromList [(8, 20), (4, 16), (3, 6)]))) + + it "Min -2x₃ + 2x₄ + x₅ with EQ constraints: obj=6, x₄=2, x₅=2" $ do + let testCase = + ( Min (M.fromList [(3, -2), (4, 2), (5, 1)]) + , [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 + , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 + ] + ) + runTest testCase (Just (Result 8 (M.fromList [(8, 6), (4, 2), (5, 2)]))) + + -- From page 59 of 'Linear and Integer Programming Made Easy' (requires two phases) + describe "From 'Linear and Integer Programming Made Easy' (page 59, requires two phases)" $ do + it "Max 2x₁ + x₂: obj=150, x₂=150" $ do + let testCase = + ( Max (M.fromList [(1, 2), (2, 1)]) + , [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) + ] + ) + runTest testCase (Just (Result 6 (M.fromList [(6, 150), (2, 150)]))) + + it "Min 2x₁ + x₂: obj=40/3, x₂=40/3" $ do + let testCase = + ( Min (M.fromList [(1, 2), (2, 1)]) + , [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) + ] + ) + runTest testCase (Just (Result 6 (M.fromList [(6, 40 % 3), (2, 40 % 3)]))) + + it "Max 2x₁ + x₂ with GEQ constraints: infeasible" $ do + let testCase = + ( Max (M.fromList [(1, 2), (2, 1)]) + , [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) + ] + ) + runTest testCase Nothing + + it "Min 2x₁ + x₂ with GEQ constraints: obj=75, x₁=75/2" $ do + let testCase = + ( Min (M.fromList [(1, 2), (2, 1)]) + , [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) + ] + ) + runTest testCase (Just (Result 6 (M.fromList [(6, 75), (1, 75 % 2)]))) + + -- From page 59 of 'Linear and Integer Programming Made Easy' + describe "From 'Linear and Integer Programming Made Easy' (page 59)" $ do + it "Min -6x₁ - 4x₂ + 2x₃: obj=-120, x₁=20" $ do + let testCase = + ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) + , [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , LEQ (M.fromList [(2, -5), (3, 5)]) 100 + , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 + ] + ) + runTest testCase (Just (Result 7 (M.fromList [(7, (-120)), (1, 20)]))) + + it "Max -6x₁ - 4x₂ + 2x₃: obj=10, x₃=5" $ do + let testCase = + ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) + , [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , LEQ (M.fromList [(2, -5), (3, 5)]) 100 + , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 + ] + ) + runTest testCase (Just (Result 7 (M.fromList [(7, 10), (3, 5)]))) + + it "Min -6x₁ - 4x₂ + 2x₃ with GEQ constraints: infeasible" $ do + let testCase = + ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) + , [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , GEQ (M.fromList [(2, -5), (3, 5)]) 100 + , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 + ] + ) + runTest testCase Nothing + + it "Max -6x₁ - 4x₂ + 2x₃ with GEQ constraints: infeasible" $ do + let testCase = + ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) + , [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , GEQ (M.fromList [(2, -5), (3, 5)]) 100 + , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 + ] + ) + runTest testCase Nothing + + -- From page 59 of 'Linear and Integer Programming Made Easy' + describe "From 'Linear and Integer Programming Made Easy' (page 59)" $ do + it "Max 3x₁ + 5x₂ + 2x₃: obj=250, x₂=50" $ do + let testCase = + ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) + , [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 + ] + ) + runTest testCase (Just (Result 7 (M.fromList [(7, 250), (2, 50)]))) + + it "Min 3x₁ + 5x₂ + 2x₃: obj=0" $ do + let testCase = + ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) + , [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 + ] + ) + runTest testCase (Just (Result 7 (M.fromList [(7, 0)]))) + + it "Max 3x₁ + 5x₂ + 2x₃ with GEQ constraints: infeasible" $ do + let testCase = + ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) + , [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 + ] + ) + runTest testCase Nothing + + it "Min 3x₁ + 5x₂ + 2x₃ with GEQ constraints: obj=300, x₃=150" $ do + let testCase = + ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) + , [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 + ] + ) + runTest testCase (Just (Result 10 (M.fromList [(10, 300), (3, 150)]))) + + describe "Simple single/two variable tests" $ do + it "Max x₁ with x₁ <= 15: obj=15, x₁=15" $ do + let testCase = + ( Max (M.fromList [(1, 1)]) + , [ LEQ (M.fromList [(1, 1)]) 15 + ] + ) + runTest testCase (Just (Result 3 (M.fromList [(3, 15), (1, 15)]))) + + it "Max 2x₁ with mixed constraints: obj=20, x₁=10, x₂=10" $ do + let testCase = + ( Max (M.fromList [(1, 2)]) + , [ LEQ (M.fromList [(1, 2)]) 20 + , GEQ (M.fromList [(2, 1)]) 10 + ] + ) + runTest testCase (Just (Result 6 (M.fromList [(6, 20), (1, 10), (2, 10)]))) + + it "Min x₁ with x₁ <= 15: obj=0" $ do + let testCase = + ( Min (M.fromList [(1, 1)]) + , [ LEQ (M.fromList [(1, 1)]) 15 + ] + ) + runTest testCase (Just (Result 3 (M.fromList [(3, 0)]))) + + it "Min 2x₁ with mixed constraints: obj=0, x₂=10" $ do + let testCase = + ( Min (M.fromList [(1, 2)]) + , [ LEQ (M.fromList [(1, 2)]) 20 + , GEQ (M.fromList [(2, 1)]) 10 + ] + ) + runTest testCase (Just (Result 6 (M.fromList [(6, 0), (2, 10)]))) + + describe "Infeasibility tests" $ do + it "Conflicting bounds x₁ <= 15 and x₁ >= 15.01: infeasible" $ do + let testCase = + ( Max (M.fromList [(1, 1)]) + , [ LEQ (M.fromList [(1, 1)]) 15 + , GEQ (M.fromList [(1, 1)]) 15.01 + ] + ) + runTest testCase Nothing + + it "Conflicting bounds with additional constraint: infeasible" $ do + let testCase = + ( Max (M.fromList [(1, 1)]) + , [ LEQ (M.fromList [(1, 1)]) 15 + , GEQ (M.fromList [(1, 1)]) 15.01 + , GEQ (M.fromList [(2, 1)]) 10 + ] + ) + runTest testCase Nothing + + it "Min x₁ with duplicate GEQ constraints: obj=0, x₂=1" $ do + let testCase = + ( Min (M.fromList [(1, 1)]) + , [ GEQ (M.fromList [(1, 1), (2, 1)]) 1 + , GEQ (M.fromList [(1, 1), (2, 1)]) 1 + ] + ) + runTest testCase (Just (Result 5 (M.fromList [(2, 1 % 1), (5, 0 % 1)]))) + + it "Conflicting x₁+x₂ >= 2 and x₁+x₂ <= 1: infeasible" $ do + let testCase = + ( Min (M.fromList [(1, 1)]) + , [ GEQ (M.fromList [(1, 1), (2, 1)]) 2 + , LEQ (M.fromList [(1, 1), (2, 1)]) 1 + ] + ) + runTest testCase Nothing + + describe "LEQ/GEQ reduction bug tests" $ do + it "testLeqGeqBugMin1: obj=3, x₁=3, x₂=3" $ do + let testCase = + ( Min (M.fromList [(1, 1)]) + , [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 + ] + ) + runTest testCase (Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + + it "testLeqGeqBugMax1: obj=3, x₁=3, x₂=3" $ do + let testCase = + ( Min (M.fromList [(1, 1)]) + , [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 + ] + ) + runTest testCase (Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + + it "testLeqGeqBugMin2: obj=3, x₁=3, x₂=3" $ do + let testCase = + ( Min (M.fromList [(1, 1)]) + , [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 + ] + ) + runTest testCase (Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + + it "testLeqGeqBugMax2: obj=3, x₁=3, x₂=3" $ do + let testCase = + ( Min (M.fromList [(1, 1)]) + , [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 + ] + ) + runTest testCase (Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + + -- PolyPaver-style tests with shared parameters + describe "PolyPaver-style tests (feasible region [0,2.5]²)" $ do + let x1l = 0.0; x1r = 2.5; x2l = 0.0; x2r = 2.5 + dx1l = -1; dx1r = -0.9; dx2l = -0.9; dx2r = -0.8 + yl = 4; yr = 5 + mkConstraints obj = + ( obj + , [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + ] + ) + + it "Min x₁: x₁=7/4, x₂=5/2" $ do + runTest (mkConstraints (Min (M.fromList [(1, 1)]))) + (Just (Result 12 (M.fromList [(12, 7 % 4), (2, 5 % 2), (1, 7 % 4), (3, 0)]))) + + it "Max x₁: x₁=5/2, x₂=5/3" $ do + runTest (mkConstraints (Max (M.fromList [(1, 1)]))) + (Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) + + it "Min x₂: x₂=5/3" $ do + runTest (mkConstraints (Min (M.fromList [(2, 1)]))) + (Just (Result 12 (M.fromList [(12, 5 % 3), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) + + it "Max x₂: x₂=5/2" $ do + runTest (mkConstraints (Max (M.fromList [(2, 1)]))) + (Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 2), (1, 5 % 2), (3, 0)]))) + + describe "PolyPaver-style tests (infeasible region [0,1.5]²)" $ do + let x1l = 0.0; x1r = 1.5; x2l = 0.0; x2r = 1.5 + dx1l = -1; dx1r = -0.9; dx2l = -0.9; dx2r = -0.8 + yl = 4; yr = 5 + mkConstraints obj = + ( obj + , [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + ] + ) + + it "Max x₁: infeasible" $ do + runTest (mkConstraints (Max (M.fromList [(1, 1)]))) Nothing + + it "Min x₁: infeasible" $ do + runTest (mkConstraints (Min (M.fromList [(1, 1)]))) Nothing + + it "Max x₂: infeasible" $ do + runTest (mkConstraints (Max (M.fromList [(2, 1)]))) Nothing + + it "Min x₂: infeasible" $ do + runTest (mkConstraints (Min (M.fromList [(2, 1)]))) Nothing + + describe "PolyPaver-style tests (feasible region [0,3.5]²)" $ do + let x1l = 0.0; x1r = 3.5; x2l = 0.0; x2r = 3.5 + dx1l = -1; dx1r = -0.9; dx2l = -0.9; dx2r = -0.8 + yl = 4; yr = 5 + mkConstraints obj = + ( obj + , [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + ] + ) + + it "Max x₁: x₁=7/2" $ do + runTest (mkConstraints (Max (M.fromList [(1, 1)]))) + (Just (Result 12 (M.fromList [(12, 7 % 2), (2, 5 % 9), (1, 7 % 2), (3, 0)]))) + + it "Min x₁: x₁=17/20" $ do + runTest (mkConstraints (Min (M.fromList [(1, 1)]))) + (Just (Result 12 (M.fromList [(12, 17 % 20), (2, 7 % 2), (1, 17 % 20), (3, 0)]))) + + it "Max x₂: x₂=7/2" $ do + runTest (mkConstraints (Max (M.fromList [(2, 1)]))) + (Just (Result 12 (M.fromList [(12, 7 % 2), (2, 7 % 2), (1, 22 % 9)]))) + + it "Min x₂: x₂=5/9" $ do + runTest (mkConstraints (Min (M.fromList [(2, 1)]))) + (Just (Result 12 (M.fromList [(12, 5 % 9), (2, 5 % 9), (1, 7 % 2), (3, 0)]))) + + describe "PolyPaver two-function tests (infeasible)" $ do + let x1l = 0.0; x1r = 2.5; x2l = 0.0; x2r = 2.5 + f1dx1l = -1; f1dx1r = -0.9; f1dx2l = -0.9; f1dx2r = -0.8 + f1yl = 4; f1yr = 5 + f2dx1l = -1; f2dx1r = -0.9; f2dx2l = -0.9; f2dx2r = -0.8 + f2yl = 1; f2yr = 2 + mkConstraints obj = + ( obj + , [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 + ] + ) + + it "Max x₁: infeasible" $ do + runTest (mkConstraints (Max (M.fromList [(1, 1)]))) Nothing + + it "Min x₁: infeasible" $ do + runTest (mkConstraints (Min (M.fromList [(1, 1)]))) Nothing + + it "Max x₂: infeasible" $ do + runTest (mkConstraints (Max (M.fromList [(2, 1)]))) Nothing + + it "Min x₂: infeasible" $ do + runTest (mkConstraints (Min (M.fromList [(2, 1)]))) Nothing + + describe "PolyPaver two-function tests (feasible)" $ do + let x1l = 0.0; x1r = 2.5; x2l = 0.0; x2r = 2.5 + f1dx1l = -1; f1dx1r = -0.9; f1dx2l = -0.9; f1dx2r = -0.8 + f1yl = 4; f1yr = 5 + f2dx1l = -0.66; f2dx1r = -0.66; f2dx2l = -0.66; f2dx2r = -0.66 + f2yl = 3; f2yr = 4 + mkConstraints obj = + ( obj + , [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) + , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) + , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) + , GEQ (M.fromList [(1, 1)]) x1l + , LEQ (M.fromList [(1, 1)]) x1r + , GEQ (M.fromList [(2, 1)]) x2l + , LEQ (M.fromList [(2, 1)]) x2r + , LEQ (M.fromList [(3, 1)]) 0 + , LEQ (M.fromList [(4, 1)]) 0 + ] + ) + + it "Max x₁: x₁=5/2" $ do + runTest (mkConstraints (Max (M.fromList [(1, 1)]))) + (Just (Result 17 (M.fromList [(17, 5 % 2), (2, 45 % 22), (1, 5 % 2), (4, 0)]))) + + it "Min x₁: x₁=45/22" $ do + runTest (mkConstraints (Min (M.fromList [(1, 1)]))) + (Just (Result 17 (M.fromList [(17, 45 % 22), (2, 5 % 2), (1, 45 % 22), (4, 0)]))) + + it "Max x₂: x₂=5/2" $ do + runTest (mkConstraints (Max (M.fromList [(2, 1)]))) + (Just (Result 17 (M.fromList [(17, 5 % 2), (2, 5 % 2), (1, 5 % 2), (4, 0)]))) + + it "Min x₂: x₂=45/22" $ do + runTest (mkConstraints (Min (M.fromList [(2, 1)]))) + (Just (Result 17 (M.fromList [(17, 45 % 22), (2, 45 % 22), (1, 5 % 2), (4, 0)]))) + + describe "QuickCheck-generated regression tests" $ do + it "testQuickCheck1: obj=-370, x₁=5/3, x₂=26" $ do + let testCase = + ( Max (M.fromList [(1, 12), (2, -15)]) + , [ EQ (M.fromList [(1, 24), (2, -2)]) (-12) + , GEQ (M.fromList [(1, -20), (2, 11)]) (-7) + , GEQ (M.fromList [(1, -28), (2, 5)]) (-8) + , GEQ (M.fromList [(1, 3), (2, 0)]) 5 + , LEQ (M.fromList [(1, -48)]) (-1) + ] + ) + runTest testCase (Just (Result 10 (M.fromList [(10, (-370)), (2, 26), (1, 5 % 3)]))) + + it "testQuickCheck2: obj=-2/9, x₁=14/9, x₂=8/9" $ do + let testCase = + ( Max (M.fromList [(1, -3), (2, 5)]) + , [ LEQ (M.fromList [(1, -6), (2, 6)]) 4 + , LEQ (M.fromList [(1, 1), (2, -4), (3, 3)]) (-2) + , LEQ (M.fromList [(2, 7), (1, -4)]) 0 + ] + ) + runTest testCase (Just (Result 8 (M.fromList [(8, (-2) % 9), (1, 14 % 9), (2, 8 % 9)]))) + + it "testQuickCheck3 (tests objective simplification): obj=-8, x₂=2" $ do + let testCase = + ( Min (M.fromList [(2, 0), (2, -4)]) + , [ GEQ (M.fromList [(1, 5), (2, 4)]) (-4) + , LEQ (M.fromList [(1, -1), (2, -1)]) 2 + , LEQ (M.fromList [(2, 1)]) 2 + , GEQ (M.fromList [(1, -5), (2, -1), (2, 1)]) (-5) + ] + ) + runTest testCase (Just (Result 7 (M.fromList [(7, (-8)), (2, 2)]))) + + describe "twoPhaseSimplex' (with VarDomainMap)" $ do + it "NonNegative domain gives same result as twoPhaseSimplex" $ do + let obj = Max (M.fromList [(1, 3), (2, 5)]) + constraints = + [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 + , LEQ (M.fromList [(1, 1), (2, 1)]) 7 + , LEQ (M.fromList [(2, 1)]) 4 + , LEQ (M.fromList [(1, -1), (2, 2)]) 6 + ] + domainMap = VarDomainMap $ M.fromList [(1, NonNegative), (2, NonNegative)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + actualResult `shouldBe` Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)])) + + it "Shift transformation with negative lower bound" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 (varValMap result) `shouldBe` Just 10 + + it "Shift transformation finds minimum at negative bound" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) 0 ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 (varValMap result) `shouldBe` Just (-5) + + it "Split transformation for unbounded variable (max)" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 10 + , GEQ (M.fromList [(1, 1)]) (-10) + ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 (varValMap result) `shouldBe` Just 10 + + it "Split transformation for unbounded variable (min)" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 10 + , GEQ (M.fromList [(1, 1)]) (-10) + ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 (varValMap result) `shouldBe` Just (-10) + + it "AddLowerBound with positive lower bound" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound 5)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 (varValMap result) `shouldBe` Just 10 + + it "AddLowerBound finds minimum at positive bound" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound 5)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 (varValMap result) `shouldBe` Just 5 + + it "Mixed domain types" $ do + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1), (2, 1)]) 5 + , GEQ (M.fromList [(2, 1)]) (-3) + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-2)), (2, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let xVal = M.findWithDefault 0 1 (varValMap result) + yVal = M.findWithDefault 0 2 (varValMap result) + (xVal + yVal) `shouldBe` 5 + + it "LowerBound 0 is equivalent to NonNegative" $ do + let obj = Max (M.fromList [(1, 3), (2, 5)]) + constraints = + [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 + , LEQ (M.fromList [(1, 1), (2, 1)]) 7 + , LEQ (M.fromList [(2, 1)]) 4 + , LEQ (M.fromList [(1, -1), (2, 2)]) 6 + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound 0), (2, LowerBound 0)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + actualResult `shouldBe` Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)])) + + it "Infeasible system with domain constraint" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + actualResult `shouldBe` Nothing From 77072ca0dc226cc3fbb38361f5c1caf543574cb1 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 31 Jan 2026 13:48:52 +0000 Subject: [PATCH 03/17] test: ensure twoPhaseSimplex' gives the same result as twoPhaseSimplex --- .gitignore | 2 + src/Linear/Simplex/Solver/TwoPhase.hs | 50 +- src/Linear/Simplex/Types.hs | 1 + test/Linear/Simplex/Solver/TwoPhaseSpec.hs | 1102 +++++++++++++++++++- 4 files changed, 1136 insertions(+), 19 deletions(-) diff --git a/.gitignore b/.gitignore index c8e2cad..3b65193 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,5 @@ *~ dist-*/ .vscode/* +.direnv/* +.envrc diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index 97cbae3..cac4ef8 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -11,7 +11,27 @@ -- 'optimizeFeasibleSystem' performs phase two of the two-phase simplex method. -- 'twoPhaseSimplex' performs both phases of the two-phase simplex method. -- 'twoPhaseSimplex'' performs both phases with variable domain support. -module Linear.Simplex.Solver.TwoPhase (findFeasibleSolution, optimizeFeasibleSystem, twoPhaseSimplex, twoPhaseSimplex') where +module Linear.Simplex.Solver.TwoPhase + ( findFeasibleSolution + , optimizeFeasibleSystem + , twoPhaseSimplex + , twoPhaseSimplex' + -- Internal functions exported for testing + , preprocess + , postprocess + , computeObjective + , collectAllVars + , generateTransform + , getTransform + , applyTransforms + , applyTransform + , applyShiftToObjective + , applyShiftToConstraint + , applySplitToObjective + , applySplitToConstraint + , unapplyTransforms + , unapplyTransform + ) where import Prelude hiding (EQ) @@ -409,11 +429,13 @@ twoPhaseSimplex objFunction unsimplifiedSystem = do -- | Perform the two phase simplex method with variable domain information. -- Variables not in the VarDomainMap are assumed to be Unbounded (no lower bound). -- This function applies necessary transformations before solving and unapplies them after. +-- The returned Result contains variable values and objective value in the original space. +-- TODO: use this as twoPhaseSimplex, add instructions in CHANGELOG for old users twoPhaseSimplex' :: (MonadIO m, MonadLogger m) => VarDomainMap -> ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result) twoPhaseSimplex' domainMap objFunction constraints = do logMsg LevelInfo $ "twoPhaseSimplex': Solving system with domain map " <> showT domainMap - let (transformedObj, transformedConstraints, transforms) = preprocess objFunction domainMap constraints + let (transformedObj, transformedConstraints, transforms) = preprocess objFunction domainMap constraints logMsg LevelInfo $ "twoPhaseSimplex': Applied transforms " <> showT transforms <> "; Transformed objective: " <> showT transformedObj @@ -424,11 +446,31 @@ twoPhaseSimplex' domainMap objFunction constraints = do logMsg LevelInfo "twoPhaseSimplex': No solution found" pure Nothing Just result -> do - let finalResult = unapplyTransforms transforms result + let finalResult = postprocess objFunction transforms result logMsg LevelInfo $ - "twoPhaseSimplex': Unapplied transforms, final result: " <> showT finalResult + "twoPhaseSimplex': Postprocessed result: " <> showT finalResult pure (Just finalResult) +-- | Postprocess the result by unapplying variable transformations and computing +-- the objective value in the original space. +postprocess :: ObjectiveFunction -> [VarTransform] -> Result -> Result +postprocess objFunction transforms result = + let -- First unapply transforms to get variable values in original space + unappliedResult = unapplyTransforms transforms result + -- Then compute the objective value using the original objective function + objVal = computeObjective objFunction unappliedResult.varValMap + -- Update the objective value in the result + finalVarValMap = M.insert unappliedResult.objectiveVar objVal unappliedResult.varValMap + in unappliedResult { varValMap = finalVarValMap } + +-- | Compute the value of an objective function given variable values. +computeObjective :: ObjectiveFunction -> M.Map Var SimplexNum -> SimplexNum +computeObjective objFunction varVals = + let coeffs = case objFunction of + Max m -> m + Min m -> m + in sum $ map (\(var, coeff) -> coeff * M.findWithDefault 0 var varVals) (M.toList coeffs) + -- | Preprocess the system by applying variable transformations based on domain information. -- Returns the transformed objective, constraints, and the list of transforms applied. preprocess :: ObjectiveFunction diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index c688aaf..3d2ea63 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -129,6 +129,7 @@ data VarDomain = NonNegative -- ^ var >= 0 (standard simplex assumption, no transformation needed) | LowerBound SimplexNum -- ^ var >= L for some L (if L < 0: shift, if L > 0: add constraint) | Unbounded -- ^ No lower bound (split into difference of two non-negative vars) + -- TODO: Upperbound can still be useful, can negate it to get a loewr bound, can add it to the constraints deriving stock (Show, Read, Eq, Generic) -- | Map from variables to their domain specifications. diff --git a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs index d3cd2a1..8d0ca39 100644 --- a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs +++ b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Linear.Simplex.Solver.TwoPhaseSpec where import Prelude hiding (EQ) @@ -5,15 +6,19 @@ import Prelude hiding (EQ) import Control.Monad.IO.Class import Control.Monad.Logger import qualified Data.Map as M +import qualified Data.Set as Set import Data.Ratio + import Text.InterpolatedString.Perl6 import Test.Hspec import Test.Hspec.Expectations.Contrib (annotate) +import Test.QuickCheck hiding (Result) +import qualified Linear.Simplex.Types as T import Linear.Simplex.Prettify import Linear.Simplex.Solver.TwoPhase -import Linear.Simplex.Types +import Linear.Simplex.Types hiding (NonNegative) import Linear.Simplex.Util -- | Helper to run a test case and check result @@ -27,6 +32,14 @@ runTest (obj, constraints) expectedResult = do prettyConstraints = map prettyShowPolyConstraint constraints expectedObjVal = extractObjectiveValue expectedResult actualObjVal = extractObjectiveValue actualResult + -- HACK: Verify NonNegative twoPhaseSimplex' NonNegative == twoPhaseSimplex + allVars = collectAllVars obj constraints + domainMap = VarDomainMap $ M.fromSet (const T.NonNegative) allVars + actualResult' <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + let actualObjVal' = extractObjectiveValue actualResult' annotate [qc| @@ -40,10 +53,15 @@ Expected Solution (Full): {expectedResult} Actual Solution (Full): {actualResult} Expected Solution (Objective): {expectedObjVal} Actual Solution (Objective): {actualObjVal} - +==================================== +Actual Solution' (Full): {actualResult'} +Actual Solution' (Objective): {actualObjVal'} |] $ do actualResult `shouldBe` expectedResult + -- TODO: worth removing twoPhaseSimplex? + actualResult' `shouldBe` expectedResult + spec :: Spec spec = do @@ -615,6 +633,7 @@ spec = do describe "twoPhaseSimplex' (with VarDomainMap)" $ do it "NonNegative domain gives same result as twoPhaseSimplex" $ do + -- TODO: redundant if we keep the runTest hack let obj = Max (M.fromList [(1, 3), (2, 5)]) constraints = [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 @@ -622,7 +641,7 @@ spec = do , LEQ (M.fromList [(2, 1)]) 4 , LEQ (M.fromList [(1, -1), (2, 2)]) 6 ] - domainMap = VarDomainMap $ M.fromList [(1, NonNegative), (2, NonNegative)] + domainMap = VarDomainMap $ M.fromList [(1, T.NonNegative), (2, T.NonNegative)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -639,7 +658,7 @@ spec = do twoPhaseSimplex' domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 (varValMap result) `shouldBe` Just 10 + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 it "Shift transformation finds minimum at negative bound" $ do let obj = Min (M.fromList [(1, 1)]) @@ -651,7 +670,7 @@ spec = do twoPhaseSimplex' domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 (varValMap result) `shouldBe` Just (-5) + Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-5) it "Split transformation for unbounded variable (max)" $ do let obj = Max (M.fromList [(1, 1)]) @@ -666,7 +685,7 @@ spec = do twoPhaseSimplex' domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 (varValMap result) `shouldBe` Just 10 + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 it "Split transformation for unbounded variable (min)" $ do let obj = Min (M.fromList [(1, 1)]) @@ -681,7 +700,7 @@ spec = do twoPhaseSimplex' domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 (varValMap result) `shouldBe` Just (-10) + Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-10) it "AddLowerBound with positive lower bound" $ do let obj = Max (M.fromList [(1, 1)]) @@ -693,7 +712,7 @@ spec = do twoPhaseSimplex' domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 (varValMap result) `shouldBe` Just 10 + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 it "AddLowerBound finds minimum at positive bound" $ do let obj = Min (M.fromList [(1, 1)]) @@ -705,7 +724,7 @@ spec = do twoPhaseSimplex' domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 (varValMap result) `shouldBe` Just 5 + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 5 it "Mixed domain types" $ do let obj = Max (M.fromList [(1, 1), (2, 1)]) @@ -721,9 +740,11 @@ spec = do case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do - let xVal = M.findWithDefault 0 1 (varValMap result) - yVal = M.findWithDefault 0 2 (varValMap result) + let xVal = M.findWithDefault 0 1 result.varValMap + yVal = M.findWithDefault 0 2 result.varValMap + oVal = M.findWithDefault 0 result.objectiveVar result.varValMap (xVal + yVal) `shouldBe` 5 + oVal `shouldBe` 5 it "LowerBound 0 is equivalent to NonNegative" $ do let obj = Max (M.fromList [(1, 3), (2, 5)]) @@ -733,12 +754,18 @@ spec = do , LEQ (M.fromList [(2, 1)]) 4 , LEQ (M.fromList [(1, -1), (2, 2)]) 6 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound 0), (2, LowerBound 0)] - actualResult <- + domainMap1 = VarDomainMap $ M.fromList [(1, LowerBound 0), (2, LowerBound 0)] + domainMap2 = VarDomainMap $ M.fromList [(1, T.NonNegative), (2, T.NonNegative)] + actualResult1 <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints - actualResult `shouldBe` Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)])) + twoPhaseSimplex' domainMap1 obj constraints + actualResult2 <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap2 obj constraints + actualResult1 `shouldBe` Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)])) + actualResult1 `shouldBe` actualResult2 it "Infeasible system with domain constraint" $ do let obj = Max (M.fromList [(1, 1)]) @@ -749,3 +776,1048 @@ spec = do filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex' domainMap obj constraints actualResult `shouldBe` Nothing + + describe "twoPhaseSimplex' with negative lower bound s (Shift transformation)" $ do + describe "Simple single variable systems" $ do + it "Max x₁ with x₁ ≤ 5, x₁ ≥ -3: optimal at upper bound x₁=5" $ do + -- Simple case: maximize x with upper bound 5 and lower bound -3 + -- Optimal should be at x₁ = 5 + let obj = Max (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-3))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 5 + + it "Min x₁ with x₁ ≤ 5, x₁ ≥ -3: optimal at lower bound x₁=-3" $ do + -- Minimize x with upper bound 5 and lower bound -3 + -- Optimal should be at x₁ = -3 + let obj = Min (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-3))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-3) + + it "Max x₁ with x₁ ≥ -10, x₁ ≤ -2: optimal at x₁=-2" $ do + -- Both bounds are negative, maximize + let obj = Max (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) (-2) ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-10))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-2) + + it "Min x₁ with x₁ ≥ -10, x₁ ≤ -2: optimal at x₁=-10" $ do + -- Both bounds are negative, minimize + let obj = Min (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) (-2) ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-10))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-10) + + describe "Two variable systems with negative bounds" $ do + it "Max x₁ + x₂ with x₁ ≥ -2, x₂ ≥ -3, x₁ + x₂ ≤ 10" $ do + -- Maximize sum, both can go up to contribute to sum ≤ 10 + -- With shifts: x₁' = x₁ + 2, x₂' = x₂ + 3 + -- Constraint becomes: x₁' + x₂' ≤ 15 + -- Optimal in transformed space: x₁' + x₂' = 15 + -- After unapply: x₁ + x₂ = 15 - 5 = 10 + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = [ LEQ (M.fromList [(1, 1), (2, 1)]) 10 ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-2)), (2, LowerBound (-3))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let x1 = M.findWithDefault 0 1 result.varValMap + x2 = M.findWithDefault 0 2 result.varValMap + objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + -- Verify the actual objective value + objVal `shouldBe` 10 + -- Verify lower bounds are respected + x1 `shouldSatisfy` (>= (-2)) + x2 `shouldSatisfy` (>= (-3)) + + it "Min x₁ + x₂ with x₁ ≥ -2, x₂ ≥ -3, x₁ + x₂ ≤ 10" $ do + -- Minimize sum with lower bounds -2 and -3 + -- Optimal: x₁ = -2, x₂ = -3, sum = -5 + let obj = Min (M.fromList [(1, 1), (2, 1)]) + constraints = [ LEQ (M.fromList [(1, 1), (2, 1)]) 10 ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-2)), (2, LowerBound (-3))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + -- Verify the actual objective value + objVal `shouldBe` (-5) + M.lookup 1 result.varValMap `shouldBe` Just (-2) + M.lookup 2 result.varValMap `shouldBe` Just (-3) + + it "Max 2x₁ - x₂ with x₁ ≥ -5, x₂ ≥ -4, x₁ ≤ 3, x₂ ≤ 6" $ do + -- Maximize 2x₁ - x₂: want x₁ large (up to 3) and x₂ small (down to -4) + -- Optimal: x₁ = 3, x₂ = -4, obj = 2*3 - (-4) = 10 + let obj = Max (M.fromList [(1, 2), (2, -1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 6 + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5)), (2, LowerBound (-4))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let x1 = M.findWithDefault 0 1 result.varValMap + x2 = M.findWithDefault 0 2 result.varValMap + M.lookup 1 result.varValMap `shouldBe` Just 3 + M.lookup 2 result.varValMap `shouldBe` Just (-4) + -- Verify objective value computed from variables + (2 * x1 - x2) `shouldBe` 10 + + it "Min 2x₁ - x₂ with x₁ ≥ -5, x₂ ≥ -4, x₁ ≤ 3, x₂ ≤ 6" $ do + -- Minimize 2x₁ - x₂: want x₁ small (down to -5) and x₂ large (up to 6) + -- Optimal: x₁ = -5, x₂ = 6, obj = 2*(-5) - 6 = -16 + let obj = Min (M.fromList [(1, 2), (2, -1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 6 + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5)), (2, LowerBound (-4))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let x1 = M.findWithDefault 0 1 result.varValMap + x2 = M.findWithDefault 0 2 result.varValMap + M.lookup 1 result.varValMap `shouldBe` Just (-5) + M.lookup 2 result.varValMap `shouldBe` Just 6 + -- Verify objective value computed from variables + (2 * x1 - x2) `shouldBe` (-16) + + describe "Systems with GEQ constraints and negative bounds" $ do + it "Max x₁ with x₁ ≥ -5, x₁ ≥ 2 (GEQ tightens bound)" $ do + -- Lower bound is -5 but GEQ constraint says x₁ ≥ 2 + -- Without upper bound, this is unbounded for Max + -- Add an upper bound via another constraint + let obj = Max (M.fromList [(1, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1)]) 2 + , LEQ (M.fromList [(1, 1)]) 10 + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 + + it "Min x₁ with x₁ ≥ -5, x₁ ≥ 2 (GEQ tightens bound)" $ do + -- Minimize with GEQ 2, so minimum is at x₁ = 2 + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1)]) 2 + , LEQ (M.fromList [(1, 1)]) 10 + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 2 + + describe "Systems with EQ constraints and negative bounds" $ do + it "Max x₁ + x₂ with x₁ - x₂ = 0, x₁ ≥ -5, x₂ ≥ -5, x₁ ≤ 10" $ do + -- x₁ = x₂, maximize x₁ + x₂ = 2x₁ + -- With x₁ ≤ 10, optimal is x₁ = x₂ = 10, obj = 20 + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = + [ EQ (M.fromList [(1, 1), (2, -1)]) 0 + , LEQ (M.fromList [(1, 1)]) 10 + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5)), (2, LowerBound (-5))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + M.lookup 1 result.varValMap `shouldBe` Just 10 + M.lookup 2 result.varValMap `shouldBe` Just 10 + -- Verify objective value + objVal `shouldBe` 20 + + it "Min x₁ + x₂ with x₁ - x₂ = 0, x₁ ≥ -5, x₂ ≥ -5, x₁ ≤ 10" $ do + -- x₁ = x₂, minimize x₁ + x₂ = 2x₁ + -- Lower bound is -5, so optimal is x₁ = x₂ = -5, obj = -10 + let obj = Min (M.fromList [(1, 1), (2, 1)]) + constraints = + [ EQ (M.fromList [(1, 1), (2, -1)]) 0 + , LEQ (M.fromList [(1, 1)]) 10 + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5)), (2, LowerBound (-5))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + M.lookup 1 result.varValMap `shouldBe` Just (-5) + M.lookup 2 result.varValMap `shouldBe` Just (-5) + -- Verify objective value + objVal `shouldBe` (-10) + + describe "Fractional negative bounds" $ do + it "Max x₁ with x₁ ≥ -7/2, x₁ ≤ 5/2" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) (5 % 2) ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound ((-7) % 2))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just (5 % 2) + + it "Min x₁ with x₁ ≥ -7/2, x₁ ≤ 5/2" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) (5 % 2) ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound ((-7) % 2))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just ((-7) % 2) + + describe "twoPhaseSimplex' with unbounded variables (Split transformation)" $ do + describe "Simple single variable systems" $ do + it "Max x₁ with -10 ≤ x₁ ≤ 10 (unbounded var with box constraints)" $ do + -- x₁ is unbounded but constrained by -10 ≤ x₁ ≤ 10 + let obj = Max (M.fromList [(1, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 10 + , GEQ (M.fromList [(1, 1)]) (-10) + ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 + + it "Min x₁ with -10 ≤ x₁ ≤ 10 (unbounded var with box constraints)" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 10 + , GEQ (M.fromList [(1, 1)]) (-10) + ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-10) + + it "Unbounded variable with only upper bound: Min finds negative value" $ do + -- x₁ unbounded, only x₁ ≤ 5, minimize x₁ + -- This should be unbounded (no solution) since x₁ can go to -∞ + let obj = Min (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + -- This should be unbounded (infeasible for optimization) + actualResult `shouldBe` Nothing + + describe "Two variable systems with unbounded variables" $ do + it "Max x₁ + x₂ with unbounded vars, -5 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 7" $ do + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 5 + , GEQ (M.fromList [(1, 1)]) (-5) + , LEQ (M.fromList [(2, 1)]) 7 + , GEQ (M.fromList [(2, 1)]) (-3) + ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded), (2, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + M.lookup 1 result.varValMap `shouldBe` Just 5 + M.lookup 2 result.varValMap `shouldBe` Just 7 + let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + objVal `shouldBe` 12 + + it "Min x₁ + x₂ with unbounded vars, -5 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 7" $ do + let obj = Min (M.fromList [(1, 1), (2, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 5 + , GEQ (M.fromList [(1, 1)]) (-5) + , LEQ (M.fromList [(2, 1)]) 7 + , GEQ (M.fromList [(2, 1)]) (-3) + ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded), (2, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + M.lookup 1 result.varValMap `shouldBe` Just (-5) + M.lookup 2 result.varValMap `shouldBe` Just (-3) + let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + objVal `shouldBe` (-8) + + it "Max x₁ - x₂ with unbounded vars: x₁ up, x₂ down" $ do + -- Maximize x₁ - x₂: want x₁ large (5) and x₂ small (-3) + let obj = Max (M.fromList [(1, 1), (2, -1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 5 + , GEQ (M.fromList [(1, 1)]) (-5) + , LEQ (M.fromList [(2, 1)]) 7 + , GEQ (M.fromList [(2, 1)]) (-3) + ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded), (2, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + M.lookup 1 result.varValMap `shouldBe` Just 5 + M.lookup 2 result.varValMap `shouldBe` Just (-3) + let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + objVal `shouldBe` 8 + + describe "Systems with EQ constraints and unbounded variables" $ do + it "Max x₁ with x₁ + x₂ = 10, unbounded vars, x₂ ≥ -5" $ do + -- x₁ + x₂ = 10, x₂ ≥ -5, unbounded x₁ + -- Maximize x₁: make x₂ as small as possible (-5), so x₁ = 15 + let obj = Max (M.fromList [(1, 1)]) + constraints = + [ EQ (M.fromList [(1, 1), (2, 1)]) 10 + , GEQ (M.fromList [(2, 1)]) (-5) + ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded), (2, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + M.lookup 1 result.varValMap `shouldBe` Just 15 + M.lookup 2 result.varValMap `shouldBe` Just (-5) + + it "Min x₁ with x₁ + x₂ = 10, unbounded vars, x₂ ≤ 20" $ do + -- x₁ + x₂ = 10, x₂ ≤ 20, unbounded x₁ + -- Minimize x₁: make x₂ as large as possible (20), so x₁ = -10 + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ EQ (M.fromList [(1, 1), (2, 1)]) 10 + , LEQ (M.fromList [(2, 1)]) 20 + ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded), (2, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + M.lookup 1 result.varValMap `shouldBe` Just (-10) + M.lookup 2 result.varValMap `shouldBe` Just 20 + + describe "twoPhaseSimplex' with mixed domain types" $ do + describe "NonNegative, negative lower bound, and unbounded in same system" $ do + it "Max x₁ + x₂ + x₃ with x₁ ≥ 0, x₂ ≥ -5, x₃ unbounded, sum ≤ 20" $ do + -- x₁ non-negative, x₂ has lower bound -5, x₃ unbounded + -- All constrained by sum ≤ 20 and individual bounds + let obj = Max (M.fromList [(1, 1), (2, 1), (3, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) 20 + , LEQ (M.fromList [(1, 1)]) 10 + , LEQ (M.fromList [(2, 1)]) 8 + , LEQ (M.fromList [(3, 1)]) 15 + , GEQ (M.fromList [(3, 1)]) (-10) + ] + domainMap = VarDomainMap $ M.fromList + [(1, T.NonNegative), (2, LowerBound (-5)), (3, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + -- Verify objective value + objVal `shouldBe` 20 + + it "Min x₁ + x₂ + x₃ with x₁ ≥ 0, x₂ ≥ -5, x₃ unbounded, sum ≥ -10" $ do + -- Minimize sum with lower bound constraint + let obj = Min (M.fromList [(1, 1), (2, 1), (3, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) (-10) + , LEQ (M.fromList [(1, 1)]) 10 + , LEQ (M.fromList [(2, 1)]) 8 + , LEQ (M.fromList [(3, 1)]) 15 + , GEQ (M.fromList [(3, 1)]) (-20) + ] + domainMap = VarDomainMap $ M.fromList + [(1, T.NonNegative), (2, LowerBound (-5)), (3, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let x1 = M.findWithDefault 0 1 result.varValMap + x2 = M.findWithDefault 0 2 result.varValMap + x3 = M.findWithDefault 0 3 result.varValMap + objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + -- Verify constraints + x1 `shouldSatisfy` (>= 0) + x2 `shouldSatisfy` (>= (-5)) + x3 `shouldSatisfy` (>= (-20)) + -- Verify objective value + objVal `shouldBe` (-10) + + describe "Positive lower bound with other domain types" $ do + it "Max 2x₁ + 3x₂ with x₁ ≥ 2 (positive bound), x₂ ≥ -3, 2x₁ + x₂ ≤ 20" $ do + -- x₁ has positive lower bound (uses AddLowerBound) + -- x₂ has negative lower bound (uses Shift) + let obj = Max (M.fromList [(1, 2), (2, 3)]) + constraints = + [ LEQ (M.fromList [(1, 2), (2, 1)]) 20 + , LEQ (M.fromList [(2, 1)]) 10 + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound 2), (2, LowerBound (-3))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let x1 = M.findWithDefault 0 1 result.varValMap + x2 = M.findWithDefault 0 2 result.varValMap + -- Verify constraints + x1 `shouldSatisfy` (>= 2) + x2 `shouldSatisfy` (>= (-3)) + (2 * x1 + x2) `shouldSatisfy` (<= 20) + + it "Min 2x₁ + 3x₂ with x₁ ≥ 2, x₂ ≥ -3, x₁ + x₂ ≥ 0" $ do + -- Minimize with lower bounds + -- x₁ = 2 (minimum), x₂ = -2 (to satisfy x₁ + x₂ ≥ 0) + let obj = Min (M.fromList [(1, 2), (2, 3)]) + constraints = + [ GEQ (M.fromList [(1, 1), (2, 1)]) 0 + , LEQ (M.fromList [(1, 1)]) 10 + , LEQ (M.fromList [(2, 1)]) 10 + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound 2), (2, LowerBound (-3))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let x1 = M.findWithDefault 0 1 result.varValMap + x2 = M.findWithDefault 0 2 result.varValMap + x1 `shouldSatisfy` (>= 2) + x2 `shouldSatisfy` (>= (-3)) + (x1 + x2) `shouldSatisfy` (>= 0) + + describe "twoPhaseSimplex' edge cases and infeasibility" $ do + it "Infeasible: negative lower bound conflicts with GEQ constraint" $ do + -- x₁ ≥ -5 (domain), but x₁ ≥ 10 and x₁ ≤ 5 (constraints conflict) + let obj = Max (M.fromList [(1, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1)]) 10 + , LEQ (M.fromList [(1, 1)]) 5 + ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + actualResult `shouldBe` Nothing + + it "Infeasible: unbounded variable with conflicting constraints" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1)]) 10 + , LEQ (M.fromList [(1, 1)]) 5 + ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + actualResult `shouldBe` Nothing + + it "Variable at exactly zero with negative lower bound" $ do + -- x₁ ≥ -5, constraint x₁ = 0 + let obj = Max (M.fromList [(1, 1)]) + constraints = [ EQ (M.fromList [(1, 1)]) 0 ] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 0 + + it "Unbounded variable constrained to zero" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [ EQ (M.fromList [(1, 1)]) 0 ] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 0 + + it "Multiple variables, only some with negative bounds" $ do + -- x₁ ≥ 0 (non-negative), x₂ ≥ -10, x₃ ≥ 0 + -- Max x₁ + x₂ + x₃ with x₁ + x₂ + x₃ ≤ 15 + let obj = Max (M.fromList [(1, 1), (2, 1), (3, 1)]) + constraints = [ LEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) 15 ] + domainMap = VarDomainMap $ M.fromList + [(1, T.NonNegative), (2, LowerBound (-10)), (3, T.NonNegative)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex' domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + -- Verify objective value + objVal `shouldBe` 15 + + -- =========================================================================== + -- Tests for internal preprocessing functions + -- =========================================================================== + + describe "collectAllVars" $ do + describe "Unit tests" $ do + it "collects variables from Max objective" $ do + let obj = Max (M.fromList [(1, 3), (2, 5)]) + constraints = [] + collectAllVars obj constraints `shouldBe` Set.fromList [1, 2] + + it "collects variables from Min objective" $ do + let obj = Min (M.fromList [(3, 1), (4, -2)]) + constraints = [] + collectAllVars obj constraints `shouldBe` Set.fromList [3, 4] + + it "collects variables from LEQ constraint" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [LEQ (M.fromList [(2, 1), (3, 2)]) 10] + collectAllVars obj constraints `shouldBe` Set.fromList [1, 2, 3] + + it "collects variables from GEQ constraint" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [GEQ (M.fromList [(4, 1)]) 5] + collectAllVars obj constraints `shouldBe` Set.fromList [1, 4] + + it "collects variables from EQ constraint" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [EQ (M.fromList [(5, 2), (6, 3)]) 15] + collectAllVars obj constraints `shouldBe` Set.fromList [1, 5, 6] + + it "collects variables from mixed constraints" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = + [ LEQ (M.fromList [(2, 1)]) 10 + , GEQ (M.fromList [(3, 1)]) 5 + , EQ (M.fromList [(4, 1)]) 7 + ] + collectAllVars obj constraints `shouldBe` Set.fromList [1, 2, 3, 4] + + it "handles empty objective coefficients" $ do + let obj = Max M.empty + constraints = [LEQ (M.fromList [(1, 1)]) 10] + collectAllVars obj constraints `shouldBe` Set.fromList [1] + + it "handles empty constraints" $ do + let obj = Max (M.fromList [(1, 1), (2, 2)]) + constraints = [] + collectAllVars obj constraints `shouldBe` Set.fromList [1, 2] + + it "deduplicates variables appearing in multiple places" $ do + let obj = Max (M.fromList [(1, 1), (2, 2)]) + constraints = + [ LEQ (M.fromList [(1, 3), (3, 4)]) 10 + , GEQ (M.fromList [(2, 5), (3, 6)]) 5 + ] + collectAllVars obj constraints `shouldBe` Set.fromList [1, 2, 3] + + describe "getTransform" $ do + describe "Unit tests" $ do + it "returns Nothing for NonNegative domain" $ do + getTransform 10 1 T.NonNegative `shouldBe` Nothing + + it "returns Nothing for LowerBound 0" $ do + getTransform 10 1 (LowerBound 0) `shouldBe` Nothing + + it "returns AddLowerBound for positive lower bound" $ do + getTransform 10 1 (LowerBound 5) `shouldBe` Just (AddLowerBound 1 5) + + it "returns AddLowerBound for fractional positive lower bound" $ do + getTransform 10 1 (LowerBound (3 % 2)) `shouldBe` Just (AddLowerBound 1 (3 % 2)) + + it "returns Shift for negative lower bound" $ do + getTransform 10 1 (LowerBound (-5)) `shouldBe` Just (Shift 1 10 (-5)) + + it "returns Shift for fractional negative lower bound" $ do + getTransform 10 1 (LowerBound ((-7) % 3)) `shouldBe` Just (Shift 1 10 ((-7) % 3)) + + it "returns Split for Unbounded domain" $ do + getTransform 10 1 Unbounded `shouldBe` Just (Split 1 10 11) + + describe "generateTransform" $ do + describe "Unit tests" $ do + it "generates no transform for NonNegative in domain map" $ do + let domainMap = M.fromList [(1, T.NonNegative)] + generateTransform domainMap 1 ([], 10) `shouldBe` ([], 10) + + it "generates AddLowerBound for positive bound in domain map" $ do + let domainMap = M.fromList [(1, LowerBound 5)] + generateTransform domainMap 1 ([], 10) `shouldBe` ([AddLowerBound 1 5], 10) + + it "generates Shift for negative bound and increments fresh var" $ do + let domainMap = M.fromList [(1, LowerBound (-5))] + generateTransform domainMap 1 ([], 10) `shouldBe` ([Shift 1 10 (-5)], 11) + + it "generates Split for Unbounded and increments fresh var by 2" $ do + let domainMap = M.fromList [(1, Unbounded)] + generateTransform domainMap 1 ([], 10) `shouldBe` ([Split 1 10 11], 12) + + it "treats variable not in domain map as Unbounded" $ do + let domainMap = M.empty + generateTransform domainMap 1 ([], 10) `shouldBe` ([Split 1 10 11], 12) + + it "accumulates transforms" $ do + let domainMap = M.fromList [(1, LowerBound 5)] + existing = [AddLowerBound 2 3] + generateTransform domainMap 1 (existing, 10) `shouldBe` ([AddLowerBound 1 5, AddLowerBound 2 3], 10) + + describe "applyShiftToObjective" $ do + describe "Unit tests" $ do + it "substitutes variable in Max objective" $ do + let obj = Max (M.fromList [(1, 3), (2, 5)]) + applyShiftToObjective 1 10 (-5) obj `shouldBe` Max (M.fromList [(10, 3), (2, 5)]) + + it "substitutes variable in Min objective" $ do + let obj = Min (M.fromList [(1, -2), (2, 4)]) + applyShiftToObjective 1 10 (-3) obj `shouldBe` Min (M.fromList [(10, -2), (2, 4)]) + + it "leaves objective unchanged if variable not present" $ do + let obj = Max (M.fromList [(2, 5), (3, 7)]) + applyShiftToObjective 1 10 (-5) obj `shouldBe` Max (M.fromList [(2, 5), (3, 7)]) + + it "preserves coefficient during substitution" $ do + let obj = Max (M.fromList [(1, 100)]) + applyShiftToObjective 1 10 (-5) obj `shouldBe` Max (M.fromList [(10, 100)]) + + describe "applyShiftToConstraint" $ do + describe "Unit tests" $ do + it "shifts LEQ constraint correctly" $ do + -- x1 = x10 + (-5), so x1 has shift -5 + -- constraint: 2*x1 <= 10 becomes 2*x10 <= 10 - 2*(-5) = 20 + let constraint = LEQ (M.fromList [(1, 2)]) 10 + applyShiftToConstraint 1 10 (-5) constraint `shouldBe` LEQ (M.fromList [(10, 2)]) 20 + + it "shifts GEQ constraint correctly" $ do + let constraint = GEQ (M.fromList [(1, 3)]) 6 + applyShiftToConstraint 1 10 (-2) constraint `shouldBe` GEQ (M.fromList [(10, 3)]) 12 + + it "shifts EQ constraint correctly" $ do + let constraint = EQ (M.fromList [(1, 4)]) 8 + applyShiftToConstraint 1 10 (-1) constraint `shouldBe` EQ (M.fromList [(10, 4)]) 12 + + it "leaves constraint unchanged if variable not present" $ do + let constraint = LEQ (M.fromList [(2, 5)]) 10 + applyShiftToConstraint 1 10 (-5) constraint `shouldBe` LEQ (M.fromList [(2, 5)]) 10 + + it "handles negative coefficients" $ do + -- x1 = x10 + (-5), constraint: -3*x1 <= 10 + -- becomes -3*x10 <= 10 - (-3)*(-5) = 10 - 15 = -5 + let constraint = LEQ (M.fromList [(1, -3)]) 10 + applyShiftToConstraint 1 10 (-5) constraint `shouldBe` LEQ (M.fromList [(10, -3)]) (-5) + + it "handles multiple variables in constraint" $ do + let constraint = LEQ (M.fromList [(1, 2), (2, 3)]) 10 + applyShiftToConstraint 1 10 (-5) constraint `shouldBe` LEQ (M.fromList [(10, 2), (2, 3)]) 20 + + describe "applySplitToObjective" $ do + describe "Unit tests" $ do + it "splits variable in Max objective" $ do + let obj = Max (M.fromList [(1, 3)]) + -- x1 = x10 - x11, so coeff 3 -> x10 gets 3, x11 gets -3 + applySplitToObjective 1 10 11 obj `shouldBe` Max (M.fromList [(10, 3), (11, -3)]) + + it "splits variable in Min objective" $ do + let obj = Min (M.fromList [(1, -2)]) + applySplitToObjective 1 10 11 obj `shouldBe` Min (M.fromList [(10, -2), (11, 2)]) + + it "leaves objective unchanged if variable not present" $ do + let obj = Max (M.fromList [(2, 5)]) + applySplitToObjective 1 10 11 obj `shouldBe` Max (M.fromList [(2, 5)]) + + it "handles multiple variables" $ do + let obj = Max (M.fromList [(1, 3), (2, 5)]) + applySplitToObjective 1 10 11 obj `shouldBe` Max (M.fromList [(10, 3), (11, -3), (2, 5)]) + + describe "applySplitToConstraint" $ do + describe "Unit tests" $ do + it "splits variable in LEQ constraint" $ do + let constraint = LEQ (M.fromList [(1, 2)]) 10 + applySplitToConstraint 1 10 11 constraint `shouldBe` LEQ (M.fromList [(10, 2), (11, -2)]) 10 + + it "splits variable in GEQ constraint" $ do + let constraint = GEQ (M.fromList [(1, 3)]) 5 + applySplitToConstraint 1 10 11 constraint `shouldBe` GEQ (M.fromList [(10, 3), (11, -3)]) 5 + + it "splits variable in EQ constraint" $ do + let constraint = EQ (M.fromList [(1, 4)]) 8 + applySplitToConstraint 1 10 11 constraint `shouldBe` EQ (M.fromList [(10, 4), (11, -4)]) 8 + + it "leaves constraint unchanged if variable not present" $ do + let constraint = LEQ (M.fromList [(2, 5)]) 10 + applySplitToConstraint 1 10 11 constraint `shouldBe` LEQ (M.fromList [(2, 5)]) 10 + + it "handles negative coefficients" $ do + let constraint = LEQ (M.fromList [(1, -3)]) 10 + applySplitToConstraint 1 10 11 constraint `shouldBe` LEQ (M.fromList [(10, -3), (11, 3)]) 10 + + it "handles multiple variables" $ do + let constraint = LEQ (M.fromList [(1, 2), (2, 3)]) 10 + applySplitToConstraint 1 10 11 constraint `shouldBe` LEQ (M.fromList [(10, 2), (11, -2), (2, 3)]) 10 + + describe "applyTransform and applyTransforms" $ do + describe "Unit tests" $ do + it "applyTransform AddLowerBound adds GEQ constraint" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [LEQ (M.fromList [(1, 1)]) 10] + transform = AddLowerBound 1 5 + applyTransform transform (obj, constraints) `shouldBe` + (obj, [GEQ (M.singleton 1 1) 5, LEQ (M.fromList [(1, 1)]) 10]) + + it "applyTransform Shift transforms objective and constraints" $ do + let obj = Max (M.fromList [(1, 2)]) + constraints = [LEQ (M.fromList [(1, 1)]) 10] + transform = Shift 1 10 (-5) + let (newObj, newConstraints) = applyTransform transform (obj, constraints) + newObj `shouldBe` Max (M.fromList [(10, 2)]) + newConstraints `shouldBe` [LEQ (M.fromList [(10, 1)]) 15] + + it "applyTransform Split transforms objective and constraints" $ do + let obj = Max (M.fromList [(1, 3)]) + constraints = [LEQ (M.fromList [(1, 1)]) 10] + transform = Split 1 10 11 + let (newObj, newConstraints) = applyTransform transform (obj, constraints) + newObj `shouldBe` Max (M.fromList [(10, 3), (11, -3)]) + newConstraints `shouldBe` [LEQ (M.fromList [(10, 1), (11, -1)]) 10] + + it "applyTransforms applies multiple transforms in order" $ do + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = [LEQ (M.fromList [(1, 1), (2, 1)]) 10] + transforms = [AddLowerBound 1 5, AddLowerBound 2 3] + let (newObj, newConstraints) = applyTransforms transforms obj constraints + newObj `shouldBe` obj + -- Two GEQ constraints should be added + length newConstraints `shouldBe` 3 + + describe "unapplyTransform and unapplyTransforms" $ do + describe "Unit tests" $ do + it "unapplyTransform AddLowerBound leaves result unchanged" $ do + let result = Result 5 (M.fromList [(5, 10), (1, 7)]) + transform = AddLowerBound 1 5 + unapplyTransform transform result `shouldBe` result + + it "unapplyTransform Shift recovers original variable value" $ do + -- originalVar = shiftedVar + shiftBy + -- If shiftedVar = 15 and shiftBy = -5, then originalVar = 10 + let result = Result 5 (M.fromList [(5, 100), (10, 15)]) + transform = Shift 1 10 (-5) + let newResult = unapplyTransform transform result + M.lookup 1 (varValMap newResult) `shouldBe` Just 10 + M.lookup 10 (varValMap newResult) `shouldBe` Nothing + + it "unapplyTransform Split recovers original variable value" $ do + -- originalVar = posVar - negVar + -- If posVar = 8 and negVar = 3, then originalVar = 5 + let result = Result 5 (M.fromList [(5, 100), (10, 8), (11, 3)]) + transform = Split 1 10 11 + let newResult = unapplyTransform transform result + M.lookup 1 (varValMap newResult) `shouldBe` Just 5 + M.lookup 10 (varValMap newResult) `shouldBe` Nothing + M.lookup 11 (varValMap newResult) `shouldBe` Nothing + + it "unapplyTransform Split handles negative original value" $ do + -- originalVar = posVar - negVar + -- If posVar = 2 and negVar = 7, then originalVar = -5 + let result = Result 5 (M.fromList [(5, 100), (10, 2), (11, 7)]) + transform = Split 1 10 11 + let newResult = unapplyTransform transform result + M.lookup 1 (varValMap newResult) `shouldBe` Just (-5) + + it "unapplyTransforms applies in correct order (reverse of apply)" $ do + -- Two shifts: var 1 shifted by -5 to var 10, var 2 shifted by -3 to var 11 + let result = Result 5 (M.fromList [(5, 100), (10, 15), (11, 8)]) + transforms = [Shift 1 10 (-5), Shift 2 11 (-3)] + let newResult = unapplyTransforms transforms result + M.lookup 1 (varValMap newResult) `shouldBe` Just 10 + M.lookup 2 (varValMap newResult) `shouldBe` Just 5 + + describe "preprocess" $ do + describe "Unit tests" $ do + it "returns empty transforms for all NonNegative domains" $ do + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = [LEQ (M.fromList [(1, 1), (2, 1)]) 10] + domainMap = VarDomainMap $ M.fromList [(1, T.NonNegative), (2, T.NonNegative)] + let (newObj, newConstraints, transforms) = preprocess obj domainMap constraints + transforms `shouldBe` [] + newObj `shouldBe` obj + newConstraints `shouldBe` constraints + + it "generates AddLowerBound for positive lower bounds" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [LEQ (M.fromList [(1, 1)]) 10] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound 5)] + let (_, newConstraints, transforms) = preprocess obj domainMap constraints + transforms `shouldBe` [AddLowerBound 1 5] + length newConstraints `shouldBe` 2 -- original + GEQ + + it "generates Shift for negative lower bounds" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [LEQ (M.fromList [(1, 1)]) 10] + domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + let (newObj, newConstraints, transforms) = preprocess obj domainMap constraints + length transforms `shouldBe` 1 + case head transforms of + Shift {..} -> do + originalVar `shouldBe` 1 + shiftBy `shouldBe` (-5) + _ -> expectationFailure "Expected Shift transform" + + it "generates Split for Unbounded domains" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [LEQ (M.fromList [(1, 1)]) 10] + domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + let (_, _, transforms) = preprocess obj domainMap constraints + length transforms `shouldBe` 1 + case head transforms of + Split {..} -> originalVar `shouldBe` 1 + _ -> expectationFailure "Expected Split transform" + + it "handles mixed domain types" $ do + let obj = Max (M.fromList [(1, 1), (2, 1), (3, 1)]) + constraints = [LEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) 10] + domainMap = VarDomainMap $ M.fromList + [(1, T.NonNegative), (2, LowerBound 5), (3, LowerBound (-3))] + let (_, _, transforms) = preprocess obj domainMap constraints + -- Should have AddLowerBound for var 2, Shift for var 3 + length transforms `shouldBe` 2 + + -- =========================================================================== + -- Property-based tests + -- =========================================================================== + + describe "Property-based tests" $ do + describe "collectAllVars properties" $ do + it "result is non-empty when objective is non-empty" $ property $ + \(NonEmpty coeffs :: NonEmptyList (Int, Rational)) -> + let obj = Max (M.fromList [(abs k `mod` 100 + 1, v) | (k, v) <- coeffs]) + in not (Set.null (collectAllVars obj [])) + + it "result contains all objective variables" $ property $ + \(vars :: [Int]) -> + let posVars = filter (> 0) (map abs vars) + obj = Max (M.fromList [(v, 1) | v <- take 5 posVars]) + in all (`Set.member` collectAllVars obj []) (M.keys $ case obj of Max m -> m; Min m -> m) + + describe "getTransform properties" $ do + it "NonNegative always produces Nothing" $ property $ + \(nextVar :: Int) (v :: Int) -> + getTransform (abs nextVar + 1) (abs v + 1) T.NonNegative == Nothing + + it "LowerBound 0 produces Nothing" $ property $ + \(nextVar :: Int) (v :: Int) -> + getTransform (abs nextVar + 1) (abs v + 1) (LowerBound 0) == Nothing + + it "positive LowerBound produces AddLowerBound" $ property $ + \(Positive bound :: Positive Rational) (nextVar :: Int) (v :: Int) -> + case getTransform (abs nextVar + 1) (abs v + 1) (LowerBound bound) of + Just (AddLowerBound var b) -> var == abs v + 1 && b == bound + _ -> False + + it "negative LowerBound produces Shift" $ property $ + \(Positive bound :: Positive Rational) (nextVar :: Int) (v :: Int) -> + let negBound = negate bound + in case getTransform (abs nextVar + 1) (abs v + 1) (LowerBound negBound) of + Just (Shift origVar _ shiftBy) -> origVar == abs v + 1 && shiftBy == negBound + _ -> False + + it "Unbounded produces Split" $ property $ + \(nextVar :: Int) (v :: Int) -> + case getTransform (abs nextVar + 1) (abs v + 1) Unbounded of + Just (Split origVar _ _) -> origVar == abs v + 1 + _ -> False + + describe "applyShiftToConstraint properties" $ do + it "RHS adjustment follows formula: newRHS = oldRHS - coeff * shiftBy" $ property $ + \(coeff :: Rational) (oldRHS :: Rational) (shiftBy :: Rational) -> + coeff /= 0 ==> + let constraint = LEQ (M.fromList [(1, coeff)]) oldRHS + LEQ _ newRHS = applyShiftToConstraint 1 10 shiftBy constraint + in newRHS == oldRHS - coeff * shiftBy + + it "preserves constraint type (LEQ stays LEQ)" $ property $ + \(coeff :: Rational) (rhs :: Rational) (shiftBy :: Rational) -> + coeff /= 0 ==> + let constraint = LEQ (M.fromList [(1, coeff)]) rhs + in case applyShiftToConstraint 1 10 shiftBy constraint of + LEQ {} -> True + _ -> False + + it "preserves constraint type (GEQ stays GEQ)" $ property $ + \(coeff :: Rational) (rhs :: Rational) (shiftBy :: Rational) -> + coeff /= 0 ==> + let constraint = GEQ (M.fromList [(1, coeff)]) rhs + in case applyShiftToConstraint 1 10 shiftBy constraint of + GEQ {} -> True + _ -> False + + describe "applySplitToConstraint properties" $ do + it "preserves RHS value" $ property $ + \(coeff :: Rational) (rhs :: Rational) -> + coeff /= 0 ==> + let constraint = LEQ (M.fromList [(1, coeff)]) rhs + LEQ _ newRHS = applySplitToConstraint 1 10 11 constraint + in newRHS == rhs + + it "negVar coefficient is negation of posVar coefficient" $ property $ + \(coeff :: Rational) (rhs :: Rational) -> + coeff /= 0 ==> + let constraint = LEQ (M.fromList [(1, coeff)]) rhs + LEQ m _ = applySplitToConstraint 1 10 11 constraint + posCoeff = M.findWithDefault 0 10 m + negCoeff = M.findWithDefault 0 11 m + in negCoeff == negate posCoeff + + describe "unapplyTransform Shift properties" $ do + it "recovers originalVar = shiftedVar + shiftBy" $ property $ + \(shiftedVal :: Rational) (shiftBy :: Rational) -> + let result = Result 5 (M.fromList [(5, 100), (10, shiftedVal)]) + transform = Shift 1 10 shiftBy + newResult = unapplyTransform transform result + in M.lookup 1 (varValMap newResult) == Just (shiftedVal + shiftBy) + + it "removes shifted variable from result" $ property $ + \(shiftedVal :: Rational) (shiftBy :: Rational) -> + let result = Result 5 (M.fromList [(5, 100), (10, shiftedVal)]) + transform = Shift 1 10 shiftBy + newResult = unapplyTransform transform result + in M.lookup 10 (varValMap newResult) == Nothing + + describe "unapplyTransform Split properties" $ do + it "recovers originalVar = posVar - negVar" $ property $ + \(posVal :: Rational) (negVal :: Rational) -> + let result = Result 5 (M.fromList [(5, 100), (10, posVal), (11, negVal)]) + transform = Split 1 10 11 + newResult = unapplyTransform transform result + in M.lookup 1 (varValMap newResult) == Just (posVal - negVal) + + it "removes pos and neg variables from result" $ property $ + \(posVal :: Rational) (negVal :: Rational) -> + let result = Result 5 (M.fromList [(5, 100), (10, posVal), (11, negVal)]) + transform = Split 1 10 11 + newResult = unapplyTransform transform result + in M.lookup 10 (varValMap newResult) == Nothing && + M.lookup 11 (varValMap newResult) == Nothing + + describe "Round-trip properties" $ do + it "Shift transform and unapply is identity for variable value" $ property $ + \(origVal :: Rational) (shiftBy :: Rational) -> + shiftBy < 0 ==> -- Only negative shifts are valid + let shiftedVal = origVal - shiftBy -- shiftedVar = originalVar - shiftBy + result = Result 5 (M.fromList [(5, 100), (10, shiftedVal)]) + transform = Shift 1 10 shiftBy + newResult = unapplyTransform transform result + in M.lookup 1 (varValMap newResult) == Just origVal + + it "Split with posVal=origVal and negVal=0 gives correct value for positive origVal" $ property $ + \(Positive origVal :: Positive Rational) -> + let result = Result 5 (M.fromList [(5, 100), (10, origVal), (11, 0)]) + transform = Split 1 10 11 + newResult = unapplyTransform transform result + in M.lookup 1 (varValMap newResult) == Just origVal + + it "Split with posVal=0 and negVal=-origVal gives correct value for negative origVal" $ property $ + \(Positive origVal :: Positive Rational) -> + let negOrigVal = negate origVal + result = Result 5 (M.fromList [(5, 100), (10, 0), (11, origVal)]) + transform = Split 1 10 11 + newResult = unapplyTransform transform result + in M.lookup 1 (varValMap newResult) == Just negOrigVal From a5e7e2e0ae44e1b53089425020f4c239e75eb67f Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 31 Jan 2026 13:48:52 +0000 Subject: [PATCH 04/17] chore: replace twoPhaseSimplex with VarDomain version --- src/Linear/Simplex/Solver/TwoPhase.hs | 59 ++++------ test/Linear/Simplex/Solver/TwoPhaseSpec.hs | 131 ++++++++------------- 2 files changed, 72 insertions(+), 118 deletions(-) diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index cac4ef8..f746a04 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -15,7 +15,6 @@ module Linear.Simplex.Solver.TwoPhase ( findFeasibleSolution , optimizeFeasibleSystem , twoPhaseSimplex - , twoPhaseSimplex' -- Internal functions exported for testing , preprocess , postprocess @@ -399,57 +398,39 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) ) (M.toList objFunction.objective) --- | Perform the two phase simplex method with a given 'ObjectiveFunction' a system of 'PolyConstraint's. --- Assumes the 'ObjectiveFunction' and 'PolyConstraint' is not empty. --- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' --- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. -twoPhaseSimplex :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result) -twoPhaseSimplex objFunction unsimplifiedSystem = do - logMsg LevelInfo $ - "twoPhaseSimplex: Solving system " <> showT unsimplifiedSystem <> " with objective " <> showT objFunction - phase1Result <- findFeasibleSolution unsimplifiedSystem - case phase1Result of - Just feasibleSystem -> do - logMsg LevelInfo $ - "twoPhaseSimplex: Feasible system found for " - <> showT unsimplifiedSystem - <> "; Feasible system: " - <> showT feasibleSystem - optimizedSystem <- optimizeFeasibleSystem objFunction feasibleSystem - logMsg LevelInfo $ - "twoPhaseSimplex: Optimized system found for " - <> showT unsimplifiedSystem - <> "; Optimized system: " - <> showT optimizedSystem - pure optimizedSystem - Nothing -> do - logMsg LevelInfo $ "twoPhaseSimplex: Phase 1 gives infeasible result for " <> showT unsimplifiedSystem - pure Nothing - -- | Perform the two phase simplex method with variable domain information. -- Variables not in the VarDomainMap are assumed to be Unbounded (no lower bound). -- This function applies necessary transformations before solving and unapplies them after. -- The returned Result contains variable values and objective value in the original space. -- TODO: use this as twoPhaseSimplex, add instructions in CHANGELOG for old users -twoPhaseSimplex' :: (MonadIO m, MonadLogger m) => VarDomainMap -> ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result) -twoPhaseSimplex' domainMap objFunction constraints = do +twoPhaseSimplex :: (MonadIO m, MonadLogger m) => VarDomainMap -> ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result) +twoPhaseSimplex domainMap objFunction constraints = do logMsg LevelInfo $ - "twoPhaseSimplex': Solving system with domain map " <> showT domainMap + "twoPhaseSimplex: Solving system with domain map " <> showT domainMap let (transformedObj, transformedConstraints, transforms) = preprocess objFunction domainMap constraints logMsg LevelInfo $ - "twoPhaseSimplex': Applied transforms " <> showT transforms + "twoPhaseSimplex: Applied transforms " <> showT transforms <> "; Transformed objective: " <> showT transformedObj <> "; Transformed constraints: " <> showT transformedConstraints - mResult <- twoPhaseSimplex transformedObj transformedConstraints - case mResult of + phase1Result <- findFeasibleSolution transformedConstraints + case phase1Result of Nothing -> do - logMsg LevelInfo "twoPhaseSimplex': No solution found" + logMsg LevelInfo "twoPhaseSimplex: No feasible solution found in phase 1" pure Nothing - Just result -> do - let finalResult = postprocess objFunction transforms result + Just feasibleSystem -> do logMsg LevelInfo $ - "twoPhaseSimplex': Postprocessed result: " <> showT finalResult - pure (Just finalResult) + "twoPhaseSimplex: Feasible system found for transformed system; Feasible system: " + <> showT feasibleSystem + mOptimizedSystem <- optimizeFeasibleSystem transformedObj feasibleSystem + case mOptimizedSystem of + Nothing -> do + logMsg LevelInfo "twoPhaseSimplex: No optimized solution found in phase 2" + pure Nothing + Just result -> do + let finalResult = postprocess objFunction transforms result + logMsg LevelInfo $ + "twoPhaseSimplex: Postprocessed result: " <> showT finalResult + pure (Just finalResult) -- | Postprocess the result by unapplying variable transformations and computing -- the objective value in the original space. diff --git a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs index 8d0ca39..af09acf 100644 --- a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs +++ b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs @@ -21,25 +21,20 @@ import Linear.Simplex.Solver.TwoPhase import Linear.Simplex.Types hiding (NonNegative) import Linear.Simplex.Util --- | Helper to run a test case and check result +-- | Helper to run a test case for a system where all vars +-- are non-negative and verify we get the expected result runTest :: (ObjectiveFunction, [PolyConstraint]) -> Maybe Result -> IO () runTest (obj, constraints) expectedResult = do - actualResult <- - runStdoutLoggingT $ - filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex obj constraints let prettyObj = prettyShowObjectiveFunction obj prettyConstraints = map prettyShowPolyConstraint constraints expectedObjVal = extractObjectiveValue expectedResult - actualObjVal = extractObjectiveValue actualResult - -- HACK: Verify NonNegative twoPhaseSimplex' NonNegative == twoPhaseSimplex allVars = collectAllVars obj constraints domainMap = VarDomainMap $ M.fromSet (const T.NonNegative) allVars - actualResult' <- + actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints - let actualObjVal' = extractObjectiveValue actualResult' + twoPhaseSimplex domainMap obj constraints + let actualObjVal = extractObjectiveValue actualResult annotate [qc| @@ -53,15 +48,9 @@ Expected Solution (Full): {expectedResult} Actual Solution (Full): {actualResult} Expected Solution (Objective): {expectedObjVal} Actual Solution (Objective): {actualObjVal} -==================================== -Actual Solution' (Full): {actualResult'} -Actual Solution' (Objective): {actualObjVal'} |] $ do actualResult `shouldBe` expectedResult - -- TODO: worth removing twoPhaseSimplex? - actualResult' `shouldBe` expectedResult - spec :: Spec spec = do @@ -631,23 +620,7 @@ spec = do ) runTest testCase (Just (Result 7 (M.fromList [(7, (-8)), (2, 2)]))) - describe "twoPhaseSimplex' (with VarDomainMap)" $ do - it "NonNegative domain gives same result as twoPhaseSimplex" $ do - -- TODO: redundant if we keep the runTest hack - let obj = Max (M.fromList [(1, 3), (2, 5)]) - constraints = - [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 - , LEQ (M.fromList [(1, 1), (2, 1)]) 7 - , LEQ (M.fromList [(2, 1)]) 4 - , LEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - domainMap = VarDomainMap $ M.fromList [(1, T.NonNegative), (2, T.NonNegative)] - actualResult <- - runStdoutLoggingT $ - filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints - actualResult `shouldBe` Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)])) - + describe "twoPhaseSimplex (with VarDomainMap)" $ do it "Shift transformation with negative lower bound" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] @@ -655,7 +628,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 @@ -667,7 +640,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-5) @@ -682,7 +655,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 @@ -697,7 +670,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-10) @@ -709,7 +682,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 @@ -721,7 +694,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 5 @@ -736,7 +709,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -759,11 +732,11 @@ spec = do actualResult1 <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap1 obj constraints + twoPhaseSimplex domainMap1 obj constraints actualResult2 <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap2 obj constraints + twoPhaseSimplex domainMap2 obj constraints actualResult1 `shouldBe` Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)])) actualResult1 `shouldBe` actualResult2 @@ -774,10 +747,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints actualResult `shouldBe` Nothing - describe "twoPhaseSimplex' with negative lower bound s (Shift transformation)" $ do + describe "twoPhaseSimplex with negative lower bounds (Shift transformation)" $ do describe "Simple single variable systems" $ do it "Max x₁ with x₁ ≤ 5, x₁ ≥ -3: optimal at upper bound x₁=5" $ do -- Simple case: maximize x with upper bound 5 and lower bound -3 @@ -788,7 +761,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 5 @@ -802,7 +775,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-3) @@ -815,7 +788,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-2) @@ -828,7 +801,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-10) @@ -846,7 +819,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -868,7 +841,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -890,7 +863,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -913,7 +886,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -938,7 +911,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 @@ -954,13 +927,13 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 2 describe "Systems with EQ constraints and negative bounds" $ do - it "Max x₁ + x₂ with x₁ - x₂ = 0, x₁ ≥ -5, x₂ ≥ -5, x₁ ≤ 10" $ do + it "Max x₁ + x₂ with x₁ - x₂ = 0, x₁ ≥ -5, x₂ ≥ -5, x₁ ≤ 10" $ do -- x₁ = x₂, maximize x₁ + x₂ = 2x₁ -- With x₁ ≤ 10, optimal is x₁ = x₂ = 10, obj = 20 let obj = Max (M.fromList [(1, 1), (2, 1)]) @@ -972,7 +945,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -994,7 +967,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -1012,7 +985,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just (5 % 2) @@ -1024,12 +997,12 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just ((-7) % 2) - describe "twoPhaseSimplex' with unbounded variables (Split transformation)" $ do + describe "twoPhaseSimplex with unbounded variables (Split transformation)" $ do describe "Simple single variable systems" $ do it "Max x₁ with -10 ≤ x₁ ≤ 10 (unbounded var with box constraints)" $ do -- x₁ is unbounded but constrained by -10 ≤ x₁ ≤ 10 @@ -1042,7 +1015,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 @@ -1057,7 +1030,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-10) @@ -1071,7 +1044,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints -- This should be unbounded (infeasible for optimization) actualResult `shouldBe` Nothing @@ -1088,7 +1061,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -1109,7 +1082,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -1131,7 +1104,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -1153,7 +1126,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -1172,14 +1145,14 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do M.lookup 1 result.varValMap `shouldBe` Just (-10) M.lookup 2 result.varValMap `shouldBe` Just 20 - describe "twoPhaseSimplex' with mixed domain types" $ do + describe "twoPhaseSimplex with mixed domain types" $ do describe "NonNegative, negative lower bound, and unbounded in same system" $ do it "Max x₁ + x₂ + x₃ with x₁ ≥ 0, x₂ ≥ -5, x₃ unbounded, sum ≤ 20" $ do -- x₁ non-negative, x₂ has lower bound -5, x₃ unbounded @@ -1197,7 +1170,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -1220,7 +1193,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -1248,7 +1221,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -1272,7 +1245,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do @@ -1282,7 +1255,7 @@ spec = do x2 `shouldSatisfy` (>= (-3)) (x1 + x2) `shouldSatisfy` (>= 0) - describe "twoPhaseSimplex' edge cases and infeasibility" $ do + describe "twoPhaseSimplex edge cases and infeasibility" $ do it "Infeasible: negative lower bound conflicts with GEQ constraint" $ do -- x₁ ≥ -5 (domain), but x₁ ≥ 10 and x₁ ≤ 5 (constraints conflict) let obj = Max (M.fromList [(1, 1)]) @@ -1294,7 +1267,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints actualResult `shouldBe` Nothing it "Infeasible: unbounded variable with conflicting constraints" $ do @@ -1307,7 +1280,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints actualResult `shouldBe` Nothing it "Variable at exactly zero with negative lower bound" $ do @@ -1318,7 +1291,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 0 @@ -1330,7 +1303,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 0 @@ -1345,7 +1318,7 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex' domainMap obj constraints + twoPhaseSimplex domainMap obj constraints case actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> do From a068ab25f5ee54cbd1de5f0abb32743f184683e4 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 31 Jan 2026 13:48:52 +0000 Subject: [PATCH 05/17] feat (wip): VarDomain supports optional upper and lower bounds --- ChangeLog.md | 15 + src/Linear/Simplex/Solver/TwoPhase.hs | 66 +++-- src/Linear/Simplex/Types.hs | 49 +++- test/Linear/Simplex/Solver/TwoPhaseSpec.hs | 301 +++++++++++++++------ 4 files changed, 318 insertions(+), 113 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 62325e2..a9ccb1e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,8 +2,23 @@ ## Unreleased changes +- **BREAKING CHANGE**: Restructured `VarDomain` type to support upper bounds + - Replaced `NonNegative`, `LowerBound SimplexNum`, and `Unbounded` constructors with + a single `Bounded { lowerBound :: Maybe SimplexNum, upperBound :: Maybe SimplexNum }` record + - Added smart constructors for convenience: `unbounded`, `nonNegative`, `lowerBoundOnly`, + `upperBoundOnly`, and `boundedRange` + - `Bounded Nothing Nothing` is equivalent to `Unbounded` + - `Bounded (Just 0) Nothing` is equivalent to `NonNegative` + - Upper bounds are now supported and automatically added as LEQ constraints +- Added `AddUpperBound` constructor to `VarTransform` for upper bound constraint generation +- Updated `getTransform` to return a list of transforms (can now generate both lower and upper bound transforms) - Use Hspec for tests - Add nix flake +- twoPhaseSimplex now takes a VarDomainMap (as the first param) + - You can specify each Var's domain using smart constructors: `nonNegative`, `unbounded`, + `lowerBoundOnly`, `upperBoundOnly`, or `boundedRange` + - If a VarDomain for a Var is undefined, it's assumed to be `unbounded` + - If you want to keep the same behaviour as before (all vars non-negative), use `nonNegative` for all Vars ## [v0.2.0.0](https://github.com/rasheedja/LPPaver/tree/v0.2.0.0) diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index f746a04..bdc0f62 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -49,6 +49,7 @@ import qualified Data.Set as Set import GHC.Real (Ratio) import Linear.Simplex.Types import Linear.Simplex.Util +import qualified Control.Applicative as LPPaver -- | Find a feasible solution for the given system of 'PolyConstraint's by performing the first phase of the two-phase simplex method -- All variables in the 'PolyConstraint' must be positive. @@ -402,7 +403,9 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) -- Variables not in the VarDomainMap are assumed to be Unbounded (no lower bound). -- This function applies necessary transformations before solving and unapplies them after. -- The returned Result contains variable values and objective value in the original space. --- TODO: use this as twoPhaseSimplex, add instructions in CHANGELOG for old users +-- TODO: we need to be able to support multiple objective functions for the LPPaver. +-- one way to do this is to have a list of objective functions and optimize them one by one. +-- think about cases where the opitmal result is infinity twoPhaseSimplex :: (MonadIO m, MonadLogger m) => VarDomainMap -> ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result) twoPhaseSimplex domainMap objFunction constraints = do logMsg LevelInfo $ @@ -489,26 +492,40 @@ collectAllVars objFunction constraints = -- Returns updated (transforms, nextFreshVar). generateTransform :: M.Map Var VarDomain -> Var -> ([VarTransform], Var) -> ([VarTransform], Var) generateTransform domainMap var (transforms, nextFreshVar) = - let domain = M.findWithDefault Unbounded var domainMap - in case getTransform nextFreshVar var domain of - Nothing -> (transforms, nextFreshVar) - Just t@(AddLowerBound {}) -> (t : transforms, nextFreshVar) - Just t@(Shift {}) -> (t : transforms, nextFreshVar + 1) - Just t@(Split {}) -> (t : transforms, nextFreshVar + 2) - --- | Determine what transform (if any) is needed for a variable given its domain. -getTransform :: Var -> Var -> VarDomain -> Maybe VarTransform -getTransform nextFreshVar var domain = - case domain of - NonNegative -> Nothing - - LowerBound l - | l == 0 -> Nothing - | l > 0 -> Just $ AddLowerBound var l - | otherwise -> Just $ Shift var nextFreshVar l -- l < 0, need to shift - - Unbounded -> - Just $ Split var nextFreshVar (nextFreshVar + 1) + let domain = M.findWithDefault unbounded var domainMap + (newTransforms, varOffset) = getTransform nextFreshVar var domain + in (newTransforms ++ transforms, nextFreshVar + varOffset) + +-- | Determine what transforms are needed for a variable given its domain. +-- Returns a list of transforms and the number of fresh variables consumed. +getTransform :: Var -> Var -> VarDomain -> ([VarTransform], Var) +getTransform nextFreshVar var (Bounded mLower mUpper) = + let -- Handle lower bound + (lowerTransforms, varOffset) = case mLower of + Nothing -> ([], 0) -- No lower bound: will need Split + Just l + | l == 0 -> ([], 0) -- NonNegative: no transform needed + | l > 0 -> ([AddLowerBound var l], 0) -- Positive lower bound: add constraint + | otherwise -> ([Shift var nextFreshVar l], 1) -- Negative lower bound: shift + + -- Handle upper bound (if present) + upperTransforms = case mUpper of + Nothing -> [] + Just u -> [AddUpperBound var u] + + -- If no lower bound (Nothing), we need Split transformation + -- Split replaces the variable, so upper bound would apply to the original var + -- which gets expressed as posVar - negVar + (finalTransforms, finalOffset) = case mLower of + Nothing -> + -- Unbounded: split the variable + -- Note: upperTransforms will still be added and will apply to the original variable + -- expression (posVar - negVar) via the constraint system + (Split var nextFreshVar (nextFreshVar + 1) : upperTransforms, 2) + Just _ -> + (lowerTransforms ++ upperTransforms, varOffset) + + in (finalTransforms, finalOffset) -- | Apply all transforms to the objective function and constraints. applyTransforms :: [VarTransform] -> ObjectiveFunction -> [PolyConstraint] -> (ObjectiveFunction, [PolyConstraint]) @@ -523,6 +540,10 @@ applyTransform transform (objFunction, constraints) = AddLowerBound v bound -> (objFunction, GEQ (M.singleton v 1) bound : constraints) + -- AddUpperBound: Add a LEQ constraint for the variable + AddUpperBound v bound -> + (objFunction, LEQ (M.singleton v 1) bound : constraints) + -- Shift: originalVar = shiftedVar + shiftBy (where shiftBy < 0) -- Substitute: wherever we see originalVar, replace with shiftedVar -- and adjust the RHS by -coeff * shiftBy @@ -624,6 +645,9 @@ unapplyTransform transform result@(Result {varValMap = valMap, ..}) = -- AddLowerBound: No variable substitution was done, nothing to unapply AddLowerBound {} -> result + -- AddUpperBound: No variable substitution was done, nothing to unapply + AddUpperBound {} -> result + -- Shift: originalVar = shiftedVar + shiftBy -- So originalVar's value = shiftedVar's value + shiftBy Shift origVar shiftedVar shiftBy -> diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 3d2ea63..8f2cf37 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -122,16 +122,45 @@ data PivotObjective = PivotObjective } deriving (Show, Read, Eq, Generic) --- | Domain specification for a variable's lower bound. --- Note: This only concerns lower bounds. Upper bounds are handled via constraints. --- Variables not in the VarDomainMap are assumed to be Unbounded. -data VarDomain - = NonNegative -- ^ var >= 0 (standard simplex assumption, no transformation needed) - | LowerBound SimplexNum -- ^ var >= L for some L (if L < 0: shift, if L > 0: add constraint) - | Unbounded -- ^ No lower bound (split into difference of two non-negative vars) - -- TODO: Upperbound can still be useful, can negate it to get a loewr bound, can add it to the constraints +-- | Domain specification for a variable's bounds. +-- Variables not in the VarDomainMap are assumed to be Unbounded (both bounds Nothing). +-- +-- Bounds semantics: +-- * @lowerBound = Just L@ means var >= L +-- * @lowerBound = Nothing@ means no lower bound (var can be arbitrarily negative) +-- * @upperBound = Just U@ means var <= U +-- * @upperBound = Nothing@ means no upper bound (var can be arbitrarily positive) +-- +-- Note: @Bounded Nothing Nothing@ is equivalent to unbounded. Use the smart constructors +-- ('unbounded', 'nonNegative', etc.) for clarity. +data VarDomain = Bounded + { lowerBound :: Maybe SimplexNum -- ^ Lower bound (Nothing = -∞) + , upperBound :: Maybe SimplexNum -- ^ Upper bound (Nothing = +∞) + } deriving stock (Show, Read, Eq, Generic) +-- | Smart constructor for an unbounded variable (no lower or upper bound). +-- The variable can take any real value. +unbounded :: VarDomain +unbounded = Bounded Nothing Nothing + +-- | Smart constructor for a non-negative variable (var >= 0). +-- This is the standard simplex assumption. +nonNegative :: VarDomain +nonNegative = Bounded (Just 0) Nothing + +-- | Smart constructor for a variable with only a lower bound (var >= L). +lowerBoundOnly :: SimplexNum -> VarDomain +lowerBoundOnly l = Bounded (Just l) Nothing + +-- | Smart constructor for a variable with only an upper bound (var <= U). +upperBoundOnly :: SimplexNum -> VarDomain +upperBoundOnly u = Bounded Nothing (Just u) + +-- | Smart constructor for a variable with both lower and upper bounds (L <= var <= U). +boundedRange :: SimplexNum -> SimplexNum -> VarDomain +boundedRange l u = Bounded (Just l) (Just u) + -- | Map from variables to their domain specifications. -- Variables not in this map are assumed to be Unbounded. newtype VarDomainMap = VarDomainMap { unVarDomainMap :: M.Map Var VarDomain } @@ -143,6 +172,10 @@ data VarTransform { var :: !Var , bound :: !SimplexNum } -- ^ var >= bound where bound > 0. Adds GEQ constraint to system. + | AddUpperBound + { var :: !Var + , bound :: !SimplexNum + } -- ^ var <= bound. Adds LEQ constraint to system. | Shift { originalVar :: !Var , shiftedVar :: !Var diff --git a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs index af09acf..1bdfbd5 100644 --- a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs +++ b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} module Linear.Simplex.Solver.TwoPhaseSpec where import Prelude hiding (EQ) @@ -14,11 +15,10 @@ import Text.InterpolatedString.Perl6 import Test.Hspec import Test.Hspec.Expectations.Contrib (annotate) import Test.QuickCheck hiding (Result) -import qualified Linear.Simplex.Types as T import Linear.Simplex.Prettify import Linear.Simplex.Solver.TwoPhase -import Linear.Simplex.Types hiding (NonNegative) +import Linear.Simplex.Types import Linear.Simplex.Util -- | Helper to run a test case for a system where all vars @@ -29,7 +29,7 @@ runTest (obj, constraints) expectedResult = do prettyConstraints = map prettyShowPolyConstraint constraints expectedObjVal = extractObjectiveValue expectedResult allVars = collectAllVars obj constraints - domainMap = VarDomainMap $ M.fromSet (const T.NonNegative) allVars + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -624,7 +624,7 @@ spec = do it "Shift transformation with negative lower bound" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -636,7 +636,7 @@ spec = do it "Shift transformation finds minimum at negative bound" $ do let obj = Min (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) 0 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -651,7 +651,7 @@ spec = do [ LEQ (M.fromList [(1, 1)]) 10 , GEQ (M.fromList [(1, 1)]) (-10) ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -666,7 +666,7 @@ spec = do [ LEQ (M.fromList [(1, 1)]) 10 , GEQ (M.fromList [(1, 1)]) (-10) ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -678,7 +678,7 @@ spec = do it "AddLowerBound with positive lower bound" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound 5)] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 5)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -690,7 +690,7 @@ spec = do it "AddLowerBound finds minimum at positive bound" $ do let obj = Min (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound 5)] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 5)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -705,7 +705,7 @@ spec = do [ LEQ (M.fromList [(1, 1), (2, 1)]) 5 , GEQ (M.fromList [(2, 1)]) (-3) ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-2)), (2, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-2)), (2, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -719,7 +719,7 @@ spec = do (xVal + yVal) `shouldBe` 5 oVal `shouldBe` 5 - it "LowerBound 0 is equivalent to NonNegative" $ do + it "lowerBoundOnly 0 is equivalent to NonNegative" $ do let obj = Max (M.fromList [(1, 3), (2, 5)]) constraints = [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 @@ -727,8 +727,8 @@ spec = do , LEQ (M.fromList [(2, 1)]) 4 , LEQ (M.fromList [(1, -1), (2, 2)]) 6 ] - domainMap1 = VarDomainMap $ M.fromList [(1, LowerBound 0), (2, LowerBound 0)] - domainMap2 = VarDomainMap $ M.fromList [(1, T.NonNegative), (2, T.NonNegative)] + domainMap1 = VarDomainMap $ M.fromList [(1, lowerBoundOnly 0), (2, lowerBoundOnly 0)] + domainMap2 = VarDomainMap $ M.fromList [(1, nonNegative), (2, nonNegative)] actualResult1 <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -743,13 +743,126 @@ spec = do it "Infeasible system with domain constraint" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound 10)] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 10)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap obj constraints actualResult `shouldBe` Nothing + describe "twoPhaseSimplex with upper bounds (AddUpperBound transformation)" $ do + describe "Simple single variable systems" $ do + it "Max x₁ with x₁ ≥ 0, x₁ ≤ 5 (using boundedRange): optimal at x₁=5" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 0 5)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 5 + + it "Min x₁ with x₁ ≥ 0, x₁ ≤ 10 (using boundedRange): optimal at x₁=0" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 0 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + -- Note: non-basic variables with value 0 may not appear in varValMap + Just result -> M.findWithDefault 0 1 result.varValMap `shouldBe` 0 + + it "Max x₁ with -5 ≤ x₁ ≤ 10 (bounded range with negative lower): optimal at x₁=10" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange (-5) 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 + + it "Min x₁ with -5 ≤ x₁ ≤ 10 (bounded range with negative lower): optimal at x₁=-5" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange (-5) 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-5) + + it "Infeasible: lower bound > upper bound" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 10 5)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap obj constraints + actualResult `shouldBe` Nothing + + describe "Two variable systems with upper bounds" $ do + it "Max x₁ + x₂ with 0 ≤ x₁ ≤ 3, 0 ≤ x₂ ≤ 4: optimal at x₁=3, x₂=4" $ do + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 0 3), (2, boundedRange 0 4)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + M.lookup 1 result.varValMap `shouldBe` Just 3 + M.lookup 2 result.varValMap `shouldBe` Just 4 + M.lookup result.objectiveVar result.varValMap `shouldBe` Just 7 + + it "Max 2x₁ - x₂ with -2 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 4" $ do + -- Maximize 2x₁ - x₂: want x₁ = 5 (max), x₂ = -3 (min) + -- Optimal: 2*5 - (-3) = 13 + let obj = Max (M.fromList [(1, 2), (2, -1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange (-2) 5), (2, boundedRange (-3) 4)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + M.lookup 1 result.varValMap `shouldBe` Just 5 + M.lookup 2 result.varValMap `shouldBe` Just (-3) + M.lookup result.objectiveVar result.varValMap `shouldBe` Just 13 + + it "Mixed bounds: x₁ nonNegative, x₂ with upper bound only (unbounded below)" $ do + -- x₁ ≥ 0, x₂ ≤ 10 (no lower bound) + -- Max x₁ + x₂ with x₁ + x₂ ≤ 20 + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = [ LEQ (M.fromList [(1, 1), (2, 1)]) 20 ] + domainMap = VarDomainMap $ M.fromList [(1, nonNegative), (2, upperBoundOnly 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap obj constraints + case actualResult of + Nothing -> expectationFailure "Expected a solution but got Nothing" + Just result -> do + let x1 = M.findWithDefault 0 1 result.varValMap + x2 = M.findWithDefault 0 2 result.varValMap + x1 `shouldSatisfy` (>= 0) + x2 `shouldSatisfy` (<= 10) + (x1 + x2) `shouldBe` 20 + describe "twoPhaseSimplex with negative lower bounds (Shift transformation)" $ do describe "Simple single variable systems" $ do it "Max x₁ with x₁ ≤ 5, x₁ ≥ -3: optimal at upper bound x₁=5" $ do @@ -757,7 +870,7 @@ spec = do -- Optimal should be at x₁ = 5 let obj = Max (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-3))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-3))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -771,7 +884,7 @@ spec = do -- Optimal should be at x₁ = -3 let obj = Min (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-3))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-3))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -784,7 +897,7 @@ spec = do -- Both bounds are negative, maximize let obj = Max (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) (-2) ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-10))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-10))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -797,7 +910,7 @@ spec = do -- Both bounds are negative, minimize let obj = Min (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) (-2) ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-10))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-10))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -815,7 +928,7 @@ spec = do -- After unapply: x₁ + x₂ = 15 - 5 = 10 let obj = Max (M.fromList [(1, 1), (2, 1)]) constraints = [ LEQ (M.fromList [(1, 1), (2, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-2)), (2, LowerBound (-3))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-2)), (2, lowerBoundOnly (-3))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -837,7 +950,7 @@ spec = do -- Optimal: x₁ = -2, x₂ = -3, sum = -5 let obj = Min (M.fromList [(1, 1), (2, 1)]) constraints = [ LEQ (M.fromList [(1, 1), (2, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-2)), (2, LowerBound (-3))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-2)), (2, lowerBoundOnly (-3))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -859,7 +972,7 @@ spec = do [ LEQ (M.fromList [(1, 1)]) 3 , LEQ (M.fromList [(2, 1)]) 6 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5)), (2, LowerBound (-4))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5)), (2, lowerBoundOnly (-4))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -882,7 +995,7 @@ spec = do [ LEQ (M.fromList [(1, 1)]) 3 , LEQ (M.fromList [(2, 1)]) 6 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5)), (2, LowerBound (-4))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5)), (2, lowerBoundOnly (-4))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -907,7 +1020,7 @@ spec = do [ GEQ (M.fromList [(1, 1)]) 2 , LEQ (M.fromList [(1, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -923,7 +1036,7 @@ spec = do [ GEQ (M.fromList [(1, 1)]) 2 , LEQ (M.fromList [(1, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -941,7 +1054,7 @@ spec = do [ EQ (M.fromList [(1, 1), (2, -1)]) 0 , LEQ (M.fromList [(1, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5)), (2, LowerBound (-5))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5)), (2, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -963,7 +1076,7 @@ spec = do [ EQ (M.fromList [(1, 1), (2, -1)]) 0 , LEQ (M.fromList [(1, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5)), (2, LowerBound (-5))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5)), (2, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -981,7 +1094,7 @@ spec = do it "Max x₁ with x₁ ≥ -7/2, x₁ ≤ 5/2" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) (5 % 2) ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound ((-7) % 2))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly ((-7) % 2))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -993,7 +1106,7 @@ spec = do it "Min x₁ with x₁ ≥ -7/2, x₁ ≤ 5/2" $ do let obj = Min (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) (5 % 2) ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound ((-7) % 2))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly ((-7) % 2))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1011,7 +1124,7 @@ spec = do [ LEQ (M.fromList [(1, 1)]) 10 , GEQ (M.fromList [(1, 1)]) (-10) ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1026,7 +1139,7 @@ spec = do [ LEQ (M.fromList [(1, 1)]) 10 , GEQ (M.fromList [(1, 1)]) (-10) ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1035,12 +1148,12 @@ spec = do Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-10) - it "Unbounded variable with only upper bound: Min finds negative value" $ do + it "unbounded variable with only upper bound: Min finds negative value" $ do -- x₁ unbounded, only x₁ ≤ 5, minimize x₁ -- This should be unbounded (no solution) since x₁ can go to -∞ let obj = Min (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1057,7 +1170,7 @@ spec = do , LEQ (M.fromList [(2, 1)]) 7 , GEQ (M.fromList [(2, 1)]) (-3) ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded), (2, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded), (2, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1078,7 +1191,7 @@ spec = do , LEQ (M.fromList [(2, 1)]) 7 , GEQ (M.fromList [(2, 1)]) (-3) ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded), (2, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded), (2, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1100,7 +1213,7 @@ spec = do , LEQ (M.fromList [(2, 1)]) 7 , GEQ (M.fromList [(2, 1)]) (-3) ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded), (2, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded), (2, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1122,7 +1235,7 @@ spec = do [ EQ (M.fromList [(1, 1), (2, 1)]) 10 , GEQ (M.fromList [(2, 1)]) (-5) ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded), (2, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded), (2, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1141,7 +1254,7 @@ spec = do [ EQ (M.fromList [(1, 1), (2, 1)]) 10 , LEQ (M.fromList [(2, 1)]) 20 ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded), (2, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded), (2, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1166,7 +1279,7 @@ spec = do , GEQ (M.fromList [(3, 1)]) (-10) ] domainMap = VarDomainMap $ M.fromList - [(1, T.NonNegative), (2, LowerBound (-5)), (3, Unbounded)] + [(1, nonNegative), (2, lowerBoundOnly (-5)), (3, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1189,7 +1302,7 @@ spec = do , GEQ (M.fromList [(3, 1)]) (-20) ] domainMap = VarDomainMap $ M.fromList - [(1, T.NonNegative), (2, LowerBound (-5)), (3, Unbounded)] + [(1, nonNegative), (2, lowerBoundOnly (-5)), (3, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1217,7 +1330,7 @@ spec = do [ LEQ (M.fromList [(1, 2), (2, 1)]) 20 , LEQ (M.fromList [(2, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound 2), (2, LowerBound (-3))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 2), (2, lowerBoundOnly (-3))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1241,7 +1354,7 @@ spec = do , LEQ (M.fromList [(1, 1)]) 10 , LEQ (M.fromList [(2, 1)]) 10 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound 2), (2, LowerBound (-3))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 2), (2, lowerBoundOnly (-3))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1263,7 +1376,7 @@ spec = do [ GEQ (M.fromList [(1, 1)]) 10 , LEQ (M.fromList [(1, 1)]) 5 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1276,7 +1389,7 @@ spec = do [ GEQ (M.fromList [(1, 1)]) 10 , LEQ (M.fromList [(1, 1)]) 5 ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1287,7 +1400,7 @@ spec = do -- x₁ ≥ -5, constraint x₁ = 0 let obj = Max (M.fromList [(1, 1)]) constraints = [ EQ (M.fromList [(1, 1)]) 0 ] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1296,10 +1409,10 @@ spec = do Nothing -> expectationFailure "Expected a solution but got Nothing" Just result -> M.lookup 1 result.varValMap `shouldBe` Just 0 - it "Unbounded variable constrained to zero" $ do + it "unbounded variable constrained to zero" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [ EQ (M.fromList [(1, 1)]) 0 ] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1314,7 +1427,7 @@ spec = do let obj = Max (M.fromList [(1, 1), (2, 1), (3, 1)]) constraints = [ LEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) 15 ] domainMap = VarDomainMap $ M.fromList - [(1, T.NonNegative), (2, LowerBound (-10)), (3, T.NonNegative)] + [(1, nonNegative), (2, lowerBoundOnly (-10)), (3, nonNegative)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1386,53 +1499,66 @@ spec = do describe "getTransform" $ do describe "Unit tests" $ do - it "returns Nothing for NonNegative domain" $ do - getTransform 10 1 T.NonNegative `shouldBe` Nothing + it "returns empty list for NonNegative domain" $ do + getTransform 10 1 nonNegative `shouldBe` ([], 0) - it "returns Nothing for LowerBound 0" $ do - getTransform 10 1 (LowerBound 0) `shouldBe` Nothing + it "returns empty list for lowerBoundOnly 0" $ do + getTransform 10 1 (lowerBoundOnly 0) `shouldBe` ([], 0) it "returns AddLowerBound for positive lower bound" $ do - getTransform 10 1 (LowerBound 5) `shouldBe` Just (AddLowerBound 1 5) + getTransform 10 1 (lowerBoundOnly 5) `shouldBe` ([AddLowerBound 1 5], 0) it "returns AddLowerBound for fractional positive lower bound" $ do - getTransform 10 1 (LowerBound (3 % 2)) `shouldBe` Just (AddLowerBound 1 (3 % 2)) + getTransform 10 1 (lowerBoundOnly (3 % 2)) `shouldBe` ([AddLowerBound 1 (3 % 2)], 0) it "returns Shift for negative lower bound" $ do - getTransform 10 1 (LowerBound (-5)) `shouldBe` Just (Shift 1 10 (-5)) + getTransform 10 1 (lowerBoundOnly (-5)) `shouldBe` ([Shift 1 10 (-5)], 1) it "returns Shift for fractional negative lower bound" $ do - getTransform 10 1 (LowerBound ((-7) % 3)) `shouldBe` Just (Shift 1 10 ((-7) % 3)) + getTransform 10 1 (lowerBoundOnly ((-7) % 3)) `shouldBe` ([Shift 1 10 ((-7) % 3)], 1) - it "returns Split for Unbounded domain" $ do - getTransform 10 1 Unbounded `shouldBe` Just (Split 1 10 11) + it "returns Split for unbounded domain" $ do + getTransform 10 1 unbounded `shouldBe` ([Split 1 10 11], 2) + + it "returns AddUpperBound for upper bound only" $ do + getTransform 10 1 (upperBoundOnly 5) `shouldBe` ([Split 1 10 11, AddUpperBound 1 5], 2) + + it "returns AddLowerBound and AddUpperBound for bounded range" $ do + getTransform 10 1 (boundedRange 2 10) `shouldBe` ([AddLowerBound 1 2, AddUpperBound 1 10], 0) + + it "returns Shift and AddUpperBound for negative lower bound with upper bound" $ do + getTransform 10 1 (boundedRange (-5) 10) `shouldBe` ([Shift 1 10 (-5), AddUpperBound 1 10], 1) describe "generateTransform" $ do describe "Unit tests" $ do it "generates no transform for NonNegative in domain map" $ do - let domainMap = M.fromList [(1, T.NonNegative)] + let domainMap = M.fromList [(1, nonNegative)] generateTransform domainMap 1 ([], 10) `shouldBe` ([], 10) it "generates AddLowerBound for positive bound in domain map" $ do - let domainMap = M.fromList [(1, LowerBound 5)] + let domainMap = M.fromList [(1, lowerBoundOnly 5)] generateTransform domainMap 1 ([], 10) `shouldBe` ([AddLowerBound 1 5], 10) it "generates Shift for negative bound and increments fresh var" $ do - let domainMap = M.fromList [(1, LowerBound (-5))] + let domainMap = M.fromList [(1, lowerBoundOnly (-5))] generateTransform domainMap 1 ([], 10) `shouldBe` ([Shift 1 10 (-5)], 11) - it "generates Split for Unbounded and increments fresh var by 2" $ do - let domainMap = M.fromList [(1, Unbounded)] + it "generates Split for unbounded and increments fresh var by 2" $ do + let domainMap = M.fromList [(1, unbounded)] generateTransform domainMap 1 ([], 10) `shouldBe` ([Split 1 10 11], 12) - it "treats variable not in domain map as Unbounded" $ do + it "treats variable not in domain map as unbounded" $ do let domainMap = M.empty generateTransform domainMap 1 ([], 10) `shouldBe` ([Split 1 10 11], 12) it "accumulates transforms" $ do - let domainMap = M.fromList [(1, LowerBound 5)] + let domainMap = M.fromList [(1, lowerBoundOnly 5)] existing = [AddLowerBound 2 3] - generateTransform domainMap 1 (existing, 10) `shouldBe` ([AddLowerBound 1 5, AddLowerBound 2 3], 10) + generateTransform domainMap 1 (existing, 10) `shouldBe` ([AddLowerBound 1 5] ++ existing, 10) + + it "generates AddUpperBound for upper bound" $ do + let domainMap = M.fromList [(1, boundedRange 0 10)] + generateTransform domainMap 1 ([], 10) `shouldBe` ([AddUpperBound 1 10], 10) describe "applyShiftToObjective" $ do describe "Unit tests" $ do @@ -1608,7 +1734,7 @@ spec = do it "returns empty transforms for all NonNegative domains" $ do let obj = Max (M.fromList [(1, 1), (2, 1)]) constraints = [LEQ (M.fromList [(1, 1), (2, 1)]) 10] - domainMap = VarDomainMap $ M.fromList [(1, T.NonNegative), (2, T.NonNegative)] + domainMap = VarDomainMap $ M.fromList [(1, nonNegative), (2, nonNegative)] let (newObj, newConstraints, transforms) = preprocess obj domainMap constraints transforms `shouldBe` [] newObj `shouldBe` obj @@ -1617,7 +1743,7 @@ spec = do it "generates AddLowerBound for positive lower bounds" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [LEQ (M.fromList [(1, 1)]) 10] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound 5)] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 5)] let (_, newConstraints, transforms) = preprocess obj domainMap constraints transforms `shouldBe` [AddLowerBound 1 5] length newConstraints `shouldBe` 2 -- original + GEQ @@ -1625,7 +1751,7 @@ spec = do it "generates Shift for negative lower bounds" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [LEQ (M.fromList [(1, 1)]) 10] - domainMap = VarDomainMap $ M.fromList [(1, LowerBound (-5))] + domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] let (newObj, newConstraints, transforms) = preprocess obj domainMap constraints length transforms `shouldBe` 1 case head transforms of @@ -1634,10 +1760,10 @@ spec = do shiftBy `shouldBe` (-5) _ -> expectationFailure "Expected Shift transform" - it "generates Split for Unbounded domains" $ do + it "generates Split for unbounded domains" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [LEQ (M.fromList [(1, 1)]) 10] - domainMap = VarDomainMap $ M.fromList [(1, Unbounded)] + domainMap = VarDomainMap $ M.fromList [(1, unbounded)] let (_, _, transforms) = preprocess obj domainMap constraints length transforms `shouldBe` 1 case head transforms of @@ -1648,7 +1774,7 @@ spec = do let obj = Max (M.fromList [(1, 1), (2, 1), (3, 1)]) constraints = [LEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) 10] domainMap = VarDomainMap $ M.fromList - [(1, T.NonNegative), (2, LowerBound 5), (3, LowerBound (-3))] + [(1, nonNegative), (2, lowerBoundOnly 5), (3, lowerBoundOnly (-3))] let (_, _, transforms) = preprocess obj domainMap constraints -- Should have AddLowerBound for var 2, Shift for var 3 length transforms `shouldBe` 2 @@ -1671,33 +1797,40 @@ spec = do in all (`Set.member` collectAllVars obj []) (M.keys $ case obj of Max m -> m; Min m -> m) describe "getTransform properties" $ do - it "NonNegative always produces Nothing" $ property $ + it "NonNegative always produces empty list" $ property $ \(nextVar :: Int) (v :: Int) -> - getTransform (abs nextVar + 1) (abs v + 1) T.NonNegative == Nothing + getTransform (abs nextVar + 1) (abs v + 1) nonNegative == ([], 0) - it "LowerBound 0 produces Nothing" $ property $ + it "lowerBoundOnly 0 produces empty list" $ property $ \(nextVar :: Int) (v :: Int) -> - getTransform (abs nextVar + 1) (abs v + 1) (LowerBound 0) == Nothing + getTransform (abs nextVar + 1) (abs v + 1) (lowerBoundOnly 0) == ([], 0) - it "positive LowerBound produces AddLowerBound" $ property $ + it "positive lowerBoundOnly produces AddLowerBound" $ property $ \(Positive bound :: Positive Rational) (nextVar :: Int) (v :: Int) -> - case getTransform (abs nextVar + 1) (abs v + 1) (LowerBound bound) of - Just (AddLowerBound var b) -> var == abs v + 1 && b == bound + case getTransform (abs nextVar + 1) (abs v + 1) (lowerBoundOnly bound) of + ([AddLowerBound var b], 0) -> var == abs v + 1 && b == bound _ -> False - it "negative LowerBound produces Shift" $ property $ + it "negative lowerBoundOnly produces Shift" $ property $ \(Positive bound :: Positive Rational) (nextVar :: Int) (v :: Int) -> let negBound = negate bound - in case getTransform (abs nextVar + 1) (abs v + 1) (LowerBound negBound) of - Just (Shift origVar _ shiftBy) -> origVar == abs v + 1 && shiftBy == negBound + in case getTransform (abs nextVar + 1) (abs v + 1) (lowerBoundOnly negBound) of + ([Shift origVar _ shiftBy], 1) -> origVar == abs v + 1 && shiftBy == negBound _ -> False - it "Unbounded produces Split" $ property $ + it "unbounded produces Split" $ property $ \(nextVar :: Int) (v :: Int) -> - case getTransform (abs nextVar + 1) (abs v + 1) Unbounded of - Just (Split origVar _ _) -> origVar == abs v + 1 + case getTransform (abs nextVar + 1) (abs v + 1) unbounded of + ([Split origVar _ _], 2) -> origVar == abs v + 1 _ -> False + it "boundedRange produces both lower and upper bound transforms" $ property $ + \(lower :: Rational) (Positive delta :: Positive Rational) (nextVar :: Int) (v :: Int) -> + let upper = lower + delta -- ensure upper > lower + in case getTransform (abs nextVar + 1) (abs v + 1) (boundedRange lower upper) of + (transforms, _) -> + any (\case AddUpperBound var u -> var == abs v + 1 && u == upper; _ -> False) transforms + describe "applyShiftToConstraint properties" $ do it "RHS adjustment follows formula: newRHS = oldRHS - coeff * shiftBy" $ property $ \(coeff :: Rational) (oldRHS :: Rational) (shiftBy :: Rational) -> From 2dbbbc4cba41e54c68f9041ab3bdce2fe8fa807a Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 31 Jan 2026 23:17:36 +0000 Subject: [PATCH 06/17] chore: cleanup twoPhaseSimplex --- src/Linear/Simplex/Solver/TwoPhase.hs | 64 ++++++++++++--------------- 1 file changed, 28 insertions(+), 36 deletions(-) diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index bdc0f62..96cea9b 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -11,7 +11,7 @@ -- 'optimizeFeasibleSystem' performs phase two of the two-phase simplex method. -- 'twoPhaseSimplex' performs both phases of the two-phase simplex method. -- 'twoPhaseSimplex'' performs both phases with variable domain support. -module Linear.Simplex.Solver.TwoPhase +module Linear.Simplex.Solver.TwoPhase ( findFeasibleSolution , optimizeFeasibleSystem , twoPhaseSimplex @@ -410,30 +410,22 @@ twoPhaseSimplex :: (MonadIO m, MonadLogger m) => VarDomainMap -> ObjectiveFuncti twoPhaseSimplex domainMap objFunction constraints = do logMsg LevelInfo $ "twoPhaseSimplex: Solving system with domain map " <> showT domainMap - let (transformedObj, transformedConstraints, transforms) = preprocess objFunction domainMap constraints + let (transformedObj, transformedConstraints, transforms) = preprocess objFunction domainMap constraints logMsg LevelInfo $ "twoPhaseSimplex: Applied transforms " <> showT transforms <> "; Transformed objective: " <> showT transformedObj <> "; Transformed constraints: " <> showT transformedConstraints - phase1Result <- findFeasibleSolution transformedConstraints - case phase1Result of - Nothing -> do - logMsg LevelInfo "twoPhaseSimplex: No feasible solution found in phase 1" - pure Nothing - Just feasibleSystem -> do - logMsg LevelInfo $ - "twoPhaseSimplex: Feasible system found for transformed system; Feasible system: " - <> showT feasibleSystem - mOptimizedSystem <- optimizeFeasibleSystem transformedObj feasibleSystem - case mOptimizedSystem of - Nothing -> do - logMsg LevelInfo "twoPhaseSimplex: No optimized solution found in phase 2" - pure Nothing - Just result -> do - let finalResult = postprocess objFunction transforms result - logMsg LevelInfo $ - "twoPhaseSimplex: Postprocessed result: " <> showT finalResult - pure (Just finalResult) + mFeasibleSystem <- findFeasibleSolution transformedConstraints + let phase1FailureLog = logMsg LevelInfo "twoPhaseSimplex: No feasible solution found in phase 1" + let runPhase2 feasibleSystem = do + logMsg LevelInfo $ + "twoPhaseSimplex: Feasible system found for transformed system; Feasible system: " + <> showT feasibleSystem + mOptimizedSystem <- optimizeFeasibleSystem transformedObj feasibleSystem + let mFinalResult = postprocess objFunction transforms <$> mOptimizedSystem + logMsg LevelInfo $ maybe "twoPhaseSimplex: No optimized solution found in phase 2" (("twoPhaseSimplex: Postprocessed result: " <>) . showT) mFinalResult + pure mFinalResult + maybe (phase1FailureLog >> pure Nothing) runPhase2 mFeasibleSystem -- | Postprocess the result by unapplying variable transformations and computing -- the objective value in the original space. @@ -457,8 +449,8 @@ computeObjective objFunction varVals = -- | Preprocess the system by applying variable transformations based on domain information. -- Returns the transformed objective, constraints, and the list of transforms applied. -preprocess :: ObjectiveFunction - -> VarDomainMap +preprocess :: ObjectiveFunction + -> VarDomainMap -> [PolyConstraint] -> (ObjectiveFunction, [PolyConstraint], [VarTransform]) preprocess objFunction (VarDomainMap domainMap) constraints = @@ -507,24 +499,24 @@ getTransform nextFreshVar var (Bounded mLower mUpper) = | l == 0 -> ([], 0) -- NonNegative: no transform needed | l > 0 -> ([AddLowerBound var l], 0) -- Positive lower bound: add constraint | otherwise -> ([Shift var nextFreshVar l], 1) -- Negative lower bound: shift - + -- Handle upper bound (if present) upperTransforms = case mUpper of Nothing -> [] Just u -> [AddUpperBound var u] - + -- If no lower bound (Nothing), we need Split transformation -- Split replaces the variable, so upper bound would apply to the original var -- which gets expressed as posVar - negVar (finalTransforms, finalOffset) = case mLower of - Nothing -> + Nothing -> -- Unbounded: split the variable -- Note: upperTransforms will still be added and will apply to the original variable -- expression (posVar - negVar) via the constraint system (Split var nextFreshVar (nextFreshVar + 1) : upperTransforms, 2) Just _ -> (lowerTransforms ++ upperTransforms, varOffset) - + in (finalTransforms, finalOffset) -- | Apply all transforms to the objective function and constraints. @@ -539,11 +531,11 @@ applyTransform transform (objFunction, constraints) = -- AddLowerBound: Add a GEQ constraint for the variable AddLowerBound v bound -> (objFunction, GEQ (M.singleton v 1) bound : constraints) - + -- AddUpperBound: Add a LEQ constraint for the variable AddUpperBound v bound -> (objFunction, LEQ (M.singleton v 1) bound : constraints) - + -- Shift: originalVar = shiftedVar + shiftBy (where shiftBy < 0) -- Substitute: wherever we see originalVar, replace with shiftedVar -- and adjust the RHS by -coeff * shiftBy @@ -551,7 +543,7 @@ applyTransform transform (objFunction, constraints) = ( applyShiftToObjective origVar shiftedVar shiftBy objFunction , map (applyShiftToConstraint origVar shiftedVar shiftBy) constraints ) - + -- Split: originalVar = posVar - negVar -- Substitute: wherever we see originalVar with coeff c, -- replace with posVar with coeff c and negVar with coeff -c @@ -585,13 +577,13 @@ applyShiftToObjective origVar shiftedVar _shiftBy objFunction = applyShiftToConstraint :: Var -> Var -> SimplexNum -> PolyConstraint -> PolyConstraint applyShiftToConstraint origVar shiftedVar shiftBy constraint = case constraint of - LEQ m rhs -> + LEQ m rhs -> let (newMap, rhsAdjust) = substituteVarInMap origVar shiftedVar shiftBy m in LEQ newMap (rhs - rhsAdjust) - GEQ m rhs -> + GEQ m rhs -> let (newMap, rhsAdjust) = substituteVarInMap origVar shiftedVar shiftBy m in GEQ newMap (rhs - rhsAdjust) - EQ m rhs -> + EQ m rhs -> let (newMap, rhsAdjust) = substituteVarInMap origVar shiftedVar shiftBy m in EQ newMap (rhs - rhsAdjust) where @@ -644,10 +636,10 @@ unapplyTransform transform result@(Result {varValMap = valMap, ..}) = case transform of -- AddLowerBound: No variable substitution was done, nothing to unapply AddLowerBound {} -> result - + -- AddUpperBound: No variable substitution was done, nothing to unapply AddUpperBound {} -> result - + -- Shift: originalVar = shiftedVar + shiftBy -- So originalVar's value = shiftedVar's value + shiftBy Shift origVar shiftedVar shiftBy -> @@ -655,7 +647,7 @@ unapplyTransform transform result@(Result {varValMap = valMap, ..}) = origVal = shiftedVal + shiftBy newMap = M.insert origVar origVal (M.delete shiftedVar valMap) in result { varValMap = newMap } - + -- Split: originalVar = posVar - negVar -- So originalVar's value = posVar's value - negVar's value Split origVar posVar negVar -> From b205f1fa52c010d4b1e17427325a0cc3d90e39a4 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 14 Feb 2026 14:49:07 +0000 Subject: [PATCH 07/17] feat: support a list of objective functions + useful if you want to optimise multiple vars with a single set of constraints + can also send 0 objective functions if you just want to run phase 1 --- src/Linear/Simplex/Solver/TwoPhase.hs | 181 ++--- src/Linear/Simplex/Types.hs | 27 +- src/Linear/Simplex/Util.hs | 20 +- test/Linear/Simplex/Solver/TwoPhaseSpec.hs | 742 +++++++++++++-------- 4 files changed, 601 insertions(+), 369 deletions(-) diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index 96cea9b..cb2ee5f 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -28,8 +28,8 @@ module Linear.Simplex.Solver.TwoPhase , applyShiftToConstraint , applySplitToObjective , applySplitToConstraint - , unapplyTransforms - , unapplyTransform + , unapplyTransformsToVarMap + , unapplyTransformToVarMap ) where import Prelude hiding (EQ) @@ -274,33 +274,39 @@ findFeasibleSolution unsimplifiedSystem = do -- | Optimize a feasible system by performing the second phase of the two-phase simplex method. -- We first pass an 'ObjectiveFunction'. -- Then, the feasible system in 'DictionaryForm' as well as a list of slack variables, a list artificial variables, and the objective variable. --- Returns a pair with the first item being the 'Integer' variable equal to the 'ObjectiveFunction' --- and the second item being a map of the values of all 'Integer' variables appearing in the system, including the 'ObjectiveFunction'. -optimizeFeasibleSystem :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> FeasibleSystem -> m (Maybe Result) +-- Returns 'Optimal' with variable values if an optimal solution is found, or 'Unbounded' if the objective is unbounded. +optimizeFeasibleSystem :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> FeasibleSystem -> m OptimisationOutcome optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = do logMsg LevelInfo $ "optimizeFeasibleSystem: Optimizing feasible system " <> showT fsys <> " with objective " <> showT objFunction - if null artificialVars + mResult <- if null artificialVars then do logMsg LevelInfo $ "optimizeFeasibleSystem: No artificial vars, system is feasible. Pivoting system (in dict form) " <> showT phase1Dict <> " with objective " <> showT normalObjective - fmap (displayResults . dictionaryFormToTableau) <$> simplexPivot normalObjective phase1Dict + simplexPivot normalObjective phase1Dict else do logMsg LevelInfo $ "optimizeFeasibleSystem: Artificial vars present. Pivoting system (in dict form) " <> showT phase1Dict <> " with objective " <> showT adjustedObjective - fmap (displayResults . dictionaryFormToTableau) <$> simplexPivot adjustedObjective phase1Dict + simplexPivot adjustedObjective phase1Dict + case mResult of + Nothing -> do + logMsg LevelInfo "optimizeFeasibleSystem: Objective is unbounded (ratio test failed)" + pure Unbounded + Just resultDict -> do + let result = displayResults (dictionaryFormToTableau resultDict) + logMsg LevelInfo $ "optimizeFeasibleSystem: Found optimal solution: " <> showT result + pure result where - -- \| displayResults takes a 'Tableau' and returns a 'Result'. The 'Tableau' + -- \| displayResults takes a 'Tableau' and returns an 'OptimisationOutcome'. The 'Tableau' -- represents the final tableau of a linear program after the simplex - -- algorithm has been applied. The 'Result' contains the value of the - -- objective variable and a map of the values of all variables appearing - -- in the system, including the objective variable. + -- algorithm has been applied. The 'OptimisationOutcome' contains the values of all + -- variables appearing in the system. -- -- The function first filters out the rows of the tableau that correspond -- to the slack and artificial variables. It then extracts the values of @@ -310,12 +316,9 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) -- is a minimization problem, the map contains the values of the variables -- as they appear in the final tableau, except for the objective variable, -- which is negated. - displayResults :: Tableau -> Result + displayResults :: Tableau -> OptimisationOutcome displayResults tableau = - Result - { objectiveVar = objectiveVar - , varValMap = extractVarVals - } + Optimal extractVarVals where extractVarVals = let tableauWithOriginalVars = @@ -402,42 +405,62 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) -- | Perform the two phase simplex method with variable domain information. -- Variables not in the VarDomainMap are assumed to be Unbounded (no lower bound). -- This function applies necessary transformations before solving and unapplies them after. --- The returned Result contains variable values and objective value in the original space. --- TODO: we need to be able to support multiple objective functions for the LPPaver. --- one way to do this is to have a list of objective functions and optimize them one by one. --- think about cases where the opitmal result is infinity -twoPhaseSimplex :: (MonadIO m, MonadLogger m) => VarDomainMap -> ObjectiveFunction -> [PolyConstraint] -> m (Maybe Result) -twoPhaseSimplex domainMap objFunction constraints = do +-- The returned SimplexResult contains: +-- * The feasible system (Nothing if infeasible) +-- * Results for each objective function (empty if infeasible) +twoPhaseSimplex :: (MonadIO m, MonadLogger m) => VarDomainMap -> [ObjectiveFunction] -> [PolyConstraint] -> m SimplexResult +twoPhaseSimplex domainMap objFunctions constraints = do logMsg LevelInfo $ "twoPhaseSimplex: Solving system with domain map " <> showT domainMap - let (transformedObj, transformedConstraints, transforms) = preprocess objFunction domainMap constraints + -- Collect original variables before any transformations + let originalVars = collectAllVars objFunctions constraints + let (transformedObjs, transformedConstraints, transforms) = preprocess objFunctions domainMap constraints logMsg LevelInfo $ "twoPhaseSimplex: Applied transforms " <> showT transforms - <> "; Transformed objective: " <> showT transformedObj + <> "; Transformed objectives: " <> showT transformedObjs <> "; Transformed constraints: " <> showT transformedConstraints mFeasibleSystem <- findFeasibleSolution transformedConstraints - let phase1FailureLog = logMsg LevelInfo "twoPhaseSimplex: No feasible solution found in phase 1" - let runPhase2 feasibleSystem = do - logMsg LevelInfo $ - "twoPhaseSimplex: Feasible system found for transformed system; Feasible system: " - <> showT feasibleSystem - mOptimizedSystem <- optimizeFeasibleSystem transformedObj feasibleSystem - let mFinalResult = postprocess objFunction transforms <$> mOptimizedSystem - logMsg LevelInfo $ maybe "twoPhaseSimplex: No optimized solution found in phase 2" (("twoPhaseSimplex: Postprocessed result: " <>) . showT) mFinalResult - pure mFinalResult - maybe (phase1FailureLog >> pure Nothing) runPhase2 mFeasibleSystem - --- | Postprocess the result by unapplying variable transformations and computing --- the objective value in the original space. -postprocess :: ObjectiveFunction -> [VarTransform] -> Result -> Result -postprocess objFunction transforms result = - let -- First unapply transforms to get variable values in original space - unappliedResult = unapplyTransforms transforms result - -- Then compute the objective value using the original objective function - objVal = computeObjective objFunction unappliedResult.varValMap - -- Update the objective value in the result - finalVarValMap = M.insert unappliedResult.objectiveVar objVal unappliedResult.varValMap - in unappliedResult { varValMap = finalVarValMap } + case mFeasibleSystem of + Nothing -> do + logMsg LevelInfo "twoPhaseSimplex: No feasible solution found in phase 1" + pure $ SimplexResult Nothing [] + Just feasibleSystem -> do + logMsg LevelInfo $ + "twoPhaseSimplex: Feasible system found for transformed system; Feasible system: " + <> showT feasibleSystem + objResults <- optimizeAllObjectives originalVars transforms feasibleSystem (zip objFunctions transformedObjs) + logMsg LevelInfo $ "twoPhaseSimplex: All objective results: " <> showT objResults + pure $ SimplexResult (Just feasibleSystem) objResults + +-- | Optimize all objective functions over the given feasible system. +-- Returns a list of ObjectiveResult, one for each objective function. +-- The originalVars set is used to filter the result to only include original decision variables. +optimizeAllObjectives :: (MonadIO m, MonadLogger m) + => Set.Set Var -- ^ Original decision variables + -> [VarTransform] + -> FeasibleSystem + -> [(ObjectiveFunction, ObjectiveFunction)] -- ^ (original, transformed) objective pairs + -> m [ObjectiveResult] +optimizeAllObjectives originalVars transforms feasibleSystem objPairs = + mapM optimizeOne objPairs + where + optimizeOne (origObj, transformedObj) = do + outcome <- optimizeFeasibleSystem transformedObj feasibleSystem + let postprocessedOutcome = postprocess originalVars transforms outcome + pure $ ObjectiveResult origObj postprocessedOutcome + +-- | Postprocess the optimisation outcome by unapplying variable transformations +-- and filtering to only include the original decision variables. +-- For Optimal outcomes, unapplies transforms to get variable values in original space. +-- For Unbounded outcomes, passes through unchanged. +postprocess :: Set.Set Var -> [VarTransform] -> OptimisationOutcome -> OptimisationOutcome +postprocess _originalVars _transforms Unbounded = Unbounded +postprocess originalVars transforms (Optimal varVals) = + let -- Unapply transforms to get variable values in original space + unappliedVarVals = unapplyTransformsToVarMap transforms varVals + -- Filter to only include original decision variables + filteredVarVals = M.filterWithKey (\k _ -> Set.member k originalVars) unappliedVarVals + in Optimal filteredVarVals -- | Compute the value of an objective function given variable values. computeObjective :: ObjectiveFunction -> M.Map Var SimplexNum -> SimplexNum @@ -448,32 +471,42 @@ computeObjective objFunction varVals = in sum $ map (\(var, coeff) -> coeff * M.findWithDefault 0 var varVals) (M.toList coeffs) -- | Preprocess the system by applying variable transformations based on domain information. --- Returns the transformed objective, constraints, and the list of transforms applied. -preprocess :: ObjectiveFunction +-- Returns the transformed objectives, constraints, and the list of transforms applied. +preprocess :: [ObjectiveFunction] -> VarDomainMap -> [PolyConstraint] - -> (ObjectiveFunction, [PolyConstraint], [VarTransform]) -preprocess objFunction (VarDomainMap domainMap) constraints = - let -- Collect all variables in the system - allVars = collectAllVars objFunction constraints + -> ([ObjectiveFunction], [PolyConstraint], [VarTransform]) +preprocess objFunctions (VarDomainMap domainMap) constraints = + let -- Collect all variables in the system (from all objectives and constraints) + allVars = collectAllVars objFunctions constraints -- Find the maximum variable to generate fresh variables maxVar = if Set.null allVars then 0 else Set.findMax allVars -- Generate transforms for each variable based on its domain -- Variables not in domainMap are treated as Unbounded (transforms, _) = foldr (generateTransform domainMap) ([], maxVar) (Set.toList allVars) -- Apply transforms to get the transformed system - (transformedObj, transformedConstraints) = applyTransforms transforms objFunction constraints - in (transformedObj, transformedConstraints, transforms) - --- | Collect all variables appearing in the objective function and constraints -collectAllVars :: ObjectiveFunction -> [PolyConstraint] -> Set Var -collectAllVars objFunction constraints = - let objVars = case objFunction of - Max m -> M.keysSet m - Min m -> M.keysSet m + transformedObjs = map (\obj -> fst $ applyTransforms transforms obj constraints) objFunctions + (_, transformedConstraints) = case objFunctions of + [] -> (Max M.empty, applyTransformsToConstraints transforms constraints) + (obj:_) -> applyTransforms transforms obj constraints + in (transformedObjs, transformedConstraints, transforms) + +-- | Apply transforms to constraints only (used when there are no objectives) +applyTransformsToConstraints :: [VarTransform] -> [PolyConstraint] -> [PolyConstraint] +applyTransformsToConstraints transforms constraints = + snd $ applyTransforms transforms (Max M.empty) constraints + +-- | Collect all variables appearing in the objective functions and constraints +collectAllVars :: [ObjectiveFunction] -> [PolyConstraint] -> Set Var +collectAllVars objFunctions constraints = + let objVars = Set.unions $ map getObjVars objFunctions constraintVars = Set.unions $ map getConstraintVars constraints in Set.union objVars constraintVars where + getObjVars :: ObjectiveFunction -> Set Var + getObjVars (Max m) = M.keysSet m + getObjVars (Min m) = M.keysSet m + getConstraintVars :: PolyConstraint -> Set Var getConstraintVars (LEQ m _) = M.keysSet m getConstraintVars (GEQ m _) = M.keysSet m @@ -624,29 +657,28 @@ applySplitToConstraint origVar posVar negVar constraint = Nothing -> m Just coeff -> M.insert pVar coeff (M.insert nVar (-coeff) (M.delete oldVar m)) --- | Unapply transforms to convert the result back to original variables. -unapplyTransforms :: [VarTransform] -> Result -> Result -unapplyTransforms transforms result = +-- | Unapply transforms to convert a variable value map back to original variables. +unapplyTransformsToVarMap :: [VarTransform] -> VarLitMap -> VarLitMap +unapplyTransformsToVarMap transforms valMap = -- Apply transforms in reverse order (since we applied them with foldr) - foldl (flip unapplyTransform) result transforms + foldl (flip unapplyTransformToVarMap) valMap transforms --- | Unapply a single transform to convert result back to original variable. -unapplyTransform :: VarTransform -> Result -> Result -unapplyTransform transform result@(Result {varValMap = valMap, ..}) = +-- | Unapply a single transform to convert a variable value map back to original variables. +unapplyTransformToVarMap :: VarTransform -> VarLitMap -> VarLitMap +unapplyTransformToVarMap transform valMap = case transform of -- AddLowerBound: No variable substitution was done, nothing to unapply - AddLowerBound {} -> result + AddLowerBound {} -> valMap -- AddUpperBound: No variable substitution was done, nothing to unapply - AddUpperBound {} -> result + AddUpperBound {} -> valMap -- Shift: originalVar = shiftedVar + shiftBy -- So originalVar's value = shiftedVar's value + shiftBy Shift origVar shiftedVar shiftBy -> let shiftedVal = M.findWithDefault 0 shiftedVar valMap origVal = shiftedVal + shiftBy - newMap = M.insert origVar origVal (M.delete shiftedVar valMap) - in result { varValMap = newMap } + in M.insert origVar origVal (M.delete shiftedVar valMap) -- Split: originalVar = posVar - negVar -- So originalVar's value = posVar's value - negVar's value @@ -654,8 +686,7 @@ unapplyTransform transform result@(Result {varValMap = valMap, ..}) = let posVal = M.findWithDefault 0 posVar valMap negVal = M.findWithDefault 0 negVar valMap origVal = posVal - negVal - newMap = M.insert origVar origVal (M.delete posVar (M.delete negVar valMap)) - in result { varValMap = newMap } + in M.insert origVar origVal (M.delete posVar (M.delete negVar valMap)) -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. simplexPivot :: (MonadIO m, MonadLogger m) => PivotObjective -> Dict -> m (Maybe Dict) diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 8f2cf37..d8b6ff2 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -39,21 +39,26 @@ data FeasibleSystem = FeasibleSystem } deriving (Show, Read, Eq, Generic) -data Result = Result - { objectiveVar :: Var - , varValMap :: VarLitMap - -- TODO: - -- Maybe VarLitMap - -- , feasible :: Bool - -- , optimisable :: Bool +-- | The outcome of optimizing a single objective function. +data OptimisationOutcome + = Optimal { varValMap :: VarLitMap } -- ^ An optimal solution was found + | Unbounded -- ^ The objective is unbounded + deriving (Show, Read, Eq, Generic) + +-- | Result for a single objective function optimization. +data ObjectiveResult = ObjectiveResult + { objectiveFunction :: ObjectiveFunction -- ^ The objective that was optimized + , outcome :: OptimisationOutcome -- ^ The optimization outcome } deriving (Show, Read, Eq, Generic) -data SimplexMeta = SimplexMeta - { objective :: ObjectiveFunction - , feasibleSystem :: Maybe FeasibleSystem - , optimisedResult :: Maybe Result +-- | Complete result of the two-phase simplex method. +-- Contains feasibility information and results for all requested objectives. +data SimplexResult = SimplexResult + { feasibleSystem :: Maybe FeasibleSystem -- ^ The feasible system (Nothing if infeasible) + , objectiveResults :: [ObjectiveResult] -- ^ Results for each objective (empty if infeasible) } + deriving (Show, Read, Eq, Generic) type VarLitMap = M.Map Var SimplexNum diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 99b1495..7bee541 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -106,14 +106,18 @@ tableauInDictionaryForm = } ) --- | If this function is given 'Nothing', return 'Nothing'. --- Otherwise, we 'lookup' the 'Integer' given in the first item of the pair in the map given in the second item of the pair. --- This is typically used to extract the value of the 'ObjectiveFunction' after calling 'Linear.Simplex.Solver.TwoPhase.twoPhaseSimplex'. -extractObjectiveValue :: Maybe Result -> Maybe SimplexNum -extractObjectiveValue = fmap $ \result -> - case Map.lookup result.objectiveVar result.varValMap of - Nothing -> error "Objective not found in results when extracting objective value" - Just r -> r +-- | Extract the objective value from an ObjectiveResult. +-- Returns Nothing if the result is Unbounded. +-- Returns Just the objective value if Optimal. +extractObjectiveValue :: ObjectiveFunction -> ObjectiveResult -> Maybe SimplexNum +extractObjectiveValue objFunction (ObjectiveResult _ outcome) = + case outcome of + Unbounded -> Nothing + Optimal varVals -> + let coeffs = case objFunction of + Max m -> m + Min m -> m + in Just $ sum $ map (\(var, coeff) -> coeff * Map.findWithDefault 0 var varVals) (Map.toList coeffs) -- | Combines two 'VarLitMapSums together by summing values with matching keys combineVarLitMapSums :: VarLitMapSum -> VarLitMapSum -> VarLitMapSum diff --git a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs index 1bdfbd5..c64de49 100644 --- a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs +++ b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs @@ -1,11 +1,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} module Linear.Simplex.Solver.TwoPhaseSpec where import Prelude hiding (EQ) import Control.Monad.IO.Class import Control.Monad.Logger +import Data.Maybe (isJust) import qualified Data.Map as M import qualified Data.Set as Set import Data.Ratio @@ -14,27 +16,102 @@ import Text.InterpolatedString.Perl6 import Test.Hspec import Test.Hspec.Expectations.Contrib (annotate) -import Test.QuickCheck hiding (Result) +import Test.QuickCheck import Linear.Simplex.Prettify import Linear.Simplex.Solver.TwoPhase import Linear.Simplex.Types import Linear.Simplex.Util +-- | Legacy Result type for backward compatibility with existing tests. +-- The old Result stored (objectiveVar, varValMap) where varValMap included +-- the objective value keyed by objectiveVar. We convert this to the new format. +data LegacyResult = LegacyResult Var VarLitMap + deriving (Show, Eq) + +-- | Pattern synonym for backward compatibility - allows using `Result` as a constructor +pattern Result :: Var -> VarLitMap -> LegacyResult +pattern Result v m = LegacyResult v m + +-- | Convert a legacy expected result to the new ExpectedResult format. +-- Removes the objective variable entry from the varValMap since we now +-- compute objective values from the variable assignments. +-- Note: The old API returned Nothing for both infeasible and unbounded cases. +-- We map Nothing to ExpectNoFiniteOptimum to match either case. +legacyToExpected :: Maybe LegacyResult -> ExpectedResult +legacyToExpected Nothing = ExpectNoFiniteOptimum -- Could be infeasible or unbounded +legacyToExpected (Just (LegacyResult objVar varValMap)) = + ExpectOptimal (M.delete objVar varValMap) + +-- | Convert a SimplexResult (single objective) to Maybe VarLitMap. +-- This is used by tests that directly call twoPhaseSimplex and need +-- to pattern match on the result. +simplexResultToVarMap :: SimplexResult -> Maybe VarLitMap +simplexResultToVarMap (SimplexResult Nothing _) = Nothing +simplexResultToVarMap (SimplexResult (Just _) []) = Nothing +simplexResultToVarMap (SimplexResult (Just _) (ObjectiveResult _ Unbounded : _)) = Nothing +simplexResultToVarMap (SimplexResult (Just _) (ObjectiveResult _ (Optimal varVals) : _)) = Just varVals + +-- | Check if a SimplexResult represents an infeasible system. +isInfeasible :: SimplexResult -> Bool +isInfeasible (SimplexResult Nothing _) = True +isInfeasible _ = False + +-- | Check if a SimplexResult represents an unbounded system (feasible but no finite optimum). +isUnbounded :: SimplexResult -> Bool +isUnbounded (SimplexResult (Just _) (ObjectiveResult _ Unbounded : _)) = True +isUnbounded _ = False + +-- | Compute the objective value from variable assignments. +-- For Max: sum of (coeff * varValue) for each variable +-- For Min: same calculation (the value represents the optimal objective value) +computeObjValue :: ObjectiveFunction -> VarLitMap -> SimplexNum +computeObjValue (Max coeffs) varMap = sum [c * M.findWithDefault 0 v varMap | (v, c) <- M.toList coeffs] +computeObjValue (Min coeffs) varMap = sum [c * M.findWithDefault 0 v varMap | (v, c) <- M.toList coeffs] + +-- | Expected result for a single objective optimization +data ExpectedResult + = ExpectInfeasible -- ^ System has no feasible solution + | ExpectUnbounded -- ^ System is feasible but unbounded (no finite optimum) + | ExpectNoFiniteOptimum -- ^ Either infeasible or unbounded (old API didn't distinguish) + | ExpectOptimal VarLitMap -- ^ Optimal solution found with given variable values + deriving (Show, Eq) + +-- | Check if two expected results match, with special handling for ExpectNoFiniteOptimum +-- which matches both ExpectInfeasible and ExpectUnbounded. +resultsMatch :: ExpectedResult -> ExpectedResult -> Bool +resultsMatch ExpectNoFiniteOptimum ExpectInfeasible = True +resultsMatch ExpectNoFiniteOptimum ExpectUnbounded = True +resultsMatch ExpectInfeasible ExpectNoFiniteOptimum = True +resultsMatch ExpectUnbounded ExpectNoFiniteOptimum = True +resultsMatch a b = a == b + -- | Helper to run a test case for a system where all vars --- are non-negative and verify we get the expected result -runTest :: (ObjectiveFunction, [PolyConstraint]) -> Maybe Result -> IO () -runTest (obj, constraints) expectedResult = do - let prettyObj = prettyShowObjectiveFunction obj +-- are non-negative and verify we get the expected result. +-- Uses the legacy Result format for backward compatibility. +runTest :: (ObjectiveFunction, [PolyConstraint]) -> Maybe LegacyResult -> IO () +runTest (obj, constraints) legacyExpected = do + let expectedResult = legacyToExpected legacyExpected + prettyObj = prettyShowObjectiveFunction obj prettyConstraints = map prettyShowPolyConstraint constraints - expectedObjVal = extractObjectiveValue expectedResult - allVars = collectAllVars obj constraints + allVars = collectAllVars [obj] constraints domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars - actualResult <- + SimplexResult mFeasibleSystem objResults <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - let actualObjVal = extractObjectiveValue actualResult + twoPhaseSimplex domainMap [obj] constraints + let actualResult = case (mFeasibleSystem, objResults) of + (Nothing, _) -> ExpectInfeasible + (Just _, []) -> ExpectInfeasible -- Should not happen with one objective + (Just _, [ObjectiveResult _ Unbounded]) -> ExpectUnbounded + (Just _, [ObjectiveResult _ (Optimal varVals)]) -> ExpectOptimal varVals + (Just _, _) -> error "Unexpected: multiple results for single objective" + actualObjVal = case actualResult of + ExpectOptimal varVals -> extractObjectiveValue obj (ObjectiveResult obj (Optimal varVals)) + _ -> Nothing + expectedObjVal = case expectedResult of + ExpectOptimal varVals -> extractObjectiveValue obj (ObjectiveResult obj (Optimal varVals)) + _ -> Nothing annotate [qc| @@ -44,13 +121,13 @@ Constraints (Non-prettified): {constraints} Objective Function (Prettified): {prettyObj} Constraints (Prettified): {prettyConstraints} ==================================== -Expected Solution (Full): {expectedResult} -Actual Solution (Full): {actualResult} -Expected Solution (Objective): {expectedObjVal} -Actual Solution (Objective): {actualObjVal} +Expected Result : {expectedResult} +Actual Result : {actualResult} +Expected Objective Value : {expectedObjVal} +Actual Objective Value : {actualObjVal} |] $ do - actualResult `shouldBe` expectedResult + resultsMatch actualResult expectedResult `shouldBe` True spec :: Spec spec = do @@ -628,10 +705,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 it "Shift transformation finds minimum at negative bound" $ do let obj = Min (M.fromList [(1, 1)]) @@ -640,10 +717,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-5) + Just varMap -> M.lookup 1 varMap `shouldBe` Just (-5) it "Split transformation for unbounded variable (max)" $ do let obj = Max (M.fromList [(1, 1)]) @@ -655,10 +732,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 it "Split transformation for unbounded variable (min)" $ do let obj = Min (M.fromList [(1, 1)]) @@ -670,10 +747,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-10) + Just varMap -> M.lookup 1 varMap `shouldBe` Just (-10) it "AddLowerBound with positive lower bound" $ do let obj = Max (M.fromList [(1, 1)]) @@ -682,10 +759,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 it "AddLowerBound finds minimum at positive bound" $ do let obj = Min (M.fromList [(1, 1)]) @@ -694,10 +771,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 5 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 5 it "Mixed domain types" $ do let obj = Max (M.fromList [(1, 1), (2, 1)]) @@ -709,13 +786,13 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let xVal = M.findWithDefault 0 1 result.varValMap - yVal = M.findWithDefault 0 2 result.varValMap - oVal = M.findWithDefault 0 result.objectiveVar result.varValMap + Just varMap -> do + let xVal = M.findWithDefault 0 1 varMap + yVal = M.findWithDefault 0 2 varMap + oVal = computeObjValue obj varMap (xVal + yVal) `shouldBe` 5 oVal `shouldBe` 5 @@ -732,13 +809,14 @@ spec = do actualResult1 <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap1 obj constraints + twoPhaseSimplex domainMap1 [obj] constraints actualResult2 <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap2 obj constraints - actualResult1 `shouldBe` Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)])) - actualResult1 `shouldBe` actualResult2 + twoPhaseSimplex domainMap2 [obj] constraints + -- Both should produce the same optimal solution with x₁=3, x₂=4 + simplexResultToVarMap actualResult1 `shouldBe` Just (M.fromList [(1, 3), (2, 4)]) + simplexResultToVarMap actualResult1 `shouldBe` simplexResultToVarMap actualResult2 it "Infeasible system with domain constraint" $ do let obj = Max (M.fromList [(1, 1)]) @@ -747,8 +825,8 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - actualResult `shouldBe` Nothing + twoPhaseSimplex domainMap [obj] constraints + isInfeasible actualResult `shouldBe` True describe "twoPhaseSimplex with upper bounds (AddUpperBound transformation)" $ do describe "Simple single variable systems" $ do @@ -759,10 +837,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 5 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 5 it "Min x₁ with x₁ ≥ 0, x₁ ≤ 10 (using boundedRange): optimal at x₁=0" $ do let obj = Min (M.fromList [(1, 1)]) @@ -771,11 +849,11 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" -- Note: non-basic variables with value 0 may not appear in varValMap - Just result -> M.findWithDefault 0 1 result.varValMap `shouldBe` 0 + Just varMap -> M.findWithDefault 0 1 varMap `shouldBe` 0 it "Max x₁ with -5 ≤ x₁ ≤ 10 (bounded range with negative lower): optimal at x₁=10" $ do let obj = Max (M.fromList [(1, 1)]) @@ -784,10 +862,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 it "Min x₁ with -5 ≤ x₁ ≤ 10 (bounded range with negative lower): optimal at x₁=-5" $ do let obj = Min (M.fromList [(1, 1)]) @@ -796,10 +874,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-5) + Just varMap -> M.lookup 1 varMap `shouldBe` Just (-5) it "Infeasible: lower bound > upper bound" $ do let obj = Max (M.fromList [(1, 1)]) @@ -808,8 +886,8 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - actualResult `shouldBe` Nothing + twoPhaseSimplex domainMap [obj] constraints + isInfeasible actualResult `shouldBe` True describe "Two variable systems with upper bounds" $ do it "Max x₁ + x₂ with 0 ≤ x₁ ≤ 3, 0 ≤ x₂ ≤ 4: optimal at x₁=3, x₂=4" $ do @@ -819,13 +897,13 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - M.lookup 1 result.varValMap `shouldBe` Just 3 - M.lookup 2 result.varValMap `shouldBe` Just 4 - M.lookup result.objectiveVar result.varValMap `shouldBe` Just 7 + Just varMap -> do + M.lookup 1 varMap `shouldBe` Just 3 + M.lookup 2 varMap `shouldBe` Just 4 + computeObjValue obj varMap `shouldBe` 7 it "Max 2x₁ - x₂ with -2 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 4" $ do -- Maximize 2x₁ - x₂: want x₁ = 5 (max), x₂ = -3 (min) @@ -836,13 +914,13 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - M.lookup 1 result.varValMap `shouldBe` Just 5 - M.lookup 2 result.varValMap `shouldBe` Just (-3) - M.lookup result.objectiveVar result.varValMap `shouldBe` Just 13 + Just varMap -> do + M.lookup 1 varMap `shouldBe` Just 5 + M.lookup 2 varMap `shouldBe` Just (-3) + computeObjValue obj varMap `shouldBe` 13 it "Mixed bounds: x₁ nonNegative, x₂ with upper bound only (unbounded below)" $ do -- x₁ ≥ 0, x₂ ≤ 10 (no lower bound) @@ -853,12 +931,12 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let x1 = M.findWithDefault 0 1 result.varValMap - x2 = M.findWithDefault 0 2 result.varValMap + Just varMap -> do + let x1 = M.findWithDefault 0 1 varMap + x2 = M.findWithDefault 0 2 varMap x1 `shouldSatisfy` (>= 0) x2 `shouldSatisfy` (<= 10) (x1 + x2) `shouldBe` 20 @@ -874,10 +952,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 5 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 5 it "Min x₁ with x₁ ≤ 5, x₁ ≥ -3: optimal at lower bound x₁=-3" $ do -- Minimize x with upper bound 5 and lower bound -3 @@ -888,10 +966,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-3) + Just varMap -> M.lookup 1 varMap `shouldBe` Just (-3) it "Max x₁ with x₁ ≥ -10, x₁ ≤ -2: optimal at x₁=-2" $ do -- Both bounds are negative, maximize @@ -901,10 +979,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-2) + Just varMap -> M.lookup 1 varMap `shouldBe` Just (-2) it "Min x₁ with x₁ ≥ -10, x₁ ≤ -2: optimal at x₁=-10" $ do -- Both bounds are negative, minimize @@ -914,10 +992,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-10) + Just varMap -> M.lookup 1 varMap `shouldBe` Just (-10) describe "Two variable systems with negative bounds" $ do it "Max x₁ + x₂ with x₁ ≥ -2, x₂ ≥ -3, x₁ + x₂ ≤ 10" $ do @@ -932,13 +1010,13 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let x1 = M.findWithDefault 0 1 result.varValMap - x2 = M.findWithDefault 0 2 result.varValMap - objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + Just varMap -> do + let x1 = M.findWithDefault 0 1 varMap + x2 = M.findWithDefault 0 2 varMap + objVal = computeObjValue obj varMap -- Verify the actual objective value objVal `shouldBe` 10 -- Verify lower bounds are respected @@ -954,15 +1032,15 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + Just varMap -> do + let objVal = computeObjValue obj varMap -- Verify the actual objective value objVal `shouldBe` (-5) - M.lookup 1 result.varValMap `shouldBe` Just (-2) - M.lookup 2 result.varValMap `shouldBe` Just (-3) + M.lookup 1 varMap `shouldBe` Just (-2) + M.lookup 2 varMap `shouldBe` Just (-3) it "Max 2x₁ - x₂ with x₁ ≥ -5, x₂ ≥ -4, x₁ ≤ 3, x₂ ≤ 6" $ do -- Maximize 2x₁ - x₂: want x₁ large (up to 3) and x₂ small (down to -4) @@ -976,14 +1054,14 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let x1 = M.findWithDefault 0 1 result.varValMap - x2 = M.findWithDefault 0 2 result.varValMap - M.lookup 1 result.varValMap `shouldBe` Just 3 - M.lookup 2 result.varValMap `shouldBe` Just (-4) + Just varMap -> do + let x1 = M.findWithDefault 0 1 varMap + x2 = M.findWithDefault 0 2 varMap + M.lookup 1 varMap `shouldBe` Just 3 + M.lookup 2 varMap `shouldBe` Just (-4) -- Verify objective value computed from variables (2 * x1 - x2) `shouldBe` 10 @@ -999,14 +1077,14 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let x1 = M.findWithDefault 0 1 result.varValMap - x2 = M.findWithDefault 0 2 result.varValMap - M.lookup 1 result.varValMap `shouldBe` Just (-5) - M.lookup 2 result.varValMap `shouldBe` Just 6 + Just varMap -> do + let x1 = M.findWithDefault 0 1 varMap + x2 = M.findWithDefault 0 2 varMap + M.lookup 1 varMap `shouldBe` Just (-5) + M.lookup 2 varMap `shouldBe` Just 6 -- Verify objective value computed from variables (2 * x1 - x2) `shouldBe` (-16) @@ -1024,10 +1102,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 it "Min x₁ with x₁ ≥ -5, x₁ ≥ 2 (GEQ tightens bound)" $ do -- Minimize with GEQ 2, so minimum is at x₁ = 2 @@ -1040,10 +1118,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 2 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 2 describe "Systems with EQ constraints and negative bounds" $ do it "Max x₁ + x₂ with x₁ - x₂ = 0, x₁ ≥ -5, x₂ ≥ -5, x₁ ≤ 10" $ do @@ -1058,13 +1136,13 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap - M.lookup 1 result.varValMap `shouldBe` Just 10 - M.lookup 2 result.varValMap `shouldBe` Just 10 + Just varMap -> do + let objVal = computeObjValue obj varMap + M.lookup 1 varMap `shouldBe` Just 10 + M.lookup 2 varMap `shouldBe` Just 10 -- Verify objective value objVal `shouldBe` 20 @@ -1080,13 +1158,13 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap - M.lookup 1 result.varValMap `shouldBe` Just (-5) - M.lookup 2 result.varValMap `shouldBe` Just (-5) + Just varMap -> do + let objVal = computeObjValue obj varMap + M.lookup 1 varMap `shouldBe` Just (-5) + M.lookup 2 varMap `shouldBe` Just (-5) -- Verify objective value objVal `shouldBe` (-10) @@ -1098,10 +1176,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just (5 % 2) + Just varMap -> M.lookup 1 varMap `shouldBe` Just (5 % 2) it "Min x₁ with x₁ ≥ -7/2, x₁ ≤ 5/2" $ do let obj = Min (M.fromList [(1, 1)]) @@ -1110,10 +1188,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just ((-7) % 2) + Just varMap -> M.lookup 1 varMap `shouldBe` Just ((-7) % 2) describe "twoPhaseSimplex with unbounded variables (Split transformation)" $ do describe "Simple single variable systems" $ do @@ -1128,10 +1206,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 10 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 it "Min x₁ with -10 ≤ x₁ ≤ 10 (unbounded var with box constraints)" $ do let obj = Min (M.fromList [(1, 1)]) @@ -1143,23 +1221,23 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just (-10) + Just varMap -> M.lookup 1 varMap `shouldBe` Just (-10) it "unbounded variable with only upper bound: Min finds negative value" $ do -- x₁ unbounded, only x₁ ≤ 5, minimize x₁ - -- This should be unbounded (no solution) since x₁ can go to -∞ + -- This should be unbounded (no finite solution) since x₁ can go to -∞ let obj = Min (M.fromList [(1, 1)]) constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] domainMap = VarDomainMap $ M.fromList [(1, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - -- This should be unbounded (infeasible for optimization) - actualResult `shouldBe` Nothing + twoPhaseSimplex domainMap [obj] constraints + -- This should be unbounded (no finite optimum exists) + isUnbounded actualResult `shouldBe` True describe "Two variable systems with unbounded variables" $ do it "Max x₁ + x₂ with unbounded vars, -5 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 7" $ do @@ -1174,13 +1252,13 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - M.lookup 1 result.varValMap `shouldBe` Just 5 - M.lookup 2 result.varValMap `shouldBe` Just 7 - let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + Just varMap -> do + M.lookup 1 varMap `shouldBe` Just 5 + M.lookup 2 varMap `shouldBe` Just 7 + let objVal = computeObjValue obj varMap objVal `shouldBe` 12 it "Min x₁ + x₂ with unbounded vars, -5 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 7" $ do @@ -1195,13 +1273,13 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - M.lookup 1 result.varValMap `shouldBe` Just (-5) - M.lookup 2 result.varValMap `shouldBe` Just (-3) - let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + Just varMap -> do + M.lookup 1 varMap `shouldBe` Just (-5) + M.lookup 2 varMap `shouldBe` Just (-3) + let objVal = computeObjValue obj varMap objVal `shouldBe` (-8) it "Max x₁ - x₂ with unbounded vars: x₁ up, x₂ down" $ do @@ -1217,13 +1295,13 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - M.lookup 1 result.varValMap `shouldBe` Just 5 - M.lookup 2 result.varValMap `shouldBe` Just (-3) - let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + Just varMap -> do + M.lookup 1 varMap `shouldBe` Just 5 + M.lookup 2 varMap `shouldBe` Just (-3) + let objVal = computeObjValue obj varMap objVal `shouldBe` 8 describe "Systems with EQ constraints and unbounded variables" $ do @@ -1239,12 +1317,12 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - M.lookup 1 result.varValMap `shouldBe` Just 15 - M.lookup 2 result.varValMap `shouldBe` Just (-5) + Just varMap -> do + M.lookup 1 varMap `shouldBe` Just 15 + M.lookup 2 varMap `shouldBe` Just (-5) it "Min x₁ with x₁ + x₂ = 10, unbounded vars, x₂ ≤ 20" $ do -- x₁ + x₂ = 10, x₂ ≤ 20, unbounded x₁ @@ -1258,12 +1336,12 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - M.lookup 1 result.varValMap `shouldBe` Just (-10) - M.lookup 2 result.varValMap `shouldBe` Just 20 + Just varMap -> do + M.lookup 1 varMap `shouldBe` Just (-10) + M.lookup 2 varMap `shouldBe` Just 20 describe "twoPhaseSimplex with mixed domain types" $ do describe "NonNegative, negative lower bound, and unbounded in same system" $ do @@ -1283,11 +1361,11 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + Just varMap -> do + let objVal = computeObjValue obj varMap -- Verify objective value objVal `shouldBe` 20 @@ -1306,14 +1384,14 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let x1 = M.findWithDefault 0 1 result.varValMap - x2 = M.findWithDefault 0 2 result.varValMap - x3 = M.findWithDefault 0 3 result.varValMap - objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + Just varMap -> do + let x1 = M.findWithDefault 0 1 varMap + x2 = M.findWithDefault 0 2 varMap + x3 = M.findWithDefault 0 3 varMap + objVal = computeObjValue obj varMap -- Verify constraints x1 `shouldSatisfy` (>= 0) x2 `shouldSatisfy` (>= (-5)) @@ -1334,12 +1412,12 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let x1 = M.findWithDefault 0 1 result.varValMap - x2 = M.findWithDefault 0 2 result.varValMap + Just varMap -> do + let x1 = M.findWithDefault 0 1 varMap + x2 = M.findWithDefault 0 2 varMap -- Verify constraints x1 `shouldSatisfy` (>= 2) x2 `shouldSatisfy` (>= (-3)) @@ -1358,12 +1436,12 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let x1 = M.findWithDefault 0 1 result.varValMap - x2 = M.findWithDefault 0 2 result.varValMap + Just varMap -> do + let x1 = M.findWithDefault 0 1 varMap + x2 = M.findWithDefault 0 2 varMap x1 `shouldSatisfy` (>= 2) x2 `shouldSatisfy` (>= (-3)) (x1 + x2) `shouldSatisfy` (>= 0) @@ -1380,8 +1458,8 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - actualResult `shouldBe` Nothing + twoPhaseSimplex domainMap [obj] constraints + isInfeasible actualResult `shouldBe` True it "Infeasible: unbounded variable with conflicting constraints" $ do let obj = Max (M.fromList [(1, 1)]) @@ -1393,8 +1471,8 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - actualResult `shouldBe` Nothing + twoPhaseSimplex domainMap [obj] constraints + isInfeasible actualResult `shouldBe` True it "Variable at exactly zero with negative lower bound" $ do -- x₁ ≥ -5, constraint x₁ = 0 @@ -1404,10 +1482,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 0 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 0 it "unbounded variable constrained to zero" $ do let obj = Max (M.fromList [(1, 1)]) @@ -1416,10 +1494,10 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> M.lookup 1 result.varValMap `shouldBe` Just 0 + Just varMap -> M.lookup 1 varMap `shouldBe` Just 0 it "Multiple variables, only some with negative bounds" $ do -- x₁ ≥ 0 (non-negative), x₂ ≥ -10, x₃ ≥ 0 @@ -1431,11 +1509,11 @@ spec = do actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap obj constraints - case actualResult of + twoPhaseSimplex domainMap [obj] constraints + case simplexResultToVarMap actualResult of Nothing -> expectationFailure "Expected a solution but got Nothing" - Just result -> do - let objVal = M.findWithDefault 0 result.objectiveVar result.varValMap + Just varMap -> do + let objVal = computeObjValue obj varMap -- Verify objective value objVal `shouldBe` 15 @@ -1448,27 +1526,27 @@ spec = do it "collects variables from Max objective" $ do let obj = Max (M.fromList [(1, 3), (2, 5)]) constraints = [] - collectAllVars obj constraints `shouldBe` Set.fromList [1, 2] + collectAllVars [obj] constraints `shouldBe` Set.fromList [1, 2] it "collects variables from Min objective" $ do let obj = Min (M.fromList [(3, 1), (4, -2)]) constraints = [] - collectAllVars obj constraints `shouldBe` Set.fromList [3, 4] + collectAllVars [obj] constraints `shouldBe` Set.fromList [3, 4] it "collects variables from LEQ constraint" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [LEQ (M.fromList [(2, 1), (3, 2)]) 10] - collectAllVars obj constraints `shouldBe` Set.fromList [1, 2, 3] + collectAllVars [obj] constraints `shouldBe` Set.fromList [1, 2, 3] it "collects variables from GEQ constraint" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [GEQ (M.fromList [(4, 1)]) 5] - collectAllVars obj constraints `shouldBe` Set.fromList [1, 4] + collectAllVars [obj] constraints `shouldBe` Set.fromList [1, 4] it "collects variables from EQ constraint" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [EQ (M.fromList [(5, 2), (6, 3)]) 15] - collectAllVars obj constraints `shouldBe` Set.fromList [1, 5, 6] + collectAllVars [obj] constraints `shouldBe` Set.fromList [1, 5, 6] it "collects variables from mixed constraints" $ do let obj = Max (M.fromList [(1, 1)]) @@ -1477,17 +1555,17 @@ spec = do , GEQ (M.fromList [(3, 1)]) 5 , EQ (M.fromList [(4, 1)]) 7 ] - collectAllVars obj constraints `shouldBe` Set.fromList [1, 2, 3, 4] + collectAllVars [obj] constraints `shouldBe` Set.fromList [1, 2, 3, 4] it "handles empty objective coefficients" $ do let obj = Max M.empty constraints = [LEQ (M.fromList [(1, 1)]) 10] - collectAllVars obj constraints `shouldBe` Set.fromList [1] + collectAllVars [obj] constraints `shouldBe` Set.fromList [1] it "handles empty constraints" $ do let obj = Max (M.fromList [(1, 1), (2, 2)]) constraints = [] - collectAllVars obj constraints `shouldBe` Set.fromList [1, 2] + collectAllVars [obj] constraints `shouldBe` Set.fromList [1, 2] it "deduplicates variables appearing in multiple places" $ do let obj = Max (M.fromList [(1, 1), (2, 2)]) @@ -1495,7 +1573,7 @@ spec = do [ LEQ (M.fromList [(1, 3), (3, 4)]) 10 , GEQ (M.fromList [(2, 5), (3, 6)]) 5 ] - collectAllVars obj constraints `shouldBe` Set.fromList [1, 2, 3] + collectAllVars [obj] constraints `shouldBe` Set.fromList [1, 2, 3] describe "getTransform" $ do describe "Unit tests" $ do @@ -1687,47 +1765,47 @@ spec = do -- Two GEQ constraints should be added length newConstraints `shouldBe` 3 - describe "unapplyTransform and unapplyTransforms" $ do + describe "unapplyTransformToVarMap and unapplyTransformsToVarMap" $ do describe "Unit tests" $ do - it "unapplyTransform AddLowerBound leaves result unchanged" $ do - let result = Result 5 (M.fromList [(5, 10), (1, 7)]) + it "unapplyTransformToVarMap AddLowerBound leaves result unchanged" $ do + let varVals = M.fromList [(1, 7)] transform = AddLowerBound 1 5 - unapplyTransform transform result `shouldBe` result + unapplyTransformToVarMap transform varVals `shouldBe` varVals - it "unapplyTransform Shift recovers original variable value" $ do + it "unapplyTransformToVarMap Shift recovers original variable value" $ do -- originalVar = shiftedVar + shiftBy -- If shiftedVar = 15 and shiftBy = -5, then originalVar = 10 - let result = Result 5 (M.fromList [(5, 100), (10, 15)]) + let varVals = M.fromList [(10, 15)] transform = Shift 1 10 (-5) - let newResult = unapplyTransform transform result - M.lookup 1 (varValMap newResult) `shouldBe` Just 10 - M.lookup 10 (varValMap newResult) `shouldBe` Nothing + let newVarVals = unapplyTransformToVarMap transform varVals + M.lookup 1 newVarVals `shouldBe` Just 10 + M.lookup 10 newVarVals `shouldBe` Nothing - it "unapplyTransform Split recovers original variable value" $ do + it "unapplyTransformToVarMap Split recovers original variable value" $ do -- originalVar = posVar - negVar -- If posVar = 8 and negVar = 3, then originalVar = 5 - let result = Result 5 (M.fromList [(5, 100), (10, 8), (11, 3)]) + let varVals = M.fromList [(10, 8), (11, 3)] transform = Split 1 10 11 - let newResult = unapplyTransform transform result - M.lookup 1 (varValMap newResult) `shouldBe` Just 5 - M.lookup 10 (varValMap newResult) `shouldBe` Nothing - M.lookup 11 (varValMap newResult) `shouldBe` Nothing + let newVarVals = unapplyTransformToVarMap transform varVals + M.lookup 1 newVarVals `shouldBe` Just 5 + M.lookup 10 newVarVals `shouldBe` Nothing + M.lookup 11 newVarVals `shouldBe` Nothing - it "unapplyTransform Split handles negative original value" $ do + it "unapplyTransformToVarMap Split handles negative original value" $ do -- originalVar = posVar - negVar -- If posVar = 2 and negVar = 7, then originalVar = -5 - let result = Result 5 (M.fromList [(5, 100), (10, 2), (11, 7)]) + let varVals = M.fromList [(10, 2), (11, 7)] transform = Split 1 10 11 - let newResult = unapplyTransform transform result - M.lookup 1 (varValMap newResult) `shouldBe` Just (-5) + let newVarVals = unapplyTransformToVarMap transform varVals + M.lookup 1 newVarVals `shouldBe` Just (-5) - it "unapplyTransforms applies in correct order (reverse of apply)" $ do + it "unapplyTransformsToVarMap applies in correct order (reverse of apply)" $ do -- Two shifts: var 1 shifted by -5 to var 10, var 2 shifted by -3 to var 11 - let result = Result 5 (M.fromList [(5, 100), (10, 15), (11, 8)]) + let varVals = M.fromList [(10, 15), (11, 8)] transforms = [Shift 1 10 (-5), Shift 2 11 (-3)] - let newResult = unapplyTransforms transforms result - M.lookup 1 (varValMap newResult) `shouldBe` Just 10 - M.lookup 2 (varValMap newResult) `shouldBe` Just 5 + let newVarVals = unapplyTransformsToVarMap transforms varVals + M.lookup 1 newVarVals `shouldBe` Just 10 + M.lookup 2 newVarVals `shouldBe` Just 5 describe "preprocess" $ do describe "Unit tests" $ do @@ -1735,7 +1813,7 @@ spec = do let obj = Max (M.fromList [(1, 1), (2, 1)]) constraints = [LEQ (M.fromList [(1, 1), (2, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, nonNegative), (2, nonNegative)] - let (newObj, newConstraints, transforms) = preprocess obj domainMap constraints + let ([newObj], newConstraints, transforms) = preprocess [obj] domainMap constraints transforms `shouldBe` [] newObj `shouldBe` obj newConstraints `shouldBe` constraints @@ -1744,7 +1822,7 @@ spec = do let obj = Max (M.fromList [(1, 1)]) constraints = [LEQ (M.fromList [(1, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 5)] - let (_, newConstraints, transforms) = preprocess obj domainMap constraints + let (_, newConstraints, transforms) = preprocess [obj] domainMap constraints transforms `shouldBe` [AddLowerBound 1 5] length newConstraints `shouldBe` 2 -- original + GEQ @@ -1752,7 +1830,7 @@ spec = do let obj = Max (M.fromList [(1, 1)]) constraints = [LEQ (M.fromList [(1, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] - let (newObj, newConstraints, transforms) = preprocess obj domainMap constraints + let ([newObj], newConstraints, transforms) = preprocess [obj] domainMap constraints length transforms `shouldBe` 1 case head transforms of Shift {..} -> do @@ -1764,7 +1842,7 @@ spec = do let obj = Max (M.fromList [(1, 1)]) constraints = [LEQ (M.fromList [(1, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, unbounded)] - let (_, _, transforms) = preprocess obj domainMap constraints + let (_, _, transforms) = preprocess [obj] domainMap constraints length transforms `shouldBe` 1 case head transforms of Split {..} -> originalVar `shouldBe` 1 @@ -1775,7 +1853,7 @@ spec = do constraints = [LEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, nonNegative), (2, lowerBoundOnly 5), (3, lowerBoundOnly (-3))] - let (_, _, transforms) = preprocess obj domainMap constraints + let (_, _, transforms) = preprocess [obj] domainMap constraints -- Should have AddLowerBound for var 2, Shift for var 3 length transforms `shouldBe` 2 @@ -1788,13 +1866,13 @@ spec = do it "result is non-empty when objective is non-empty" $ property $ \(NonEmpty coeffs :: NonEmptyList (Int, Rational)) -> let obj = Max (M.fromList [(abs k `mod` 100 + 1, v) | (k, v) <- coeffs]) - in not (Set.null (collectAllVars obj [])) + in not (Set.null (collectAllVars [obj] [])) it "result contains all objective variables" $ property $ \(vars :: [Int]) -> let posVars = filter (> 0) (map abs vars) obj = Max (M.fromList [(v, 1) | v <- take 5 posVars]) - in all (`Set.member` collectAllVars obj []) (M.keys $ case obj of Max m -> m; Min m -> m) + in all (`Set.member` collectAllVars [obj] []) (M.keys $ case obj of Max m -> m; Min m -> m) describe "getTransform properties" $ do it "NonNegative always produces empty list" $ property $ @@ -1872,58 +1950,172 @@ spec = do negCoeff = M.findWithDefault 0 11 m in negCoeff == negate posCoeff - describe "unapplyTransform Shift properties" $ do + describe "unapplyTransformToVarMap Shift properties" $ do it "recovers originalVar = shiftedVar + shiftBy" $ property $ \(shiftedVal :: Rational) (shiftBy :: Rational) -> - let result = Result 5 (M.fromList [(5, 100), (10, shiftedVal)]) + let varMap = M.fromList [(5, 100), (10, shiftedVal)] transform = Shift 1 10 shiftBy - newResult = unapplyTransform transform result - in M.lookup 1 (varValMap newResult) == Just (shiftedVal + shiftBy) + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 1 newVarMap == Just (shiftedVal + shiftBy) it "removes shifted variable from result" $ property $ \(shiftedVal :: Rational) (shiftBy :: Rational) -> - let result = Result 5 (M.fromList [(5, 100), (10, shiftedVal)]) + let varMap = M.fromList [(5, 100), (10, shiftedVal)] transform = Shift 1 10 shiftBy - newResult = unapplyTransform transform result - in M.lookup 10 (varValMap newResult) == Nothing + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 10 newVarMap == Nothing - describe "unapplyTransform Split properties" $ do + describe "unapplyTransformToVarMap Split properties" $ do it "recovers originalVar = posVar - negVar" $ property $ \(posVal :: Rational) (negVal :: Rational) -> - let result = Result 5 (M.fromList [(5, 100), (10, posVal), (11, negVal)]) + let varMap = M.fromList [(5, 100), (10, posVal), (11, negVal)] transform = Split 1 10 11 - newResult = unapplyTransform transform result - in M.lookup 1 (varValMap newResult) == Just (posVal - negVal) + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 1 newVarMap == Just (posVal - negVal) + it "removes pos and neg variables from result" $ property $ \(posVal :: Rational) (negVal :: Rational) -> - let result = Result 5 (M.fromList [(5, 100), (10, posVal), (11, negVal)]) + let varMap = M.fromList [(5, 100), (10, posVal), (11, negVal)] transform = Split 1 10 11 - newResult = unapplyTransform transform result - in M.lookup 10 (varValMap newResult) == Nothing && - M.lookup 11 (varValMap newResult) == Nothing + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 10 newVarMap == Nothing && + M.lookup 11 newVarMap == Nothing describe "Round-trip properties" $ do it "Shift transform and unapply is identity for variable value" $ property $ \(origVal :: Rational) (shiftBy :: Rational) -> shiftBy < 0 ==> -- Only negative shifts are valid let shiftedVal = origVal - shiftBy -- shiftedVar = originalVar - shiftBy - result = Result 5 (M.fromList [(5, 100), (10, shiftedVal)]) + varMap = M.fromList [(5, 100), (10, shiftedVal)] transform = Shift 1 10 shiftBy - newResult = unapplyTransform transform result - in M.lookup 1 (varValMap newResult) == Just origVal + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 1 newVarMap == Just origVal it "Split with posVal=origVal and negVal=0 gives correct value for positive origVal" $ property $ \(Positive origVal :: Positive Rational) -> - let result = Result 5 (M.fromList [(5, 100), (10, origVal), (11, 0)]) + let varMap = M.fromList [(5, 100), (10, origVal), (11, 0)] transform = Split 1 10 11 - newResult = unapplyTransform transform result - in M.lookup 1 (varValMap newResult) == Just origVal + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 1 newVarMap == Just origVal it "Split with posVal=0 and negVal=-origVal gives correct value for negative origVal" $ property $ \(Positive origVal :: Positive Rational) -> let negOrigVal = negate origVal - result = Result 5 (M.fromList [(5, 100), (10, 0), (11, origVal)]) + varMap = M.fromList [(5, 100), (10, 0), (11, origVal)] transform = Split 1 10 11 - newResult = unapplyTransform transform result - in M.lookup 1 (varValMap newResult) == Just negOrigVal + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 1 newVarMap == Just negOrigVal + + describe "twoPhaseSimplex with multiple objectives" $ do + it "optimizes two objectives over the same feasible region" $ do + -- Feasible region: x₁ + x₂ ≤ 10, x₁ ≤ 6, x₂ ≤ 8, x₁,x₂ ≥ 0 + -- Max x₁: optimal at x₁=6, x₂=0 (or x₁=6, x₂=4) with obj=6 + -- Max x₂: optimal at x₁=0, x₂=8 (or x₁=2, x₂=8) with obj=8 + let obj1 = Max (M.fromList [(1, 1)]) -- Max x₁ + obj2 = Max (M.fromList [(2, 1)]) -- Max x₂ + constraints = + [ LEQ (M.fromList [(1, 1), (2, 1)]) 10 + , LEQ (M.fromList [(1, 1)]) 6 + , LEQ (M.fromList [(2, 1)]) 8 + ] + allVars = collectAllVars [obj1, obj2] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + SimplexResult mFeasibleSystem objResults <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj1, obj2] constraints + -- Should have a feasible system + mFeasibleSystem `shouldSatisfy` isJust + -- Should have two results + length objResults `shouldBe` 2 + -- First result (Max x₁) should have x₁=6 + case objResults !! 0 of + ObjectiveResult _ (Optimal varVals) -> + M.lookup 1 varVals `shouldBe` Just 6 + _ -> expectationFailure "Expected optimal result for obj1" + -- Second result (Max x₂) should have x₂=8 + case objResults !! 1 of + ObjectiveResult _ (Optimal varVals) -> + M.lookup 2 varVals `shouldBe` Just 8 + _ -> expectationFailure "Expected optimal result for obj2" + + it "handles empty objective list returning feasible system only" $ do + let constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] + domainMap = VarDomainMap $ M.fromSet (const nonNegative) (Set.singleton 1) + SimplexResult mFeasibleSystem objResults <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [] constraints + mFeasibleSystem `shouldSatisfy` isJust + length objResults `shouldBe` 0 + + it "handles infeasible system with multiple objectives" $ do + -- x₁ ≤ 5 and x₁ ≥ 10 is infeasible + let obj1 = Max (M.fromList [(1, 1)]) + obj2 = Min (M.fromList [(1, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 5 + , GEQ (M.fromList [(1, 1)]) 10 + ] + allVars = collectAllVars [obj1, obj2] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + SimplexResult mFeasibleSystem objResults <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj1, obj2] constraints + -- Should be infeasible + mFeasibleSystem `shouldBe` Nothing + -- No objective results when infeasible + length objResults `shouldBe` 0 + + it "optimizes Max and Min of same function over feasible region" $ do + -- Feasible region: 0 ≤ x₁ ≤ 10 + -- Max x₁: optimal at x₁=10 + -- Min x₁: optimal at x₁=0 + let obj1 = Max (M.fromList [(1, 1)]) + obj2 = Min (M.fromList [(1, 1)]) + constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] + domainMap = VarDomainMap $ M.fromList [(1, nonNegative)] + SimplexResult mFeasibleSystem objResults <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj1, obj2] constraints + mFeasibleSystem `shouldSatisfy` isJust + length objResults `shouldBe` 2 + -- Max x₁ should be 10 + case objResults !! 0 of + ObjectiveResult _ (Optimal varVals) -> + M.lookup 1 varVals `shouldBe` Just 10 + _ -> expectationFailure "Expected optimal result for Max x₁" + -- Min x₁ should be 0 (or not present in map if zero) + case objResults !! 1 of + ObjectiveResult _ (Optimal varVals) -> + M.findWithDefault 0 1 varVals `shouldBe` 0 + _ -> expectationFailure "Expected optimal result for Min x₁" + + it "handles one unbounded objective among multiple objectives" $ do + -- x₁ with only a lower bound (non-negative) + -- Max x₁: unbounded (no upper constraint) + -- Min x₁ with x₁ ≥ 0: optimal at x₁=0 + let obj1 = Max (M.fromList [(1, 1)]) -- This will be unbounded + obj2 = Min (M.fromList [(1, 1)]) -- This will have optimal at 0 + -- Add a dummy constraint to ensure the system is processable + -- x₁ ≥ 0 (enforced by nonNegative domain) but no upper bound + constraints = [ GEQ (M.fromList [(1, 1)]) 0 ] -- x₁ ≥ 0 + domainMap = VarDomainMap $ M.fromList [(1, nonNegative)] + SimplexResult mFeasibleSystem objResults <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj1, obj2] constraints + mFeasibleSystem `shouldSatisfy` isJust + length objResults `shouldBe` 2 + -- Max x₁ should be unbounded + case objResults !! 0 of + ObjectiveResult _ Unbounded -> pure () + _ -> expectationFailure "Expected unbounded result for Max x₁" + -- Min x₁ should be 0 + case objResults !! 1 of + ObjectiveResult _ (Optimal varVals) -> + M.findWithDefault 0 1 varVals `shouldBe` 0 + _ -> expectationFailure "Expected optimal result for Min x₁" From 81d243a274f6255f0aa40e63c2b8030c3b6a657a Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 14 Feb 2026 15:45:08 +0000 Subject: [PATCH 08/17] test: remove legacy types --- test/Linear/Simplex/Solver/TwoPhaseSpec.hs | 537 +++++++++++---------- 1 file changed, 276 insertions(+), 261 deletions(-) diff --git a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs index c64de49..acb4124 100644 --- a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs +++ b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs @@ -1,6 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} module Linear.Simplex.Solver.TwoPhaseSpec where import Prelude hiding (EQ) @@ -23,45 +22,6 @@ import Linear.Simplex.Solver.TwoPhase import Linear.Simplex.Types import Linear.Simplex.Util --- | Legacy Result type for backward compatibility with existing tests. --- The old Result stored (objectiveVar, varValMap) where varValMap included --- the objective value keyed by objectiveVar. We convert this to the new format. -data LegacyResult = LegacyResult Var VarLitMap - deriving (Show, Eq) - --- | Pattern synonym for backward compatibility - allows using `Result` as a constructor -pattern Result :: Var -> VarLitMap -> LegacyResult -pattern Result v m = LegacyResult v m - --- | Convert a legacy expected result to the new ExpectedResult format. --- Removes the objective variable entry from the varValMap since we now --- compute objective values from the variable assignments. --- Note: The old API returned Nothing for both infeasible and unbounded cases. --- We map Nothing to ExpectNoFiniteOptimum to match either case. -legacyToExpected :: Maybe LegacyResult -> ExpectedResult -legacyToExpected Nothing = ExpectNoFiniteOptimum -- Could be infeasible or unbounded -legacyToExpected (Just (LegacyResult objVar varValMap)) = - ExpectOptimal (M.delete objVar varValMap) - --- | Convert a SimplexResult (single objective) to Maybe VarLitMap. --- This is used by tests that directly call twoPhaseSimplex and need --- to pattern match on the result. -simplexResultToVarMap :: SimplexResult -> Maybe VarLitMap -simplexResultToVarMap (SimplexResult Nothing _) = Nothing -simplexResultToVarMap (SimplexResult (Just _) []) = Nothing -simplexResultToVarMap (SimplexResult (Just _) (ObjectiveResult _ Unbounded : _)) = Nothing -simplexResultToVarMap (SimplexResult (Just _) (ObjectiveResult _ (Optimal varVals) : _)) = Just varVals - --- | Check if a SimplexResult represents an infeasible system. -isInfeasible :: SimplexResult -> Bool -isInfeasible (SimplexResult Nothing _) = True -isInfeasible _ = False - --- | Check if a SimplexResult represents an unbounded system (feasible but no finite optimum). -isUnbounded :: SimplexResult -> Bool -isUnbounded (SimplexResult (Just _) (ObjectiveResult _ Unbounded : _)) = True -isUnbounded _ = False - -- | Compute the objective value from variable assignments. -- For Max: sum of (coeff * varValue) for each variable -- For Min: same calculation (the value represents the optimal objective value) @@ -71,28 +31,19 @@ computeObjValue (Min coeffs) varMap = sum [c * M.findWithDefault 0 v varMap | (v -- | Expected result for a single objective optimization data ExpectedResult - = ExpectInfeasible -- ^ System has no feasible solution - | ExpectUnbounded -- ^ System is feasible but unbounded (no finite optimum) - | ExpectNoFiniteOptimum -- ^ Either infeasible or unbounded (old API didn't distinguish) - | ExpectOptimal VarLitMap -- ^ Optimal solution found with given variable values + = ExpectInfeasible + -- ^ System has no feasible solution + | ExpectUnbounded + -- ^ System is feasible but unbounded (no finite optimum) + | ExpectOptimal (Maybe SimplexNum) VarLitMap + -- ^ Optimal solution found with optional expected objective value and variable values deriving (Show, Eq) --- | Check if two expected results match, with special handling for ExpectNoFiniteOptimum --- which matches both ExpectInfeasible and ExpectUnbounded. -resultsMatch :: ExpectedResult -> ExpectedResult -> Bool -resultsMatch ExpectNoFiniteOptimum ExpectInfeasible = True -resultsMatch ExpectNoFiniteOptimum ExpectUnbounded = True -resultsMatch ExpectInfeasible ExpectNoFiniteOptimum = True -resultsMatch ExpectUnbounded ExpectNoFiniteOptimum = True -resultsMatch a b = a == b - -- | Helper to run a test case for a system where all vars -- are non-negative and verify we get the expected result. --- Uses the legacy Result format for backward compatibility. -runTest :: (ObjectiveFunction, [PolyConstraint]) -> Maybe LegacyResult -> IO () -runTest (obj, constraints) legacyExpected = do - let expectedResult = legacyToExpected legacyExpected - prettyObj = prettyShowObjectiveFunction obj +runTest :: (ObjectiveFunction, [PolyConstraint]) -> ExpectedResult -> IO () +runTest (obj, constraints) expectedResult = do + let prettyObj = prettyShowObjectiveFunction obj prettyConstraints = map prettyShowPolyConstraint constraints allVars = collectAllVars [obj] constraints domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars @@ -104,13 +55,14 @@ runTest (obj, constraints) legacyExpected = do (Nothing, _) -> ExpectInfeasible (Just _, []) -> ExpectInfeasible -- Should not happen with one objective (Just _, [ObjectiveResult _ Unbounded]) -> ExpectUnbounded - (Just _, [ObjectiveResult _ (Optimal varVals)]) -> ExpectOptimal varVals + (Just _, [ObjectiveResult _ (Optimal varVals)]) -> ExpectOptimal Nothing varVals (Just _, _) -> error "Unexpected: multiple results for single objective" actualObjVal = case actualResult of - ExpectOptimal varVals -> extractObjectiveValue obj (ObjectiveResult obj (Optimal varVals)) + ExpectOptimal _ varVals -> extractObjectiveValue obj (ObjectiveResult obj (Optimal varVals)) _ -> Nothing expectedObjVal = case expectedResult of - ExpectOptimal varVals -> extractObjectiveValue obj (ObjectiveResult obj (Optimal varVals)) + ExpectOptimal (Just ov) _ -> Just ov + ExpectOptimal Nothing varVals -> extractObjectiveValue obj (ObjectiveResult obj (Optimal varVals)) _ -> Nothing annotate [qc| @@ -127,7 +79,14 @@ Expected Objective Value : {expectedObjVal} Actual Objective Value : {actualObjVal} |] $ do - resultsMatch actualResult expectedResult `shouldBe` True + -- Compare variable maps (ignoring objective value field in ExpectOptimal) + let stripObjVal (ExpectOptimal _ vm) = ExpectOptimal Nothing vm + stripObjVal other = other + stripObjVal actualResult `shouldBe` stripObjVal expectedResult + -- When an expected objective value is provided, verify it matches + case expectedResult of + ExpectOptimal (Just _) _ -> actualObjVal `shouldBe` expectedObjVal + _ -> pure () spec :: Spec spec = do @@ -143,7 +102,7 @@ spec = do , LEQ (M.fromList [(1, -1), (2, 2)]) 6 ] ) - runTest testCase (Just (Result 7 (M.fromList [(7, 29), (1, 3), (2, 4)]))) + runTest testCase (ExpectOptimal (Just 29) (M.fromList [(1, 3), (2, 4)])) it "Min 3x₁ + 5x₂ with LEQ constraints: obj=0" $ do let testCase = @@ -154,9 +113,9 @@ spec = do , LEQ (M.fromList [(1, -1), (2, 2)]) 6 ] ) - runTest testCase (Just (Result 7 (M.fromList [(7, 0)]))) + runTest testCase (ExpectOptimal (Just 0) M.empty) - it "Max 3x₁ + 5x₂ with GEQ constraints: infeasible" $ do + it "Max 3x₁ + 5x₂ with GEQ constraints: unbounded" $ do let testCase = ( Max (M.fromList [(1, 3), (2, 5)]) , [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 @@ -165,7 +124,7 @@ spec = do , GEQ (M.fromList [(1, -1), (2, 2)]) 6 ] ) - runTest testCase Nothing + runTest testCase ExpectUnbounded it "Min 3x₁ + 5x₂ with GEQ constraints: obj=237/7, x₁=24/7, x₂=33/7" $ do let testCase = @@ -176,7 +135,7 @@ spec = do , GEQ (M.fromList [(1, -1), (2, 2)]) 6 ] ) - runTest testCase (Just (Result 11 (M.fromList [(11, 237 % 7), (1, 24 % 7), (2, 33 % 7)]))) + runTest testCase (ExpectOptimal (Just (237 % 7)) (M.fromList [(1, 24 % 7), (2, 33 % 7)])) -- From https://www.eng.uwaterloo.ca/~syde05/phase1.pdf (requires two phases) describe "From eng.uwaterloo.ca phase1.pdf (requires two phases)" $ do @@ -188,9 +147,9 @@ spec = do , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] ) - runTest testCase (Just (Result 9 (M.fromList [(9, 3 % 5), (2, 14 % 5), (3, 17 % 5)]))) + runTest testCase (ExpectOptimal (Just (3 % 5)) (M.fromList [(2, 14 % 5), (3, 17 % 5)])) - it "Min x₁ - x₂ + x₃ with LEQ constraints: infeasible" $ do + it "Min x₁ - x₂ + x₃ with LEQ constraints: unbounded" $ do let testCase = ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) , [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 @@ -198,7 +157,7 @@ spec = do , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] ) - runTest testCase Nothing + runTest testCase ExpectUnbounded it "Max x₁ - x₂ + x₃ with GEQ constraints: obj=1, x₁=3, x₂=2" $ do let testCase = @@ -208,7 +167,7 @@ spec = do , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] ) - runTest testCase (Just (Result 8 (M.fromList [(8, 1), (2, 2), (1, 3)]))) + runTest testCase (ExpectOptimal (Just 1) (M.fromList [(1, 3), (2, 2)])) it "Min x₁ - x₂ + x₃ with GEQ constraints: obj=-1/4, x₁=17/4, x₂=9/2" $ do let testCase = @@ -218,7 +177,7 @@ spec = do , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] ) - runTest testCase (Just (Result 8 (M.fromList [(8, (-1) % 4), (2, 9 % 2), (1, 17 % 4)]))) + runTest testCase (ExpectOptimal (Just ((-1) % 4)) (M.fromList [(1, 17 % 4), (2, 9 % 2)])) -- From page 49 of 'Linear and Integer Programming Made Easy' (requires two phases) describe "From 'Linear and Integer Programming Made Easy' (page 49, requires two phases)" $ do @@ -229,7 +188,7 @@ spec = do , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 ] ) - runTest testCase (Just (Result 7 (M.fromList [(7, 5), (3, 2), (4, 1)]))) + runTest testCase (ExpectOptimal (Just 5) (M.fromList [(3, 2), (4, 1)])) it "Max x₁ + x₂ + 2x₃ + x₄ with EQ constraints: obj=8, x₁=2, x₂=6" $ do let testCase = @@ -238,7 +197,7 @@ spec = do , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 ] ) - runTest testCase (Just (Result 7 (M.fromList [(7, 8), (1, 2), (2, 6)]))) + runTest testCase (ExpectOptimal (Just 8) (M.fromList [(1, 2), (2, 6)])) -- From page 52 of 'Linear and Integer Programming Made Easy' describe "From 'Linear and Integer Programming Made Easy' (page 52)" $ do @@ -249,7 +208,7 @@ spec = do , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 ] ) - runTest testCase (Just (Result 8 (M.fromList [(8, 20), (4, 16), (3, 6)]))) + runTest testCase (ExpectOptimal (Just 20) (M.fromList [(3, 6), (4, 16)])) it "Min -2x₃ + 2x₄ + x₅ with EQ constraints: obj=6, x₄=2, x₅=2" $ do let testCase = @@ -258,7 +217,7 @@ spec = do , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 ] ) - runTest testCase (Just (Result 8 (M.fromList [(8, 6), (4, 2), (5, 2)]))) + runTest testCase (ExpectOptimal (Just 6) (M.fromList [(4, 2), (5, 2)])) -- From page 59 of 'Linear and Integer Programming Made Easy' (requires two phases) describe "From 'Linear and Integer Programming Made Easy' (page 59, requires two phases)" $ do @@ -269,7 +228,7 @@ spec = do , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) - runTest testCase (Just (Result 6 (M.fromList [(6, 150), (2, 150)]))) + runTest testCase (ExpectOptimal (Just 150) (M.fromList [(2, 150)])) it "Min 2x₁ + x₂: obj=40/3, x₂=40/3" $ do let testCase = @@ -278,16 +237,16 @@ spec = do , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) - runTest testCase (Just (Result 6 (M.fromList [(6, 40 % 3), (2, 40 % 3)]))) + runTest testCase (ExpectOptimal (Just (40 % 3)) (M.fromList [(2, 40 % 3)])) - it "Max 2x₁ + x₂ with GEQ constraints: infeasible" $ do + it "Max 2x₁ + x₂ with GEQ constraints: unbounded" $ do let testCase = ( Max (M.fromList [(1, 2), (2, 1)]) , [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) - runTest testCase Nothing + runTest testCase ExpectUnbounded it "Min 2x₁ + x₂ with GEQ constraints: obj=75, x₁=75/2" $ do let testCase = @@ -296,7 +255,7 @@ spec = do , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) - runTest testCase (Just (Result 6 (M.fromList [(6, 75), (1, 75 % 2)]))) + runTest testCase (ExpectOptimal (Just 75) (M.fromList [(1, 75 % 2)])) -- From page 59 of 'Linear and Integer Programming Made Easy' describe "From 'Linear and Integer Programming Made Easy' (page 59)" $ do @@ -308,7 +267,7 @@ spec = do , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] ) - runTest testCase (Just (Result 7 (M.fromList [(7, (-120)), (1, 20)]))) + runTest testCase (ExpectOptimal (Just (-120)) (M.fromList [(1, 20)])) it "Max -6x₁ - 4x₂ + 2x₃: obj=10, x₃=5" $ do let testCase = @@ -318,9 +277,9 @@ spec = do , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] ) - runTest testCase (Just (Result 7 (M.fromList [(7, 10), (3, 5)]))) + runTest testCase (ExpectOptimal (Just 10) (M.fromList [(3, 5)])) - it "Min -6x₁ - 4x₂ + 2x₃ with GEQ constraints: infeasible" $ do + it "Min -6x₁ - 4x₂ + 2x₃ with GEQ constraints: unbounded" $ do let testCase = ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) , [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 @@ -328,9 +287,9 @@ spec = do , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] ) - runTest testCase Nothing + runTest testCase ExpectUnbounded - it "Max -6x₁ - 4x₂ + 2x₃ with GEQ constraints: infeasible" $ do + it "Max -6x₁ - 4x₂ + 2x₃ with GEQ constraints: unbounded" $ do let testCase = ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) , [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 @@ -338,7 +297,7 @@ spec = do , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] ) - runTest testCase Nothing + runTest testCase ExpectUnbounded -- From page 59 of 'Linear and Integer Programming Made Easy' describe "From 'Linear and Integer Programming Made Easy' (page 59)" $ do @@ -350,7 +309,7 @@ spec = do , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] ) - runTest testCase (Just (Result 7 (M.fromList [(7, 250), (2, 50)]))) + runTest testCase (ExpectOptimal (Just 250) (M.fromList [(2, 50)])) it "Min 3x₁ + 5x₂ + 2x₃: obj=0" $ do let testCase = @@ -360,9 +319,9 @@ spec = do , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] ) - runTest testCase (Just (Result 7 (M.fromList [(7, 0)]))) + runTest testCase (ExpectOptimal (Just 0) M.empty) - it "Max 3x₁ + 5x₂ + 2x₃ with GEQ constraints: infeasible" $ do + it "Max 3x₁ + 5x₂ + 2x₃ with GEQ constraints: unbounded" $ do let testCase = ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) , [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 @@ -370,7 +329,7 @@ spec = do , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] ) - runTest testCase Nothing + runTest testCase ExpectUnbounded it "Min 3x₁ + 5x₂ + 2x₃ with GEQ constraints: obj=300, x₃=150" $ do let testCase = @@ -380,7 +339,7 @@ spec = do , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] ) - runTest testCase (Just (Result 10 (M.fromList [(10, 300), (3, 150)]))) + runTest testCase (ExpectOptimal (Just 300) (M.fromList [(3, 150)])) describe "Simple single/two variable tests" $ do it "Max x₁ with x₁ <= 15: obj=15, x₁=15" $ do @@ -389,7 +348,7 @@ spec = do , [ LEQ (M.fromList [(1, 1)]) 15 ] ) - runTest testCase (Just (Result 3 (M.fromList [(3, 15), (1, 15)]))) + runTest testCase (ExpectOptimal (Just 15) (M.fromList [(1, 15)])) it "Max 2x₁ with mixed constraints: obj=20, x₁=10, x₂=10" $ do let testCase = @@ -398,7 +357,7 @@ spec = do , GEQ (M.fromList [(2, 1)]) 10 ] ) - runTest testCase (Just (Result 6 (M.fromList [(6, 20), (1, 10), (2, 10)]))) + runTest testCase (ExpectOptimal (Just 20) (M.fromList [(1, 10), (2, 10)])) it "Min x₁ with x₁ <= 15: obj=0" $ do let testCase = @@ -406,7 +365,7 @@ spec = do , [ LEQ (M.fromList [(1, 1)]) 15 ] ) - runTest testCase (Just (Result 3 (M.fromList [(3, 0)]))) + runTest testCase (ExpectOptimal (Just 0) M.empty) it "Min 2x₁ with mixed constraints: obj=0, x₂=10" $ do let testCase = @@ -415,7 +374,7 @@ spec = do , GEQ (M.fromList [(2, 1)]) 10 ] ) - runTest testCase (Just (Result 6 (M.fromList [(6, 0), (2, 10)]))) + runTest testCase (ExpectOptimal (Just 0) (M.fromList [(2, 10)])) describe "Infeasibility tests" $ do it "Conflicting bounds x₁ <= 15 and x₁ >= 15.01: infeasible" $ do @@ -425,7 +384,7 @@ spec = do , GEQ (M.fromList [(1, 1)]) 15.01 ] ) - runTest testCase Nothing + runTest testCase ExpectInfeasible it "Conflicting bounds with additional constraint: infeasible" $ do let testCase = @@ -435,7 +394,7 @@ spec = do , GEQ (M.fromList [(2, 1)]) 10 ] ) - runTest testCase Nothing + runTest testCase ExpectInfeasible it "Min x₁ with duplicate GEQ constraints: obj=0, x₂=1" $ do let testCase = @@ -444,7 +403,7 @@ spec = do , GEQ (M.fromList [(1, 1), (2, 1)]) 1 ] ) - runTest testCase (Just (Result 5 (M.fromList [(2, 1 % 1), (5, 0 % 1)]))) + runTest testCase (ExpectOptimal (Just 0) (M.fromList [(2, 1 % 1)])) it "Conflicting x₁+x₂ >= 2 and x₁+x₂ <= 1: infeasible" $ do let testCase = @@ -453,7 +412,7 @@ spec = do , LEQ (M.fromList [(1, 1), (2, 1)]) 1 ] ) - runTest testCase Nothing + runTest testCase ExpectInfeasible describe "LEQ/GEQ reduction bug tests" $ do it "testLeqGeqBugMin1: obj=3, x₁=3, x₂=3" $ do @@ -465,7 +424,7 @@ spec = do , LEQ (M.fromList [(2, 1)]) 3 ] ) - runTest testCase (Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + runTest testCase (ExpectOptimal (Just 3) (M.fromList [(1, 3), (2, 3)])) it "testLeqGeqBugMax1: obj=3, x₁=3, x₂=3" $ do let testCase = @@ -476,7 +435,7 @@ spec = do , LEQ (M.fromList [(2, 1)]) 3 ] ) - runTest testCase (Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + runTest testCase (ExpectOptimal (Just 3) (M.fromList [(1, 3), (2, 3)])) it "testLeqGeqBugMin2: obj=3, x₁=3, x₂=3" $ do let testCase = @@ -487,7 +446,7 @@ spec = do , LEQ (M.fromList [(2, 1)]) 3 ] ) - runTest testCase (Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + runTest testCase (ExpectOptimal (Just 3) (M.fromList [(1, 3), (2, 3)])) it "testLeqGeqBugMax2: obj=3, x₁=3, x₂=3" $ do let testCase = @@ -498,7 +457,7 @@ spec = do , LEQ (M.fromList [(2, 1)]) 3 ] ) - runTest testCase (Just (Result 5 (M.fromList [(5, 3), (1, 3), (2, 3)]))) + runTest testCase (ExpectOptimal (Just 3) (M.fromList [(1, 3), (2, 3)])) -- PolyPaver-style tests with shared parameters describe "PolyPaver-style tests (feasible region [0,2.5]²)" $ do @@ -519,19 +478,19 @@ spec = do it "Min x₁: x₁=7/4, x₂=5/2" $ do runTest (mkConstraints (Min (M.fromList [(1, 1)]))) - (Just (Result 12 (M.fromList [(12, 7 % 4), (2, 5 % 2), (1, 7 % 4), (3, 0)]))) + (ExpectOptimal (Just (7 % 4)) (M.fromList [(1, 7 % 4), (2, 5 % 2), (3, 0)])) it "Max x₁: x₁=5/2, x₂=5/3" $ do runTest (mkConstraints (Max (M.fromList [(1, 1)]))) - (Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) + (ExpectOptimal (Just (5 % 2)) (M.fromList [(1, 5 % 2), (2, 5 % 3), (3, 0)])) it "Min x₂: x₂=5/3" $ do runTest (mkConstraints (Min (M.fromList [(2, 1)]))) - (Just (Result 12 (M.fromList [(12, 5 % 3), (2, 5 % 3), (1, 5 % 2), (3, 0)]))) + (ExpectOptimal (Just (5 % 3)) (M.fromList [(2, 5 % 3), (1, 5 % 2), (3, 0)])) it "Max x₂: x₂=5/2" $ do runTest (mkConstraints (Max (M.fromList [(2, 1)]))) - (Just (Result 12 (M.fromList [(12, 5 % 2), (2, 5 % 2), (1, 5 % 2), (3, 0)]))) + (ExpectOptimal (Just (5 % 2)) (M.fromList [(2, 5 % 2), (1, 5 % 2), (3, 0)])) describe "PolyPaver-style tests (infeasible region [0,1.5]²)" $ do let x1l = 0.0; x1r = 1.5; x2l = 0.0; x2r = 1.5 @@ -550,16 +509,16 @@ spec = do ) it "Max x₁: infeasible" $ do - runTest (mkConstraints (Max (M.fromList [(1, 1)]))) Nothing + runTest (mkConstraints (Max (M.fromList [(1, 1)]))) ExpectInfeasible it "Min x₁: infeasible" $ do - runTest (mkConstraints (Min (M.fromList [(1, 1)]))) Nothing + runTest (mkConstraints (Min (M.fromList [(1, 1)]))) ExpectInfeasible it "Max x₂: infeasible" $ do - runTest (mkConstraints (Max (M.fromList [(2, 1)]))) Nothing + runTest (mkConstraints (Max (M.fromList [(2, 1)]))) ExpectInfeasible it "Min x₂: infeasible" $ do - runTest (mkConstraints (Min (M.fromList [(2, 1)]))) Nothing + runTest (mkConstraints (Min (M.fromList [(2, 1)]))) ExpectInfeasible describe "PolyPaver-style tests (feasible region [0,3.5]²)" $ do let x1l = 0.0; x1r = 3.5; x2l = 0.0; x2r = 3.5 @@ -579,19 +538,19 @@ spec = do it "Max x₁: x₁=7/2" $ do runTest (mkConstraints (Max (M.fromList [(1, 1)]))) - (Just (Result 12 (M.fromList [(12, 7 % 2), (2, 5 % 9), (1, 7 % 2), (3, 0)]))) + (ExpectOptimal (Just (7 % 2)) (M.fromList [(2, 5 % 9), (1, 7 % 2), (3, 0)])) it "Min x₁: x₁=17/20" $ do runTest (mkConstraints (Min (M.fromList [(1, 1)]))) - (Just (Result 12 (M.fromList [(12, 17 % 20), (2, 7 % 2), (1, 17 % 20), (3, 0)]))) + (ExpectOptimal (Just (17 % 20)) (M.fromList [(1, 17 % 20), (2, 7 % 2), (3, 0)])) it "Max x₂: x₂=7/2" $ do runTest (mkConstraints (Max (M.fromList [(2, 1)]))) - (Just (Result 12 (M.fromList [(12, 7 % 2), (2, 7 % 2), (1, 22 % 9)]))) + (ExpectOptimal (Just (7 % 2)) (M.fromList [(2, 7 % 2), (1, 22 % 9)])) it "Min x₂: x₂=5/9" $ do runTest (mkConstraints (Min (M.fromList [(2, 1)]))) - (Just (Result 12 (M.fromList [(12, 5 % 9), (2, 5 % 9), (1, 7 % 2), (3, 0)]))) + (ExpectOptimal (Just (5 % 9)) (M.fromList [(2, 5 % 9), (1, 7 % 2), (3, 0)])) describe "PolyPaver two-function tests (infeasible)" $ do let x1l = 0.0; x1r = 2.5; x2l = 0.0; x2r = 2.5 @@ -615,16 +574,16 @@ spec = do ) it "Max x₁: infeasible" $ do - runTest (mkConstraints (Max (M.fromList [(1, 1)]))) Nothing + runTest (mkConstraints (Max (M.fromList [(1, 1)]))) ExpectInfeasible it "Min x₁: infeasible" $ do - runTest (mkConstraints (Min (M.fromList [(1, 1)]))) Nothing + runTest (mkConstraints (Min (M.fromList [(1, 1)]))) ExpectInfeasible it "Max x₂: infeasible" $ do - runTest (mkConstraints (Max (M.fromList [(2, 1)]))) Nothing + runTest (mkConstraints (Max (M.fromList [(2, 1)]))) ExpectInfeasible it "Min x₂: infeasible" $ do - runTest (mkConstraints (Min (M.fromList [(2, 1)]))) Nothing + runTest (mkConstraints (Min (M.fromList [(2, 1)]))) ExpectInfeasible describe "PolyPaver two-function tests (feasible)" $ do let x1l = 0.0; x1r = 2.5; x2l = 0.0; x2r = 2.5 @@ -649,19 +608,19 @@ spec = do it "Max x₁: x₁=5/2" $ do runTest (mkConstraints (Max (M.fromList [(1, 1)]))) - (Just (Result 17 (M.fromList [(17, 5 % 2), (2, 45 % 22), (1, 5 % 2), (4, 0)]))) + (ExpectOptimal (Just (5 % 2)) (M.fromList [(1, 5 % 2), (2, 45 % 22), (4, 0)])) it "Min x₁: x₁=45/22" $ do runTest (mkConstraints (Min (M.fromList [(1, 1)]))) - (Just (Result 17 (M.fromList [(17, 45 % 22), (2, 5 % 2), (1, 45 % 22), (4, 0)]))) + (ExpectOptimal (Just (45 % 22)) (M.fromList [(1, 45 % 22), (2, 5 % 2), (4, 0)])) it "Max x₂: x₂=5/2" $ do runTest (mkConstraints (Max (M.fromList [(2, 1)]))) - (Just (Result 17 (M.fromList [(17, 5 % 2), (2, 5 % 2), (1, 5 % 2), (4, 0)]))) + (ExpectOptimal (Just (5 % 2)) (M.fromList [(2, 5 % 2), (1, 5 % 2), (4, 0)])) it "Min x₂: x₂=45/22" $ do runTest (mkConstraints (Min (M.fromList [(2, 1)]))) - (Just (Result 17 (M.fromList [(17, 45 % 22), (2, 45 % 22), (1, 5 % 2), (4, 0)]))) + (ExpectOptimal (Just (45 % 22)) (M.fromList [(2, 45 % 22), (1, 5 % 2), (4, 0)])) describe "QuickCheck-generated regression tests" $ do it "testQuickCheck1: obj=-370, x₁=5/3, x₂=26" $ do @@ -674,7 +633,7 @@ spec = do , LEQ (M.fromList [(1, -48)]) (-1) ] ) - runTest testCase (Just (Result 10 (M.fromList [(10, (-370)), (2, 26), (1, 5 % 3)]))) + runTest testCase (ExpectOptimal (Just (-370)) (M.fromList [(2, 26), (1, 5 % 3)])) it "testQuickCheck2: obj=-2/9, x₁=14/9, x₂=8/9" $ do let testCase = @@ -684,7 +643,7 @@ spec = do , LEQ (M.fromList [(2, 7), (1, -4)]) 0 ] ) - runTest testCase (Just (Result 8 (M.fromList [(8, (-2) % 9), (1, 14 % 9), (2, 8 % 9)]))) + runTest testCase (ExpectOptimal (Just ((-2) % 9)) (M.fromList [(1, 14 % 9), (2, 8 % 9)])) it "testQuickCheck3 (tests objective simplification): obj=-8, x₂=2" $ do let testCase = @@ -695,7 +654,7 @@ spec = do , GEQ (M.fromList [(1, -5), (2, -1), (2, 1)]) (-5) ] ) - runTest testCase (Just (Result 7 (M.fromList [(7, (-8)), (2, 2)]))) + runTest testCase (ExpectOptimal (Just (-8)) (M.fromList [(2, 2)])) describe "twoPhaseSimplex (with VarDomainMap)" $ do it "Shift transformation with negative lower bound" $ do @@ -706,9 +665,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 10 + _ -> expectationFailure "Unexpected result format" it "Shift transformation finds minimum at negative bound" $ do let obj = Min (M.fromList [(1, 1)]) @@ -718,9 +678,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just (-5) + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just (-5) + _ -> expectationFailure "Unexpected result format" it "Split transformation for unbounded variable (max)" $ do let obj = Max (M.fromList [(1, 1)]) @@ -733,9 +694,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 10 + _ -> expectationFailure "Unexpected result format" it "Split transformation for unbounded variable (min)" $ do let obj = Min (M.fromList [(1, 1)]) @@ -748,9 +710,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just (-10) + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just (-10) + _ -> expectationFailure "Unexpected result format" it "AddLowerBound with positive lower bound" $ do let obj = Max (M.fromList [(1, 1)]) @@ -760,9 +723,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 10 + _ -> expectationFailure "Unexpected result format" it "AddLowerBound finds minimum at positive bound" $ do let obj = Min (M.fromList [(1, 1)]) @@ -772,9 +736,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 5 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 5 + _ -> expectationFailure "Unexpected result format" it "Mixed domain types" $ do let obj = Max (M.fromList [(1, 1), (2, 1)]) @@ -787,14 +752,15 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let xVal = M.findWithDefault 0 1 varMap yVal = M.findWithDefault 0 2 varMap oVal = computeObjValue obj varMap (xVal + yVal) `shouldBe` 5 oVal `shouldBe` 5 + _ -> expectationFailure "Unexpected result format" it "lowerBoundOnly 0 is equivalent to NonNegative" $ do let obj = Max (M.fromList [(1, 3), (2, 5)]) @@ -815,8 +781,11 @@ spec = do filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap2 [obj] constraints -- Both should produce the same optimal solution with x₁=3, x₂=4 - simplexResultToVarMap actualResult1 `shouldBe` Just (M.fromList [(1, 3), (2, 4)]) - simplexResultToVarMap actualResult1 `shouldBe` simplexResultToVarMap actualResult2 + case (actualResult1, actualResult2) of + (SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap1)], SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap2)]) -> do + varMap1 `shouldBe` M.fromList [(1, 3), (2, 4)] + varMap1 `shouldBe` varMap2 + _ -> expectationFailure "Expected optimal results" it "Infeasible system with domain constraint" $ do let obj = Max (M.fromList [(1, 1)]) @@ -826,7 +795,9 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - isInfeasible actualResult `shouldBe` True + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible result" describe "twoPhaseSimplex with upper bounds (AddUpperBound transformation)" $ do describe "Simple single variable systems" $ do @@ -838,9 +809,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 5 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 5 + _ -> expectationFailure "Unexpected result format" it "Min x₁ with x₁ ≥ 0, x₁ ≤ 10 (using boundedRange): optimal at x₁=0" $ do let obj = Min (M.fromList [(1, 1)]) @@ -850,10 +822,12 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - -- Note: non-basic variables with value 0 may not appear in varValMap - Just varMap -> M.findWithDefault 0 1 varMap `shouldBe` 0 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> + -- Note: non-basic variables with value 0 may not appear in varValMap + M.findWithDefault 0 1 varMap `shouldBe` 0 + _ -> expectationFailure "Unexpected result format" it "Max x₁ with -5 ≤ x₁ ≤ 10 (bounded range with negative lower): optimal at x₁=10" $ do let obj = Max (M.fromList [(1, 1)]) @@ -863,9 +837,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 10 + _ -> expectationFailure "Unexpected result format" it "Min x₁ with -5 ≤ x₁ ≤ 10 (bounded range with negative lower): optimal at x₁=-5" $ do let obj = Min (M.fromList [(1, 1)]) @@ -875,9 +850,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just (-5) + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just (-5) + _ -> expectationFailure "Unexpected result format" it "Infeasible: lower bound > upper bound" $ do let obj = Max (M.fromList [(1, 1)]) @@ -887,7 +863,9 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - isInfeasible actualResult `shouldBe` True + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible system" describe "Two variable systems with upper bounds" $ do it "Max x₁ + x₂ with 0 ≤ x₁ ≤ 3, 0 ≤ x₂ ≤ 4: optimal at x₁=3, x₂=4" $ do @@ -898,12 +876,13 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just 3 M.lookup 2 varMap `shouldBe` Just 4 computeObjValue obj varMap `shouldBe` 7 + _ -> expectationFailure "Unexpected result format" it "Max 2x₁ - x₂ with -2 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 4" $ do -- Maximize 2x₁ - x₂: want x₁ = 5 (max), x₂ = -3 (min) @@ -915,12 +894,13 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just 5 M.lookup 2 varMap `shouldBe` Just (-3) computeObjValue obj varMap `shouldBe` 13 + _ -> expectationFailure "Unexpected result format" it "Mixed bounds: x₁ nonNegative, x₂ with upper bound only (unbounded below)" $ do -- x₁ ≥ 0, x₂ ≤ 10 (no lower bound) @@ -932,14 +912,15 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let x1 = M.findWithDefault 0 1 varMap x2 = M.findWithDefault 0 2 varMap x1 `shouldSatisfy` (>= 0) x2 `shouldSatisfy` (<= 10) (x1 + x2) `shouldBe` 20 + _ -> expectationFailure "Unexpected result format" describe "twoPhaseSimplex with negative lower bounds (Shift transformation)" $ do describe "Simple single variable systems" $ do @@ -953,9 +934,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 5 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 5 + _ -> expectationFailure "Unexpected result format" it "Min x₁ with x₁ ≤ 5, x₁ ≥ -3: optimal at lower bound x₁=-3" $ do -- Minimize x with upper bound 5 and lower bound -3 @@ -967,9 +949,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just (-3) + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just (-3) + _ -> expectationFailure "Unexpected result format" it "Max x₁ with x₁ ≥ -10, x₁ ≤ -2: optimal at x₁=-2" $ do -- Both bounds are negative, maximize @@ -980,9 +963,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just (-2) + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just (-2) + _ -> expectationFailure "Unexpected result format" it "Min x₁ with x₁ ≥ -10, x₁ ≤ -2: optimal at x₁=-10" $ do -- Both bounds are negative, minimize @@ -993,9 +977,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just (-10) + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just (-10) + _ -> expectationFailure "Unexpected result format" describe "Two variable systems with negative bounds" $ do it "Max x₁ + x₂ with x₁ ≥ -2, x₂ ≥ -3, x₁ + x₂ ≤ 10" $ do @@ -1011,9 +996,9 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let x1 = M.findWithDefault 0 1 varMap x2 = M.findWithDefault 0 2 varMap objVal = computeObjValue obj varMap @@ -1022,6 +1007,7 @@ spec = do -- Verify lower bounds are respected x1 `shouldSatisfy` (>= (-2)) x2 `shouldSatisfy` (>= (-3)) + _ -> expectationFailure "Unexpected result format" it "Min x₁ + x₂ with x₁ ≥ -2, x₂ ≥ -3, x₁ + x₂ ≤ 10" $ do -- Minimize sum with lower bounds -2 and -3 @@ -1033,14 +1019,15 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let objVal = computeObjValue obj varMap -- Verify the actual objective value objVal `shouldBe` (-5) M.lookup 1 varMap `shouldBe` Just (-2) M.lookup 2 varMap `shouldBe` Just (-3) + _ -> expectationFailure "Unexpected result format" it "Max 2x₁ - x₂ with x₁ ≥ -5, x₂ ≥ -4, x₁ ≤ 3, x₂ ≤ 6" $ do -- Maximize 2x₁ - x₂: want x₁ large (up to 3) and x₂ small (down to -4) @@ -1055,15 +1042,16 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let x1 = M.findWithDefault 0 1 varMap x2 = M.findWithDefault 0 2 varMap M.lookup 1 varMap `shouldBe` Just 3 M.lookup 2 varMap `shouldBe` Just (-4) -- Verify objective value computed from variables (2 * x1 - x2) `shouldBe` 10 + _ -> expectationFailure "Unexpected result format" it "Min 2x₁ - x₂ with x₁ ≥ -5, x₂ ≥ -4, x₁ ≤ 3, x₂ ≤ 6" $ do -- Minimize 2x₁ - x₂: want x₁ small (down to -5) and x₂ large (up to 6) @@ -1078,15 +1066,16 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let x1 = M.findWithDefault 0 1 varMap x2 = M.findWithDefault 0 2 varMap M.lookup 1 varMap `shouldBe` Just (-5) M.lookup 2 varMap `shouldBe` Just 6 -- Verify objective value computed from variables (2 * x1 - x2) `shouldBe` (-16) + _ -> expectationFailure "Unexpected result format" describe "Systems with GEQ constraints and negative bounds" $ do it "Max x₁ with x₁ ≥ -5, x₁ ≥ 2 (GEQ tightens bound)" $ do @@ -1103,9 +1092,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 10 + _ -> expectationFailure "Unexpected result format" it "Min x₁ with x₁ ≥ -5, x₁ ≥ 2 (GEQ tightens bound)" $ do -- Minimize with GEQ 2, so minimum is at x₁ = 2 @@ -1119,9 +1109,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 2 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 2 + _ -> expectationFailure "Unexpected result format" describe "Systems with EQ constraints and negative bounds" $ do it "Max x₁ + x₂ with x₁ - x₂ = 0, x₁ ≥ -5, x₂ ≥ -5, x₁ ≤ 10" $ do @@ -1137,14 +1128,15 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let objVal = computeObjValue obj varMap M.lookup 1 varMap `shouldBe` Just 10 M.lookup 2 varMap `shouldBe` Just 10 -- Verify objective value objVal `shouldBe` 20 + _ -> expectationFailure "Unexpected result format" it "Min x₁ + x₂ with x₁ - x₂ = 0, x₁ ≥ -5, x₂ ≥ -5, x₁ ≤ 10" $ do -- x₁ = x₂, minimize x₁ + x₂ = 2x₁ @@ -1159,14 +1151,15 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let objVal = computeObjValue obj varMap M.lookup 1 varMap `shouldBe` Just (-5) M.lookup 2 varMap `shouldBe` Just (-5) -- Verify objective value objVal `shouldBe` (-10) + _ -> expectationFailure "Unexpected result format" describe "Fractional negative bounds" $ do it "Max x₁ with x₁ ≥ -7/2, x₁ ≤ 5/2" $ do @@ -1177,9 +1170,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just (5 % 2) + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just (5 % 2) + _ -> expectationFailure "Unexpected result format" it "Min x₁ with x₁ ≥ -7/2, x₁ ≤ 5/2" $ do let obj = Min (M.fromList [(1, 1)]) @@ -1189,9 +1183,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just ((-7) % 2) + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just ((-7) % 2) + _ -> expectationFailure "Unexpected result format" describe "twoPhaseSimplex with unbounded variables (Split transformation)" $ do describe "Simple single variable systems" $ do @@ -1207,9 +1202,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 10 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 10 + _ -> expectationFailure "Unexpected result format" it "Min x₁ with -10 ≤ x₁ ≤ 10 (unbounded var with box constraints)" $ do let obj = Min (M.fromList [(1, 1)]) @@ -1222,9 +1218,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just (-10) + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just (-10) + _ -> expectationFailure "Unexpected result format" it "unbounded variable with only upper bound: Min finds negative value" $ do -- x₁ unbounded, only x₁ ≤ 5, minimize x₁ @@ -1237,7 +1234,9 @@ spec = do filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints -- This should be unbounded (no finite optimum exists) - isUnbounded actualResult `shouldBe` True + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ Unbounded] -> pure () + _ -> expectationFailure "Expected unbounded system" describe "Two variable systems with unbounded variables" $ do it "Max x₁ + x₂ with unbounded vars, -5 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 7" $ do @@ -1253,13 +1252,14 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just 5 M.lookup 2 varMap `shouldBe` Just 7 let objVal = computeObjValue obj varMap objVal `shouldBe` 12 + _ -> expectationFailure "Unexpected result format" it "Min x₁ + x₂ with unbounded vars, -5 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 7" $ do let obj = Min (M.fromList [(1, 1), (2, 1)]) @@ -1274,13 +1274,14 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just (-5) M.lookup 2 varMap `shouldBe` Just (-3) let objVal = computeObjValue obj varMap objVal `shouldBe` (-8) + _ -> expectationFailure "Unexpected result format" it "Max x₁ - x₂ with unbounded vars: x₁ up, x₂ down" $ do -- Maximize x₁ - x₂: want x₁ large (5) and x₂ small (-3) @@ -1296,13 +1297,14 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just 5 M.lookup 2 varMap `shouldBe` Just (-3) let objVal = computeObjValue obj varMap objVal `shouldBe` 8 + _ -> expectationFailure "Unexpected result format" describe "Systems with EQ constraints and unbounded variables" $ do it "Max x₁ with x₁ + x₂ = 10, unbounded vars, x₂ ≥ -5" $ do @@ -1318,11 +1320,12 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just 15 M.lookup 2 varMap `shouldBe` Just (-5) + _ -> expectationFailure "Unexpected result format" it "Min x₁ with x₁ + x₂ = 10, unbounded vars, x₂ ≤ 20" $ do -- x₁ + x₂ = 10, x₂ ≤ 20, unbounded x₁ @@ -1337,11 +1340,12 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just (-10) M.lookup 2 varMap `shouldBe` Just 20 + _ -> expectationFailure "Unexpected result format" describe "twoPhaseSimplex with mixed domain types" $ do describe "NonNegative, negative lower bound, and unbounded in same system" $ do @@ -1362,12 +1366,13 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let objVal = computeObjValue obj varMap -- Verify objective value objVal `shouldBe` 20 + _ -> expectationFailure "Unexpected result format" it "Min x₁ + x₂ + x₃ with x₁ ≥ 0, x₂ ≥ -5, x₃ unbounded, sum ≥ -10" $ do -- Minimize sum with lower bound constraint @@ -1385,9 +1390,9 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let x1 = M.findWithDefault 0 1 varMap x2 = M.findWithDefault 0 2 varMap x3 = M.findWithDefault 0 3 varMap @@ -1398,6 +1403,7 @@ spec = do x3 `shouldSatisfy` (>= (-20)) -- Verify objective value objVal `shouldBe` (-10) + _ -> expectationFailure "Unexpected result format" describe "Positive lower bound with other domain types" $ do it "Max 2x₁ + 3x₂ with x₁ ≥ 2 (positive bound), x₂ ≥ -3, 2x₁ + x₂ ≤ 20" $ do @@ -1413,15 +1419,16 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let x1 = M.findWithDefault 0 1 varMap x2 = M.findWithDefault 0 2 varMap -- Verify constraints x1 `shouldSatisfy` (>= 2) x2 `shouldSatisfy` (>= (-3)) (2 * x1 + x2) `shouldSatisfy` (<= 20) + _ -> expectationFailure "Unexpected result format" it "Min 2x₁ + 3x₂ with x₁ ≥ 2, x₂ ≥ -3, x₁ + x₂ ≥ 0" $ do -- Minimize with lower bounds @@ -1437,14 +1444,15 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let x1 = M.findWithDefault 0 1 varMap x2 = M.findWithDefault 0 2 varMap x1 `shouldSatisfy` (>= 2) x2 `shouldSatisfy` (>= (-3)) (x1 + x2) `shouldSatisfy` (>= 0) + _ -> expectationFailure "Unexpected result format" describe "twoPhaseSimplex edge cases and infeasibility" $ do it "Infeasible: negative lower bound conflicts with GEQ constraint" $ do @@ -1459,7 +1467,9 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - isInfeasible actualResult `shouldBe` True + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible system" it "Infeasible: unbounded variable with conflicting constraints" $ do let obj = Max (M.fromList [(1, 1)]) @@ -1472,7 +1482,9 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - isInfeasible actualResult `shouldBe` True + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible system" it "Variable at exactly zero with negative lower bound" $ do -- x₁ ≥ -5, constraint x₁ = 0 @@ -1483,9 +1495,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 0 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 0 + _ -> expectationFailure "Unexpected result format" it "unbounded variable constrained to zero" $ do let obj = Max (M.fromList [(1, 1)]) @@ -1495,9 +1508,10 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> M.lookup 1 varMap `shouldBe` Just 0 + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> M.lookup 1 varMap `shouldBe` Just 0 + _ -> expectationFailure "Unexpected result format" it "Multiple variables, only some with negative bounds" $ do -- x₁ ≥ 0 (non-negative), x₂ ≥ -10, x₃ ≥ 0 @@ -1510,12 +1524,13 @@ spec = do runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ twoPhaseSimplex domainMap [obj] constraints - case simplexResultToVarMap actualResult of - Nothing -> expectationFailure "Expected a solution but got Nothing" - Just varMap -> do + case actualResult of + SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let objVal = computeObjValue obj varMap -- Verify objective value objVal `shouldBe` 15 + _ -> expectationFailure "Unexpected result format" -- =========================================================================== -- Tests for internal preprocessing functions From 6be7aa6641bd52c853930487eb3a1ac4421f7c06 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 28 Feb 2026 14:29:15 +0000 Subject: [PATCH 09/17] chore: add Makefile, use make commands in workflow --- .github/workflows/haskell.yml | 16 +++++++------- Makefile | 39 +++++++++++++++++++++++++++++++++++ 2 files changed, 46 insertions(+), 9 deletions(-) create mode 100644 Makefile diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index bbf33cf..f6c74e1 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -15,7 +15,7 @@ jobs: - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 - uses: haskell-actions/run-fourmolu@3b7702b41516aa428dfe6e295dc73476ae58f69e # v11 with: - version: "0.14.0.0" + version: "0.17.0.0" build: name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} runs-on: ${{ matrix.os }} @@ -43,12 +43,10 @@ jobs: echo "CABAL_VERSION=${CABAL_VERSION}" >> "${GITHUB_ENV}" - name: Check cabal file - run: cabal check + run: make cabal-check - name: Configure the build - run: | - cabal configure --enable-tests --enable-benchmarks --disable-documentation - cabal build --dry-run + run: make configure - name: Restore cached dependencies uses: actions/cache/restore@5a3ec84eff668545956fd18022155c47e93e2684 # v4.2.3 @@ -61,7 +59,7 @@ jobs: restore-keys: ${{ env.key }}- - name: Build dependencies - run: cabal build --only-dependencies + run: make deps - name: Save cached dependencies uses: actions/cache/save@5a3ec84eff668545956fd18022155c47e93e2684 # v4.2.3 @@ -71,10 +69,10 @@ jobs: key: ${{ steps.cache.outputs.cache-primary-key }} - name: Build the package - run: cabal build all + run: make build - name: Run tests - run: cabal test all + run: make test - name: Build documentation - run: cabal haddock all --disable-documentation + run: make docs diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..7d62be6 --- /dev/null +++ b/Makefile @@ -0,0 +1,39 @@ +HS_FILES := $(shell git ls-files '*.hs') + +.PHONY: format +format: + @test -n "$(HS_FILES)" || { echo "No tracked .hs files found"; exit 0; } + fourmolu -i $(HS_FILES) + +.PHONY: format-check +format-check: + @test -n "$(HS_FILES)" || { echo "No tracked .hs files found"; exit 0; } + fourmolu -m check $(HS_FILES) + +.PHONY: cabal-check +cabal-check: + cabal check + +.PHONY: configure +configure: + cabal configure --enable-tests --enable-benchmarks --disable-documentation + cabal build --dry-run + +.PHONY: deps +deps: + cabal build --only-dependencies + +.PHONY: build +build: + cabal build all + +.PHONY: test +test: + cabal test all + +.PHONY: docs +docs: + cabal haddock all --disable-documentation + +.PHONY: ci +ci: format-check cabal-check configure deps build test docs From 62d8a530746faffcfcd8c6766b59aacf0fae74ba Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 28 Feb 2026 14:29:15 +0000 Subject: [PATCH 10/17] chore: run formatter --- src/Linear/Simplex/Solver/TwoPhase.hs | 133 ++-- src/Linear/Simplex/Types.hs | 65 +- src/Linear/Simplex/Util.hs | 4 +- test/Linear/Simplex/Solver/TwoPhaseSpec.hs | 736 ++++++++++++--------- 4 files changed, 538 insertions(+), 400 deletions(-) diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index cb2ee5f..4107420 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -34,6 +34,7 @@ module Linear.Simplex.Solver.TwoPhase import Prelude hiding (EQ) +import qualified Control.Applicative as LPPaver import Control.Lens import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO) @@ -43,13 +44,12 @@ import Data.List import qualified Data.Map as M import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Ratio (denominator, numerator, (%)) -import qualified Data.Text as Text import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Text as Text import GHC.Real (Ratio) import Linear.Simplex.Types import Linear.Simplex.Util -import qualified Control.Applicative as LPPaver -- | Find a feasible solution for the given system of 'PolyConstraint's by performing the first phase of the two-phase simplex method -- All variables in the 'PolyConstraint' must be positive. @@ -226,7 +226,6 @@ findFeasibleSolution unsimplifiedSystem = do , newArtificialVar : artificialVarsWithNewMaxVar -- Slack var is negative, r is positive (when original constraint was GEQ) ) else -- r < 0 - if basicVarCoeff <= 0 -- Should only be -1 in the standard call path then (M.insert basicVar (TableauRow {lhs = v, rhs = r}) newSystemWithoutNewMaxVar, artificialVarsWithoutNewMaxVar) else @@ -279,21 +278,22 @@ optimizeFeasibleSystem :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> Fea optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = do logMsg LevelInfo $ "optimizeFeasibleSystem: Optimizing feasible system " <> showT fsys <> " with objective " <> showT objFunction - mResult <- if null artificialVars - then do - logMsg LevelInfo $ - "optimizeFeasibleSystem: No artificial vars, system is feasible. Pivoting system (in dict form) " - <> showT phase1Dict - <> " with objective " - <> showT normalObjective - simplexPivot normalObjective phase1Dict - else do - logMsg LevelInfo $ - "optimizeFeasibleSystem: Artificial vars present. Pivoting system (in dict form) " - <> showT phase1Dict - <> " with objective " - <> showT adjustedObjective - simplexPivot adjustedObjective phase1Dict + mResult <- + if null artificialVars + then do + logMsg LevelInfo $ + "optimizeFeasibleSystem: No artificial vars, system is feasible. Pivoting system (in dict form) " + <> showT phase1Dict + <> " with objective " + <> showT normalObjective + simplexPivot normalObjective phase1Dict + else do + logMsg LevelInfo $ + "optimizeFeasibleSystem: Artificial vars present. Pivoting system (in dict form) " + <> showT phase1Dict + <> " with objective " + <> showT adjustedObjective + simplexPivot adjustedObjective phase1Dict case mResult of Nothing -> do logMsg LevelInfo "optimizeFeasibleSystem: Objective is unbounded (ratio test failed)" @@ -408,7 +408,8 @@ optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) -- The returned SimplexResult contains: -- * The feasible system (Nothing if infeasible) -- * Results for each objective function (empty if infeasible) -twoPhaseSimplex :: (MonadIO m, MonadLogger m) => VarDomainMap -> [ObjectiveFunction] -> [PolyConstraint] -> m SimplexResult +twoPhaseSimplex :: + (MonadIO m, MonadLogger m) => VarDomainMap -> [ObjectiveFunction] -> [PolyConstraint] -> m SimplexResult twoPhaseSimplex domainMap objFunctions constraints = do logMsg LevelInfo $ "twoPhaseSimplex: Solving system with domain map " <> showT domainMap @@ -416,9 +417,12 @@ twoPhaseSimplex domainMap objFunctions constraints = do let originalVars = collectAllVars objFunctions constraints let (transformedObjs, transformedConstraints, transforms) = preprocess objFunctions domainMap constraints logMsg LevelInfo $ - "twoPhaseSimplex: Applied transforms " <> showT transforms - <> "; Transformed objectives: " <> showT transformedObjs - <> "; Transformed constraints: " <> showT transformedConstraints + "twoPhaseSimplex: Applied transforms " + <> showT transforms + <> "; Transformed objectives: " + <> showT transformedObjs + <> "; Transformed constraints: " + <> showT transformedConstraints mFeasibleSystem <- findFeasibleSolution transformedConstraints case mFeasibleSystem of Nothing -> do @@ -435,13 +439,16 @@ twoPhaseSimplex domainMap objFunctions constraints = do -- | Optimize all objective functions over the given feasible system. -- Returns a list of ObjectiveResult, one for each objective function. -- The originalVars set is used to filter the result to only include original decision variables. -optimizeAllObjectives :: (MonadIO m, MonadLogger m) - => Set.Set Var -- ^ Original decision variables - -> [VarTransform] - -> FeasibleSystem - -> [(ObjectiveFunction, ObjectiveFunction)] -- ^ (original, transformed) objective pairs - -> m [ObjectiveResult] -optimizeAllObjectives originalVars transforms feasibleSystem objPairs = +optimizeAllObjectives :: + (MonadIO m, MonadLogger m) => + -- | Original decision variables + Set.Set Var -> + [VarTransform] -> + FeasibleSystem -> + -- | (original, transformed) objective pairs + [(ObjectiveFunction, ObjectiveFunction)] -> + m [ObjectiveResult] +optimizeAllObjectives originalVars transforms feasibleSystem objPairs = mapM optimizeOne objPairs where optimizeOne (origObj, transformedObj) = do @@ -460,7 +467,7 @@ postprocess originalVars transforms (Optimal varVals) = unappliedVarVals = unapplyTransformsToVarMap transforms varVals -- Filter to only include original decision variables filteredVarVals = M.filterWithKey (\k _ -> Set.member k originalVars) unappliedVarVals - in Optimal filteredVarVals + in Optimal filteredVarVals -- | Compute the value of an objective function given variable values. computeObjective :: ObjectiveFunction -> M.Map Var SimplexNum -> SimplexNum @@ -468,14 +475,15 @@ computeObjective objFunction varVals = let coeffs = case objFunction of Max m -> m Min m -> m - in sum $ map (\(var, coeff) -> coeff * M.findWithDefault 0 var varVals) (M.toList coeffs) + in sum $ map (\(var, coeff) -> coeff * M.findWithDefault 0 var varVals) (M.toList coeffs) -- | Preprocess the system by applying variable transformations based on domain information. -- Returns the transformed objectives, constraints, and the list of transforms applied. -preprocess :: [ObjectiveFunction] - -> VarDomainMap - -> [PolyConstraint] - -> ([ObjectiveFunction], [PolyConstraint], [VarTransform]) +preprocess :: + [ObjectiveFunction] -> + VarDomainMap -> + [PolyConstraint] -> + ([ObjectiveFunction], [PolyConstraint], [VarTransform]) preprocess objFunctions (VarDomainMap domainMap) constraints = let -- Collect all variables in the system (from all objectives and constraints) allVars = collectAllVars objFunctions constraints @@ -488,8 +496,8 @@ preprocess objFunctions (VarDomainMap domainMap) constraints = transformedObjs = map (\obj -> fst $ applyTransforms transforms obj constraints) objFunctions (_, transformedConstraints) = case objFunctions of [] -> (Max M.empty, applyTransformsToConstraints transforms constraints) - (obj:_) -> applyTransforms transforms obj constraints - in (transformedObjs, transformedConstraints, transforms) + (obj : _) -> applyTransforms transforms obj constraints + in (transformedObjs, transformedConstraints, transforms) -- | Apply transforms to constraints only (used when there are no objectives) applyTransformsToConstraints :: [VarTransform] -> [PolyConstraint] -> [PolyConstraint] @@ -501,12 +509,12 @@ collectAllVars :: [ObjectiveFunction] -> [PolyConstraint] -> Set Var collectAllVars objFunctions constraints = let objVars = Set.unions $ map getObjVars objFunctions constraintVars = Set.unions $ map getConstraintVars constraints - in Set.union objVars constraintVars + in Set.union objVars constraintVars where getObjVars :: ObjectiveFunction -> Set Var getObjVars (Max m) = M.keysSet m getObjVars (Min m) = M.keysSet m - + getConstraintVars :: PolyConstraint -> Set Var getConstraintVars (LEQ m _) = M.keysSet m getConstraintVars (GEQ m _) = M.keysSet m @@ -519,7 +527,7 @@ generateTransform :: M.Map Var VarDomain -> Var -> ([VarTransform], Var) -> ([Va generateTransform domainMap var (transforms, nextFreshVar) = let domain = M.findWithDefault unbounded var domainMap (newTransforms, varOffset) = getTransform nextFreshVar var domain - in (newTransforms ++ transforms, nextFreshVar + varOffset) + in (newTransforms ++ transforms, nextFreshVar + varOffset) -- | Determine what transforms are needed for a variable given its domain. -- Returns a list of transforms and the number of fresh variables consumed. @@ -527,16 +535,16 @@ getTransform :: Var -> Var -> VarDomain -> ([VarTransform], Var) getTransform nextFreshVar var (Bounded mLower mUpper) = let -- Handle lower bound (lowerTransforms, varOffset) = case mLower of - Nothing -> ([], 0) -- No lower bound: will need Split + Nothing -> ([], 0) -- No lower bound: will need Split Just l - | l == 0 -> ([], 0) -- NonNegative: no transform needed - | l > 0 -> ([AddLowerBound var l], 0) -- Positive lower bound: add constraint - | otherwise -> ([Shift var nextFreshVar l], 1) -- Negative lower bound: shift + | l == 0 -> ([], 0) -- NonNegative: no transform needed + | l > 0 -> ([AddLowerBound var l], 0) -- Positive lower bound: add constraint + | otherwise -> ([Shift var nextFreshVar l], 1) -- Negative lower bound: shift -- Handle upper bound (if present) upperTransforms = case mUpper of Nothing -> [] - Just u -> [AddUpperBound var u] + Just u -> [AddUpperBound var u] -- If no lower bound (Nothing), we need Split transformation -- Split replaces the variable, so upper bound would apply to the original var @@ -549,8 +557,7 @@ getTransform nextFreshVar var (Bounded mLower mUpper) = (Split var nextFreshVar (nextFreshVar + 1) : upperTransforms, 2) Just _ -> (lowerTransforms ++ upperTransforms, varOffset) - - in (finalTransforms, finalOffset) + in (finalTransforms, finalOffset) -- | Apply all transforms to the objective function and constraints. applyTransforms :: [VarTransform] -> ObjectiveFunction -> [PolyConstraint] -> (ObjectiveFunction, [PolyConstraint]) @@ -564,11 +571,9 @@ applyTransform transform (objFunction, constraints) = -- AddLowerBound: Add a GEQ constraint for the variable AddLowerBound v bound -> (objFunction, GEQ (M.singleton v 1) bound : constraints) - -- AddUpperBound: Add a LEQ constraint for the variable AddUpperBound v bound -> (objFunction, LEQ (M.singleton v 1) bound : constraints) - -- Shift: originalVar = shiftedVar + shiftBy (where shiftBy < 0) -- Substitute: wherever we see originalVar, replace with shiftedVar -- and adjust the RHS by -coeff * shiftBy @@ -576,9 +581,8 @@ applyTransform transform (objFunction, constraints) = ( applyShiftToObjective origVar shiftedVar shiftBy objFunction , map (applyShiftToConstraint origVar shiftedVar shiftBy) constraints ) - -- Split: originalVar = posVar - negVar - -- Substitute: wherever we see originalVar with coeff c, + -- Substitute: wherever we see originalVar with coeff c, -- replace with posVar with coeff c and negVar with coeff -c Split origVar posVar negVar -> ( applySplitToObjective origVar posVar negVar objFunction @@ -612,13 +616,13 @@ applyShiftToConstraint origVar shiftedVar shiftBy constraint = case constraint of LEQ m rhs -> let (newMap, rhsAdjust) = substituteVarInMap origVar shiftedVar shiftBy m - in LEQ newMap (rhs - rhsAdjust) + in LEQ newMap (rhs - rhsAdjust) GEQ m rhs -> let (newMap, rhsAdjust) = substituteVarInMap origVar shiftedVar shiftBy m - in GEQ newMap (rhs - rhsAdjust) + in GEQ newMap (rhs - rhsAdjust) EQ m rhs -> let (newMap, rhsAdjust) = substituteVarInMap origVar shiftedVar shiftBy m - in EQ newMap (rhs - rhsAdjust) + in EQ newMap (rhs - rhsAdjust) where substituteVarInMap :: Var -> Var -> SimplexNum -> VarLitMapSum -> (VarLitMapSum, SimplexNum) substituteVarInMap oldVar newVar shift m = @@ -669,24 +673,21 @@ unapplyTransformToVarMap transform valMap = case transform of -- AddLowerBound: No variable substitution was done, nothing to unapply AddLowerBound {} -> valMap - -- AddUpperBound: No variable substitution was done, nothing to unapply AddUpperBound {} -> valMap - -- Shift: originalVar = shiftedVar + shiftBy -- So originalVar's value = shiftedVar's value + shiftBy Shift origVar shiftedVar shiftBy -> let shiftedVal = M.findWithDefault 0 shiftedVar valMap origVal = shiftedVal + shiftBy - in M.insert origVar origVal (M.delete shiftedVar valMap) - + in M.insert origVar origVal (M.delete shiftedVar valMap) -- Split: originalVar = posVar - negVar -- So originalVar's value = posVar's value - negVar's value Split origVar posVar negVar -> let posVal = M.findWithDefault 0 posVar valMap negVal = M.findWithDefault 0 negVar valMap origVal = posVal - negVal - in M.insert origVar origVal (M.delete posVar (M.delete negVar valMap)) + in M.insert origVar origVal (M.delete posVar (M.delete negVar valMap)) -- | Perform the simplex pivot algorithm on a system with basic vars, assume that the first row is the 'ObjectiveFunction'. simplexPivot :: (MonadIO m, MonadLogger m) => PivotObjective -> Dict -> m (Maybe Dict) @@ -794,13 +795,13 @@ simplexPivot objective@(PivotObjective {variable = objectiveVar, function = obje dictEntertingRow & #varMapSum %~ ( \basicEquation -> - -- uncurry - M.insert - leavingVariable - (-1) - (filterOutEnteringVarTerm basicEquation) - & traverse - %~ divideByNegatedEnteringVariableCoeff + -- uncurry + M.insert + leavingVariable + (-1) + (filterOutEnteringVarTerm basicEquation) + & traverse + %~ divideByNegatedEnteringVariableCoeff ) & #constant %~ divideByNegatedEnteringVariableCoeff diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index d8b6ff2..55562c1 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -41,22 +41,28 @@ data FeasibleSystem = FeasibleSystem -- | The outcome of optimizing a single objective function. data OptimisationOutcome - = Optimal { varValMap :: VarLitMap } -- ^ An optimal solution was found - | Unbounded -- ^ The objective is unbounded + = -- | An optimal solution was found + Optimal {varValMap :: VarLitMap} + | -- | The objective is unbounded + Unbounded deriving (Show, Read, Eq, Generic) -- | Result for a single objective function optimization. data ObjectiveResult = ObjectiveResult - { objectiveFunction :: ObjectiveFunction -- ^ The objective that was optimized - , outcome :: OptimisationOutcome -- ^ The optimization outcome + { objectiveFunction :: ObjectiveFunction + -- ^ The objective that was optimized + , outcome :: OptimisationOutcome + -- ^ The optimization outcome } deriving (Show, Read, Eq, Generic) -- | Complete result of the two-phase simplex method. -- Contains feasibility information and results for all requested objectives. data SimplexResult = SimplexResult - { feasibleSystem :: Maybe FeasibleSystem -- ^ The feasible system (Nothing if infeasible) - , objectiveResults :: [ObjectiveResult] -- ^ Results for each objective (empty if infeasible) + { feasibleSystem :: Maybe FeasibleSystem + -- ^ The feasible system (Nothing if infeasible) + , objectiveResults :: [ObjectiveResult] + -- ^ Results for each objective (empty if infeasible) } deriving (Show, Read, Eq, Generic) @@ -129,18 +135,20 @@ data PivotObjective = PivotObjective -- | Domain specification for a variable's bounds. -- Variables not in the VarDomainMap are assumed to be Unbounded (both bounds Nothing). --- +-- -- Bounds semantics: -- * @lowerBound = Just L@ means var >= L -- * @lowerBound = Nothing@ means no lower bound (var can be arbitrarily negative) --- * @upperBound = Just U@ means var <= U +-- * @upperBound = Just U@ means var <= U -- * @upperBound = Nothing@ means no upper bound (var can be arbitrarily positive) -- -- Note: @Bounded Nothing Nothing@ is equivalent to unbounded. Use the smart constructors -- ('unbounded', 'nonNegative', etc.) for clarity. -data VarDomain = Bounded - { lowerBound :: Maybe SimplexNum -- ^ Lower bound (Nothing = -∞) - , upperBound :: Maybe SimplexNum -- ^ Upper bound (Nothing = +∞) +data VarDomain = Bounded + { lowerBound :: Maybe SimplexNum + -- ^ Lower bound (Nothing = -∞) + , upperBound :: Maybe SimplexNum + -- ^ Upper bound (Nothing = +∞) } deriving stock (Show, Read, Eq, Generic) @@ -168,30 +176,31 @@ boundedRange l u = Bounded (Just l) (Just u) -- | Map from variables to their domain specifications. -- Variables not in this map are assumed to be Unbounded. -newtype VarDomainMap = VarDomainMap { unVarDomainMap :: M.Map Var VarDomain } +newtype VarDomainMap = VarDomainMap {unVarDomainMap :: M.Map Var VarDomain} deriving stock (Show, Read, Eq, Generic) -- | Transformations applied to variables to ensure they satisfy the non-negativity requirement. -data VarTransform - = AddLowerBound +data VarTransform + = -- | var >= bound where bound > 0. Adds GEQ constraint to system. + AddLowerBound { var :: !Var - , bound :: !SimplexNum - } -- ^ var >= bound where bound > 0. Adds GEQ constraint to system. - | AddUpperBound + , bound :: !SimplexNum + } + | -- | var <= bound. Adds LEQ constraint to system. + AddUpperBound { var :: !Var , bound :: !SimplexNum - } -- ^ var <= bound. Adds LEQ constraint to system. - | Shift + } + | -- | originalVar = shiftedVar + shiftBy, where shiftBy < 0. After solving: originalVar = shiftedVar + shiftBy + Shift { originalVar :: !Var - , shiftedVar :: !Var - , shiftBy :: !SimplexNum - } -- ^ originalVar = shiftedVar + shiftBy, where shiftBy < 0. After solving: originalVar = shiftedVar + shiftBy - | Split + , shiftedVar :: !Var + , shiftBy :: !SimplexNum + } + | -- | originalVar = posVar - negVar, both posVar and negVar >= 0 + Split { originalVar :: !Var , posVar :: !Var - , negVar :: !Var - } -- ^ originalVar = posVar - negVar, both posVar and negVar >= 0 + , negVar :: !Var + } deriving stock (Show, Read, Eq, Generic) - - - diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 7bee541..b87a8dc 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -113,11 +113,11 @@ extractObjectiveValue :: ObjectiveFunction -> ObjectiveResult -> Maybe SimplexNu extractObjectiveValue objFunction (ObjectiveResult _ outcome) = case outcome of Unbounded -> Nothing - Optimal varVals -> + Optimal varVals -> let coeffs = case objFunction of Max m -> m Min m -> m - in Just $ sum $ map (\(var, coeff) -> coeff * Map.findWithDefault 0 var varVals) (Map.toList coeffs) + in Just $ sum $ map (\(var, coeff) -> coeff * Map.findWithDefault 0 var varVals) (Map.toList coeffs) -- | Combines two 'VarLitMapSums together by summing values with matching keys combineVarLitMapSums :: VarLitMapSum -> VarLitMapSum -> VarLitMapSum diff --git a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs index acb4124..122e7e8 100644 --- a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs +++ b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Linear.Simplex.Solver.TwoPhaseSpec where import Prelude hiding (EQ) import Control.Monad.IO.Class import Control.Monad.Logger -import Data.Maybe (isJust) import qualified Data.Map as M -import qualified Data.Set as Set +import Data.Maybe (isJust) import Data.Ratio +import qualified Data.Set as Set import Text.InterpolatedString.Perl6 @@ -30,13 +31,13 @@ computeObjValue (Max coeffs) varMap = sum [c * M.findWithDefault 0 v varMap | (v computeObjValue (Min coeffs) varMap = sum [c * M.findWithDefault 0 v varMap | (v, c) <- M.toList coeffs] -- | Expected result for a single objective optimization -data ExpectedResult - = ExpectInfeasible - -- ^ System has no feasible solution - | ExpectUnbounded - -- ^ System is feasible but unbounded (no finite optimum) - | ExpectOptimal (Maybe SimplexNum) VarLitMap - -- ^ Optimal solution found with optional expected objective value and variable values +data ExpectedResult + = -- | System has no feasible solution + ExpectInfeasible + | -- | System is feasible but unbounded (no finite optimum) + ExpectUnbounded + | -- | Optimal solution found with optional expected objective value and variable values + ExpectOptimal (Maybe SimplexNum) VarLitMap deriving (Show, Eq) -- | Helper to run a test case for a system where all vars @@ -49,11 +50,11 @@ runTest (obj, constraints) expectedResult = do domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars SimplexResult mFeasibleSystem objResults <- runStdoutLoggingT $ - filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap [obj] constraints + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints let actualResult = case (mFeasibleSystem, objResults) of (Nothing, _) -> ExpectInfeasible - (Just _, []) -> ExpectInfeasible -- Should not happen with one objective + (Just _, []) -> ExpectInfeasible -- Should not happen with one objective (Just _, [ObjectiveResult _ Unbounded]) -> ExpectUnbounded (Just _, [ObjectiveResult _ (Optimal varVals)]) -> ExpectOptimal Nothing varVals (Just _, _) -> error "Unexpected: multiple results for single objective" @@ -96,7 +97,8 @@ spec = do it "Max 3x₁ + 5x₂ with LEQ constraints: obj=29, x₁=3, x₂=4" $ do let testCase = ( Max (M.fromList [(1, 3), (2, 5)]) - , [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 + , + [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 , LEQ (M.fromList [(1, 1), (2, 1)]) 7 , LEQ (M.fromList [(2, 1)]) 4 , LEQ (M.fromList [(1, -1), (2, 2)]) 6 @@ -107,7 +109,8 @@ spec = do it "Min 3x₁ + 5x₂ with LEQ constraints: obj=0" $ do let testCase = ( Min (M.fromList [(1, 3), (2, 5)]) - , [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 + , + [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 , LEQ (M.fromList [(1, 1), (2, 1)]) 7 , LEQ (M.fromList [(2, 1)]) 4 , LEQ (M.fromList [(1, -1), (2, 2)]) 6 @@ -118,7 +121,8 @@ spec = do it "Max 3x₁ + 5x₂ with GEQ constraints: unbounded" $ do let testCase = ( Max (M.fromList [(1, 3), (2, 5)]) - , [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 + , + [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 , GEQ (M.fromList [(1, 1), (2, 1)]) 7 , GEQ (M.fromList [(2, 1)]) 4 , GEQ (M.fromList [(1, -1), (2, 2)]) 6 @@ -129,7 +133,8 @@ spec = do it "Min 3x₁ + 5x₂ with GEQ constraints: obj=237/7, x₁=24/7, x₂=33/7" $ do let testCase = ( Min (M.fromList [(1, 3), (2, 5)]) - , [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 + , + [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 , GEQ (M.fromList [(1, 1), (2, 1)]) 7 , GEQ (M.fromList [(2, 1)]) 4 , GEQ (M.fromList [(1, -1), (2, 2)]) 6 @@ -142,7 +147,8 @@ spec = do it "Max x₁ - x₂ + x₃ with LEQ constraints: obj=3/5, x₂=14/5, x₃=17/5" $ do let testCase = ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) - , [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , + [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] @@ -152,7 +158,8 @@ spec = do it "Min x₁ - x₂ + x₃ with LEQ constraints: unbounded" $ do let testCase = ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) - , [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , + [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] @@ -162,7 +169,8 @@ spec = do it "Max x₁ - x₂ + x₃ with GEQ constraints: obj=1, x₁=3, x₂=2" $ do let testCase = ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) - , [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , + [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] @@ -172,7 +180,8 @@ spec = do it "Min x₁ - x₂ + x₃ with GEQ constraints: obj=-1/4, x₁=17/4, x₂=9/2" $ do let testCase = ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) - , [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , + [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) ] @@ -184,7 +193,8 @@ spec = do it "Min x₁ + x₂ + 2x₃ + x₄ with EQ constraints: obj=5, x₃=2, x₄=1" $ do let testCase = ( Min (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) - , [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 + , + [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 ] ) @@ -193,7 +203,8 @@ spec = do it "Max x₁ + x₂ + 2x₃ + x₄ with EQ constraints: obj=8, x₁=2, x₂=6" $ do let testCase = ( Max (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) - , [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 + , + [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 ] ) @@ -204,7 +215,8 @@ spec = do it "Max -2x₃ + 2x₄ + x₅ with EQ constraints: obj=20, x₃=6, x₄=16" $ do let testCase = ( Max (M.fromList [(3, -2), (4, 2), (5, 1)]) - , [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 + , + [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 ] ) @@ -213,7 +225,8 @@ spec = do it "Min -2x₃ + 2x₄ + x₅ with EQ constraints: obj=6, x₄=2, x₅=2" $ do let testCase = ( Min (M.fromList [(3, -2), (4, 2), (5, 1)]) - , [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 + , + [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 ] ) @@ -224,7 +237,8 @@ spec = do it "Max 2x₁ + x₂: obj=150, x₂=150" $ do let testCase = ( Max (M.fromList [(1, 2), (2, 1)]) - , [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 + , + [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) @@ -233,7 +247,8 @@ spec = do it "Min 2x₁ + x₂: obj=40/3, x₂=40/3" $ do let testCase = ( Min (M.fromList [(1, 2), (2, 1)]) - , [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 + , + [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) @@ -242,7 +257,8 @@ spec = do it "Max 2x₁ + x₂ with GEQ constraints: unbounded" $ do let testCase = ( Max (M.fromList [(1, 2), (2, 1)]) - , [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 + , + [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) @@ -251,7 +267,8 @@ spec = do it "Min 2x₁ + x₂ with GEQ constraints: obj=75, x₁=75/2" $ do let testCase = ( Min (M.fromList [(1, 2), (2, 1)]) - , [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 + , + [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) ] ) @@ -262,7 +279,8 @@ spec = do it "Min -6x₁ - 4x₂ + 2x₃: obj=-120, x₁=20" $ do let testCase = ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) - , [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , + [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 , LEQ (M.fromList [(2, -5), (3, 5)]) 100 , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] @@ -272,7 +290,8 @@ spec = do it "Max -6x₁ - 4x₂ + 2x₃: obj=10, x₃=5" $ do let testCase = ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) - , [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , + [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 , LEQ (M.fromList [(2, -5), (3, 5)]) 100 , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] @@ -282,7 +301,8 @@ spec = do it "Min -6x₁ - 4x₂ + 2x₃ with GEQ constraints: unbounded" $ do let testCase = ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) - , [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , + [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 , GEQ (M.fromList [(2, -5), (3, 5)]) 100 , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] @@ -292,7 +312,8 @@ spec = do it "Max -6x₁ - 4x₂ + 2x₃ with GEQ constraints: unbounded" $ do let testCase = ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) - , [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , + [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 , GEQ (M.fromList [(2, -5), (3, 5)]) 100 , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 ] @@ -304,7 +325,8 @@ spec = do it "Max 3x₁ + 5x₂ + 2x₃: obj=250, x₂=50" $ do let testCase = ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) - , [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , + [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] @@ -314,7 +336,8 @@ spec = do it "Min 3x₁ + 5x₂ + 2x₃: obj=0" $ do let testCase = ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) - , [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , + [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] @@ -324,7 +347,8 @@ spec = do it "Max 3x₁ + 5x₂ + 2x₃ with GEQ constraints: unbounded" $ do let testCase = ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) - , [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , + [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] @@ -334,7 +358,8 @@ spec = do it "Min 3x₁ + 5x₂ + 2x₃ with GEQ constraints: obj=300, x₃=150" $ do let testCase = ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) - , [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , + [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 ] @@ -345,7 +370,8 @@ spec = do it "Max x₁ with x₁ <= 15: obj=15, x₁=15" $ do let testCase = ( Max (M.fromList [(1, 1)]) - , [ LEQ (M.fromList [(1, 1)]) 15 + , + [ LEQ (M.fromList [(1, 1)]) 15 ] ) runTest testCase (ExpectOptimal (Just 15) (M.fromList [(1, 15)])) @@ -353,7 +379,8 @@ spec = do it "Max 2x₁ with mixed constraints: obj=20, x₁=10, x₂=10" $ do let testCase = ( Max (M.fromList [(1, 2)]) - , [ LEQ (M.fromList [(1, 2)]) 20 + , + [ LEQ (M.fromList [(1, 2)]) 20 , GEQ (M.fromList [(2, 1)]) 10 ] ) @@ -362,7 +389,8 @@ spec = do it "Min x₁ with x₁ <= 15: obj=0" $ do let testCase = ( Min (M.fromList [(1, 1)]) - , [ LEQ (M.fromList [(1, 1)]) 15 + , + [ LEQ (M.fromList [(1, 1)]) 15 ] ) runTest testCase (ExpectOptimal (Just 0) M.empty) @@ -370,7 +398,8 @@ spec = do it "Min 2x₁ with mixed constraints: obj=0, x₂=10" $ do let testCase = ( Min (M.fromList [(1, 2)]) - , [ LEQ (M.fromList [(1, 2)]) 20 + , + [ LEQ (M.fromList [(1, 2)]) 20 , GEQ (M.fromList [(2, 1)]) 10 ] ) @@ -380,7 +409,8 @@ spec = do it "Conflicting bounds x₁ <= 15 and x₁ >= 15.01: infeasible" $ do let testCase = ( Max (M.fromList [(1, 1)]) - , [ LEQ (M.fromList [(1, 1)]) 15 + , + [ LEQ (M.fromList [(1, 1)]) 15 , GEQ (M.fromList [(1, 1)]) 15.01 ] ) @@ -389,7 +419,8 @@ spec = do it "Conflicting bounds with additional constraint: infeasible" $ do let testCase = ( Max (M.fromList [(1, 1)]) - , [ LEQ (M.fromList [(1, 1)]) 15 + , + [ LEQ (M.fromList [(1, 1)]) 15 , GEQ (M.fromList [(1, 1)]) 15.01 , GEQ (M.fromList [(2, 1)]) 10 ] @@ -399,7 +430,8 @@ spec = do it "Min x₁ with duplicate GEQ constraints: obj=0, x₂=1" $ do let testCase = ( Min (M.fromList [(1, 1)]) - , [ GEQ (M.fromList [(1, 1), (2, 1)]) 1 + , + [ GEQ (M.fromList [(1, 1), (2, 1)]) 1 , GEQ (M.fromList [(1, 1), (2, 1)]) 1 ] ) @@ -408,7 +440,8 @@ spec = do it "Conflicting x₁+x₂ >= 2 and x₁+x₂ <= 1: infeasible" $ do let testCase = ( Min (M.fromList [(1, 1)]) - , [ GEQ (M.fromList [(1, 1), (2, 1)]) 2 + , + [ GEQ (M.fromList [(1, 1), (2, 1)]) 2 , LEQ (M.fromList [(1, 1), (2, 1)]) 1 ] ) @@ -418,7 +451,8 @@ spec = do it "testLeqGeqBugMin1: obj=3, x₁=3, x₂=3" $ do let testCase = ( Min (M.fromList [(1, 1)]) - , [ GEQ (M.fromList [(1, 1)]) 3 + , + [ GEQ (M.fromList [(1, 1)]) 3 , LEQ (M.fromList [(1, 1)]) 3 , GEQ (M.fromList [(2, 1)]) 3 , LEQ (M.fromList [(2, 1)]) 3 @@ -429,7 +463,8 @@ spec = do it "testLeqGeqBugMax1: obj=3, x₁=3, x₂=3" $ do let testCase = ( Min (M.fromList [(1, 1)]) - , [ GEQ (M.fromList [(1, 1)]) 3 + , + [ GEQ (M.fromList [(1, 1)]) 3 , LEQ (M.fromList [(1, 1)]) 3 , GEQ (M.fromList [(2, 1)]) 3 , LEQ (M.fromList [(2, 1)]) 3 @@ -440,7 +475,8 @@ spec = do it "testLeqGeqBugMin2: obj=3, x₁=3, x₂=3" $ do let testCase = ( Min (M.fromList [(1, 1)]) - , [ GEQ (M.fromList [(1, 1)]) 3 + , + [ GEQ (M.fromList [(1, 1)]) 3 , LEQ (M.fromList [(1, 1)]) 3 , GEQ (M.fromList [(2, 1)]) 3 , LEQ (M.fromList [(2, 1)]) 3 @@ -451,7 +487,8 @@ spec = do it "testLeqGeqBugMax2: obj=3, x₁=3, x₂=3" $ do let testCase = ( Min (M.fromList [(1, 1)]) - , [ GEQ (M.fromList [(1, 1)]) 3 + , + [ GEQ (M.fromList [(1, 1)]) 3 , LEQ (M.fromList [(1, 1)]) 3 , GEQ (M.fromList [(2, 1)]) 3 , LEQ (M.fromList [(2, 1)]) 3 @@ -461,12 +498,20 @@ spec = do -- PolyPaver-style tests with shared parameters describe "PolyPaver-style tests (feasible region [0,2.5]²)" $ do - let x1l = 0.0; x1r = 2.5; x2l = 0.0; x2r = 2.5 - dx1l = -1; dx1r = -0.9; dx2l = -0.9; dx2r = -0.8 - yl = 4; yr = 5 + let x1l = 0.0 + x1r = 2.5 + x2l = 0.0 + x2r = 2.5 + dx1l = -1 + dx1r = -0.9 + dx2l = -0.9 + dx2r = -0.8 + yl = 4 + yr = 5 mkConstraints obj = ( obj - , [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r @@ -477,28 +522,40 @@ spec = do ) it "Min x₁: x₁=7/4, x₂=5/2" $ do - runTest (mkConstraints (Min (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (7 % 4)) (M.fromList [(1, 7 % 4), (2, 5 % 2), (3, 0)])) + runTest + (mkConstraints (Min (M.fromList [(1, 1)]))) + (ExpectOptimal (Just (7 % 4)) (M.fromList [(1, 7 % 4), (2, 5 % 2), (3, 0)])) it "Max x₁: x₁=5/2, x₂=5/3" $ do - runTest (mkConstraints (Max (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (5 % 2)) (M.fromList [(1, 5 % 2), (2, 5 % 3), (3, 0)])) + runTest + (mkConstraints (Max (M.fromList [(1, 1)]))) + (ExpectOptimal (Just (5 % 2)) (M.fromList [(1, 5 % 2), (2, 5 % 3), (3, 0)])) it "Min x₂: x₂=5/3" $ do - runTest (mkConstraints (Min (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (5 % 3)) (M.fromList [(2, 5 % 3), (1, 5 % 2), (3, 0)])) + runTest + (mkConstraints (Min (M.fromList [(2, 1)]))) + (ExpectOptimal (Just (5 % 3)) (M.fromList [(2, 5 % 3), (1, 5 % 2), (3, 0)])) it "Max x₂: x₂=5/2" $ do - runTest (mkConstraints (Max (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (5 % 2)) (M.fromList [(2, 5 % 2), (1, 5 % 2), (3, 0)])) + runTest + (mkConstraints (Max (M.fromList [(2, 1)]))) + (ExpectOptimal (Just (5 % 2)) (M.fromList [(2, 5 % 2), (1, 5 % 2), (3, 0)])) describe "PolyPaver-style tests (infeasible region [0,1.5]²)" $ do - let x1l = 0.0; x1r = 1.5; x2l = 0.0; x2r = 1.5 - dx1l = -1; dx1r = -0.9; dx2l = -0.9; dx2r = -0.8 - yl = 4; yr = 5 + let x1l = 0.0 + x1r = 1.5 + x2l = 0.0 + x2r = 1.5 + dx1l = -1 + dx1r = -0.9 + dx2l = -0.9 + dx2r = -0.8 + yl = 4 + yr = 5 mkConstraints obj = ( obj - , [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r @@ -521,12 +578,20 @@ spec = do runTest (mkConstraints (Min (M.fromList [(2, 1)]))) ExpectInfeasible describe "PolyPaver-style tests (feasible region [0,3.5]²)" $ do - let x1l = 0.0; x1r = 3.5; x2l = 0.0; x2r = 3.5 - dx1l = -1; dx1r = -0.9; dx2l = -0.9; dx2r = -0.8 - yl = 4; yr = 5 + let x1l = 0.0 + x1r = 3.5 + x2l = 0.0 + x2r = 3.5 + dx1l = -1 + dx1r = -0.9 + dx2l = -0.9 + dx2r = -0.8 + yl = 4 + yr = 5 mkConstraints obj = ( obj - , [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) + , + [ LEQ (M.fromList [(1, dx1l), (2, dx2l), (3, (-1))]) (-yl + dx1l * x1l + dx2l * x2l) , GEQ (M.fromList [(1, dx1r), (2, dx2r), (3, (-1))]) (-yr + dx1r * x1l + dx2r * x2l) , GEQ (M.fromList [(1, 1)]) x1l , LEQ (M.fromList [(1, 1)]) x1r @@ -537,30 +602,46 @@ spec = do ) it "Max x₁: x₁=7/2" $ do - runTest (mkConstraints (Max (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (7 % 2)) (M.fromList [(2, 5 % 9), (1, 7 % 2), (3, 0)])) + runTest + (mkConstraints (Max (M.fromList [(1, 1)]))) + (ExpectOptimal (Just (7 % 2)) (M.fromList [(2, 5 % 9), (1, 7 % 2), (3, 0)])) it "Min x₁: x₁=17/20" $ do - runTest (mkConstraints (Min (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (17 % 20)) (M.fromList [(1, 17 % 20), (2, 7 % 2), (3, 0)])) + runTest + (mkConstraints (Min (M.fromList [(1, 1)]))) + (ExpectOptimal (Just (17 % 20)) (M.fromList [(1, 17 % 20), (2, 7 % 2), (3, 0)])) it "Max x₂: x₂=7/2" $ do - runTest (mkConstraints (Max (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (7 % 2)) (M.fromList [(2, 7 % 2), (1, 22 % 9)])) + runTest + (mkConstraints (Max (M.fromList [(2, 1)]))) + (ExpectOptimal (Just (7 % 2)) (M.fromList [(2, 7 % 2), (1, 22 % 9)])) it "Min x₂: x₂=5/9" $ do - runTest (mkConstraints (Min (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (5 % 9)) (M.fromList [(2, 5 % 9), (1, 7 % 2), (3, 0)])) + runTest + (mkConstraints (Min (M.fromList [(2, 1)]))) + (ExpectOptimal (Just (5 % 9)) (M.fromList [(2, 5 % 9), (1, 7 % 2), (3, 0)])) describe "PolyPaver two-function tests (infeasible)" $ do - let x1l = 0.0; x1r = 2.5; x2l = 0.0; x2r = 2.5 - f1dx1l = -1; f1dx1r = -0.9; f1dx2l = -0.9; f1dx2r = -0.8 - f1yl = 4; f1yr = 5 - f2dx1l = -1; f2dx1r = -0.9; f2dx2l = -0.9; f2dx2r = -0.8 - f2yl = 1; f2yr = 2 + let x1l = 0.0 + x1r = 2.5 + x2l = 0.0 + x2r = 2.5 + f1dx1l = -1 + f1dx1r = -0.9 + f1dx2l = -0.9 + f1dx2r = -0.8 + f1yl = 4 + f1yr = 5 + f2dx1l = -1 + f2dx1r = -0.9 + f2dx2l = -0.9 + f2dx2r = -0.8 + f2yl = 1 + f2yr = 2 mkConstraints obj = ( obj - , [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , + [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) @@ -586,14 +667,26 @@ spec = do runTest (mkConstraints (Min (M.fromList [(2, 1)]))) ExpectInfeasible describe "PolyPaver two-function tests (feasible)" $ do - let x1l = 0.0; x1r = 2.5; x2l = 0.0; x2r = 2.5 - f1dx1l = -1; f1dx1r = -0.9; f1dx2l = -0.9; f1dx2r = -0.8 - f1yl = 4; f1yr = 5 - f2dx1l = -0.66; f2dx1r = -0.66; f2dx2l = -0.66; f2dx2r = -0.66 - f2yl = 3; f2yr = 4 + let x1l = 0.0 + x1r = 2.5 + x2l = 0.0 + x2r = 2.5 + f1dx1l = -1 + f1dx1r = -0.9 + f1dx2l = -0.9 + f1dx2r = -0.8 + f1yl = 4 + f1yr = 5 + f2dx1l = -0.66 + f2dx1r = -0.66 + f2dx2l = -0.66 + f2dx2r = -0.66 + f2yl = 3 + f2yr = 4 mkConstraints obj = ( obj - , [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) + , + [ LEQ (M.fromList [(1, f1dx1l), (2, f1dx2l), (3, (-1))]) (-f1yl + f1dx1l * x1l + f1dx2l * x2l) , GEQ (M.fromList [(1, f1dx1r), (2, f1dx2r), (3, (-1))]) (-f1yr + f1dx1r * x1l + f1dx2r * x2l) , LEQ (M.fromList [(1, f2dx1l), (2, f2dx2l), (4, (-1))]) (-f2yl + f2dx1l * x1l + f2dx2l * x2l) , GEQ (M.fromList [(1, f2dx1r), (2, f2dx2r), (4, (-1))]) (-f2yr + f2dx1r * x1l + f2dx2r * x2l) @@ -607,26 +700,31 @@ spec = do ) it "Max x₁: x₁=5/2" $ do - runTest (mkConstraints (Max (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (5 % 2)) (M.fromList [(1, 5 % 2), (2, 45 % 22), (4, 0)])) + runTest + (mkConstraints (Max (M.fromList [(1, 1)]))) + (ExpectOptimal (Just (5 % 2)) (M.fromList [(1, 5 % 2), (2, 45 % 22), (4, 0)])) it "Min x₁: x₁=45/22" $ do - runTest (mkConstraints (Min (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (45 % 22)) (M.fromList [(1, 45 % 22), (2, 5 % 2), (4, 0)])) + runTest + (mkConstraints (Min (M.fromList [(1, 1)]))) + (ExpectOptimal (Just (45 % 22)) (M.fromList [(1, 45 % 22), (2, 5 % 2), (4, 0)])) it "Max x₂: x₂=5/2" $ do - runTest (mkConstraints (Max (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (5 % 2)) (M.fromList [(2, 5 % 2), (1, 5 % 2), (4, 0)])) + runTest + (mkConstraints (Max (M.fromList [(2, 1)]))) + (ExpectOptimal (Just (5 % 2)) (M.fromList [(2, 5 % 2), (1, 5 % 2), (4, 0)])) it "Min x₂: x₂=45/22" $ do - runTest (mkConstraints (Min (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (45 % 22)) (M.fromList [(2, 45 % 22), (1, 5 % 2), (4, 0)])) + runTest + (mkConstraints (Min (M.fromList [(2, 1)]))) + (ExpectOptimal (Just (45 % 22)) (M.fromList [(2, 45 % 22), (1, 5 % 2), (4, 0)])) describe "QuickCheck-generated regression tests" $ do it "testQuickCheck1: obj=-370, x₁=5/3, x₂=26" $ do let testCase = ( Max (M.fromList [(1, 12), (2, -15)]) - , [ EQ (M.fromList [(1, 24), (2, -2)]) (-12) + , + [ EQ (M.fromList [(1, 24), (2, -2)]) (-12) , GEQ (M.fromList [(1, -20), (2, 11)]) (-7) , GEQ (M.fromList [(1, -28), (2, 5)]) (-8) , GEQ (M.fromList [(1, 3), (2, 0)]) 5 @@ -638,7 +736,8 @@ spec = do it "testQuickCheck2: obj=-2/9, x₁=14/9, x₂=8/9" $ do let testCase = ( Max (M.fromList [(1, -3), (2, 5)]) - , [ LEQ (M.fromList [(1, -6), (2, 6)]) 4 + , + [ LEQ (M.fromList [(1, -6), (2, 6)]) 4 , LEQ (M.fromList [(1, 1), (2, -4), (3, 3)]) (-2) , LEQ (M.fromList [(2, 7), (1, -4)]) 0 ] @@ -648,7 +747,8 @@ spec = do it "testQuickCheck3 (tests objective simplification): obj=-8, x₂=2" $ do let testCase = ( Min (M.fromList [(2, 0), (2, -4)]) - , [ GEQ (M.fromList [(1, 5), (2, 4)]) (-4) + , + [ GEQ (M.fromList [(1, 5), (2, 4)]) (-4) , LEQ (M.fromList [(1, -1), (2, -1)]) 2 , LEQ (M.fromList [(2, 1)]) 2 , GEQ (M.fromList [(1, -5), (2, -1), (2, 1)]) (-5) @@ -659,7 +759,7 @@ spec = do describe "twoPhaseSimplex (with VarDomainMap)" $ do it "Shift transformation with negative lower bound" $ do let obj = Max (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] + constraints = [LEQ (M.fromList [(1, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ @@ -672,7 +772,7 @@ spec = do it "Shift transformation finds minimum at negative bound" $ do let obj = Min (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) 0 ] + constraints = [LEQ (M.fromList [(1, 1)]) 0] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ @@ -685,7 +785,7 @@ spec = do it "Split transformation for unbounded variable (max)" $ do let obj = Max (M.fromList [(1, 1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1)]) 10 , GEQ (M.fromList [(1, 1)]) (-10) ] @@ -701,7 +801,7 @@ spec = do it "Split transformation for unbounded variable (min)" $ do let obj = Min (M.fromList [(1, 1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1)]) 10 , GEQ (M.fromList [(1, 1)]) (-10) ] @@ -717,7 +817,7 @@ spec = do it "AddLowerBound with positive lower bound" $ do let obj = Max (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] + constraints = [LEQ (M.fromList [(1, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 5)] actualResult <- runStdoutLoggingT $ @@ -730,7 +830,7 @@ spec = do it "AddLowerBound finds minimum at positive bound" $ do let obj = Min (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] + constraints = [LEQ (M.fromList [(1, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 5)] actualResult <- runStdoutLoggingT $ @@ -743,7 +843,7 @@ spec = do it "Mixed domain types" $ do let obj = Max (M.fromList [(1, 1), (2, 1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1), (2, 1)]) 5 , GEQ (M.fromList [(2, 1)]) (-3) ] @@ -764,7 +864,7 @@ spec = do it "lowerBoundOnly 0 is equivalent to NonNegative" $ do let obj = Max (M.fromList [(1, 3), (2, 5)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 , LEQ (M.fromList [(1, 1), (2, 1)]) 7 , LEQ (M.fromList [(2, 1)]) 4 @@ -782,14 +882,16 @@ spec = do twoPhaseSimplex domainMap2 [obj] constraints -- Both should produce the same optimal solution with x₁=3, x₂=4 case (actualResult1, actualResult2) of - (SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap1)], SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap2)]) -> do - varMap1 `shouldBe` M.fromList [(1, 3), (2, 4)] - varMap1 `shouldBe` varMap2 + ( SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap1)] + , SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap2)] + ) -> do + varMap1 `shouldBe` M.fromList [(1, 3), (2, 4)] + varMap1 `shouldBe` varMap2 _ -> expectationFailure "Expected optimal results" it "Infeasible system with domain constraint" $ do let obj = Max (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] + constraints = [LEQ (M.fromList [(1, 1)]) 5] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 10)] actualResult <- runStdoutLoggingT $ @@ -824,7 +926,7 @@ spec = do twoPhaseSimplex domainMap [obj] constraints case actualResult of SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" - SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> -- Note: non-basic variables with value 0 may not appear in varValMap M.findWithDefault 0 1 varMap `shouldBe` 0 _ -> expectationFailure "Unexpected result format" @@ -906,7 +1008,7 @@ spec = do -- x₁ ≥ 0, x₂ ≤ 10 (no lower bound) -- Max x₁ + x₂ with x₁ + x₂ ≤ 20 let obj = Max (M.fromList [(1, 1), (2, 1)]) - constraints = [ LEQ (M.fromList [(1, 1), (2, 1)]) 20 ] + constraints = [LEQ (M.fromList [(1, 1), (2, 1)]) 20] domainMap = VarDomainMap $ M.fromList [(1, nonNegative), (2, upperBoundOnly 10)] actualResult <- runStdoutLoggingT $ @@ -928,7 +1030,7 @@ spec = do -- Simple case: maximize x with upper bound 5 and lower bound -3 -- Optimal should be at x₁ = 5 let obj = Max (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] + constraints = [LEQ (M.fromList [(1, 1)]) 5] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-3))] actualResult <- runStdoutLoggingT $ @@ -943,7 +1045,7 @@ spec = do -- Minimize x with upper bound 5 and lower bound -3 -- Optimal should be at x₁ = -3 let obj = Min (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] + constraints = [LEQ (M.fromList [(1, 1)]) 5] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-3))] actualResult <- runStdoutLoggingT $ @@ -957,7 +1059,7 @@ spec = do it "Max x₁ with x₁ ≥ -10, x₁ ≤ -2: optimal at x₁=-2" $ do -- Both bounds are negative, maximize let obj = Max (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) (-2) ] + constraints = [LEQ (M.fromList [(1, 1)]) (-2)] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-10))] actualResult <- runStdoutLoggingT $ @@ -971,7 +1073,7 @@ spec = do it "Min x₁ with x₁ ≥ -10, x₁ ≤ -2: optimal at x₁=-10" $ do -- Both bounds are negative, minimize let obj = Min (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) (-2) ] + constraints = [LEQ (M.fromList [(1, 1)]) (-2)] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-10))] actualResult <- runStdoutLoggingT $ @@ -990,7 +1092,7 @@ spec = do -- Optimal in transformed space: x₁' + x₂' = 15 -- After unapply: x₁ + x₂ = 15 - 5 = 10 let obj = Max (M.fromList [(1, 1), (2, 1)]) - constraints = [ LEQ (M.fromList [(1, 1), (2, 1)]) 10 ] + constraints = [LEQ (M.fromList [(1, 1), (2, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-2)), (2, lowerBoundOnly (-3))] actualResult <- runStdoutLoggingT $ @@ -1013,7 +1115,7 @@ spec = do -- Minimize sum with lower bounds -2 and -3 -- Optimal: x₁ = -2, x₂ = -3, sum = -5 let obj = Min (M.fromList [(1, 1), (2, 1)]) - constraints = [ LEQ (M.fromList [(1, 1), (2, 1)]) 10 ] + constraints = [LEQ (M.fromList [(1, 1), (2, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-2)), (2, lowerBoundOnly (-3))] actualResult <- runStdoutLoggingT $ @@ -1033,7 +1135,7 @@ spec = do -- Maximize 2x₁ - x₂: want x₁ large (up to 3) and x₂ small (down to -4) -- Optimal: x₁ = 3, x₂ = -4, obj = 2*3 - (-4) = 10 let obj = Max (M.fromList [(1, 2), (2, -1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1)]) 3 , LEQ (M.fromList [(2, 1)]) 6 ] @@ -1057,7 +1159,7 @@ spec = do -- Minimize 2x₁ - x₂: want x₁ small (down to -5) and x₂ large (up to 6) -- Optimal: x₁ = -5, x₂ = 6, obj = 2*(-5) - 6 = -16 let obj = Min (M.fromList [(1, 2), (2, -1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1)]) 3 , LEQ (M.fromList [(2, 1)]) 6 ] @@ -1083,7 +1185,7 @@ spec = do -- Without upper bound, this is unbounded for Max -- Add an upper bound via another constraint let obj = Max (M.fromList [(1, 1)]) - constraints = + constraints = [ GEQ (M.fromList [(1, 1)]) 2 , LEQ (M.fromList [(1, 1)]) 10 ] @@ -1100,7 +1202,7 @@ spec = do it "Min x₁ with x₁ ≥ -5, x₁ ≥ 2 (GEQ tightens bound)" $ do -- Minimize with GEQ 2, so minimum is at x₁ = 2 let obj = Min (M.fromList [(1, 1)]) - constraints = + constraints = [ GEQ (M.fromList [(1, 1)]) 2 , LEQ (M.fromList [(1, 1)]) 10 ] @@ -1115,11 +1217,11 @@ spec = do _ -> expectationFailure "Unexpected result format" describe "Systems with EQ constraints and negative bounds" $ do - it "Max x₁ + x₂ with x₁ - x₂ = 0, x₁ ≥ -5, x₂ ≥ -5, x₁ ≤ 10" $ do + it "Max x₁ + x₂ with x₁ - x₂ = 0, x₁ ≥ -5, x₂ ≥ -5, x₁ ≤ 10" $ do -- x₁ = x₂, maximize x₁ + x₂ = 2x₁ -- With x₁ ≤ 10, optimal is x₁ = x₂ = 10, obj = 20 let obj = Max (M.fromList [(1, 1), (2, 1)]) - constraints = + constraints = [ EQ (M.fromList [(1, 1), (2, -1)]) 0 , LEQ (M.fromList [(1, 1)]) 10 ] @@ -1142,7 +1244,7 @@ spec = do -- x₁ = x₂, minimize x₁ + x₂ = 2x₁ -- Lower bound is -5, so optimal is x₁ = x₂ = -5, obj = -10 let obj = Min (M.fromList [(1, 1), (2, 1)]) - constraints = + constraints = [ EQ (M.fromList [(1, 1), (2, -1)]) 0 , LEQ (M.fromList [(1, 1)]) 10 ] @@ -1164,7 +1266,7 @@ spec = do describe "Fractional negative bounds" $ do it "Max x₁ with x₁ ≥ -7/2, x₁ ≤ 5/2" $ do let obj = Max (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) (5 % 2) ] + constraints = [LEQ (M.fromList [(1, 1)]) (5 % 2)] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly ((-7) % 2))] actualResult <- runStdoutLoggingT $ @@ -1177,7 +1279,7 @@ spec = do it "Min x₁ with x₁ ≥ -7/2, x₁ ≤ 5/2" $ do let obj = Min (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) (5 % 2) ] + constraints = [LEQ (M.fromList [(1, 1)]) (5 % 2)] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly ((-7) % 2))] actualResult <- runStdoutLoggingT $ @@ -1193,7 +1295,7 @@ spec = do it "Max x₁ with -10 ≤ x₁ ≤ 10 (unbounded var with box constraints)" $ do -- x₁ is unbounded but constrained by -10 ≤ x₁ ≤ 10 let obj = Max (M.fromList [(1, 1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1)]) 10 , GEQ (M.fromList [(1, 1)]) (-10) ] @@ -1209,7 +1311,7 @@ spec = do it "Min x₁ with -10 ≤ x₁ ≤ 10 (unbounded var with box constraints)" $ do let obj = Min (M.fromList [(1, 1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1)]) 10 , GEQ (M.fromList [(1, 1)]) (-10) ] @@ -1227,7 +1329,7 @@ spec = do -- x₁ unbounded, only x₁ ≤ 5, minimize x₁ -- This should be unbounded (no finite solution) since x₁ can go to -∞ let obj = Min (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) 5 ] + constraints = [LEQ (M.fromList [(1, 1)]) 5] domainMap = VarDomainMap $ M.fromList [(1, unbounded)] actualResult <- runStdoutLoggingT $ @@ -1241,7 +1343,7 @@ spec = do describe "Two variable systems with unbounded variables" $ do it "Max x₁ + x₂ with unbounded vars, -5 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 7" $ do let obj = Max (M.fromList [(1, 1), (2, 1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1)]) 5 , GEQ (M.fromList [(1, 1)]) (-5) , LEQ (M.fromList [(2, 1)]) 7 @@ -1263,7 +1365,7 @@ spec = do it "Min x₁ + x₂ with unbounded vars, -5 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 7" $ do let obj = Min (M.fromList [(1, 1), (2, 1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1)]) 5 , GEQ (M.fromList [(1, 1)]) (-5) , LEQ (M.fromList [(2, 1)]) 7 @@ -1286,7 +1388,7 @@ spec = do it "Max x₁ - x₂ with unbounded vars: x₁ up, x₂ down" $ do -- Maximize x₁ - x₂: want x₁ large (5) and x₂ small (-3) let obj = Max (M.fromList [(1, 1), (2, -1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1)]) 5 , GEQ (M.fromList [(1, 1)]) (-5) , LEQ (M.fromList [(2, 1)]) 7 @@ -1311,7 +1413,7 @@ spec = do -- x₁ + x₂ = 10, x₂ ≥ -5, unbounded x₁ -- Maximize x₁: make x₂ as small as possible (-5), so x₁ = 15 let obj = Max (M.fromList [(1, 1)]) - constraints = + constraints = [ EQ (M.fromList [(1, 1), (2, 1)]) 10 , GEQ (M.fromList [(2, 1)]) (-5) ] @@ -1331,7 +1433,7 @@ spec = do -- x₁ + x₂ = 10, x₂ ≤ 20, unbounded x₁ -- Minimize x₁: make x₂ as large as possible (20), so x₁ = -10 let obj = Min (M.fromList [(1, 1)]) - constraints = + constraints = [ EQ (M.fromList [(1, 1), (2, 1)]) 10 , LEQ (M.fromList [(2, 1)]) 20 ] @@ -1353,15 +1455,17 @@ spec = do -- x₁ non-negative, x₂ has lower bound -5, x₃ unbounded -- All constrained by sum ≤ 20 and individual bounds let obj = Max (M.fromList [(1, 1), (2, 1), (3, 1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) 20 , LEQ (M.fromList [(1, 1)]) 10 , LEQ (M.fromList [(2, 1)]) 8 , LEQ (M.fromList [(3, 1)]) 15 , GEQ (M.fromList [(3, 1)]) (-10) ] - domainMap = VarDomainMap $ M.fromList - [(1, nonNegative), (2, lowerBoundOnly (-5)), (3, unbounded)] + domainMap = + VarDomainMap $ + M.fromList + [(1, nonNegative), (2, lowerBoundOnly (-5)), (3, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1377,15 +1481,17 @@ spec = do it "Min x₁ + x₂ + x₃ with x₁ ≥ 0, x₂ ≥ -5, x₃ unbounded, sum ≥ -10" $ do -- Minimize sum with lower bound constraint let obj = Min (M.fromList [(1, 1), (2, 1), (3, 1)]) - constraints = + constraints = [ GEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) (-10) , LEQ (M.fromList [(1, 1)]) 10 , LEQ (M.fromList [(2, 1)]) 8 , LEQ (M.fromList [(3, 1)]) 15 , GEQ (M.fromList [(3, 1)]) (-20) ] - domainMap = VarDomainMap $ M.fromList - [(1, nonNegative), (2, lowerBoundOnly (-5)), (3, unbounded)] + domainMap = + VarDomainMap $ + M.fromList + [(1, nonNegative), (2, lowerBoundOnly (-5)), (3, unbounded)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1410,7 +1516,7 @@ spec = do -- x₁ has positive lower bound (uses AddLowerBound) -- x₂ has negative lower bound (uses Shift) let obj = Max (M.fromList [(1, 2), (2, 3)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 2), (2, 1)]) 20 , LEQ (M.fromList [(2, 1)]) 10 ] @@ -1434,7 +1540,7 @@ spec = do -- Minimize with lower bounds -- x₁ = 2 (minimum), x₂ = -2 (to satisfy x₁ + x₂ ≥ 0) let obj = Min (M.fromList [(1, 2), (2, 3)]) - constraints = + constraints = [ GEQ (M.fromList [(1, 1), (2, 1)]) 0 , LEQ (M.fromList [(1, 1)]) 10 , LEQ (M.fromList [(2, 1)]) 10 @@ -1458,7 +1564,7 @@ spec = do it "Infeasible: negative lower bound conflicts with GEQ constraint" $ do -- x₁ ≥ -5 (domain), but x₁ ≥ 10 and x₁ ≤ 5 (constraints conflict) let obj = Max (M.fromList [(1, 1)]) - constraints = + constraints = [ GEQ (M.fromList [(1, 1)]) 10 , LEQ (M.fromList [(1, 1)]) 5 ] @@ -1473,7 +1579,7 @@ spec = do it "Infeasible: unbounded variable with conflicting constraints" $ do let obj = Max (M.fromList [(1, 1)]) - constraints = + constraints = [ GEQ (M.fromList [(1, 1)]) 10 , LEQ (M.fromList [(1, 1)]) 5 ] @@ -1489,7 +1595,7 @@ spec = do it "Variable at exactly zero with negative lower bound" $ do -- x₁ ≥ -5, constraint x₁ = 0 let obj = Max (M.fromList [(1, 1)]) - constraints = [ EQ (M.fromList [(1, 1)]) 0 ] + constraints = [EQ (M.fromList [(1, 1)]) 0] domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly (-5))] actualResult <- runStdoutLoggingT $ @@ -1502,7 +1608,7 @@ spec = do it "unbounded variable constrained to zero" $ do let obj = Max (M.fromList [(1, 1)]) - constraints = [ EQ (M.fromList [(1, 1)]) 0 ] + constraints = [EQ (M.fromList [(1, 1)]) 0] domainMap = VarDomainMap $ M.fromList [(1, unbounded)] actualResult <- runStdoutLoggingT $ @@ -1517,9 +1623,11 @@ spec = do -- x₁ ≥ 0 (non-negative), x₂ ≥ -10, x₃ ≥ 0 -- Max x₁ + x₂ + x₃ with x₁ + x₂ + x₃ ≤ 15 let obj = Max (M.fromList [(1, 1), (2, 1), (3, 1)]) - constraints = [ LEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) 15 ] - domainMap = VarDomainMap $ M.fromList - [(1, nonNegative), (2, lowerBoundOnly (-10)), (3, nonNegative)] + constraints = [LEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) 15] + domainMap = + VarDomainMap $ + M.fromList + [(1, nonNegative), (2, lowerBoundOnly (-10)), (3, nonNegative)] actualResult <- runStdoutLoggingT $ filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ @@ -1565,7 +1673,7 @@ spec = do it "collects variables from mixed constraints" $ do let obj = Max (M.fromList [(1, 1)]) - constraints = + constraints = [ LEQ (M.fromList [(2, 1)]) 10 , GEQ (M.fromList [(3, 1)]) 5 , EQ (M.fromList [(4, 1)]) 7 @@ -1584,7 +1692,7 @@ spec = do it "deduplicates variables appearing in multiple places" $ do let obj = Max (M.fromList [(1, 1), (2, 2)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 3), (3, 4)]) 10 , GEQ (M.fromList [(2, 5), (3, 6)]) 5 ] @@ -1752,8 +1860,8 @@ spec = do let obj = Max (M.fromList [(1, 1)]) constraints = [LEQ (M.fromList [(1, 1)]) 10] transform = AddLowerBound 1 5 - applyTransform transform (obj, constraints) `shouldBe` - (obj, [GEQ (M.singleton 1 1) 5, LEQ (M.fromList [(1, 1)]) 10]) + applyTransform transform (obj, constraints) + `shouldBe` (obj, [GEQ (M.singleton 1 1) 5, LEQ (M.fromList [(1, 1)]) 10]) it "applyTransform Shift transforms objective and constraints" $ do let obj = Max (M.fromList [(1, 2)]) @@ -1839,8 +1947,7 @@ spec = do domainMap = VarDomainMap $ M.fromList [(1, lowerBoundOnly 5)] let (_, newConstraints, transforms) = preprocess [obj] domainMap constraints transforms `shouldBe` [AddLowerBound 1 5] - length newConstraints `shouldBe` 2 -- original + GEQ - + length newConstraints `shouldBe` 2 -- original + GEQ it "generates Shift for negative lower bounds" $ do let obj = Max (M.fromList [(1, 1)]) constraints = [LEQ (M.fromList [(1, 1)]) 10] @@ -1866,8 +1973,10 @@ spec = do it "handles mixed domain types" $ do let obj = Max (M.fromList [(1, 1), (2, 1), (3, 1)]) constraints = [LEQ (M.fromList [(1, 1), (2, 1), (3, 1)]) 10] - domainMap = VarDomainMap $ M.fromList - [(1, nonNegative), (2, lowerBoundOnly 5), (3, lowerBoundOnly (-3))] + domainMap = + VarDomainMap $ + M.fromList + [(1, nonNegative), (2, lowerBoundOnly 5), (3, lowerBoundOnly (-3))] let (_, _, transforms) = preprocess [obj] domainMap constraints -- Should have AddLowerBound for var 2, Shift for var 3 length transforms `shouldBe` 2 @@ -1878,158 +1987,177 @@ spec = do describe "Property-based tests" $ do describe "collectAllVars properties" $ do - it "result is non-empty when objective is non-empty" $ property $ - \(NonEmpty coeffs :: NonEmptyList (Int, Rational)) -> - let obj = Max (M.fromList [(abs k `mod` 100 + 1, v) | (k, v) <- coeffs]) - in not (Set.null (collectAllVars [obj] [])) - - it "result contains all objective variables" $ property $ - \(vars :: [Int]) -> - let posVars = filter (> 0) (map abs vars) - obj = Max (M.fromList [(v, 1) | v <- take 5 posVars]) - in all (`Set.member` collectAllVars [obj] []) (M.keys $ case obj of Max m -> m; Min m -> m) + it "result is non-empty when objective is non-empty" $ + property $ + \(NonEmpty coeffs :: NonEmptyList (Int, Rational)) -> + let obj = Max (M.fromList [(abs k `mod` 100 + 1, v) | (k, v) <- coeffs]) + in not (Set.null (collectAllVars [obj] [])) + + it "result contains all objective variables" $ + property $ + \(vars :: [Int]) -> + let posVars = filter (> 0) (map abs vars) + obj = Max (M.fromList [(v, 1) | v <- take 5 posVars]) + in all (`Set.member` collectAllVars [obj] []) (M.keys $ case obj of Max m -> m; Min m -> m) describe "getTransform properties" $ do - it "NonNegative always produces empty list" $ property $ - \(nextVar :: Int) (v :: Int) -> - getTransform (abs nextVar + 1) (abs v + 1) nonNegative == ([], 0) - - it "lowerBoundOnly 0 produces empty list" $ property $ - \(nextVar :: Int) (v :: Int) -> - getTransform (abs nextVar + 1) (abs v + 1) (lowerBoundOnly 0) == ([], 0) - - it "positive lowerBoundOnly produces AddLowerBound" $ property $ - \(Positive bound :: Positive Rational) (nextVar :: Int) (v :: Int) -> - case getTransform (abs nextVar + 1) (abs v + 1) (lowerBoundOnly bound) of - ([AddLowerBound var b], 0) -> var == abs v + 1 && b == bound - _ -> False - - it "negative lowerBoundOnly produces Shift" $ property $ - \(Positive bound :: Positive Rational) (nextVar :: Int) (v :: Int) -> - let negBound = negate bound - in case getTransform (abs nextVar + 1) (abs v + 1) (lowerBoundOnly negBound) of - ([Shift origVar _ shiftBy], 1) -> origVar == abs v + 1 && shiftBy == negBound - _ -> False - - it "unbounded produces Split" $ property $ - \(nextVar :: Int) (v :: Int) -> - case getTransform (abs nextVar + 1) (abs v + 1) unbounded of - ([Split origVar _ _], 2) -> origVar == abs v + 1 - _ -> False - - it "boundedRange produces both lower and upper bound transforms" $ property $ - \(lower :: Rational) (Positive delta :: Positive Rational) (nextVar :: Int) (v :: Int) -> - let upper = lower + delta -- ensure upper > lower - in case getTransform (abs nextVar + 1) (abs v + 1) (boundedRange lower upper) of - (transforms, _) -> - any (\case AddUpperBound var u -> var == abs v + 1 && u == upper; _ -> False) transforms + it "NonNegative always produces empty list" $ + property $ + \(nextVar :: Int) (v :: Int) -> + getTransform (abs nextVar + 1) (abs v + 1) nonNegative == ([], 0) + + it "lowerBoundOnly 0 produces empty list" $ + property $ + \(nextVar :: Int) (v :: Int) -> + getTransform (abs nextVar + 1) (abs v + 1) (lowerBoundOnly 0) == ([], 0) + + it "positive lowerBoundOnly produces AddLowerBound" $ + property $ + \(Positive bound :: Positive Rational) (nextVar :: Int) (v :: Int) -> + case getTransform (abs nextVar + 1) (abs v + 1) (lowerBoundOnly bound) of + ([AddLowerBound var b], 0) -> var == abs v + 1 && b == bound + _ -> False + + it "negative lowerBoundOnly produces Shift" $ + property $ + \(Positive bound :: Positive Rational) (nextVar :: Int) (v :: Int) -> + let negBound = negate bound + in case getTransform (abs nextVar + 1) (abs v + 1) (lowerBoundOnly negBound) of + ([Shift origVar _ shiftBy], 1) -> origVar == abs v + 1 && shiftBy == negBound + _ -> False + + it "unbounded produces Split" $ + property $ + \(nextVar :: Int) (v :: Int) -> + case getTransform (abs nextVar + 1) (abs v + 1) unbounded of + ([Split origVar _ _], 2) -> origVar == abs v + 1 + _ -> False + + it "boundedRange produces both lower and upper bound transforms" $ + property $ + \(lower :: Rational) (Positive delta :: Positive Rational) (nextVar :: Int) (v :: Int) -> + let upper = lower + delta -- ensure upper > lower + in case getTransform (abs nextVar + 1) (abs v + 1) (boundedRange lower upper) of + (transforms, _) -> + any (\case AddUpperBound var u -> var == abs v + 1 && u == upper; _ -> False) transforms describe "applyShiftToConstraint properties" $ do - it "RHS adjustment follows formula: newRHS = oldRHS - coeff * shiftBy" $ property $ - \(coeff :: Rational) (oldRHS :: Rational) (shiftBy :: Rational) -> - coeff /= 0 ==> - let constraint = LEQ (M.fromList [(1, coeff)]) oldRHS - LEQ _ newRHS = applyShiftToConstraint 1 10 shiftBy constraint - in newRHS == oldRHS - coeff * shiftBy - - it "preserves constraint type (LEQ stays LEQ)" $ property $ - \(coeff :: Rational) (rhs :: Rational) (shiftBy :: Rational) -> - coeff /= 0 ==> - let constraint = LEQ (M.fromList [(1, coeff)]) rhs - in case applyShiftToConstraint 1 10 shiftBy constraint of - LEQ {} -> True - _ -> False - - it "preserves constraint type (GEQ stays GEQ)" $ property $ - \(coeff :: Rational) (rhs :: Rational) (shiftBy :: Rational) -> - coeff /= 0 ==> - let constraint = GEQ (M.fromList [(1, coeff)]) rhs - in case applyShiftToConstraint 1 10 shiftBy constraint of - GEQ {} -> True - _ -> False + it "RHS adjustment follows formula: newRHS = oldRHS - coeff * shiftBy" $ + property $ + \(coeff :: Rational) (oldRHS :: Rational) (shiftBy :: Rational) -> + coeff /= 0 ==> + let constraint = LEQ (M.fromList [(1, coeff)]) oldRHS + LEQ _ newRHS = applyShiftToConstraint 1 10 shiftBy constraint + in newRHS == oldRHS - coeff * shiftBy + + it "preserves constraint type (LEQ stays LEQ)" $ + property $ + \(coeff :: Rational) (rhs :: Rational) (shiftBy :: Rational) -> + coeff /= 0 ==> + let constraint = LEQ (M.fromList [(1, coeff)]) rhs + in case applyShiftToConstraint 1 10 shiftBy constraint of + LEQ {} -> True + _ -> False + + it "preserves constraint type (GEQ stays GEQ)" $ + property $ + \(coeff :: Rational) (rhs :: Rational) (shiftBy :: Rational) -> + coeff /= 0 ==> + let constraint = GEQ (M.fromList [(1, coeff)]) rhs + in case applyShiftToConstraint 1 10 shiftBy constraint of + GEQ {} -> True + _ -> False describe "applySplitToConstraint properties" $ do - it "preserves RHS value" $ property $ - \(coeff :: Rational) (rhs :: Rational) -> - coeff /= 0 ==> - let constraint = LEQ (M.fromList [(1, coeff)]) rhs - LEQ _ newRHS = applySplitToConstraint 1 10 11 constraint - in newRHS == rhs - - it "negVar coefficient is negation of posVar coefficient" $ property $ - \(coeff :: Rational) (rhs :: Rational) -> - coeff /= 0 ==> - let constraint = LEQ (M.fromList [(1, coeff)]) rhs - LEQ m _ = applySplitToConstraint 1 10 11 constraint - posCoeff = M.findWithDefault 0 10 m - negCoeff = M.findWithDefault 0 11 m - in negCoeff == negate posCoeff + it "preserves RHS value" $ + property $ + \(coeff :: Rational) (rhs :: Rational) -> + coeff /= 0 ==> + let constraint = LEQ (M.fromList [(1, coeff)]) rhs + LEQ _ newRHS = applySplitToConstraint 1 10 11 constraint + in newRHS == rhs + + it "negVar coefficient is negation of posVar coefficient" $ + property $ + \(coeff :: Rational) (rhs :: Rational) -> + coeff /= 0 ==> + let constraint = LEQ (M.fromList [(1, coeff)]) rhs + LEQ m _ = applySplitToConstraint 1 10 11 constraint + posCoeff = M.findWithDefault 0 10 m + negCoeff = M.findWithDefault 0 11 m + in negCoeff == negate posCoeff describe "unapplyTransformToVarMap Shift properties" $ do - it "recovers originalVar = shiftedVar + shiftBy" $ property $ - \(shiftedVal :: Rational) (shiftBy :: Rational) -> - let varMap = M.fromList [(5, 100), (10, shiftedVal)] - transform = Shift 1 10 shiftBy - newVarMap = unapplyTransformToVarMap transform varMap - in M.lookup 1 newVarMap == Just (shiftedVal + shiftBy) - - it "removes shifted variable from result" $ property $ - \(shiftedVal :: Rational) (shiftBy :: Rational) -> - let varMap = M.fromList [(5, 100), (10, shiftedVal)] - transform = Shift 1 10 shiftBy - newVarMap = unapplyTransformToVarMap transform varMap - in M.lookup 10 newVarMap == Nothing + it "recovers originalVar = shiftedVar + shiftBy" $ + property $ + \(shiftedVal :: Rational) (shiftBy :: Rational) -> + let varMap = M.fromList [(5, 100), (10, shiftedVal)] + transform = Shift 1 10 shiftBy + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 1 newVarMap == Just (shiftedVal + shiftBy) + + it "removes shifted variable from result" $ + property $ + \(shiftedVal :: Rational) (shiftBy :: Rational) -> + let varMap = M.fromList [(5, 100), (10, shiftedVal)] + transform = Shift 1 10 shiftBy + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 10 newVarMap == Nothing describe "unapplyTransformToVarMap Split properties" $ do - it "recovers originalVar = posVar - negVar" $ property $ - \(posVal :: Rational) (negVal :: Rational) -> - let varMap = M.fromList [(5, 100), (10, posVal), (11, negVal)] - transform = Split 1 10 11 - newVarMap = unapplyTransformToVarMap transform varMap - in M.lookup 1 newVarMap == Just (posVal - negVal) - - - it "removes pos and neg variables from result" $ property $ - \(posVal :: Rational) (negVal :: Rational) -> - let varMap = M.fromList [(5, 100), (10, posVal), (11, negVal)] - transform = Split 1 10 11 - newVarMap = unapplyTransformToVarMap transform varMap - in M.lookup 10 newVarMap == Nothing && - M.lookup 11 newVarMap == Nothing + it "recovers originalVar = posVar - negVar" $ + property $ + \(posVal :: Rational) (negVal :: Rational) -> + let varMap = M.fromList [(5, 100), (10, posVal), (11, negVal)] + transform = Split 1 10 11 + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 1 newVarMap == Just (posVal - negVal) + + it "removes pos and neg variables from result" $ + property $ + \(posVal :: Rational) (negVal :: Rational) -> + let varMap = M.fromList [(5, 100), (10, posVal), (11, negVal)] + transform = Split 1 10 11 + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 10 newVarMap == Nothing + && M.lookup 11 newVarMap == Nothing describe "Round-trip properties" $ do - it "Shift transform and unapply is identity for variable value" $ property $ - \(origVal :: Rational) (shiftBy :: Rational) -> - shiftBy < 0 ==> -- Only negative shifts are valid - let shiftedVal = origVal - shiftBy -- shiftedVar = originalVar - shiftBy - varMap = M.fromList [(5, 100), (10, shiftedVal)] - transform = Shift 1 10 shiftBy + it "Shift transform and unapply is identity for variable value" $ + property $ + \(origVal :: Rational) (shiftBy :: Rational) -> + shiftBy < 0 ==> -- Only negative shifts are valid + let shiftedVal = origVal - shiftBy -- shiftedVar = originalVar - shiftBy + varMap = M.fromList [(5, 100), (10, shiftedVal)] + transform = Shift 1 10 shiftBy + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 1 newVarMap == Just origVal + + it "Split with posVal=origVal and negVal=0 gives correct value for positive origVal" $ + property $ + \(Positive origVal :: Positive Rational) -> + let varMap = M.fromList [(5, 100), (10, origVal), (11, 0)] + transform = Split 1 10 11 + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 1 newVarMap == Just origVal + + it "Split with posVal=0 and negVal=-origVal gives correct value for negative origVal" $ + property $ + \(Positive origVal :: Positive Rational) -> + let negOrigVal = negate origVal + varMap = M.fromList [(5, 100), (10, 0), (11, origVal)] + transform = Split 1 10 11 newVarMap = unapplyTransformToVarMap transform varMap - in M.lookup 1 newVarMap == Just origVal - - it "Split with posVal=origVal and negVal=0 gives correct value for positive origVal" $ property $ - \(Positive origVal :: Positive Rational) -> - let varMap = M.fromList [(5, 100), (10, origVal), (11, 0)] - transform = Split 1 10 11 - newVarMap = unapplyTransformToVarMap transform varMap - in M.lookup 1 newVarMap == Just origVal - - it "Split with posVal=0 and negVal=-origVal gives correct value for negative origVal" $ property $ - \(Positive origVal :: Positive Rational) -> - let negOrigVal = negate origVal - varMap = M.fromList [(5, 100), (10, 0), (11, origVal)] - transform = Split 1 10 11 - newVarMap = unapplyTransformToVarMap transform varMap - in M.lookup 1 newVarMap == Just negOrigVal + in M.lookup 1 newVarMap == Just negOrigVal describe "twoPhaseSimplex with multiple objectives" $ do it "optimizes two objectives over the same feasible region" $ do -- Feasible region: x₁ + x₂ ≤ 10, x₁ ≤ 6, x₂ ≤ 8, x₁,x₂ ≥ 0 -- Max x₁: optimal at x₁=6, x₂=0 (or x₁=6, x₂=4) with obj=6 -- Max x₂: optimal at x₁=0, x₂=8 (or x₁=2, x₂=8) with obj=8 - let obj1 = Max (M.fromList [(1, 1)]) -- Max x₁ - obj2 = Max (M.fromList [(2, 1)]) -- Max x₂ - constraints = + let obj1 = Max (M.fromList [(1, 1)]) -- Max x₁ + obj2 = Max (M.fromList [(2, 1)]) -- Max x₂ + constraints = [ LEQ (M.fromList [(1, 1), (2, 1)]) 10 , LEQ (M.fromList [(1, 1)]) 6 , LEQ (M.fromList [(2, 1)]) 8 @@ -2046,17 +2174,17 @@ spec = do length objResults `shouldBe` 2 -- First result (Max x₁) should have x₁=6 case objResults !! 0 of - ObjectiveResult _ (Optimal varVals) -> + ObjectiveResult _ (Optimal varVals) -> M.lookup 1 varVals `shouldBe` Just 6 _ -> expectationFailure "Expected optimal result for obj1" -- Second result (Max x₂) should have x₂=8 case objResults !! 1 of - ObjectiveResult _ (Optimal varVals) -> + ObjectiveResult _ (Optimal varVals) -> M.lookup 2 varVals `shouldBe` Just 8 _ -> expectationFailure "Expected optimal result for obj2" it "handles empty objective list returning feasible system only" $ do - let constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] + let constraints = [LEQ (M.fromList [(1, 1)]) 10] domainMap = VarDomainMap $ M.fromSet (const nonNegative) (Set.singleton 1) SimplexResult mFeasibleSystem objResults <- runStdoutLoggingT $ @@ -2069,7 +2197,7 @@ spec = do -- x₁ ≤ 5 and x₁ ≥ 10 is infeasible let obj1 = Max (M.fromList [(1, 1)]) obj2 = Min (M.fromList [(1, 1)]) - constraints = + constraints = [ LEQ (M.fromList [(1, 1)]) 5 , GEQ (M.fromList [(1, 1)]) 10 ] @@ -2090,7 +2218,7 @@ spec = do -- Min x₁: optimal at x₁=0 let obj1 = Max (M.fromList [(1, 1)]) obj2 = Min (M.fromList [(1, 1)]) - constraints = [ LEQ (M.fromList [(1, 1)]) 10 ] + constraints = [LEQ (M.fromList [(1, 1)]) 10] domainMap = VarDomainMap $ M.fromList [(1, nonNegative)] SimplexResult mFeasibleSystem objResults <- runStdoutLoggingT $ @@ -2100,12 +2228,12 @@ spec = do length objResults `shouldBe` 2 -- Max x₁ should be 10 case objResults !! 0 of - ObjectiveResult _ (Optimal varVals) -> + ObjectiveResult _ (Optimal varVals) -> M.lookup 1 varVals `shouldBe` Just 10 _ -> expectationFailure "Expected optimal result for Max x₁" -- Min x₁ should be 0 (or not present in map if zero) case objResults !! 1 of - ObjectiveResult _ (Optimal varVals) -> + ObjectiveResult _ (Optimal varVals) -> M.findWithDefault 0 1 varVals `shouldBe` 0 _ -> expectationFailure "Expected optimal result for Min x₁" @@ -2113,11 +2241,11 @@ spec = do -- x₁ with only a lower bound (non-negative) -- Max x₁: unbounded (no upper constraint) -- Min x₁ with x₁ ≥ 0: optimal at x₁=0 - let obj1 = Max (M.fromList [(1, 1)]) -- This will be unbounded - obj2 = Min (M.fromList [(1, 1)]) -- This will have optimal at 0 + let obj1 = Max (M.fromList [(1, 1)]) -- This will be unbounded + obj2 = Min (M.fromList [(1, 1)]) -- This will have optimal at 0 -- Add a dummy constraint to ensure the system is processable -- x₁ ≥ 0 (enforced by nonNegative domain) but no upper bound - constraints = [ GEQ (M.fromList [(1, 1)]) 0 ] -- x₁ ≥ 0 + constraints = [GEQ (M.fromList [(1, 1)]) 0] -- x₁ ≥ 0 domainMap = VarDomainMap $ M.fromList [(1, nonNegative)] SimplexResult mFeasibleSystem objResults <- runStdoutLoggingT $ @@ -2131,6 +2259,6 @@ spec = do _ -> expectationFailure "Expected unbounded result for Max x₁" -- Min x₁ should be 0 case objResults !! 1 of - ObjectiveResult _ (Optimal varVals) -> + ObjectiveResult _ (Optimal varVals) -> M.findWithDefault 0 1 varVals `shouldBe` 0 _ -> expectationFailure "Expected optimal result for Min x₁" From 93dd0a0ceba18102b70d0e43b2bb0956519ec613 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 28 Feb 2026 14:43:37 +0000 Subject: [PATCH 11/17] chore: use nix in ci --- .github/workflows/haskell.yml | 71 ++++++++++++----------------------- 1 file changed, 24 insertions(+), 47 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index f6c74e1..c2108a0 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -8,71 +8,48 @@ permissions: contents: read jobs: - fourmolu: + nix-ci: runs-on: ubuntu-latest + env: + NIX_CONFIG: accept-flake-config = true steps: - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 - - uses: haskell-actions/run-fourmolu@3b7702b41516aa428dfe6e295dc73476ae58f69e # v11 - with: - version: "0.17.0.0" - build: - name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} - runs-on: ${{ matrix.os }} - strategy: - fail-fast: false - matrix: - os: [windows-latest, macos-latest, ubuntu-latest] - ghc-version: ["9.12", "9.10", "9.8", "9.6", "9.4", "9.2"] - steps: - - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 + - name: Check Nix flake inputs + uses: DeterminateSystems/flake-checker-action@3164002371bc90729c68af0e24d5aacf20d7c9f6 # v12 + + - name: Install Nix + uses: DeterminateSystems/nix-installer-action@c5a866b6ab867e88becbed4467b93592bce69f8a # v21 - - name: Set up GHC ${{ matrix.ghc-version }} - uses: haskell-actions/setup@96f3dafd067155f32643c2a0757ab71d2910e2c2 # v2.8.0 - id: setup - with: - ghc-version: ${{ matrix.ghc-version }} + - name: Enable Nix cache + uses: DeterminateSystems/magic-nix-cache-action@565684385bcd71bad329742eefe8d12f2e765b39 # v13 - - name: Installed minor versions of GHC, Cabal, and Stack + - name: Show toolchain versions from nix shell shell: bash run: | - GHC_VERSION=$(ghc --numeric-version) - CABAL_VERSION=$(cabal --numeric-version) - echo "GHC_VERSION=${GHC_VERSION}" >> "${GITHUB_ENV}" - echo "CABAL_VERSION=${CABAL_VERSION}" >> "${GITHUB_ENV}" + nix develop --command bash -lc 'ghc --numeric-version' + nix develop --command bash -lc 'cabal --numeric-version' + nix develop --command bash -lc 'stack --numeric-version || true' + nix develop --command bash -lc 'fourmolu --version' + + - name: Check formatting + run: nix develop --command make format-check - name: Check cabal file - run: make cabal-check + run: nix develop --command make cabal-check - name: Configure the build - run: make configure - - - name: Restore cached dependencies - uses: actions/cache/restore@5a3ec84eff668545956fd18022155c47e93e2684 # v4.2.3 - id: cache - env: - key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} - with: - path: ${{ steps.setup.outputs.cabal-store }} - key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} - restore-keys: ${{ env.key }}- + run: nix develop --command make configure - name: Build dependencies - run: make deps - - - name: Save cached dependencies - uses: actions/cache/save@5a3ec84eff668545956fd18022155c47e93e2684 # v4.2.3 - if: steps.cache.outputs.cache-hit != 'true' - with: - path: ${{ steps.setup.outputs.cabal-store }} - key: ${{ steps.cache.outputs.cache-primary-key }} + run: nix develop --command make deps - name: Build the package - run: make build + run: nix develop --command make build - name: Run tests - run: make test + run: nix develop --command make test - name: Build documentation - run: make docs + run: nix develop --command make docs From 2125abe5c681603dfedc405be08aaa0fbc1d5a12 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 28 Feb 2026 15:22:28 +0000 Subject: [PATCH 12/17] chore: fix ci, haddocks, remove unused functions --- .github/workflows/haskell.yml | 3 +++ .gitignore | 1 + Makefile | 6 ++++- src/Linear/Simplex/Prettify.hs | 2 +- src/Linear/Simplex/Solver/TwoPhase.hs | 4 +-- src/Linear/Simplex/Types.hs | 35 +++++++++------------------ src/Linear/Simplex/Util.hs | 23 +++--------------- 7 files changed, 26 insertions(+), 48 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index c2108a0..8ccc650 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -39,6 +39,9 @@ jobs: - name: Check cabal file run: nix develop --command make cabal-check + - name: Update cabal package index + run: nix develop --command make cabal-update + - name: Configure the build run: nix develop --command make configure diff --git a/.gitignore b/.gitignore index 3b65193..14b3fe5 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,4 @@ dist-*/ .vscode/* .direnv/* .envrc +cabal.project.local diff --git a/Makefile b/Makefile index 7d62be6..067d93a 100644 --- a/Makefile +++ b/Makefile @@ -14,6 +14,10 @@ format-check: cabal-check: cabal check +.PHONY: cabal-update +cabal-update: + cabal update + .PHONY: configure configure: cabal configure --enable-tests --enable-benchmarks --disable-documentation @@ -36,4 +40,4 @@ docs: cabal haddock all --disable-documentation .PHONY: ci -ci: format-check cabal-check configure deps build test docs +ci: format-check cabal-check cabal-update configure deps build test docs diff --git a/src/Linear/Simplex/Prettify.hs b/src/Linear/Simplex/Prettify.hs index b19cc44..72b9ca9 100644 --- a/src/Linear/Simplex/Prettify.hs +++ b/src/Linear/Simplex/Prettify.hs @@ -18,7 +18,7 @@ import Data.Map qualified as M import Data.Ratio import Linear.Simplex.Types --- | Convert a 'VarConstMap' into a human-readable 'String' +-- | Convert a 'VarLitMapSum' into a human-readable 'String' prettyShowVarConstMap :: VarLitMapSum -> String prettyShowVarConstMap = aux . M.toList where diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index 4107420..808526f 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -10,7 +10,7 @@ -- 'findFeasibleSolution' performs phase one of the two-phase simplex method. -- 'optimizeFeasibleSystem' performs phase two of the two-phase simplex method. -- 'twoPhaseSimplex' performs both phases of the two-phase simplex method. --- 'twoPhaseSimplex'' performs both phases with variable domain support. +-- 'twoPhaseSimplex' supports variable domains via its 'VarDomainMap' argument. module Linear.Simplex.Solver.TwoPhase ( findFeasibleSolution , optimizeFeasibleSystem @@ -272,7 +272,7 @@ findFeasibleSolution unsimplifiedSystem = do -- | Optimize a feasible system by performing the second phase of the two-phase simplex method. -- We first pass an 'ObjectiveFunction'. --- Then, the feasible system in 'DictionaryForm' as well as a list of slack variables, a list artificial variables, and the objective variable. +-- Then, the feasible system in 'Dict' form as well as a list of slack variables, a list artificial variables, and the objective variable. -- Returns 'Optimal' with variable values if an optimal solution is found, or 'Unbounded' if the objective is unbounded. optimizeFeasibleSystem :: (MonadIO m, MonadLogger m) => ObjectiveFunction -> FeasibleSystem -> m OptimisationOutcome optimizeFeasibleSystem objFunction fsys@(FeasibleSystem {dict = phase1Dict, ..}) = do diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index 55562c1..c912c11 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -13,24 +13,14 @@ import Data.List (sort) import qualified Data.Map as M import GHC.Generics (Generic) +-- | Variable identifier used in maps and constraints. +-- Conventionally this maps to x1, x2, ... in examples. type Var = Int +-- | Numeric type used throughout simplex computations. type SimplexNum = Rational -type SystemRow = PolyConstraint - -type System = [SystemRow] - --- A 'Tableau' where the basic variable may be empty. --- All non-empty basic vars are slack vars -data SystemWithSlackVarRow = SystemInStandardFormRow - { mSlackVar :: Maybe Var - -- ^ This is Nothing iff the row does not have a slack variable - , row :: TableauRow - } - -type SystemWithSlackVars = [SystemWithSlackVarRow] - +-- | A feasible system produced by phase one, ready for phase two optimization. data FeasibleSystem = FeasibleSystem { dict :: Dict , slackVars :: [Var] @@ -66,6 +56,7 @@ data SimplexResult = SimplexResult } deriving (Show, Read, Eq, Generic) +-- | Mapping from variable id to its numeric value/coefficient. type VarLitMap = M.Map Var SimplexNum -- | List of variables with their 'SimplexNum' coefficients. @@ -75,7 +66,7 @@ type VarLitMap = M.Map Var SimplexNum type VarLitMapSum = VarLitMap -- | For specifying constraints in a system. --- The LHS is a 'Vars', and the RHS, is a 'SimplexNum' number. +-- The LHS is a 'VarLitMapSum', and the RHS, is a 'SimplexNum' number. -- LEQ [(1, 2), (2, 1)] 3.5 is equivalent to 2x1 + x2 <= 3.5. -- Users must only provide positive integer variables. -- @@ -87,17 +78,10 @@ data PolyConstraint deriving (Show, Read, Eq, Generic) -- | Create an objective function. --- We can either 'Max'imize or 'Min'imize a 'VarTermSum'. +-- We can either 'Max'imize or 'Min'imize a 'VarLitMapSum'. data ObjectiveFunction = Max {objective :: VarLitMapSum} | Min {objective :: VarLitMapSum} deriving (Show, Read, Eq, Generic) --- | TODO: Maybe we want this type --- TODO: A better/alternative name -data Equation = Equation - { lhs :: VarLitMapSum - , rhs :: SimplexNum - } - -- | Value for 'Tableau'. lhs = rhs. data TableauRow = TableauRow { lhs :: VarLitMapSum @@ -105,7 +89,7 @@ data TableauRow = TableauRow } deriving (Show, Read, Eq, Generic) --- | A simplex 'Tableu' of equations. +-- | A simplex 'Tableau' of equations. -- Each entry in the map is a row. type Tableau = M.Map Var TableauRow @@ -126,6 +110,9 @@ data DictValue = DictValue -- deriving (Show, Read, Eq, Generic) type Dict = M.Map Var DictValue +-- | Objective row representation used during pivoting. +-- 'variable' is the objective basic variable and 'function'/'constant' encode +-- the objective in dictionary form. data PivotObjective = PivotObjective { variable :: Var , function :: VarLitMapSum diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index b87a8dc..ebb55b4 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -30,7 +30,7 @@ isMax :: ObjectiveFunction -> Bool isMax (Max _) = True isMax (Min _) = False --- | Simplifies a system of 'PolyConstraint's by first calling 'simplifyPolyConstraint', +-- | Simplifies a system of 'PolyConstraint's, -- then reducing 'LEQ' and 'GEQ' with same LHS and RHS (and other similar situations) into 'EQ', -- and finally removing duplicate elements using 'nub'. simplifySystem :: [PolyConstraint] -> [PolyConstraint] @@ -78,7 +78,7 @@ simplifySystem = nub . reduceSystem then EQ lhs rhs : reduceSystem pcs else EQ lhs rhs : reduceSystem (pcs \\ matchingConstraints) --- | Converts a 'Dict' to a 'Tableau' using 'dictEntryToTableauEntry'. +-- | Converts a 'Dict' to a 'Tableau'. -- FIXME: maybe remove this line. The basic variables will have a coefficient of 1 in the 'Tableau'. dictionaryFormToTableau :: Dict -> Tableau dictionaryFormToTableau = @@ -130,17 +130,6 @@ combineVarLitMapSums = keepVal = const pure sumVals k v1 v2 = Just $ v1 + v2 -foldDictValue :: [DictValue] -> DictValue -foldDictValue [] = error "Empty list of DictValues given to foldDictValue" -foldDictValue [x] = x -foldDictValue (DictValue {varMapSum = vm1, constant = c1} : DictValue {varMapSum = vm2, constant = c2} : dvs) = - let combinedDictValue = - DictValue - { varMapSum = foldVarLitMap [vm1, vm2] - , constant = c1 + c2 - } - in foldDictValue $ combinedDictValue : dvs - foldVarLitMap :: [VarLitMap] -> VarLitMap foldVarLitMap [] = error "Empty list of VarLitMaps given to foldVarLitMap" foldVarLitMap [x] = x @@ -158,7 +147,7 @@ foldVarLitMap (vm1 : vm2 : vms) = (Just vm1VarVal, Just vm2VarVal) -> vm1VarVal + vm2VarVal (Just vm1VarVal, Nothing) -> vm1VarVal (Nothing, Just vm2VarVal) -> vm2VarVal - (Nothing, Nothing) -> error "Reached unreachable branch in foldDictValue" + (Nothing, Nothing) -> error "Reached unreachable branch in foldVarLitMap" ) ) combinedVars @@ -180,9 +169,3 @@ logMsg lvl msg = do LevelWarn -> $logWarn msgToLog LevelError -> $logError msgToLog LevelOther otherLvl -> error "logMsg: LevelOther is not implemented" - -extractTableauValues :: Tableau -> Map.Map Var SimplexNum -extractTableauValues = Map.map (.rhs) - -extractDictValues :: Dict -> Map.Map Var SimplexNum -extractDictValues = Map.map (.constant) From 9895193503c3ea8652d057227949785502616415 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 28 Feb 2026 15:22:28 +0000 Subject: [PATCH 13/17] chore: update flake lock --- flake.lock | 101 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 59 insertions(+), 42 deletions(-) diff --git a/flake.lock b/flake.lock index 7d8c09d..7542e61 100644 --- a/flake.lock +++ b/flake.lock @@ -16,23 +16,6 @@ "type": "github" } }, - "cabal-32": { - "flake": false, - "locked": { - "lastModified": 1603716527, - "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", - "owner": "haskell", - "repo": "cabal", - "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", - "type": "github" - }, - "original": { - "owner": "haskell", - "ref": "3.2", - "repo": "cabal", - "type": "github" - } - }, "cabal-34": { "flake": false, "locked": { @@ -121,11 +104,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1758846310, - "narHash": "sha256-kVnn9TScof8n41p7LqwvBvoLlfFhLDkjrP+aOAhmQ9k=", + "lastModified": 1772238810, + "narHash": "sha256-3rxB+zgRuI1ZrLiYvXolrcjL0s6CRCBuSz7qJLPWOe0=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "173aca690d454916a2d1ab5a7d13b593240fa0f5", + "rev": "93f0f7e558abaf3b02e3b48868d5de90bd64c399", "type": "github" }, "original": { @@ -137,11 +120,11 @@ "hackage-for-stackage": { "flake": false, "locked": { - "lastModified": 1758846300, - "narHash": "sha256-uS0e51ny5rGdI5HiOttTYMjGyOqBSoraXDWCY7gFc9g=", + "lastModified": 1772238803, + "narHash": "sha256-GThaHPxYJSgnhZ+qrVwWiIZEdzan109+26vBXETkVHQ=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "813f87b29c01a70bf479ff7c72b240d7d6a3fe16", + "rev": "a240f6b4f719ffd84447684bad1285bd026e75d0", "type": "github" }, "original": { @@ -170,7 +153,6 @@ "haskellNix": { "inputs": { "HTTP": "HTTP", - "cabal-32": "cabal-32", "cabal-34": "cabal-34", "cabal-36": "cabal-36", "cardano-shell": "cardano-shell", @@ -183,6 +165,7 @@ "hls-2.0": "hls-2.0", "hls-2.10": "hls-2.10", "hls-2.11": "hls-2.11", + "hls-2.12": "hls-2.12", "hls-2.2": "hls-2.2", "hls-2.3": "hls-2.3", "hls-2.4": "hls-2.4", @@ -202,16 +185,17 @@ "nixpkgs-2405": "nixpkgs-2405", "nixpkgs-2411": "nixpkgs-2411", "nixpkgs-2505": "nixpkgs-2505", + "nixpkgs-2511": "nixpkgs-2511", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", "stackage": "stackage" }, "locked": { - "lastModified": 1758847890, - "narHash": "sha256-rGX7RF8Au5ZJJSqlQivsl4seyEslI/K3OnEC9ulLwNM=", + "lastModified": 1772239947, + "narHash": "sha256-xnTR2j4ijIJdIQ1dm6IQ+jkIkNo00ID1yRLPioy0H+w=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "46abef90b4101ff9253a574cf6fbdc74b78a5863", + "rev": "7f5a9ef313d6a14019f1ab320dbce6b10907c83a", "type": "github" }, "original": { @@ -304,6 +288,23 @@ "type": "github" } }, + "hls-2.12": { + "flake": false, + "locked": { + "lastModified": 1758709460, + "narHash": "sha256-xkI8MIIVEVARskfWbGAgP5sHG/lyeKnkm0LIOJ19X5w=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "7d983de4fa7ff54369f6dd31444bdb9869aec83e", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.12.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hls-2.2": { "flake": false, "locked": { @@ -459,11 +460,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1755243078, - "narHash": "sha256-GLbl1YaohKdpzZVJFRdcI1O1oE3F3uBer4lFv3Yy0l8=", + "lastModified": 1770174258, + "narHash": "sha256-x6QYupvHZM7rRpVO4AIC5gUWFprFQ59A95FPC7/Owjg=", "owner": "stable-haskell", "repo": "iserv-proxy", - "rev": "150605195cb7183a6fb7bed82f23fedf37c6f52a", + "rev": "91ef7ffdeedfb141a4d69dcf9e550abe3e1160c6", "type": "github" }, "original": { @@ -523,11 +524,11 @@ }, "nixpkgs-2411": { "locked": { - "lastModified": 1748037224, - "narHash": "sha256-92vihpZr6dwEMV6g98M5kHZIttrWahb9iRPBm1atcPk=", + "lastModified": 1751290243, + "narHash": "sha256-kNf+obkpJZWar7HZymXZbW+Rlk3HTEIMlpc6FCNz0Ds=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "f09dede81861f3a83f7f06641ead34f02f37597f", + "rev": "5ab036a8d97cb9476fbe81b09076e6e91d15e1b6", "type": "github" }, "original": { @@ -539,11 +540,11 @@ }, "nixpkgs-2505": { "locked": { - "lastModified": 1754477006, - "narHash": "sha256-suIgZZHXdb4ca9nN4MIcmdjeN+ZWsTwCtYAG4HExqAo=", + "lastModified": 1764560356, + "narHash": "sha256-M5aFEFPppI4UhdOxwdmceJ9bDJC4T6C6CzCK1E2FZyo=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "4896699973299bffae27d0d9828226983544d9e9", + "rev": "6c8f0cca84510cc79e09ea99a299c9bc17d03cb6", "type": "github" }, "original": { @@ -553,13 +554,29 @@ "type": "github" } }, + "nixpkgs-2511": { + "locked": { + "lastModified": 1764572236, + "narHash": "sha256-hLp6T/vKdrBQolpbN3EhJOKTXZYxJZPzpnoZz+fEGlE=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "b0924ea1889b366de6bb0018a9db70b2c43a15f8", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-25.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-unstable": { "locked": { - "lastModified": 1754393734, - "narHash": "sha256-fbnmAwTQkuXHKBlcL5Nq1sMAzd3GFqCOQgEQw6Hy0Ak=", + "lastModified": 1764587062, + "narHash": "sha256-hdFa0TAVQAQLDF31cEW3enWmBP+b592OvHs6WVe3D8k=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "a683adc19ff5228af548c6539dbc3440509bfed3", + "rev": "c1cb7d097cb250f6e1904aacd5f2ba5ffd8a49ce", "type": "github" }, "original": { @@ -599,11 +616,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1758845522, - "narHash": "sha256-SgkvlWF9a+Qrkn791ZOiUVt3wuZXRJ06YjpTZMRy+R8=", + "lastModified": 1772237728, + "narHash": "sha256-1GUz83fMt+g8A3Vh8EYakENOEXN9snn2qVlDDE6FmB8=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "e2f097d435e38fb6e649efa4a95e214a506a1da5", + "rev": "d3613b6dec720201ac5c57dd7399358ff28a3190", "type": "github" }, "original": { From 48f30f4803be5bc4ca056238009e2137f119e851 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 28 Feb 2026 23:37:56 +0000 Subject: [PATCH 14/17] refactor: explicitly list imports for all unqualified Haskell imports --- src/Linear/Simplex/Prettify.hs | 14 +- src/Linear/Simplex/Solver/TwoPhase.hs | 19 +- src/Linear/Simplex/Util.hs | 13 - test/Linear/Simplex/Solver/TwoPhaseSpec.hs | 1774 ++++++++++++++------ test/Linear/Simplex/UtilSpec.hs | 276 +++ 5 files changed, 1592 insertions(+), 504 deletions(-) create mode 100644 test/Linear/Simplex/UtilSpec.hs diff --git a/src/Linear/Simplex/Prettify.hs b/src/Linear/Simplex/Prettify.hs index 72b9ca9..6737dbf 100644 --- a/src/Linear/Simplex/Prettify.hs +++ b/src/Linear/Simplex/Prettify.hs @@ -19,8 +19,8 @@ import Data.Ratio import Linear.Simplex.Types -- | Convert a 'VarLitMapSum' into a human-readable 'String' -prettyShowVarConstMap :: VarLitMapSum -> String -prettyShowVarConstMap = aux . M.toList +prettyShowVarLitMapSum :: VarLitMapSum -> String +prettyShowVarLitMapSum = aux . M.toList where aux [] = "" aux ((vName, vCoeff) : vs) = prettyShowRational vCoeff ++ " * " ++ show vName ++ " + " ++ aux vs @@ -34,11 +34,11 @@ prettyShowVarConstMap = aux . M.toList -- | Convert a 'PolyConstraint' into a human-readable 'String' prettyShowPolyConstraint :: PolyConstraint -> String -prettyShowPolyConstraint (LEQ vcm r) = prettyShowVarConstMap vcm ++ " <= " ++ show r -prettyShowPolyConstraint (GEQ vcm r) = prettyShowVarConstMap vcm ++ " >= " ++ show r -prettyShowPolyConstraint (Linear.Simplex.Types.EQ vcm r) = prettyShowVarConstMap vcm ++ " == " ++ show r +prettyShowPolyConstraint (LEQ vcm r) = prettyShowVarLitMapSum vcm ++ " <= " ++ show r +prettyShowPolyConstraint (GEQ vcm r) = prettyShowVarLitMapSum vcm ++ " >= " ++ show r +prettyShowPolyConstraint (Linear.Simplex.Types.EQ vcm r) = prettyShowVarLitMapSum vcm ++ " == " ++ show r -- | Convert an 'ObjectiveFunction' into a human-readable 'String' prettyShowObjectiveFunction :: ObjectiveFunction -> String -prettyShowObjectiveFunction (Min vcm) = "min: " ++ prettyShowVarConstMap vcm -prettyShowObjectiveFunction (Max vcm) = "max: " ++ prettyShowVarConstMap vcm +prettyShowObjectiveFunction (Min vcm) = "min: " ++ prettyShowVarLitMapSum vcm +prettyShowObjectiveFunction (Max vcm) = "max: " ++ prettyShowVarLitMapSum vcm diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index 808526f..0d43e6e 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -147,14 +147,17 @@ findFeasibleSolution unsimplifiedSystem = do system = simplifySystem unsimplifiedSystem maxVar = - maximum $ - map - ( \case - LEQ vcm _ -> maximum (map fst $ M.toList vcm) - GEQ vcm _ -> maximum (map fst $ M.toList vcm) - EQ vcm _ -> maximum (map fst $ M.toList vcm) - ) - system + if null system + then 0 + else + maximum $ + map + ( \case + LEQ vcm _ -> maximum (map fst $ M.toList vcm) + GEQ vcm _ -> maximum (map fst $ M.toList vcm) + EQ vcm _ -> maximum (map fst $ M.toList vcm) + ) + system (systemWithSlackVars, slackVars) = systemInStandardForm system maxVar [] diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index ebb55b4..85186d5 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -106,19 +106,6 @@ tableauInDictionaryForm = } ) --- | Extract the objective value from an ObjectiveResult. --- Returns Nothing if the result is Unbounded. --- Returns Just the objective value if Optimal. -extractObjectiveValue :: ObjectiveFunction -> ObjectiveResult -> Maybe SimplexNum -extractObjectiveValue objFunction (ObjectiveResult _ outcome) = - case outcome of - Unbounded -> Nothing - Optimal varVals -> - let coeffs = case objFunction of - Max m -> m - Min m -> m - in Just $ sum $ map (\(var, coeff) -> coeff * Map.findWithDefault 0 var varVals) (Map.toList coeffs) - -- | Combines two 'VarLitMapSums together by summing values with matching keys combineVarLitMapSums :: VarLitMapSum -> VarLitMapSum -> VarLitMapSum combineVarLitMapSums = diff --git a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs index 122e7e8..70ed5b7 100644 --- a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs +++ b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs @@ -5,89 +5,18 @@ module Linear.Simplex.Solver.TwoPhaseSpec where import Prelude hiding (EQ) -import Control.Monad.IO.Class import Control.Monad.Logger import qualified Data.Map as M import Data.Maybe (isJust) import Data.Ratio import qualified Data.Set as Set -import Text.InterpolatedString.Perl6 - import Test.Hspec -import Test.Hspec.Expectations.Contrib (annotate) import Test.QuickCheck import Linear.Simplex.Prettify import Linear.Simplex.Solver.TwoPhase import Linear.Simplex.Types -import Linear.Simplex.Util - --- | Compute the objective value from variable assignments. --- For Max: sum of (coeff * varValue) for each variable --- For Min: same calculation (the value represents the optimal objective value) -computeObjValue :: ObjectiveFunction -> VarLitMap -> SimplexNum -computeObjValue (Max coeffs) varMap = sum [c * M.findWithDefault 0 v varMap | (v, c) <- M.toList coeffs] -computeObjValue (Min coeffs) varMap = sum [c * M.findWithDefault 0 v varMap | (v, c) <- M.toList coeffs] - --- | Expected result for a single objective optimization -data ExpectedResult - = -- | System has no feasible solution - ExpectInfeasible - | -- | System is feasible but unbounded (no finite optimum) - ExpectUnbounded - | -- | Optimal solution found with optional expected objective value and variable values - ExpectOptimal (Maybe SimplexNum) VarLitMap - deriving (Show, Eq) - --- | Helper to run a test case for a system where all vars --- are non-negative and verify we get the expected result. -runTest :: (ObjectiveFunction, [PolyConstraint]) -> ExpectedResult -> IO () -runTest (obj, constraints) expectedResult = do - let prettyObj = prettyShowObjectiveFunction obj - prettyConstraints = map prettyShowPolyConstraint constraints - allVars = collectAllVars [obj] constraints - domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars - SimplexResult mFeasibleSystem objResults <- - runStdoutLoggingT $ - filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ - twoPhaseSimplex domainMap [obj] constraints - let actualResult = case (mFeasibleSystem, objResults) of - (Nothing, _) -> ExpectInfeasible - (Just _, []) -> ExpectInfeasible -- Should not happen with one objective - (Just _, [ObjectiveResult _ Unbounded]) -> ExpectUnbounded - (Just _, [ObjectiveResult _ (Optimal varVals)]) -> ExpectOptimal Nothing varVals - (Just _, _) -> error "Unexpected: multiple results for single objective" - actualObjVal = case actualResult of - ExpectOptimal _ varVals -> extractObjectiveValue obj (ObjectiveResult obj (Optimal varVals)) - _ -> Nothing - expectedObjVal = case expectedResult of - ExpectOptimal (Just ov) _ -> Just ov - ExpectOptimal Nothing varVals -> extractObjectiveValue obj (ObjectiveResult obj (Optimal varVals)) - _ -> Nothing - annotate - [qc| - -Objective Function (Non-prettified): {obj} -Constraints (Non-prettified): {constraints} -==================================== -Objective Function (Prettified): {prettyObj} -Constraints (Prettified): {prettyConstraints} -==================================== -Expected Result : {expectedResult} -Actual Result : {actualResult} -Expected Objective Value : {expectedObjVal} -Actual Objective Value : {actualObjVal} - |] - $ do - -- Compare variable maps (ignoring objective value field in ExpectOptimal) - let stripObjVal (ExpectOptimal _ vm) = ExpectOptimal Nothing vm - stripObjVal other = other - stripObjVal actualResult `shouldBe` stripObjVal expectedResult - -- When an expected objective value is provided, verify it matches - case expectedResult of - ExpectOptimal (Just _) _ -> actualObjVal `shouldBe` expectedObjVal - _ -> pure () spec :: Spec spec = do @@ -95,406 +24,709 @@ spec = do -- From page 50 of 'Linear and Integer Programming Made Easy' describe "From 'Linear and Integer Programming Made Easy' (page 50)" $ do it "Max 3x₁ + 5x₂ with LEQ constraints: obj=29, x₁=3, x₂=4" $ do - let testCase = - ( Max (M.fromList [(1, 3), (2, 5)]) - , - [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 - , LEQ (M.fromList [(1, 1), (2, 1)]) 7 - , LEQ (M.fromList [(2, 1)]) 4 - , LEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - runTest testCase (ExpectOptimal (Just 29) (M.fromList [(1, 3), (2, 4)])) + let obj = Max (M.fromList [(1, 3), (2, 5)]) + constraints = + [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 + , LEQ (M.fromList [(1, 1), (2, 1)]) 7 + , LEQ (M.fromList [(2, 1)]) 4 + , LEQ (M.fromList [(1, -1), (2, 2)]) 6 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 3), (2, 4)] + computeObjective obj varMap `shouldBe` 29 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min 3x₁ + 5x₂ with LEQ constraints: obj=0" $ do - let testCase = - ( Min (M.fromList [(1, 3), (2, 5)]) - , - [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 - , LEQ (M.fromList [(1, 1), (2, 1)]) 7 - , LEQ (M.fromList [(2, 1)]) 4 - , LEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - runTest testCase (ExpectOptimal (Just 0) M.empty) + let obj = Min (M.fromList [(1, 3), (2, 5)]) + constraints = + [ LEQ (M.fromList [(1, 3), (2, 1)]) 15 + , LEQ (M.fromList [(1, 1), (2, 1)]) 7 + , LEQ (M.fromList [(2, 1)]) 4 + , LEQ (M.fromList [(1, -1), (2, 2)]) 6 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.empty + computeObjective obj varMap `shouldBe` 0 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Max 3x₁ + 5x₂ with GEQ constraints: unbounded" $ do - let testCase = - ( Max (M.fromList [(1, 3), (2, 5)]) - , - [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 - , GEQ (M.fromList [(1, 1), (2, 1)]) 7 - , GEQ (M.fromList [(2, 1)]) 4 - , GEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - runTest testCase ExpectUnbounded + let obj = Max (M.fromList [(1, 3), (2, 5)]) + constraints = + [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 + , GEQ (M.fromList [(1, 1), (2, 1)]) 7 + , GEQ (M.fromList [(2, 1)]) 4 + , GEQ (M.fromList [(1, -1), (2, 2)]) 6 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ Unbounded] -> pure () + SimplexResult Nothing _ -> expectationFailure "Expected unbounded but got infeasible" + _ -> expectationFailure "Expected unbounded" it "Min 3x₁ + 5x₂ with GEQ constraints: obj=237/7, x₁=24/7, x₂=33/7" $ do - let testCase = - ( Min (M.fromList [(1, 3), (2, 5)]) - , - [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 - , GEQ (M.fromList [(1, 1), (2, 1)]) 7 - , GEQ (M.fromList [(2, 1)]) 4 - , GEQ (M.fromList [(1, -1), (2, 2)]) 6 - ] - ) - runTest testCase (ExpectOptimal (Just (237 % 7)) (M.fromList [(1, 24 % 7), (2, 33 % 7)])) + let obj = Min (M.fromList [(1, 3), (2, 5)]) + constraints = + [ GEQ (M.fromList [(1, 3), (2, 1)]) 15 + , GEQ (M.fromList [(1, 1), (2, 1)]) 7 + , GEQ (M.fromList [(2, 1)]) 4 + , GEQ (M.fromList [(1, -1), (2, 2)]) 6 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 24 % 7), (2, 33 % 7)] + computeObjective obj varMap `shouldBe` (237 % 7) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" -- From https://www.eng.uwaterloo.ca/~syde05/phase1.pdf (requires two phases) describe "From eng.uwaterloo.ca phase1.pdf (requires two phases)" $ do it "Max x₁ - x₂ + x₃ with LEQ constraints: obj=3/5, x₂=14/5, x₃=17/5" $ do - let testCase = - ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - runTest testCase (ExpectOptimal (Just (3 % 5)) (M.fromList [(2, 14 % 5), (3, 17 % 5)])) + let obj = Max (M.fromList [(1, 1), (2, -1), (3, 1)]) + constraints = + [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 14 % 5), (3, 17 % 5)] + computeObjective obj varMap `shouldBe` (3 % 5) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min x₁ - x₂ + x₃ with LEQ constraints: unbounded" $ do - let testCase = - ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - runTest testCase ExpectUnbounded + let obj = Min (M.fromList [(1, 1), (2, -1), (3, 1)]) + constraints = + [ LEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , LEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , LEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ Unbounded] -> pure () + SimplexResult Nothing _ -> expectationFailure "Expected unbounded but got infeasible" + _ -> expectationFailure "Expected unbounded" it "Max x₁ - x₂ + x₃ with GEQ constraints: obj=1, x₁=3, x₂=2" $ do - let testCase = - ( Max (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - runTest testCase (ExpectOptimal (Just 1) (M.fromList [(1, 3), (2, 2)])) + let obj = Max (M.fromList [(1, 1), (2, -1), (3, 1)]) + constraints = + [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 3), (2, 2)] + computeObjective obj varMap `shouldBe` 1 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min x₁ - x₂ + x₃ with GEQ constraints: obj=-1/4, x₁=17/4, x₂=9/2" $ do - let testCase = - ( Min (M.fromList [(1, 1), (2, -1), (3, 1)]) - , - [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 - , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) - , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) - ] - ) - runTest testCase (ExpectOptimal (Just ((-1) % 4)) (M.fromList [(1, 17 % 4), (2, 9 % 2)])) + let obj = Min (M.fromList [(1, 1), (2, -1), (3, 1)]) + constraints = + [ GEQ (M.fromList [(1, 2), (2, -1), (3, 2)]) 4 + , GEQ (M.fromList [(1, 2), (2, -3), (3, 1)]) (-5) + , GEQ (M.fromList [(1, -1), (2, 1), (3, -2)]) (-1) + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 17 % 4), (2, 9 % 2)] + computeObjective obj varMap `shouldBe` ((-1) % 4) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" -- From page 49 of 'Linear and Integer Programming Made Easy' (requires two phases) describe "From 'Linear and Integer Programming Made Easy' (page 49, requires two phases)" $ do it "Min x₁ + x₂ + 2x₃ + x₄ with EQ constraints: obj=5, x₃=2, x₄=1" $ do - let testCase = - ( Min (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) - , - [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 - , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 - ] - ) - runTest testCase (ExpectOptimal (Just 5) (M.fromList [(3, 2), (4, 1)])) + let obj = Min (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) + constraints = + [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 + , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(3, 2), (4, 1)] + computeObjective obj varMap `shouldBe` 5 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Max x₁ + x₂ + 2x₃ + x₄ with EQ constraints: obj=8, x₁=2, x₂=6" $ do - let testCase = - ( Max (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) - , - [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 - , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 - ] - ) - runTest testCase (ExpectOptimal (Just 8) (M.fromList [(1, 2), (2, 6)])) + let obj = Max (M.fromList [(1, 1), (2, 1), (3, 2), (4, 1)]) + constraints = + [ EQ (M.fromList [(1, 1), (3, 2), (4, -2)]) 2 + , EQ (M.fromList [(2, 1), (3, 1), (4, 4)]) 6 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 2), (2, 6)] + computeObjective obj varMap `shouldBe` 8 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" -- From page 52 of 'Linear and Integer Programming Made Easy' describe "From 'Linear and Integer Programming Made Easy' (page 52)" $ do it "Max -2x₃ + 2x₄ + x₅ with EQ constraints: obj=20, x₃=6, x₄=16" $ do - let testCase = - ( Max (M.fromList [(3, -2), (4, 2), (5, 1)]) - , - [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 - , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 - ] - ) - runTest testCase (ExpectOptimal (Just 20) (M.fromList [(3, 6), (4, 16)])) + let obj = Max (M.fromList [(3, -2), (4, 2), (5, 1)]) + constraints = + [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 + , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(3, 6), (4, 16)] + computeObjective obj varMap `shouldBe` 20 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min -2x₃ + 2x₄ + x₅ with EQ constraints: obj=6, x₄=2, x₅=2" $ do - let testCase = - ( Min (M.fromList [(3, -2), (4, 2), (5, 1)]) - , - [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 - , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 - ] - ) - runTest testCase (ExpectOptimal (Just 6) (M.fromList [(4, 2), (5, 2)])) + let obj = Min (M.fromList [(3, -2), (4, 2), (5, 1)]) + constraints = + [ EQ (M.fromList [(3, -2), (4, 1), (5, 1)]) 4 + , EQ (M.fromList [(3, 3), (4, -1), (5, 2)]) 2 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(4, 2), (5, 2)] + computeObjective obj varMap `shouldBe` 6 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" -- From page 59 of 'Linear and Integer Programming Made Easy' (requires two phases) describe "From 'Linear and Integer Programming Made Easy' (page 59, requires two phases)" $ do it "Max 2x₁ + x₂: obj=150, x₂=150" $ do - let testCase = - ( Max (M.fromList [(1, 2), (2, 1)]) - , - [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - runTest testCase (ExpectOptimal (Just 150) (M.fromList [(2, 150)])) + let obj = Max (M.fromList [(1, 2), (2, 1)]) + constraints = + [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 150)] + computeObjective obj varMap `shouldBe` 150 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min 2x₁ + x₂: obj=40/3, x₂=40/3" $ do - let testCase = - ( Min (M.fromList [(1, 2), (2, 1)]) - , - [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - runTest testCase (ExpectOptimal (Just (40 % 3)) (M.fromList [(2, 40 % 3)])) + let obj = Min (M.fromList [(1, 2), (2, 1)]) + constraints = + [ LEQ (M.fromList [(1, 4), (2, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, -3)]) (-40) + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 40 % 3)] + computeObjective obj varMap `shouldBe` (40 % 3) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Max 2x₁ + x₂ with GEQ constraints: unbounded" $ do - let testCase = - ( Max (M.fromList [(1, 2), (2, 1)]) - , - [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - runTest testCase ExpectUnbounded + let obj = Max (M.fromList [(1, 2), (2, 1)]) + constraints = + [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ Unbounded] -> pure () + SimplexResult Nothing _ -> expectationFailure "Expected unbounded but got infeasible" + _ -> expectationFailure "Expected unbounded" it "Min 2x₁ + x₂ with GEQ constraints: obj=75, x₁=75/2" $ do - let testCase = - ( Min (M.fromList [(1, 2), (2, 1)]) - , - [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) - ] - ) - runTest testCase (ExpectOptimal (Just 75) (M.fromList [(1, 75 % 2)])) + let obj = Min (M.fromList [(1, 2), (2, 1)]) + constraints = + [ GEQ (M.fromList [(1, 4), (2, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, -3)]) (-40) + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 75 % 2)] + computeObjective obj varMap `shouldBe` 75 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" -- From page 59 of 'Linear and Integer Programming Made Easy' describe "From 'Linear and Integer Programming Made Easy' (page 59)" $ do it "Min -6x₁ - 4x₂ + 2x₃: obj=-120, x₁=20" $ do - let testCase = - ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , LEQ (M.fromList [(2, -5), (3, 5)]) 100 - , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - runTest testCase (ExpectOptimal (Just (-120)) (M.fromList [(1, 20)])) + let obj = Min (M.fromList [(1, -6), (2, -4), (3, 2)]) + constraints = + [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , LEQ (M.fromList [(2, -5), (3, 5)]) 100 + , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 20)] + computeObjective obj varMap `shouldBe` (-120) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Max -6x₁ - 4x₂ + 2x₃: obj=10, x₃=5" $ do - let testCase = - ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , LEQ (M.fromList [(2, -5), (3, 5)]) 100 - , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - runTest testCase (ExpectOptimal (Just 10) (M.fromList [(3, 5)])) + let obj = Max (M.fromList [(1, -6), (2, -4), (3, 2)]) + constraints = + [ LEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , LEQ (M.fromList [(2, -5), (3, 5)]) 100 + , LEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(3, 5)] + computeObjective obj varMap `shouldBe` 10 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min -6x₁ - 4x₂ + 2x₃ with GEQ constraints: unbounded" $ do - let testCase = - ( Min (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , GEQ (M.fromList [(2, -5), (3, 5)]) 100 - , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - runTest testCase ExpectUnbounded + let obj = Min (M.fromList [(1, -6), (2, -4), (3, 2)]) + constraints = + [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , GEQ (M.fromList [(2, -5), (3, 5)]) 100 + , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ Unbounded] -> pure () + SimplexResult Nothing _ -> expectationFailure "Expected unbounded but got infeasible" + _ -> expectationFailure "Expected unbounded" it "Max -6x₁ - 4x₂ + 2x₃ with GEQ constraints: unbounded" $ do - let testCase = - ( Max (M.fromList [(1, -6), (2, -4), (3, 2)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 - , GEQ (M.fromList [(2, -5), (3, 5)]) 100 - , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 - ] - ) - runTest testCase ExpectUnbounded + let obj = Max (M.fromList [(1, -6), (2, -4), (3, 2)]) + constraints = + [ GEQ (M.fromList [(1, 1), (2, 1), (3, 4)]) 20 + , GEQ (M.fromList [(2, -5), (3, 5)]) 100 + , GEQ (M.fromList [(1, 1), (3, 1), (1, 1)]) 400 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ Unbounded] -> pure () + SimplexResult Nothing _ -> expectationFailure "Expected unbounded but got infeasible" + _ -> expectationFailure "Expected unbounded" -- From page 59 of 'Linear and Integer Programming Made Easy' describe "From 'Linear and Integer Programming Made Easy' (page 59)" $ do it "Max 3x₁ + 5x₂ + 2x₃: obj=250, x₂=50" $ do - let testCase = - ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - runTest testCase (ExpectOptimal (Just 250) (M.fromList [(2, 50)])) + let obj = Max (M.fromList [(1, 3), (2, 5), (3, 2)]) + constraints = + [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 50)] + computeObjective obj varMap `shouldBe` 250 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min 3x₁ + 5x₂ + 2x₃: obj=0" $ do - let testCase = - ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - runTest testCase (ExpectOptimal (Just 0) M.empty) + let obj = Min (M.fromList [(1, 3), (2, 5), (3, 2)]) + constraints = + [ LEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , LEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , LEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.empty + computeObjective obj varMap `shouldBe` 0 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Max 3x₁ + 5x₂ + 2x₃ with GEQ constraints: unbounded" $ do - let testCase = - ( Max (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - runTest testCase ExpectUnbounded + let obj = Max (M.fromList [(1, 3), (2, 5), (3, 2)]) + constraints = + [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ Unbounded] -> pure () + SimplexResult Nothing _ -> expectationFailure "Expected unbounded but got infeasible" + _ -> expectationFailure "Expected unbounded" it "Min 3x₁ + 5x₂ + 2x₃ with GEQ constraints: obj=300, x₃=150" $ do - let testCase = - ( Min (M.fromList [(1, 3), (2, 5), (3, 2)]) - , - [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 - , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 - , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 - ] - ) - runTest testCase (ExpectOptimal (Just 300) (M.fromList [(3, 150)])) + let obj = Min (M.fromList [(1, 3), (2, 5), (3, 2)]) + constraints = + [ GEQ (M.fromList [(1, 5), (2, 1), (3, 4)]) 50 + , GEQ (M.fromList [(1, 1), (2, -1), (3, 1)]) 150 + , GEQ (M.fromList [(1, 2), (2, 1), (3, 2)]) 100 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(3, 150)] + computeObjective obj varMap `shouldBe` 300 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" describe "Simple single/two variable tests" $ do it "Max x₁ with x₁ <= 15: obj=15, x₁=15" $ do - let testCase = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - ] - ) - runTest testCase (ExpectOptimal (Just 15) (M.fromList [(1, 15)])) + let obj = Max (M.fromList [(1, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 15 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 15)] + computeObjective obj varMap `shouldBe` 15 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Max 2x₁ with mixed constraints: obj=20, x₁=10, x₂=10" $ do - let testCase = - ( Max (M.fromList [(1, 2)]) - , - [ LEQ (M.fromList [(1, 2)]) 20 - , GEQ (M.fromList [(2, 1)]) 10 - ] - ) - runTest testCase (ExpectOptimal (Just 20) (M.fromList [(1, 10), (2, 10)])) + let obj = Max (M.fromList [(1, 2)]) + constraints = + [ LEQ (M.fromList [(1, 2)]) 20 + , GEQ (M.fromList [(2, 1)]) 10 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 10), (2, 10)] + computeObjective obj varMap `shouldBe` 20 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min x₁ with x₁ <= 15: obj=0" $ do - let testCase = - ( Min (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - ] - ) - runTest testCase (ExpectOptimal (Just 0) M.empty) + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 15 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.empty + computeObjective obj varMap `shouldBe` 0 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min 2x₁ with mixed constraints: obj=0, x₂=10" $ do - let testCase = - ( Min (M.fromList [(1, 2)]) - , - [ LEQ (M.fromList [(1, 2)]) 20 - , GEQ (M.fromList [(2, 1)]) 10 - ] - ) - runTest testCase (ExpectOptimal (Just 0) (M.fromList [(2, 10)])) + let obj = Min (M.fromList [(1, 2)]) + constraints = + [ LEQ (M.fromList [(1, 2)]) 20 + , GEQ (M.fromList [(2, 1)]) 10 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 10)] + computeObjective obj varMap `shouldBe` 0 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" describe "Infeasibility tests" $ do it "Conflicting bounds x₁ <= 15 and x₁ >= 15.01: infeasible" $ do - let testCase = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - , GEQ (M.fromList [(1, 1)]) 15.01 - ] - ) - runTest testCase ExpectInfeasible + let obj = Max (M.fromList [(1, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 15 + , GEQ (M.fromList [(1, 1)]) 15.01 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" it "Conflicting bounds with additional constraint: infeasible" $ do - let testCase = - ( Max (M.fromList [(1, 1)]) - , - [ LEQ (M.fromList [(1, 1)]) 15 - , GEQ (M.fromList [(1, 1)]) 15.01 - , GEQ (M.fromList [(2, 1)]) 10 - ] - ) - runTest testCase ExpectInfeasible + let obj = Max (M.fromList [(1, 1)]) + constraints = + [ LEQ (M.fromList [(1, 1)]) 15 + , GEQ (M.fromList [(1, 1)]) 15.01 + , GEQ (M.fromList [(2, 1)]) 10 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" it "Min x₁ with duplicate GEQ constraints: obj=0, x₂=1" $ do - let testCase = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1)]) 1 - , GEQ (M.fromList [(1, 1), (2, 1)]) 1 - ] - ) - runTest testCase (ExpectOptimal (Just 0) (M.fromList [(2, 1 % 1)])) + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1), (2, 1)]) 1 + , GEQ (M.fromList [(1, 1), (2, 1)]) 1 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 1 % 1)] + computeObjective obj varMap `shouldBe` 0 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Conflicting x₁+x₂ >= 2 and x₁+x₂ <= 1: infeasible" $ do - let testCase = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1), (2, 1)]) 2 - , LEQ (M.fromList [(1, 1), (2, 1)]) 1 - ] - ) - runTest testCase ExpectInfeasible + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1), (2, 1)]) 2 + , LEQ (M.fromList [(1, 1), (2, 1)]) 1 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" describe "LEQ/GEQ reduction bug tests" $ do it "testLeqGeqBugMin1: obj=3, x₁=3, x₂=3" $ do - let testCase = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - runTest testCase (ExpectOptimal (Just 3) (M.fromList [(1, 3), (2, 3)])) + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 3), (2, 3)] + computeObjective obj varMap `shouldBe` 3 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "testLeqGeqBugMax1: obj=3, x₁=3, x₂=3" $ do - let testCase = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - runTest testCase (ExpectOptimal (Just 3) (M.fromList [(1, 3), (2, 3)])) + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 3), (2, 3)] + computeObjective obj varMap `shouldBe` 3 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "testLeqGeqBugMin2: obj=3, x₁=3, x₂=3" $ do - let testCase = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - runTest testCase (ExpectOptimal (Just 3) (M.fromList [(1, 3), (2, 3)])) + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 3), (2, 3)] + computeObjective obj varMap `shouldBe` 3 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "testLeqGeqBugMax2: obj=3, x₁=3, x₂=3" $ do - let testCase = - ( Min (M.fromList [(1, 1)]) - , - [ GEQ (M.fromList [(1, 1)]) 3 - , LEQ (M.fromList [(1, 1)]) 3 - , GEQ (M.fromList [(2, 1)]) 3 - , LEQ (M.fromList [(2, 1)]) 3 - ] - ) - runTest testCase (ExpectOptimal (Just 3) (M.fromList [(1, 3), (2, 3)])) + let obj = Min (M.fromList [(1, 1)]) + constraints = + [ GEQ (M.fromList [(1, 1)]) 3 + , LEQ (M.fromList [(1, 1)]) 3 + , GEQ (M.fromList [(2, 1)]) 3 + , LEQ (M.fromList [(2, 1)]) 3 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 3), (2, 3)] + computeObjective obj varMap `shouldBe` 3 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" -- PolyPaver-style tests with shared parameters describe "PolyPaver-style tests (feasible region [0,2.5]²)" $ do @@ -522,24 +754,64 @@ spec = do ) it "Min x₁: x₁=7/4, x₂=5/2" $ do - runTest - (mkConstraints (Min (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (7 % 4)) (M.fromList [(1, 7 % 4), (2, 5 % 2), (3, 0)])) + let (obj, constraints) = mkConstraints (Min (M.fromList [(1, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 7 % 4), (2, 5 % 2), (3, 0)] + computeObjective obj varMap `shouldBe` (7 % 4) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Max x₁: x₁=5/2, x₂=5/3" $ do - runTest - (mkConstraints (Max (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (5 % 2)) (M.fromList [(1, 5 % 2), (2, 5 % 3), (3, 0)])) + let (obj, constraints) = mkConstraints (Max (M.fromList [(1, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 5 % 2), (2, 5 % 3), (3, 0)] + computeObjective obj varMap `shouldBe` (5 % 2) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min x₂: x₂=5/3" $ do - runTest - (mkConstraints (Min (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (5 % 3)) (M.fromList [(2, 5 % 3), (1, 5 % 2), (3, 0)])) + let (obj, constraints) = mkConstraints (Min (M.fromList [(2, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 5 % 3), (1, 5 % 2), (3, 0)] + computeObjective obj varMap `shouldBe` (5 % 3) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Max x₂: x₂=5/2" $ do - runTest - (mkConstraints (Max (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (5 % 2)) (M.fromList [(2, 5 % 2), (1, 5 % 2), (3, 0)])) + let (obj, constraints) = mkConstraints (Max (M.fromList [(2, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 5 % 2), (1, 5 % 2), (3, 0)] + computeObjective obj varMap `shouldBe` (5 % 2) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" describe "PolyPaver-style tests (infeasible region [0,1.5]²)" $ do let x1l = 0.0 @@ -566,16 +838,52 @@ spec = do ) it "Max x₁: infeasible" $ do - runTest (mkConstraints (Max (M.fromList [(1, 1)]))) ExpectInfeasible + let (obj, constraints) = mkConstraints (Max (M.fromList [(1, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" it "Min x₁: infeasible" $ do - runTest (mkConstraints (Min (M.fromList [(1, 1)]))) ExpectInfeasible + let (obj, constraints) = mkConstraints (Min (M.fromList [(1, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" it "Max x₂: infeasible" $ do - runTest (mkConstraints (Max (M.fromList [(2, 1)]))) ExpectInfeasible + let (obj, constraints) = mkConstraints (Max (M.fromList [(2, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" it "Min x₂: infeasible" $ do - runTest (mkConstraints (Min (M.fromList [(2, 1)]))) ExpectInfeasible + let (obj, constraints) = mkConstraints (Min (M.fromList [(2, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" describe "PolyPaver-style tests (feasible region [0,3.5]²)" $ do let x1l = 0.0 @@ -602,24 +910,64 @@ spec = do ) it "Max x₁: x₁=7/2" $ do - runTest - (mkConstraints (Max (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (7 % 2)) (M.fromList [(2, 5 % 9), (1, 7 % 2), (3, 0)])) + let (obj, constraints) = mkConstraints (Max (M.fromList [(1, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 5 % 9), (1, 7 % 2), (3, 0)] + computeObjective obj varMap `shouldBe` (7 % 2) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min x₁: x₁=17/20" $ do - runTest - (mkConstraints (Min (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (17 % 20)) (M.fromList [(1, 17 % 20), (2, 7 % 2), (3, 0)])) + let (obj, constraints) = mkConstraints (Min (M.fromList [(1, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 17 % 20), (2, 7 % 2), (3, 0)] + computeObjective obj varMap `shouldBe` (17 % 20) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Max x₂: x₂=7/2" $ do - runTest - (mkConstraints (Max (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (7 % 2)) (M.fromList [(2, 7 % 2), (1, 22 % 9)])) + let (obj, constraints) = mkConstraints (Max (M.fromList [(2, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 7 % 2), (1, 22 % 9)] + computeObjective obj varMap `shouldBe` (7 % 2) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min x₂: x₂=5/9" $ do - runTest - (mkConstraints (Min (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (5 % 9)) (M.fromList [(2, 5 % 9), (1, 7 % 2), (3, 0)])) + let (obj, constraints) = mkConstraints (Min (M.fromList [(2, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 5 % 9), (1, 7 % 2), (3, 0)] + computeObjective obj varMap `shouldBe` (5 % 9) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" describe "PolyPaver two-function tests (infeasible)" $ do let x1l = 0.0 @@ -655,16 +1003,52 @@ spec = do ) it "Max x₁: infeasible" $ do - runTest (mkConstraints (Max (M.fromList [(1, 1)]))) ExpectInfeasible + let (obj, constraints) = mkConstraints (Max (M.fromList [(1, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" it "Min x₁: infeasible" $ do - runTest (mkConstraints (Min (M.fromList [(1, 1)]))) ExpectInfeasible + let (obj, constraints) = mkConstraints (Min (M.fromList [(1, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" it "Max x₂: infeasible" $ do - runTest (mkConstraints (Max (M.fromList [(2, 1)]))) ExpectInfeasible + let (obj, constraints) = mkConstraints (Max (M.fromList [(2, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" it "Min x₂: infeasible" $ do - runTest (mkConstraints (Min (M.fromList [(2, 1)]))) ExpectInfeasible + let (obj, constraints) = mkConstraints (Min (M.fromList [(2, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult Nothing _ -> pure () + _ -> expectationFailure "Expected infeasible" describe "PolyPaver two-function tests (feasible)" $ do let x1l = 0.0 @@ -700,61 +1084,294 @@ spec = do ) it "Max x₁: x₁=5/2" $ do - runTest - (mkConstraints (Max (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (5 % 2)) (M.fromList [(1, 5 % 2), (2, 45 % 22), (4, 0)])) + let (obj, constraints) = mkConstraints (Max (M.fromList [(1, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 5 % 2), (2, 45 % 22), (4, 0)] + computeObjective obj varMap `shouldBe` (5 % 2) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min x₁: x₁=45/22" $ do - runTest - (mkConstraints (Min (M.fromList [(1, 1)]))) - (ExpectOptimal (Just (45 % 22)) (M.fromList [(1, 45 % 22), (2, 5 % 2), (4, 0)])) + let (obj, constraints) = mkConstraints (Min (M.fromList [(1, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 45 % 22), (2, 5 % 2), (4, 0)] + computeObjective obj varMap `shouldBe` (45 % 22) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Max x₂: x₂=5/2" $ do - runTest - (mkConstraints (Max (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (5 % 2)) (M.fromList [(2, 5 % 2), (1, 5 % 2), (4, 0)])) + let (obj, constraints) = mkConstraints (Max (M.fromList [(2, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 5 % 2), (1, 5 % 2), (4, 0)] + computeObjective obj varMap `shouldBe` (5 % 2) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "Min x₂: x₂=45/22" $ do - runTest - (mkConstraints (Min (M.fromList [(2, 1)]))) - (ExpectOptimal (Just (45 % 22)) (M.fromList [(2, 45 % 22), (1, 5 % 2), (4, 0)])) + let (obj, constraints) = mkConstraints (Min (M.fromList [(2, 1)])) + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 45 % 22), (1, 5 % 2), (4, 0)] + computeObjective obj varMap `shouldBe` (45 % 22) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" describe "QuickCheck-generated regression tests" $ do it "testQuickCheck1: obj=-370, x₁=5/3, x₂=26" $ do - let testCase = - ( Max (M.fromList [(1, 12), (2, -15)]) - , - [ EQ (M.fromList [(1, 24), (2, -2)]) (-12) - , GEQ (M.fromList [(1, -20), (2, 11)]) (-7) - , GEQ (M.fromList [(1, -28), (2, 5)]) (-8) - , GEQ (M.fromList [(1, 3), (2, 0)]) 5 - , LEQ (M.fromList [(1, -48)]) (-1) - ] - ) - runTest testCase (ExpectOptimal (Just (-370)) (M.fromList [(2, 26), (1, 5 % 3)])) + let obj = Max (M.fromList [(1, 12), (2, -15)]) + constraints = + [ EQ (M.fromList [(1, 24), (2, -2)]) (-12) + , GEQ (M.fromList [(1, -20), (2, 11)]) (-7) + , GEQ (M.fromList [(1, -28), (2, 5)]) (-8) + , GEQ (M.fromList [(1, 3), (2, 0)]) 5 + , LEQ (M.fromList [(1, -48)]) (-1) + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 26), (1, 5 % 3)] + computeObjective obj varMap `shouldBe` (-370) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "testQuickCheck2: obj=-2/9, x₁=14/9, x₂=8/9" $ do - let testCase = - ( Max (M.fromList [(1, -3), (2, 5)]) - , - [ LEQ (M.fromList [(1, -6), (2, 6)]) 4 - , LEQ (M.fromList [(1, 1), (2, -4), (3, 3)]) (-2) - , LEQ (M.fromList [(2, 7), (1, -4)]) 0 - ] - ) - runTest testCase (ExpectOptimal (Just ((-2) % 9)) (M.fromList [(1, 14 % 9), (2, 8 % 9)])) + let obj = Max (M.fromList [(1, -3), (2, 5)]) + constraints = + [ LEQ (M.fromList [(1, -6), (2, 6)]) 4 + , LEQ (M.fromList [(1, 1), (2, -4), (3, 3)]) (-2) + , LEQ (M.fromList [(2, 7), (1, -4)]) 0 + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(1, 14 % 9), (2, 8 % 9)] + computeObjective obj varMap `shouldBe` ((-2) % 9) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" it "testQuickCheck3 (tests objective simplification): obj=-8, x₂=2" $ do - let testCase = - ( Min (M.fromList [(2, 0), (2, -4)]) - , - [ GEQ (M.fromList [(1, 5), (2, 4)]) (-4) - , LEQ (M.fromList [(1, -1), (2, -1)]) 2 - , LEQ (M.fromList [(2, 1)]) 2 - , GEQ (M.fromList [(1, -5), (2, -1), (2, 1)]) (-5) - ] - ) - runTest testCase (ExpectOptimal (Just (-8)) (M.fromList [(2, 2)])) + let obj = Min (M.fromList [(2, 0), (2, -4)]) + constraints = + [ GEQ (M.fromList [(1, 5), (2, 4)]) (-4) + , LEQ (M.fromList [(1, -1), (2, -1)]) 2 + , LEQ (M.fromList [(2, 1)]) 2 + , GEQ (M.fromList [(1, -5), (2, -1), (2, 1)]) (-5) + ] + allVars = collectAllVars [obj] constraints + domainMap = VarDomainMap $ M.fromSet (const nonNegative) allVars + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + varMap `shouldBe` M.fromList [(2, 2)] + computeObjective obj varMap `shouldBe` (-8) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" + + describe "twoPhaseSimplex with empty constraint system" $ do + describe "Single variable with boundedRange" $ do + it "Max x₁ with 0 ≤ x₁ ≤ 10: optimal at x₁=10" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 0 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + M.findWithDefault 0 1 varMap `shouldBe` 10 + computeObjective obj varMap `shouldBe` 10 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" + + it "Min x₁ with 0 ≤ x₁ ≤ 10: optimal at x₁=0" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 0 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + M.findWithDefault 0 1 varMap `shouldBe` 0 + computeObjective obj varMap `shouldBe` 0 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" + + it "Max x₁ with 5 ≤ x₁ ≤ 15: optimal at x₁=15" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 5 15)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + M.findWithDefault 0 1 varMap `shouldBe` 15 + computeObjective obj varMap `shouldBe` 15 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" + + it "Min x₁ with 5 ≤ x₁ ≤ 15: optimal at x₁=5" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 5 15)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + M.findWithDefault 0 1 varMap `shouldBe` 5 + computeObjective obj varMap `shouldBe` 5 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" + + it "Max x₁ with -5 ≤ x₁ ≤ 10: optimal at x₁=10" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange (-5) 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + M.findWithDefault 0 1 varMap `shouldBe` 10 + computeObjective obj varMap `shouldBe` 10 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" + + it "Min x₁ with -5 ≤ x₁ ≤ 10: optimal at x₁=-5" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange (-5) 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + M.findWithDefault 0 1 varMap `shouldBe` (-5) + computeObjective obj varMap `shouldBe` (-5) + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" + + describe "Two variables with boundedRange" $ do + it "Max x₁ + x₂ with 0 ≤ x₁ ≤ 10, 0 ≤ x₂ ≤ 10: optimal at 20" $ do + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 0 10), (2, boundedRange 0 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + M.lookup 1 varMap `shouldBe` Just 10 + M.lookup 2 varMap `shouldBe` Just 10 + computeObjective obj varMap `shouldBe` 20 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" + + it "Min x₁ + x₂ with 0 ≤ x₁ ≤ 10, 0 ≤ x₂ ≤ 10: optimal at 0" $ do + let obj = Min (M.fromList [(1, 1), (2, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 0 10), (2, boundedRange 0 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> + computeObjective obj varMap `shouldBe` 0 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" + + it "Max 2x₁ - x₂ with 0 ≤ x₁ ≤ 10, 0 ≤ x₂ ≤ 5: optimal at 20" $ do + let obj = Max (M.fromList [(1, 2), (2, -1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange 0 10), (2, boundedRange 0 5)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + M.lookup 1 varMap `shouldBe` Just 10 + M.findWithDefault 0 2 varMap `shouldBe` 0 + computeObjective obj varMap `shouldBe` 20 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" + + describe "NonNegative only (no upper bound), empty constraints" $ do + it "Max x₁ with x₁ ≥ 0 and no constraints: unbounded" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, nonNegative)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ Unbounded] -> pure () + _ -> expectationFailure "Expected unbounded" + + it "Min x₁ with x₁ ≥ 0 and no constraints: optimal at 0" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, nonNegative)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_s l -> l > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> + M.findWithDefault 0 1 varMap `shouldBe` 0 + SimplexResult Nothing _ -> expectationFailure "Expected optimal but got infeasible" + _ -> expectationFailure "Unexpected result" describe "twoPhaseSimplex (with VarDomainMap)" $ do it "Shift transformation with negative lower bound" $ do @@ -857,7 +1474,7 @@ spec = do SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let xVal = M.findWithDefault 0 1 varMap yVal = M.findWithDefault 0 2 varMap - oVal = computeObjValue obj varMap + oVal = computeObjective obj varMap (xVal + yVal) `shouldBe` 5 oVal `shouldBe` 5 _ -> expectationFailure "Unexpected result format" @@ -983,7 +1600,7 @@ spec = do SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just 3 M.lookup 2 varMap `shouldBe` Just 4 - computeObjValue obj varMap `shouldBe` 7 + computeObjective obj varMap `shouldBe` 7 _ -> expectationFailure "Unexpected result format" it "Max 2x₁ - x₂ with -2 ≤ x₁ ≤ 5, -3 ≤ x₂ ≤ 4" $ do @@ -1001,7 +1618,7 @@ spec = do SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just 5 M.lookup 2 varMap `shouldBe` Just (-3) - computeObjValue obj varMap `shouldBe` 13 + computeObjective obj varMap `shouldBe` 13 _ -> expectationFailure "Unexpected result format" it "Mixed bounds: x₁ nonNegative, x₂ with upper bound only (unbounded below)" $ do @@ -1103,7 +1720,7 @@ spec = do SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do let x1 = M.findWithDefault 0 1 varMap x2 = M.findWithDefault 0 2 varMap - objVal = computeObjValue obj varMap + objVal = computeObjective obj varMap -- Verify the actual objective value objVal `shouldBe` 10 -- Verify lower bounds are respected @@ -1124,7 +1741,7 @@ spec = do case actualResult of SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do - let objVal = computeObjValue obj varMap + let objVal = computeObjective obj varMap -- Verify the actual objective value objVal `shouldBe` (-5) M.lookup 1 varMap `shouldBe` Just (-2) @@ -1233,7 +1850,7 @@ spec = do case actualResult of SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do - let objVal = computeObjValue obj varMap + let objVal = computeObjective obj varMap M.lookup 1 varMap `shouldBe` Just 10 M.lookup 2 varMap `shouldBe` Just 10 -- Verify objective value @@ -1256,7 +1873,7 @@ spec = do case actualResult of SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do - let objVal = computeObjValue obj varMap + let objVal = computeObjective obj varMap M.lookup 1 varMap `shouldBe` Just (-5) M.lookup 2 varMap `shouldBe` Just (-5) -- Verify objective value @@ -1359,7 +1976,7 @@ spec = do SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just 5 M.lookup 2 varMap `shouldBe` Just 7 - let objVal = computeObjValue obj varMap + let objVal = computeObjective obj varMap objVal `shouldBe` 12 _ -> expectationFailure "Unexpected result format" @@ -1381,7 +1998,7 @@ spec = do SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just (-5) M.lookup 2 varMap `shouldBe` Just (-3) - let objVal = computeObjValue obj varMap + let objVal = computeObjective obj varMap objVal `shouldBe` (-8) _ -> expectationFailure "Unexpected result format" @@ -1404,7 +2021,7 @@ spec = do SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do M.lookup 1 varMap `shouldBe` Just 5 M.lookup 2 varMap `shouldBe` Just (-3) - let objVal = computeObjValue obj varMap + let objVal = computeObjective obj varMap objVal `shouldBe` 8 _ -> expectationFailure "Unexpected result format" @@ -1473,7 +2090,7 @@ spec = do case actualResult of SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do - let objVal = computeObjValue obj varMap + let objVal = computeObjective obj varMap -- Verify objective value objVal `shouldBe` 20 _ -> expectationFailure "Unexpected result format" @@ -1502,7 +2119,7 @@ spec = do let x1 = M.findWithDefault 0 1 varMap x2 = M.findWithDefault 0 2 varMap x3 = M.findWithDefault 0 3 varMap - objVal = computeObjValue obj varMap + objVal = computeObjective obj varMap -- Verify constraints x1 `shouldSatisfy` (>= 0) x2 `shouldSatisfy` (>= (-5)) @@ -1635,7 +2252,7 @@ spec = do case actualResult of SimplexResult Nothing _ -> expectationFailure "Expected a solution but got Nothing" SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do - let objVal = computeObjValue obj varMap + let objVal = computeObjective obj varMap -- Verify objective value objVal `shouldBe` 15 _ -> expectationFailure "Unexpected result format" @@ -2150,6 +2767,213 @@ spec = do newVarMap = unapplyTransformToVarMap transform varMap in M.lookup 1 newVarMap == Just negOrigVal + describe "twoPhaseSimplex with upperBoundOnly domain" $ do + it "Max x\x2081 with x\x2081 \x2264 10 (upper bound only): x\x2081 unconstrained below, unbounded" $ do + -- upperBoundOnly means no lower bound (split) + upper bound + -- Max x\x2081 with only x\x2081 \x2264 10: unbounded below, but maximizing so optimal at 10 + let obj = Max (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, upperBoundOnly 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> + M.findWithDefault 0 1 varMap `shouldBe` 10 + _ -> expectationFailure "Expected optimal at upper bound" + + it "Min x\x2081 with x\x2081 \x2264 10 (upper bound only): unbounded (no lower bound)" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, upperBoundOnly 10)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ Unbounded] -> pure () + _ -> expectationFailure "Expected unbounded (no lower bound)" + + it "Max x\x2081 with x\x2081 \x2264 5 and x\x2081 + x\x2082 \x2264 8, x\x2082 upperBoundOnly 3" $ do + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = [LEQ (M.fromList [(1, 1), (2, 1)]) 8] + domainMap = VarDomainMap $ M.fromList [(1, upperBoundOnly 5), (2, upperBoundOnly 3)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + let x1 = M.findWithDefault 0 1 varMap + x2 = M.findWithDefault 0 2 varMap + x1 `shouldSatisfy` (<= 5) + x2 `shouldSatisfy` (<= 3) + computeObjective obj varMap `shouldBe` 8 + _ -> expectationFailure "Expected optimal result" + + it "Min x\x2081 with x\x2081 \x2264 5, x\x2081 \x2265 -3: optimal at lower bound" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [GEQ (M.fromList [(1, 1)]) (-3)] + domainMap = VarDomainMap $ M.fromList [(1, upperBoundOnly 5)] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> + M.lookup 1 varMap `shouldBe` Just (-3) + _ -> expectationFailure "Expected optimal at -3" + + describe "twoPhaseSimplex with fully-negative boundedRange" $ do + it "Max x\x2081 with -10 \x2264 x\x2081 \x2264 -2: optimal at x\x2081=-2" $ do + let obj = Max (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange (-10) (-2))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> + M.lookup 1 varMap `shouldBe` Just (-2) + _ -> expectationFailure "Expected optimal at -2" + + it "Min x\x2081 with -10 \x2264 x\x2081 \x2264 -2: optimal at x\x2081=-10" $ do + let obj = Min (M.fromList [(1, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange (-10) (-2))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> + M.lookup 1 varMap `shouldBe` Just (-10) + _ -> expectationFailure "Expected optimal at -10" + + it "Max x\x2081 + x\x2082 with -8 \x2264 x\x2081 \x2264 -1, -6 \x2264 x\x2082 \x2264 -2" $ do + let obj = Max (M.fromList [(1, 1), (2, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange (-8) (-1)), (2, boundedRange (-6) (-2))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + M.lookup 1 varMap `shouldBe` Just (-1) + M.lookup 2 varMap `shouldBe` Just (-2) + computeObjective obj varMap `shouldBe` (-3) + _ -> expectationFailure "Expected optimal at (-1, -2)" + + it "Min x\x2081 + x\x2082 with -8 \x2264 x\x2081 \x2264 -1, -6 \x2264 x\x2082 \x2264 -2" $ do + let obj = Min (M.fromList [(1, 1), (2, 1)]) + constraints = [] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange (-8) (-1)), (2, boundedRange (-6) (-2))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + M.lookup 1 varMap `shouldBe` Just (-8) + M.lookup 2 varMap `shouldBe` Just (-6) + computeObjective obj varMap `shouldBe` (-14) + _ -> expectationFailure "Expected optimal at (-8, -6)" + + it "Max x\x2081 with -5 \x2264 x\x2081 \x2264 -1 and x\x2081 + x\x2082 \x2264 0, x\x2082 in [-5, -1]" $ do + -- With constraint x\x2081 + x\x2082 \x2264 0, and both negative ranges + let obj = Max (M.fromList [(1, 1)]) + constraints = [LEQ (M.fromList [(1, 1), (2, 1)]) 0] + domainMap = VarDomainMap $ M.fromList [(1, boundedRange (-5) (-1)), (2, boundedRange (-5) (-1))] + actualResult <- + runStdoutLoggingT $ + filterLogger (\_logSource logLevel -> logLevel > LevelInfo) $ + twoPhaseSimplex domainMap [obj] constraints + case actualResult of + SimplexResult (Just _) [ObjectiveResult _ (Optimal varMap)] -> do + let x1 = M.findWithDefault 0 1 varMap + x2 = M.findWithDefault 0 2 varMap + x1 `shouldBe` (-1) + (x1 + x2) `shouldSatisfy` (<= 0) + _ -> expectationFailure "Expected optimal result" + + describe "postprocess" $ do + it "passes through Unbounded unchanged" $ do + let originalVars = Set.fromList [1, 2] + transforms = [Shift 1 3 (-5)] + postprocess originalVars transforms Unbounded `shouldBe` Unbounded + + it "filters to original variables only" $ do + let originalVars = Set.fromList [1, 2] + transforms = [] + -- varMap has original vars and some extra (slack/artificial) + varMap = M.fromList [(1, 5), (2, 10), (3, 99), (4, 100)] + postprocess originalVars transforms (Optimal varMap) `shouldBe` Optimal (M.fromList [(1, 5), (2, 10)]) + + it "unapplies Shift transform and filters" $ do + -- Shift: original var 1 was shifted to var 3 with offset -5 + -- In transformed space: var 3 = 8, meaning original var 1 = 8 + (-5) = 3 + let originalVars = Set.fromList [1] + transforms = [Shift 1 3 (-5)] + varMap = M.fromList [(3, 8)] + postprocess originalVars transforms (Optimal varMap) `shouldBe` Optimal (M.fromList [(1, 3)]) + + it "unapplies Split transform and filters" $ do + -- Split: original var 1 was split into pos var 3 and neg var 4 + -- original var 1 = var 3 - var 4 + let originalVars = Set.fromList [1] + transforms = [Split 1 3 4] + varMap = M.fromList [(3, 7), (4, 2)] + postprocess originalVars transforms (Optimal varMap) `shouldBe` Optimal (M.fromList [(1, 5)]) + + it "unapplies multiple transforms and filters" $ do + -- var 1: Shift by -3 to var 3 + -- var 2: Split into vars 4 and 5 + let originalVars = Set.fromList [1, 2] + transforms = [Shift 1 3 (-3), Split 2 4 5] + varMap = M.fromList [(3, 10), (4, 6), (5, 1)] + postprocess originalVars transforms (Optimal varMap) + `shouldBe` Optimal (M.fromList [(1, 7), (2, 5)]) + + it "returns empty map when no original vars have values" $ do + let originalVars = Set.fromList [1] + transforms = [] + varMap = M.fromList [(2, 5)] + postprocess originalVars transforms (Optimal varMap) `shouldBe` Optimal M.empty + + describe "prettyShowVarLitMapSum" $ do + it "shows empty map as empty string" $ do + prettyShowVarLitMapSum M.empty `shouldBe` "" + + it "shows single positive coefficient" $ do + prettyShowVarLitMapSum (M.fromList [(1, 3)]) `shouldBe` "3 * 1 + " + + it "shows single negative coefficient with parentheses" $ do + prettyShowVarLitMapSum (M.fromList [(1, -2)]) `shouldBe` "(-2) * 1 + " + + it "shows multiple coefficients" $ do + let result = prettyShowVarLitMapSum (M.fromList [(1, 2), (2, 3)]) + result `shouldBe` "2 * 1 + 3 * 2 + " + + describe "prettyShowPolyConstraint" $ do + it "shows LEQ constraint" $ do + prettyShowPolyConstraint (LEQ (M.fromList [(1, 2)]) 10) `shouldBe` "2 * 1 + " ++ " <= " ++ show (10 :: Rational) + + it "shows GEQ constraint" $ do + prettyShowPolyConstraint (GEQ (M.fromList [(1, 1)]) 5) `shouldBe` "1 * 1 + " ++ " >= " ++ show (5 :: Rational) + + it "shows EQ constraint" $ do + prettyShowPolyConstraint (EQ (M.fromList [(1, 1)]) 3) `shouldBe` "1 * 1 + " ++ " == " ++ show (3 :: Rational) + + describe "prettyShowObjectiveFunction" $ do + it "shows Max objective" $ do + prettyShowObjectiveFunction (Max (M.fromList [(1, 2)])) `shouldBe` "max: 2 * 1 + " + + it "shows Min objective" $ do + prettyShowObjectiveFunction (Min (M.fromList [(1, 5)])) `shouldBe` "min: 5 * 1 + " + describe "twoPhaseSimplex with multiple objectives" $ do it "optimizes two objectives over the same feasible region" $ do -- Feasible region: x₁ + x₂ ≤ 10, x₁ ≤ 6, x₂ ≤ 8, x₁,x₂ ≥ 0 @@ -2243,9 +3067,7 @@ spec = do -- Min x₁ with x₁ ≥ 0: optimal at x₁=0 let obj1 = Max (M.fromList [(1, 1)]) -- This will be unbounded obj2 = Min (M.fromList [(1, 1)]) -- This will have optimal at 0 - -- Add a dummy constraint to ensure the system is processable - -- x₁ ≥ 0 (enforced by nonNegative domain) but no upper bound - constraints = [GEQ (M.fromList [(1, 1)]) 0] -- x₁ ≥ 0 + constraints = [] domainMap = VarDomainMap $ M.fromList [(1, nonNegative)] SimplexResult mFeasibleSystem objResults <- runStdoutLoggingT $ diff --git a/test/Linear/Simplex/UtilSpec.hs b/test/Linear/Simplex/UtilSpec.hs new file mode 100644 index 0000000..68b0d4a --- /dev/null +++ b/test/Linear/Simplex/UtilSpec.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Linear.Simplex.UtilSpec where + +import Prelude hiding (EQ) + +import Control.Exception (evaluate) +import qualified Data.Map as M +import Test.Hspec +import Test.QuickCheck + +import Linear.Simplex.Types +import Linear.Simplex.Util + +spec :: Spec +spec = do + describe "isMax" $ do + it "returns True for Max" $ do + isMax (Max (M.fromList [(1, 1)])) `shouldBe` True + + it "returns False for Min" $ do + isMax (Min (M.fromList [(1, 1)])) `shouldBe` False + + it "returns True for Max with empty coefficients" $ do + isMax (Max M.empty) `shouldBe` True + + it "returns False for Min with empty coefficients" $ do + isMax (Min M.empty) `shouldBe` False + + describe "simplifySystem" $ do + describe "Unit tests" $ do + it "returns empty list for empty input" $ do + simplifySystem [] `shouldBe` [] + + it "preserves a single LEQ constraint" $ do + let c = LEQ (M.fromList [(1, 2)]) 10 + simplifySystem [c] `shouldBe` [c] + + it "preserves a single GEQ constraint" $ do + let c = GEQ (M.fromList [(1, 1)]) 5 + simplifySystem [c] `shouldBe` [c] + + it "preserves a single EQ constraint" $ do + let c = EQ (M.fromList [(1, 3)]) 15 + simplifySystem [c] `shouldBe` [c] + + it "reduces matching LEQ and GEQ into EQ" $ do + let lhs = M.fromList [(1, 1)] + rhs = 5 + simplifySystem [LEQ lhs rhs, GEQ lhs rhs] `shouldBe` [EQ lhs rhs] + + it "reduces matching GEQ and LEQ into EQ" $ do + let lhs = M.fromList [(1, 1)] + rhs = 5 + simplifySystem [GEQ lhs rhs, LEQ lhs rhs] `shouldBe` [EQ lhs rhs] + + it "keeps non-matching LEQ and GEQ separate" $ do + let c1 = LEQ (M.fromList [(1, 1)]) 10 + c2 = GEQ (M.fromList [(1, 1)]) 5 + simplifySystem [c1, c2] `shouldBe` [c1, c2] + + it "removes duplicate constraints" $ do + let c = LEQ (M.fromList [(1, 2)]) 10 + simplifySystem [c, c] `shouldBe` [c] + + it "reduces LEQ matching an existing EQ" $ do + let lhs = M.fromList [(1, 1)] + rhs = 5 + simplifySystem [LEQ lhs rhs, EQ lhs rhs] `shouldBe` [EQ lhs rhs] + + it "reduces GEQ matching an existing EQ" $ do + let lhs = M.fromList [(1, 1)] + rhs = 5 + simplifySystem [GEQ lhs rhs, EQ lhs rhs] `shouldBe` [EQ lhs rhs] + + it "keeps EQ and removes matching LEQ from rest" $ do + let lhs = M.fromList [(1, 1)] + rhs = 5 + simplifySystem [EQ lhs rhs, LEQ lhs rhs] `shouldBe` [EQ lhs rhs] + + it "preserves unrelated constraints alongside a reduction" $ do + let lhs = M.fromList [(1, 1)] + rhs = 5 + unrelated = GEQ (M.fromList [(2, 3)]) 7 + simplifySystem [LEQ lhs rhs, GEQ lhs rhs, unrelated] + `shouldBe` [EQ lhs rhs, unrelated] + + describe "Properties" $ do + it "idempotent: simplifying twice equals simplifying once" $ + property $ + \(constraints :: [(Int, Rational, Rational)]) -> + let mkConstraint (tag, coeff, rhs) = + case tag `mod` 3 of + 0 -> LEQ (M.fromList [(1, coeff)]) rhs + 1 -> GEQ (M.fromList [(1, coeff)]) rhs + _ -> EQ (M.fromList [(1, coeff)]) rhs + system = map mkConstraint constraints + in simplifySystem (simplifySystem system) == simplifySystem system + + it "never increases the number of constraints" $ + property $ + \(constraints :: [(Int, Rational, Rational)]) -> + let mkConstraint (tag, coeff, rhs) = + case tag `mod` 3 of + 0 -> LEQ (M.fromList [(1, coeff)]) rhs + 1 -> GEQ (M.fromList [(1, coeff)]) rhs + _ -> EQ (M.fromList [(1, coeff)]) rhs + system = map mkConstraint constraints + in length (simplifySystem system) <= length system + + it "matching LEQ and GEQ always produce EQ" $ + property $ + \(coeff :: Rational, rhs :: Rational) -> + let lhs = M.fromList [(1, coeff)] + in simplifySystem [LEQ lhs rhs, GEQ lhs rhs] == [EQ lhs rhs] + + describe "dictionaryFormToTableau and tableauInDictionaryForm" $ do + describe "Unit tests" $ do + it "converts a simple dictionary entry to tableau form" $ do + -- Dict: x₁ = 3 + 2*x₂ means DictValue {varMapSum = {2: 2}, constant = 3} + -- Tableau: x₁ - 2*x₂ = 3 means TableauRow {lhs = {1: 1, 2: -2}, rhs = 3} + let dict = M.fromList [(1, DictValue {varMapSum = M.fromList [(2, 2)], constant = 3})] + tableau = dictionaryFormToTableau dict + case M.lookup 1 tableau of + Just row -> do + row.lhs `shouldBe` M.fromList [(1, 1), (2, -2)] + row.rhs `shouldBe` 3 + Nothing -> expectationFailure "Expected row for var 1" + + it "converts an empty dictionary to empty tableau" $ do + dictionaryFormToTableau M.empty `shouldBe` M.empty + + it "converts a simple tableau entry to dictionary form" $ do + -- Tableau: 1*x₁ + (-2)*x₂ = 3 means x₁ = 3 + 2*x₂ + let tableau = M.fromList [(1, TableauRow {lhs = M.fromList [(1, 1), (2, -2)], rhs = 3})] + dict = tableauInDictionaryForm tableau + case M.lookup 1 dict of + Just entry -> do + entry.varMapSum `shouldBe` M.fromList [(2, 2)] + entry.constant `shouldBe` 3 + Nothing -> expectationFailure "Expected entry for var 1" + + it "converts an empty tableau to empty dictionary" $ do + tableauInDictionaryForm M.empty `shouldBe` M.empty + + describe "Round-trip properties" $ do + it "tableauInDictionaryForm . dictionaryFormToTableau is identity" $ + property $ + \(pairs :: [(Int, [(Int, Rational)], Rational)]) -> + let mkEntry (var, coeffs, c) = + let basicVar = abs var + 1 + -- Ensure no coefficient var clashes with the basic var + safeCoeffs = filter (\(v, _) -> abs v + 1000 /= basicVar) coeffs + in (basicVar, DictValue {varMapSum = M.fromList (map (\(v, coeff) -> (abs v + 1000, coeff)) safeCoeffs), constant = c}) + dict = M.fromList (map mkEntry pairs) + roundTripped = tableauInDictionaryForm (dictionaryFormToTableau dict) + in roundTripped == dict + + it "dictionaryFormToTableau . tableauInDictionaryForm is identity for well-formed tableaux" $ + property $ + \(var :: Positive Int, coeffPairs :: [(Positive Int, Rational)], c :: Rational) -> + let basicVar = getPositive var + -- Ensure basic var has coefficient 1 (well-formed tableau) + otherCoeffs = M.fromList [(getPositive v + basicVar, coeff) | (v, coeff) <- coeffPairs] + lhs = M.insert basicVar 1 otherCoeffs + tableau = M.singleton basicVar (TableauRow {lhs = lhs, rhs = c}) + roundTripped = dictionaryFormToTableau (tableauInDictionaryForm tableau) + in roundTripped == tableau + + describe "combineVarLitMapSums" $ do + describe "Unit tests" $ do + it "combines two disjoint maps" $ do + let m1 = M.fromList [(1, 3)] + m2 = M.fromList [(2, 5)] + combineVarLitMapSums m1 m2 `shouldBe` M.fromList [(1, 3), (2, 5)] + + it "sums values for overlapping keys" $ do + let m1 = M.fromList [(1, 3), (2, 4)] + m2 = M.fromList [(1, 7), (3, 1)] + combineVarLitMapSums m1 m2 `shouldBe` M.fromList [(1, 10), (2, 4), (3, 1)] + + it "returns other map when one is empty" $ do + let m = M.fromList [(1, 5)] + combineVarLitMapSums M.empty m `shouldBe` m + combineVarLitMapSums m M.empty `shouldBe` m + + it "returns empty for two empty maps" $ do + combineVarLitMapSums M.empty M.empty `shouldBe` (M.empty :: VarLitMapSum) + + describe "Properties" $ do + it "is commutative" $ + property $ + \(pairs1 :: [(Int, Rational)], pairs2 :: [(Int, Rational)]) -> + let m1 = M.fromList pairs1 + m2 = M.fromList pairs2 + in combineVarLitMapSums m1 m2 == combineVarLitMapSums m2 m1 + + it "has empty map as identity" $ + property $ + \(pairs :: [(Int, Rational)]) -> + let m = M.fromList pairs + in combineVarLitMapSums m M.empty == m + && combineVarLitMapSums M.empty m == m + + it "is associative" $ + property $ + \(p1 :: [(Int, Rational)], p2 :: [(Int, Rational)], p3 :: [(Int, Rational)]) -> + let m1 = M.fromList p1 + m2 = M.fromList p2 + m3 = M.fromList p3 + in combineVarLitMapSums (combineVarLitMapSums m1 m2) m3 + == combineVarLitMapSums m1 (combineVarLitMapSums m2 m3) + + describe "foldVarLitMap" $ do + describe "Unit tests" $ do + it "returns the single map for a singleton list" $ do + let m = M.fromList [(1, 5), (2, 3)] + foldVarLitMap [m] `shouldBe` m + + it "combines two maps" $ do + let m1 = M.fromList [(1, 3)] + m2 = M.fromList [(1, 7), (2, 4)] + foldVarLitMap [m1, m2] `shouldBe` M.fromList [(1, 10), (2, 4)] + + it "combines three maps" $ do + let m1 = M.fromList [(1, 1)] + m2 = M.fromList [(1, 2), (2, 3)] + m3 = M.fromList [(2, 7), (3, 5)] + foldVarLitMap [m1, m2, m3] `shouldBe` M.fromList [(1, 3), (2, 10), (3, 5)] + + it "throws error on empty list" $ do + evaluate (foldVarLitMap []) `shouldThrow` anyErrorCall + + describe "Properties" $ do + it "folding a singleton list is identity" $ + property $ + \(pairs :: [(Int, Rational)]) -> + let m = M.fromList pairs + in foldVarLitMap [m] == m + + it "folding two maps equals combineVarLitMapSums" $ + property $ + \(p1 :: [(Int, Rational)], p2 :: [(Int, Rational)]) -> + let m1 = M.fromList p1 + m2 = M.fromList p2 + in foldVarLitMap [m1, m2] == combineVarLitMapSums m1 m2 + + describe "insertPivotObjectiveToDict" $ do + it "inserts objective into empty dictionary" $ do + let obj = PivotObjective {variable = 1, function = M.fromList [(2, 3)], constant = 5} + result = insertPivotObjectiveToDict obj M.empty + case M.lookup 1 result of + Just entry -> do + entry.varMapSum `shouldBe` M.fromList [(2, 3)] + entry.constant `shouldBe` 5 + Nothing -> expectationFailure "Expected entry for objective variable" + + it "inserts objective into non-empty dictionary without overwriting others" $ do + let existing = M.fromList [(2, DictValue {varMapSum = M.fromList [(3, 1)], constant = 10})] + obj = PivotObjective {variable = 1, function = M.fromList [(3, 4)], constant = 7} + result = insertPivotObjectiveToDict obj existing + M.size result `shouldBe` 2 + case M.lookup 2 result of + Just entry -> entry.constant `shouldBe` 10 + Nothing -> expectationFailure "Existing entry should be preserved" + + it "overwrites existing entry with same variable" $ do + let existing = M.fromList [(1, DictValue {varMapSum = M.fromList [(2, 1)], constant = 3})] + obj = PivotObjective {variable = 1, function = M.fromList [(2, 99)], constant = 42} + result = insertPivotObjectiveToDict obj existing + M.size result `shouldBe` 1 + case M.lookup 1 result of + Just entry -> do + entry.varMapSum `shouldBe` M.fromList [(2, 99)] + entry.constant `shouldBe` 42 + Nothing -> expectationFailure "Expected updated entry" From d9a5f837a10b9fa806fb9b71218cdaa0aea601a0 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sat, 28 Feb 2026 23:37:56 +0000 Subject: [PATCH 15/17] wip --- .github/workflows/haskell-nix.yml | 59 ++++++++++++++++++++++++ .github/workflows/haskell.yml | 74 ++++++++++++++++++++---------- .github/workflows/update-flake.yml | 43 +++++++++++++++++ simplex-method.cabal | 1 + 4 files changed, 153 insertions(+), 24 deletions(-) create mode 100644 .github/workflows/haskell-nix.yml create mode 100644 .github/workflows/update-flake.yml diff --git a/.github/workflows/haskell-nix.yml b/.github/workflows/haskell-nix.yml new file mode 100644 index 0000000..6e4c2a8 --- /dev/null +++ b/.github/workflows/haskell-nix.yml @@ -0,0 +1,59 @@ +name: Haskell CI with Nix + +on: + push: + pull_request: + workflow_dispatch: + +permissions: + contents: read + +jobs: + nix-ci: + runs-on: ubuntu-latest + env: + NIX_CONFIG: accept-flake-config = true + + steps: + - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 + + - name: Check Nix flake inputs + uses: DeterminateSystems/flake-checker-action@3164002371bc90729c68af0e24d5aacf20d7c9f6 # v12 + + - name: Install Nix + uses: DeterminateSystems/nix-installer-action@c5a866b6ab867e88becbed4467b93592bce69f8a # v21 + + - name: Enable Nix cache + uses: DeterminateSystems/magic-nix-cache-action@565684385bcd71bad329742eefe8d12f2e765b39 # v13 + + - name: Show toolchain versions from nix shell + shell: bash + run: | + nix develop --command bash -lc 'ghc --numeric-version' + nix develop --command bash -lc 'cabal --numeric-version' + nix develop --command bash -lc 'stack --numeric-version || true' + nix develop --command bash -lc 'fourmolu --version' + + - name: Check formatting + run: nix develop --command make format-check + + - name: Check cabal file + run: nix develop --command make cabal-check + + - name: Update cabal package index + run: nix develop --command make cabal-update + + - name: Configure the build + run: nix develop --command make configure + + - name: Build dependencies + run: nix develop --command make deps + + - name: Build the package + run: nix develop --command make build + + - name: Run tests + run: nix develop --command make test + + - name: Build documentation + run: nix develop --command make docs diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 8ccc650..9904c9d 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -2,57 +2,83 @@ name: Haskell CI on: push: + pull_request: workflow_dispatch: permissions: contents: read jobs: - nix-ci: + fourmolu: runs-on: ubuntu-latest - env: - NIX_CONFIG: accept-flake-config = true steps: - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 - - name: Check Nix flake inputs - uses: DeterminateSystems/flake-checker-action@3164002371bc90729c68af0e24d5aacf20d7c9f6 # v12 + - uses: haskell-actions/run-fourmolu@v11 + with: + version: "0.17.0.0" - - name: Install Nix - uses: DeterminateSystems/nix-installer-action@c5a866b6ab867e88becbed4467b93592bce69f8a # v21 + build: + name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, macos-latest, windows-latest] + ghc-version: ["9.6.7"] - - name: Enable Nix cache - uses: DeterminateSystems/magic-nix-cache-action@565684385bcd71bad329742eefe8d12f2e765b39 # v13 + steps: + - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 + + - name: Set up GHC ${{ matrix.ghc-version }} + uses: haskell-actions/setup@v2 + id: setup + with: + ghc-version: ${{ matrix.ghc-version }} + cabal-version: "3.16.0.0" - - name: Show toolchain versions from nix shell + - name: Show toolchain versions shell: bash run: | - nix develop --command bash -lc 'ghc --numeric-version' - nix develop --command bash -lc 'cabal --numeric-version' - nix develop --command bash -lc 'stack --numeric-version || true' - nix develop --command bash -lc 'fourmolu --version' - - - name: Check formatting - run: nix develop --command make format-check + ghc --numeric-version + cabal --numeric-version - name: Check cabal file - run: nix develop --command make cabal-check + run: cabal check - name: Update cabal package index - run: nix develop --command make cabal-update + run: cabal update - name: Configure the build - run: nix develop --command make configure + run: | + cabal configure --enable-tests --enable-benchmarks --disable-documentation + cabal build --dry-run + + - name: Restore cabal store cache + uses: actions/cache/restore@v4 + id: cache-restore + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ runner.os }}-ghc-${{ matrix.ghc-version }}-cabal-${{ hashFiles('**/plan.json') }} + restore-keys: | + ${{ runner.os }}-ghc-${{ matrix.ghc-version }}-cabal- - name: Build dependencies - run: nix develop --command make deps + run: cabal build --only-dependencies + + - name: Save cabal store cache + uses: actions/cache/save@v4 + if: steps.cache-restore.outputs.cache-hit != 'true' + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ steps.cache-restore.outputs.cache-primary-key }} - name: Build the package - run: nix develop --command make build + run: cabal build all - name: Run tests - run: nix develop --command make test + run: cabal test all - name: Build documentation - run: nix develop --command make docs + run: cabal haddock all --disable-documentation diff --git a/.github/workflows/update-flake.yml b/.github/workflows/update-flake.yml new file mode 100644 index 0000000..71e3642 --- /dev/null +++ b/.github/workflows/update-flake.yml @@ -0,0 +1,43 @@ +name: Update Nix Flake + +on: + schedule: + # Every 2 weeks on Monday at 06:00 UTC + - cron: "0 6 1,15 * *" + workflow_dispatch: + +permissions: + contents: write + pull-requests: write + +jobs: + update-flake: + runs-on: ubuntu-latest + env: + NIX_CONFIG: accept-flake-config = true + + steps: + - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 + + - name: Install Nix + uses: DeterminateSystems/nix-installer-action@c5a866b6ab867e88becbed4467b93592bce69f8a # v21 + + - name: Enable Nix cache + uses: DeterminateSystems/magic-nix-cache-action@565684385bcd71bad329742eefe8d12f2e765b39 # v13 + + - name: Update flake lockfile + run: nix flake update + + - name: Create Pull Request + uses: peter-evans/create-pull-request@271a8d0340265f705b14b6d32b9829c1cb33d45e # v7.0.8 + with: + commit-message: "chore(nix): update flake lockfile" + title: "chore(nix): update flake lockfile" + body: | + Automated flake lockfile update via `nix flake update`. + + This PR was created by the scheduled update-flake workflow. + Please review CI results before merging. + branch: automation/update-flake-lock + delete-branch: true + labels: dependencies, automated diff --git a/simplex-method.cabal b/simplex-method.cabal index f3e9673..a672069 100644 --- a/simplex-method.cabal +++ b/simplex-method.cabal @@ -66,6 +66,7 @@ test-suite simplex-haskell-test main-is: Spec.hs other-modules: Linear.Simplex.Solver.TwoPhaseSpec + Linear.Simplex.UtilSpec Paths_simplex_method hs-source-dirs: test From d5aeb83df61e7cb68ae82e0761ee99a302020064 Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sun, 1 Mar 2026 00:51:31 +0000 Subject: [PATCH 16/17] refactor: add explicit import lists to all unqualified Haskell imports --- src/Linear/Simplex/Prettify.hs | 5 +- src/Linear/Simplex/Solver/TwoPhase.hs | 39 +++++++- src/Linear/Simplex/Types.hs | 9 +- src/Linear/Simplex/Util.hs | 19 +++- test/Linear/Simplex/Solver/TwoPhaseSpec.hs | 106 ++++++++++++++------- test/Linear/Simplex/UtilSpec.hs | 19 +++- 6 files changed, 142 insertions(+), 55 deletions(-) diff --git a/src/Linear/Simplex/Prettify.hs b/src/Linear/Simplex/Prettify.hs index 6737dbf..adb62ec 100644 --- a/src/Linear/Simplex/Prettify.hs +++ b/src/Linear/Simplex/Prettify.hs @@ -12,11 +12,10 @@ -- Converts "Linear.Simplex.Types" types into human-readable 'String's module Linear.Simplex.Prettify where -import Control.Lens import Data.Generics.Labels () import Data.Map qualified as M -import Data.Ratio -import Linear.Simplex.Types +import Data.Ratio (denominator, numerator) +import Linear.Simplex.Types (ObjectiveFunction (..), PolyConstraint (..), VarLitMapSum) -- | Convert a 'VarLitMapSum' into a human-readable 'String' prettyShowVarLitMapSum :: VarLitMapSum -> String diff --git a/src/Linear/Simplex/Solver/TwoPhase.hs b/src/Linear/Simplex/Solver/TwoPhase.hs index 0d43e6e..f5ecfa9 100644 --- a/src/Linear/Simplex/Solver/TwoPhase.hs +++ b/src/Linear/Simplex/Solver/TwoPhase.hs @@ -34,13 +34,11 @@ module Linear.Simplex.Solver.TwoPhase import Prelude hiding (EQ) -import qualified Control.Applicative as LPPaver -import Control.Lens +import Control.Lens ((%~), (&), (.~), (<&>)) import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Logger -import Data.Bifunctor -import Data.List +import Control.Monad.Logger (LogLevel (LevelError, LevelInfo, LevelWarn), MonadLogger) +import Data.Bifunctor (second) import qualified Data.Map as M import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Ratio (denominator, numerator, (%)) @@ -49,7 +47,38 @@ import qualified Data.Set as Set import qualified Data.Text as Text import GHC.Real (Ratio) import Linear.Simplex.Types + ( Dict + , DictValue (..) + , FeasibleSystem (..) + , ObjectiveFunction (..) + , ObjectiveResult (..) + , OptimisationOutcome (..) + , PivotObjective (..) + , PolyConstraint (..) + , SimplexNum + , SimplexResult (..) + , Tableau + , TableauRow (..) + , Var + , VarDomain (..) + , VarDomainMap (..) + , VarLitMap + , VarLitMapSum + , VarTransform (..) + , nonNegative + , unbounded + ) import Linear.Simplex.Util + ( combineVarLitMapSums + , dictionaryFormToTableau + , foldVarLitMap + , insertPivotObjectiveToDict + , isMax + , logMsg + , showT + , simplifySystem + , tableauInDictionaryForm + ) -- | Find a feasible solution for the given system of 'PolyConstraint's by performing the first phase of the two-phase simplex method -- All variables in the 'PolyConstraint' must be positive. diff --git a/src/Linear/Simplex/Types.hs b/src/Linear/Simplex/Types.hs index c912c11..83b0a9a 100644 --- a/src/Linear/Simplex/Types.hs +++ b/src/Linear/Simplex/Types.hs @@ -7,20 +7,19 @@ -- Stability : experimental module Linear.Simplex.Types where -import Control.Lens import Data.Generics.Labels () import Data.List (sort) import qualified Data.Map as M import GHC.Generics (Generic) --- | Variable identifier used in maps and constraints. --- Conventionally this maps to x1, x2, ... in examples. +-- | Variable identifier type Var = Int --- | Numeric type used throughout simplex computations. +-- | Numeric type used in this library type SimplexNum = Rational --- | A feasible system produced by phase one, ready for phase two optimization. +-- | A feasible system, typically produced by phase one of +-- the two-phase simplex method. data FeasibleSystem = FeasibleSystem { dict :: Dict , slackVars :: [Var] diff --git a/src/Linear/Simplex/Util.hs b/src/Linear/Simplex/Util.hs index 85186d5..38b415c 100644 --- a/src/Linear/Simplex/Util.hs +++ b/src/Linear/Simplex/Util.hs @@ -9,13 +9,10 @@ -- Helper functions for performing the two-phase simplex method. module Linear.Simplex.Util where -import Control.Lens import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Logger (LogLevel (..), LogLine, MonadLogger, logDebug, logError, logInfo, logWarn) -import Data.Bifunctor +import Control.Monad.Logger (LogLevel (..), MonadLogger, logDebug, logError, logInfo, logWarn) import Data.Generics.Labels () -import Data.Generics.Product (field) -import Data.List +import Data.List (nub, (\\)) import qualified Data.Map as Map import qualified Data.Map.Merge.Lazy as MapMerge import Data.Maybe (fromMaybe) @@ -23,6 +20,18 @@ import qualified Data.Text as T import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import Linear.Simplex.Types + ( Dict + , DictValue (..) + , ObjectiveFunction (..) + , PivotObjective (..) + , PolyConstraint (..) + , SimplexNum + , Tableau + , TableauRow (..) + , Var + , VarLitMap + , VarLitMapSum + ) import Prelude hiding (EQ) -- | Is the given 'ObjectiveFunction' to be 'Max'imized? diff --git a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs index 70ed5b7..ba1ee48 100644 --- a/test/Linear/Simplex/Solver/TwoPhaseSpec.hs +++ b/test/Linear/Simplex/Solver/TwoPhaseSpec.hs @@ -5,18 +5,47 @@ module Linear.Simplex.Solver.TwoPhaseSpec where import Prelude hiding (EQ) -import Control.Monad.Logger +import Control.Monad.Logger (LogLevel (LevelInfo), filterLogger, runStdoutLoggingT) import qualified Data.Map as M import Data.Maybe (isJust) -import Data.Ratio +import Data.Ratio ((%)) import qualified Data.Set as Set -import Test.Hspec -import Test.QuickCheck +import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe, shouldSatisfy) +import Test.QuickCheck (NonEmptyList (..), Positive (..), property, (==>)) -import Linear.Simplex.Prettify +import Linear.Simplex.Prettify (prettyShowObjectiveFunction, prettyShowPolyConstraint, prettyShowVarLitMapSum) import Linear.Simplex.Solver.TwoPhase + ( applyShiftToConstraint + , applyShiftToObjective + , applySplitToConstraint + , applySplitToObjective + , applyTransform + , applyTransforms + , collectAllVars + , computeObjective + , generateTransform + , getTransform + , postprocess + , preprocess + , twoPhaseSimplex + , unapplyTransformToVarMap + , unapplyTransformsToVarMap + ) import Linear.Simplex.Types + ( ObjectiveFunction (..) + , ObjectiveResult (..) + , OptimisationOutcome (..) + , PolyConstraint (..) + , SimplexResult (..) + , VarDomainMap (..) + , VarTransform (..) + , boundedRange + , lowerBoundOnly + , nonNegative + , unbounded + , upperBoundOnly + ) spec :: Spec spec = do @@ -2662,47 +2691,52 @@ spec = do it "RHS adjustment follows formula: newRHS = oldRHS - coeff * shiftBy" $ property $ \(coeff :: Rational) (oldRHS :: Rational) (shiftBy :: Rational) -> - coeff /= 0 ==> - let constraint = LEQ (M.fromList [(1, coeff)]) oldRHS - LEQ _ newRHS = applyShiftToConstraint 1 10 shiftBy constraint - in newRHS == oldRHS - coeff * shiftBy + coeff + /= 0 + ==> let constraint = LEQ (M.fromList [(1, coeff)]) oldRHS + LEQ _ newRHS = applyShiftToConstraint 1 10 shiftBy constraint + in newRHS == oldRHS - coeff * shiftBy it "preserves constraint type (LEQ stays LEQ)" $ property $ \(coeff :: Rational) (rhs :: Rational) (shiftBy :: Rational) -> - coeff /= 0 ==> - let constraint = LEQ (M.fromList [(1, coeff)]) rhs - in case applyShiftToConstraint 1 10 shiftBy constraint of - LEQ {} -> True - _ -> False + coeff + /= 0 + ==> let constraint = LEQ (M.fromList [(1, coeff)]) rhs + in case applyShiftToConstraint 1 10 shiftBy constraint of + LEQ {} -> True + _ -> False it "preserves constraint type (GEQ stays GEQ)" $ property $ \(coeff :: Rational) (rhs :: Rational) (shiftBy :: Rational) -> - coeff /= 0 ==> - let constraint = GEQ (M.fromList [(1, coeff)]) rhs - in case applyShiftToConstraint 1 10 shiftBy constraint of - GEQ {} -> True - _ -> False + coeff + /= 0 + ==> let constraint = GEQ (M.fromList [(1, coeff)]) rhs + in case applyShiftToConstraint 1 10 shiftBy constraint of + GEQ {} -> True + _ -> False describe "applySplitToConstraint properties" $ do it "preserves RHS value" $ property $ \(coeff :: Rational) (rhs :: Rational) -> - coeff /= 0 ==> - let constraint = LEQ (M.fromList [(1, coeff)]) rhs - LEQ _ newRHS = applySplitToConstraint 1 10 11 constraint - in newRHS == rhs + coeff + /= 0 + ==> let constraint = LEQ (M.fromList [(1, coeff)]) rhs + LEQ _ newRHS = applySplitToConstraint 1 10 11 constraint + in newRHS == rhs it "negVar coefficient is negation of posVar coefficient" $ property $ \(coeff :: Rational) (rhs :: Rational) -> - coeff /= 0 ==> - let constraint = LEQ (M.fromList [(1, coeff)]) rhs - LEQ m _ = applySplitToConstraint 1 10 11 constraint - posCoeff = M.findWithDefault 0 10 m - negCoeff = M.findWithDefault 0 11 m - in negCoeff == negate posCoeff + coeff + /= 0 + ==> let constraint = LEQ (M.fromList [(1, coeff)]) rhs + LEQ m _ = applySplitToConstraint 1 10 11 constraint + posCoeff = M.findWithDefault 0 10 m + negCoeff = M.findWithDefault 0 11 m + in negCoeff == negate posCoeff describe "unapplyTransformToVarMap Shift properties" $ do it "recovers originalVar = shiftedVar + shiftBy" $ @@ -2743,12 +2777,14 @@ spec = do it "Shift transform and unapply is identity for variable value" $ property $ \(origVal :: Rational) (shiftBy :: Rational) -> - shiftBy < 0 ==> -- Only negative shifts are valid - let shiftedVal = origVal - shiftBy -- shiftedVar = originalVar - shiftBy - varMap = M.fromList [(5, 100), (10, shiftedVal)] - transform = Shift 1 10 shiftBy - newVarMap = unapplyTransformToVarMap transform varMap - in M.lookup 1 newVarMap == Just origVal + shiftBy + < 0 + ==> let shiftedVal -- Only negative shifts are valid + = origVal - shiftBy -- shiftedVar = originalVar - shiftBy + varMap = M.fromList [(5, 100), (10, shiftedVal)] + transform = Shift 1 10 shiftBy + newVarMap = unapplyTransformToVarMap transform varMap + in M.lookup 1 newVarMap == Just origVal it "Split with posVal=origVal and negVal=0 gives correct value for positive origVal" $ property $ diff --git a/test/Linear/Simplex/UtilSpec.hs b/test/Linear/Simplex/UtilSpec.hs index 68b0d4a..6b74215 100644 --- a/test/Linear/Simplex/UtilSpec.hs +++ b/test/Linear/Simplex/UtilSpec.hs @@ -6,11 +6,26 @@ import Prelude hiding (EQ) import Control.Exception (evaluate) import qualified Data.Map as M -import Test.Hspec -import Test.QuickCheck +import Test.Hspec (Spec, anyErrorCall, describe, expectationFailure, it, shouldBe, shouldThrow) +import Test.QuickCheck (Positive (..), property) import Linear.Simplex.Types + ( DictValue (..) + , ObjectiveFunction (..) + , PivotObjective (..) + , PolyConstraint (..) + , TableauRow (..) + , VarLitMapSum + ) import Linear.Simplex.Util + ( combineVarLitMapSums + , dictionaryFormToTableau + , foldVarLitMap + , insertPivotObjectiveToDict + , isMax + , simplifySystem + , tableauInDictionaryForm + ) spec :: Spec spec = do From 1ec80c3008886778db08856dec2939134f2426ea Mon Sep 17 00:00:00 2001 From: Junaid Rasheed Date: Sun, 1 Mar 2026 00:51:31 +0000 Subject: [PATCH 17/17] chore: disable pull_request workflow trigger + we already trigger on every push --- .github/workflows/haskell-nix.yml | 1 - .github/workflows/haskell.yml | 1 - 2 files changed, 2 deletions(-) diff --git a/.github/workflows/haskell-nix.yml b/.github/workflows/haskell-nix.yml index 6e4c2a8..26628c9 100644 --- a/.github/workflows/haskell-nix.yml +++ b/.github/workflows/haskell-nix.yml @@ -2,7 +2,6 @@ name: Haskell CI with Nix on: push: - pull_request: workflow_dispatch: permissions: diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 9904c9d..01702fc 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -2,7 +2,6 @@ name: Haskell CI on: push: - pull_request: workflow_dispatch: permissions: