├── .github
└── workflows
│ └── ci.yml
├── .gitignore
├── .hlint.yaml
├── .travis.yml
├── .vscode
└── settings.json
├── CHANGELOG.md
├── CODE_OF_CONDUCT.md
├── CONTRIBUTING.md
├── LICENSE.md
├── MODULES.md
├── README.md
├── bin
└── retag
├── cabal.project
├── cbits
├── Makefile
├── dlx.cpp
├── dlx.hpp
├── dlx_capi.cpp
├── dlx_capi.h
├── dlx_queens.cpp
├── dxz.cpp
├── dxz.hpp
├── dxz_capi.cpp
├── dxz_capi.h
└── dxz_queens.cpp
├── guanxi.cabal
├── src
├── Aligned
│ ├── Base.hs
│ ├── Free.hs
│ ├── Freer.hs
│ └── Internal.hs
├── Cover
│ ├── DLX.hs
│ └── DXZ.hs
├── Disjoint.hs
├── Domain
│ ├── Internal.hs
│ ├── Interval.hs
│ └── Relational.hs
├── Equality.hs
├── FD
│ ├── Monad.hs
│ └── Var.hs
├── Key.hs
├── Key
│ └── Coercible.hs
├── Log.hs
├── Logic
│ ├── Class.hs
│ ├── Cont.hs
│ ├── Naive.hs
│ └── Reflection.hs
├── Par
│ ├── Class.hs
│ ├── Cont.hs
│ ├── Future.hs
│ └── Promise.hs
├── Prompt
│ ├── Class.hs
│ ├── Iterator.hs
│ └── Reflection.hs
├── Ref.hs
├── Relative
│ ├── Base.hs
│ └── Internal.hs
├── SAT.hs
├── Sharing.hs
├── Signal.hs
├── Sink.hs
├── Tactic.hs
├── Unaligned
│ ├── Base.hs
│ └── Internal.hs
├── Unification
│ └── Class.hs
├── Unique.hs
└── Vec.hs
├── test
├── Spec
│ ├── Cover
│ │ └── DLX.hs
│ ├── Domain
│ │ └── Interval.hs
│ ├── FD
│ │ └── Monad.hs
│ ├── Logic
│ │ └── Reflection.hs
│ ├── Prompt
│ │ └── Iterator.hs
│ └── Unaligned
│ │ └── Base.hs
├── doctest-main.hs
├── doctest.json
├── hedgehog-main.hs
├── queens.hs
└── spec.hs
└── wip
├── ProbabilisticTree.hs
└── RationalArithmetic.hs
/.github/workflows/ci.yml:
--------------------------------------------------------------------------------
1 | name: haskell ci
2 | on:
3 | push:
4 | pull_request:
5 | workflow_dispatch:
6 | jobs:
7 | generate-matrix:
8 | name: "Generate matrix from cabal"
9 | outputs:
10 | matrix: ${{ steps.set-matrix.outputs.matrix }}
11 | runs-on: ubuntu-latest
12 | steps:
13 | - name: Extract the tested GHC versions
14 | id: set-matrix
15 | uses: kleidukos/get-tested@v0.1.7.0
16 | with:
17 | cabal-file: guanxi.cabal
18 | ubuntu-version: latest
19 | macos-version: latest
20 | windows-version: latest
21 | version: 0.1.7.0
22 | tests:
23 | name: ${{ matrix.ghc }} on ${{ matrix.os }}
24 | needs: generate-matrix
25 | runs-on: ${{ matrix.os }}
26 | strategy:
27 | fail-fast: false
28 | matrix: ${{ fromJSON(needs.generate-matrix.outputs.matrix) }}
29 | steps:
30 | - uses: actions/checkout@v4
31 | - uses: haskell-actions/setup@v2
32 | id: setup-haskell
33 | with:
34 | ghc-version: ${{ matrix.ghc }}
35 | - run: cabal freeze --enable-tests
36 | - uses: actions/cache@v2
37 | with:
38 | path: ${{ steps.setup-haskell.outputs.cabal-store }}
39 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
40 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}-
41 | - run: cabal build all
42 | - run: cabal test --test-option=--color --test-show-details=always test:queens
43 | if: matrix.os == 'ubuntu-latest' || matrix.os == 'macos-latest'
44 | - run: cabal test --test-option=--color --test-show-details=always test:spec
45 | if: matrix.os == 'ubuntu-latest' || matrix.os == 'macos-latest'
46 | - run: cabal test --test-option=--color --test-show-details=always test:hedgehog
47 | if: matrix.os == 'ubuntu-latest' || matrix.os == 'macos-latest'
48 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | *#
2 | *.aux
3 | *.chi
4 | *.chs.h
5 | *.dyn_hi
6 | *.dyn_o
7 | *.eventlog
8 | *.hi
9 | *.hp
10 | *.o
11 | *.prof
12 | *~
13 | .*.swo
14 | .*.swp
15 | .DS_Store
16 | .HTF/
17 | .cabal-sandbox/
18 | .depend
19 | .ghc.environment.*
20 | .ghcid*
21 | .hpc
22 | .hsenv
23 | .stack-work/
24 | TAGS
25 | cabal-dev
26 | cabal.project.local
27 | cabal.project.local~
28 | cabal.sandbox.config
29 | cbits/.depend
30 | cbits/dlx_queens
31 | cbits/dxz_queens
32 | dist
33 | dist-newstyle
34 | dist-doctest
35 | docs
36 | ghcid.txt
37 | old
38 | tags
39 | wiki
40 | wip
41 |
--------------------------------------------------------------------------------
/.hlint.yaml:
--------------------------------------------------------------------------------
1 | - arguments: [--color, --cpp-define=HLINT]
2 | - ignore: {name: "Use const" }
3 | - ignore: {name: "Use camelCase" }
4 | - ignore: {name: "Use <$>", within: [ Sharing ]}
5 | - ignore: {name: "Unused LANGUAGE pragma", within: [ FD.Monad ]}
6 | - ignore: {name: "Parse error", within: [ Ref.Log ]}
7 | - ignore: {name: "Eta reduce", within: [ Cover.DXZ, Ref.Env, Ref.Key, Ref.Log ]}
8 |
--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | language: haskell
2 | dist: trusty
3 |
4 | cache:
5 | directories:
6 | - $HOME/.cabal/store
7 |
8 | cabal: "2.4"
9 |
10 | matrix:
11 | include:
12 | - ghc: "8.6.4"
13 |
14 | install:
15 | - cabal --version
16 | - ghc --version
17 |
18 | script:
19 | - cabal v2-update
20 | - cabal v2-build
21 | - cabal v2-test --enable-test
22 |
23 | notifications:
24 | irc:
25 | channels:
26 | - "irc.freenode.org##haskell-lens"
27 | skip_join: true
28 | template:
29 | - "\x0313guanxi\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f"
30 |
--------------------------------------------------------------------------------
/.vscode/settings.json:
--------------------------------------------------------------------------------
1 | {
2 | "files.exclude": {
3 | ".ghc.environment*": true,
4 | "**/.depend": true,
5 | "**/*.o": true,
6 | "cbits/*_queens": true,
7 | "dist": true,
8 | "dist-doctest": true,
9 | "dist-newstyle": true
10 | }
11 |
12 | }
--------------------------------------------------------------------------------
/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | # 0
2 |
3 | * Repository initialized.
4 |
--------------------------------------------------------------------------------
/CODE_OF_CONDUCT.md:
--------------------------------------------------------------------------------
1 | # Contributor Covenant Code of Conduct
2 |
3 | ## Our Pledge
4 |
5 | In the interest of fostering an open and welcoming environment, we as contributors and maintainers pledge to making participation in our project and our community a harassment-free experience for everyone, regardless of age, body size, disability, ethnicity, gender identity and expression, level of experience, nationality, personal appearance, race, religion, or sexual identity and orientation.
6 |
7 | ## Our Standards
8 |
9 | Examples of behavior that contributes to creating a positive environment include:
10 |
11 | * Using welcoming and inclusive language
12 | * Being respectful of differing viewpoints and experiences
13 | * Gracefully accepting constructive criticism
14 | * Focusing on what is best for the community
15 | * Showing empathy towards other community members
16 |
17 | Examples of unacceptable behavior by participants include:
18 |
19 | * The use of sexualized language or imagery and unwelcome sexual attention or advances
20 | * Trolling, insulting/derogatory comments, and personal or political attacks
21 | * Public or private harassment
22 | * Publishing others' private information, such as a physical or electronic address, without explicit permission
23 | * Other conduct which could reasonably be considered inappropriate in a professional setting
24 |
25 | ## Our Responsibilities
26 |
27 | Project maintainers are responsible for clarifying the standards of acceptable behavior and are expected to take appropriate and fair corrective action in response to any instances of unacceptable behavior.
28 |
29 | Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, or to ban temporarily or permanently any contributor for other behaviors that they deem inappropriate, threatening, offensive, or harmful.
30 |
31 | ## Scope
32 |
33 | This Code of Conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. Examples of representing a project or community include using an official project e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. Representation of a project may be further defined and clarified by project maintainers.
34 |
35 | ## Enforcement
36 |
37 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by contacting the project team at ekmett@gmail.com. The project team will review and investigate all complaints, and will respond in a way that it deems appropriate to the circumstances. The project team is obligated to maintain confidentiality with regard to the reporter of an incident. Further details of specific enforcement policies may be posted separately.
38 |
39 | Project maintainers who do not follow or enforce the Code of Conduct in good faith may face temporary or permanent repercussions as determined by other members of the project's leadership.
40 |
41 | ## Attribution
42 |
43 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, available at [http://contributor-covenant.org/version/1/4][version]
44 |
45 | [homepage]: http://contributor-covenant.org
46 | [version]: http://contributor-covenant.org/version/1/4/
47 |
--------------------------------------------------------------------------------
/CONTRIBUTING.md:
--------------------------------------------------------------------------------
1 | Patches welcome!
2 |
--------------------------------------------------------------------------------
/LICENSE.md:
--------------------------------------------------------------------------------
1 | # License
2 |
3 | Licensed under either of
4 | * Apache License, Version 2.0 (http://www.apache.org/licenses/LICENSE-2.0)
5 | * BSD 2-Clause license (https://opensource.org/licenses/BSD-2-Clause)
6 | at your option.
7 |
8 | ## BSD 2-Clause License
9 |
10 | - Copyright 2017-2018 Edward Kmett
11 | - Copyright 2012-2014 Edward Kmett and Dan Doel
12 |
13 | All rights reserved.
14 |
15 | Redistribution and use in source and binary forms, with or without
16 | modification, are permitted provided that the following conditions
17 | are met:
18 |
19 | 1. Redistributions of source code must retain the above copyright
20 | notice, this list of conditions and the following disclaimer.
21 |
22 | 2. Redistributions in binary form must reproduce the above copyright
23 | notice, this list of conditions and the following disclaimer in the
24 | documentation and/or other materials provided with the distribution.
25 |
26 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
27 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
28 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
29 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
30 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
31 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
32 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
33 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
34 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
35 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
36 | POSSIBILITY OF SUCH DAMAGE.
37 |
38 | ## Apache License
39 |
40 | _Version 2.0, January 2004_
41 | _< >_
42 |
43 | ### Terms and Conditions for use, reproduction, and distribution
44 |
45 | #### 1. Definitions
46 |
47 | “License” shall mean the terms and conditions for use, reproduction, and
48 | distribution as defined by Sections 1 through 9 of this document.
49 |
50 | “Licensor” shall mean the copyright owner or entity authorized by the copyright
51 | owner that is granting the License.
52 |
53 | “Legal Entity” shall mean the union of the acting entity and all other entities
54 | that control, are controlled by, or are under common control with that entity.
55 | For the purposes of this definition, “control” means **(i)** the power, direct or
56 | indirect, to cause the direction or management of such entity, whether by
57 | contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of the
58 | outstanding shares, or **(iii)** beneficial ownership of such entity.
59 |
60 | “You” (or “Your”) shall mean an individual or Legal Entity exercising
61 | permissions granted by this License.
62 |
63 | “Source” form shall mean the preferred form for making modifications, including
64 | but not limited to software source code, documentation source, and configuration
65 | files.
66 |
67 | “Object” form shall mean any form resulting from mechanical transformation or
68 | translation of a Source form, including but not limited to compiled object code,
69 | generated documentation, and conversions to other media types.
70 |
71 | “Work” shall mean the work of authorship, whether in Source or Object form, made
72 | available under the License, as indicated by a copyright notice that is included
73 | in or attached to the work (an example is provided in the Appendix below).
74 |
75 | “Derivative Works” shall mean any work, whether in Source or Object form, that
76 | is based on (or derived from) the Work and for which the editorial revisions,
77 | annotations, elaborations, or other modifications represent, as a whole, an
78 | original work of authorship. For the purposes of this License, Derivative Works
79 | shall not include works that remain separable from, or merely link (or bind by
80 | name) to the interfaces of, the Work and Derivative Works thereof.
81 |
82 | “Contribution” shall mean any work of authorship, including the original version
83 | of the Work and any modifications or additions to that Work or Derivative Works
84 | thereof, that is intentionally submitted to Licensor for inclusion in the Work
85 | by the copyright owner or by an individual or Legal Entity authorized to submit
86 | on behalf of the copyright owner. For the purposes of this definition,
87 | “submitted” means any form of electronic, verbal, or written communication sent
88 | to the Licensor or its representatives, including but not limited to
89 | communication on electronic mailing lists, source code control systems, and
90 | issue tracking systems that are managed by, or on behalf of, the Licensor for
91 | the purpose of discussing and improving the Work, but excluding communication
92 | that is conspicuously marked or otherwise designated in writing by the copyright
93 | owner as “Not a Contribution.”
94 |
95 | “Contributor” shall mean Licensor and any individual or Legal Entity on behalf
96 | of whom a Contribution has been received by Licensor and subsequently
97 | incorporated within the Work.
98 |
99 | #### 2. Grant of Copyright License
100 |
101 | Subject to the terms and conditions of this License, each Contributor hereby
102 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free,
103 | irrevocable copyright license to reproduce, prepare Derivative Works of,
104 | publicly display, publicly perform, sublicense, and distribute the Work and such
105 | Derivative Works in Source or Object form.
106 |
107 | #### 3. Grant of Patent License
108 |
109 | Subject to the terms and conditions of this License, each Contributor hereby
110 | grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free,
111 | irrevocable (except as stated in this section) patent license to make, have
112 | made, use, offer to sell, sell, import, and otherwise transfer the Work, where
113 | such license applies only to those patent claims licensable by such Contributor
114 | that are necessarily infringed by their Contribution(s) alone or by combination
115 | of their Contribution(s) with the Work to which such Contribution(s) was
116 | submitted. If You institute patent litigation against any entity (including a
117 | cross-claim or counterclaim in a lawsuit) alleging that the Work or a
118 | Contribution incorporated within the Work constitutes direct or contributory
119 | patent infringement, then any patent licenses granted to You under this License
120 | for that Work shall terminate as of the date such litigation is filed.
121 |
122 | #### 4. Redistribution
123 |
124 | You may reproduce and distribute copies of the Work or Derivative Works thereof
125 | in any medium, with or without modifications, and in Source or Object form,
126 | provided that You meet the following conditions:
127 |
128 | * **(a)** You must give any other recipients of the Work or Derivative Works a copy of
129 | this License; and
130 | * **(b)** You must cause any modified files to carry prominent notices stating that You
131 | changed the files; and
132 | * **(c)** You must retain, in the Source form of any Derivative Works that You distribute,
133 | all copyright, patent, trademark, and attribution notices from the Source form
134 | of the Work, excluding those notices that do not pertain to any part of the
135 | Derivative Works; and
136 | * **(d)** If the Work includes a “NOTICE” text file as part of its distribution, then any
137 | Derivative Works that You distribute must include a readable copy of the
138 | attribution notices contained within such NOTICE file, excluding those notices
139 | that do not pertain to any part of the Derivative Works, in at least one of the
140 | following places: within a NOTICE text file distributed as part of the
141 | Derivative Works; within the Source form or documentation, if provided along
142 | with the Derivative Works; or, within a display generated by the Derivative
143 | Works, if and wherever such third-party notices normally appear. The contents of
144 | the NOTICE file are for informational purposes only and do not modify the
145 | License. You may add Your own attribution notices within Derivative Works that
146 | You distribute, alongside or as an addendum to the NOTICE text from the Work,
147 | provided that such additional attribution notices cannot be construed as
148 | modifying the License.
149 |
150 | You may add Your own copyright statement to Your modifications and may provide
151 | additional or different license terms and conditions for use, reproduction, or
152 | distribution of Your modifications, or for any such Derivative Works as a whole,
153 | provided Your use, reproduction, and distribution of the Work otherwise complies
154 | with the conditions stated in this License.
155 |
156 | #### 5. Submission of Contributions
157 |
158 | Unless You explicitly state otherwise, any Contribution intentionally submitted
159 | for inclusion in the Work by You to the Licensor shall be under the terms and
160 | conditions of this License, without any additional terms or conditions.
161 | Notwithstanding the above, nothing herein shall supersede or modify the terms of
162 | any separate license agreement you may have executed with Licensor regarding
163 | such Contributions.
164 |
165 | #### 6. Trademarks
166 |
167 | This License does not grant permission to use the trade names, trademarks,
168 | service marks, or product names of the Licensor, except as required for
169 | reasonable and customary use in describing the origin of the Work and
170 | reproducing the content of the NOTICE file.
171 |
172 | #### 7. Disclaimer of Warranty
173 |
174 | Unless required by applicable law or agreed to in writing, Licensor provides the
175 | Work (and each Contributor provides its Contributions) on an “AS IS” BASIS,
176 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied,
177 | including, without limitation, any warranties or conditions of TITLE,
178 | NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are
179 | solely responsible for determining the appropriateness of using or
180 | redistributing the Work and assume any risks associated with Your exercise of
181 | permissions under this License.
182 |
183 | #### 8. Limitation of Liability
184 |
185 | In no event and under no legal theory, whether in tort (including negligence),
186 | contract, or otherwise, unless required by applicable law (such as deliberate
187 | and grossly negligent acts) or agreed to in writing, shall any Contributor be
188 | liable to You for damages, including any direct, indirect, special, incidental,
189 | or consequential damages of any character arising as a result of this License or
190 | out of the use or inability to use the Work (including but not limited to
191 | damages for loss of goodwill, work stoppage, computer failure or malfunction, or
192 | any and all other commercial damages or losses), even if such Contributor has
193 | been advised of the possibility of such damages.
194 |
195 | #### 9. Accepting Warranty or Additional Liability
196 |
197 | While redistributing the Work or Derivative Works thereof, You may choose to
198 | offer, and charge a fee for, acceptance of support, warranty, indemnity, or
199 | other liability obligations and/or rights consistent with this License. However,
200 | in accepting such obligations, You may act only on Your own behalf and on Your
201 | sole responsibility, not on behalf of any other Contributor, and only if You
202 | agree to indemnify, defend, and hold each Contributor harmless for any liability
203 | incurred by, or claims asserted against, such Contributor by reason of your
204 | accepting any such warranty or additional liability.
205 |
206 | _END OF TERMS AND CONDITIONS_
207 |
208 | ### APPENDIX: How to apply the Apache License to your work
209 |
210 | To apply the Apache License to your work, attach the following boilerplate
211 | notice, with the fields enclosed by brackets `[]` replaced with your own
212 | identifying information. (Don't include the brackets!) The text should be
213 | enclosed in the appropriate comment syntax for the file format. We also
214 | recommend that a file or class name and description of purpose be included on
215 | the same “printed page” as the copyright notice for easier identification within
216 | third-party archives.
217 |
218 | Copyright [yyyy] [name of copyright owner]
219 |
220 | Licensed under the Apache License, Version 2.0 (the "License");
221 | you may not use this file except in compliance with the License.
222 | You may obtain a copy of the License at
223 |
224 | http://www.apache.org/licenses/LICENSE-2.0
225 |
226 | Unless required by applicable law or agreed to in writing, software
227 | distributed under the License is distributed on an "AS IS" BASIS,
228 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
229 | See the License for the specific language governing permissions and
230 | limitations under the License.
231 |
232 |
--------------------------------------------------------------------------------
/MODULES.md:
--------------------------------------------------------------------------------
1 | Modules
2 | =======
3 |
4 | This is a brief and incomplete description of the rough module layout of guanxi
5 |
6 | * Aligned
7 | * Base - type-aligned sequences
8 | * Free - Reflection Without Remorse (RWR) free monad
9 | * Freer - RWR freer monad
10 | * Cover
11 | * DLX - Knuth's dancling links
12 | * DXZ - DLX with ZDDs (zero-suppressed binary decision diagrams) https://aaai.org/ocs/index.php/AAAI/AAAI17/paper/view/14907
13 | * Domain
14 | * Interval - interval arithmetic built with propagators
15 | * FD (Finite Domain)
16 | * Monad - This monad drives everything else in guanxi for now
17 | * Var - finite domain variables encoded as sets of values
18 | * Unaligned
19 | * Base - Okasaki-style catenable sequences and queues
20 | * Logic
21 | * Class - LogicT type class
22 | * Cont - continuation-based implementation of LogicT. If you don't need reflection, this implementation is the fastest.
23 | * Naive - naive LogicT implementation
24 | * Reflection - RWR-style LogicT, using Unaligned.Base
25 | * Prompt
26 | * Class - delimited continuations based on RWR
27 | * Signal - partial propagator implementation
28 | * Tactics - A toy tactic language
29 | * Unique - Fast unique symbols
30 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | guanxi
2 | ======
3 |
4 | [](https://github.com/ekmett/guanxi/actions/workflows/ci.yml)
5 |
6 | An exploration of relational programming in Haskell.
7 |
8 | License
9 | -------
10 |
11 | [Licensed](LICENSE.md) under either of
12 |
13 | * [Apache License, Version 2.0][license-apache]
14 |
15 | * [BSD 2-Clause license][license-bsd]
16 |
17 | at your option.
18 |
19 | Contribution
20 | ------------
21 |
22 | Unless you explicitly state otherwise, any contribution intentionally submitted
23 | for inclusion in the work by you shall be dual-licensed as above, without any
24 | additional terms or conditions.
25 |
26 | Contact Information
27 | -------------------
28 |
29 | Contributions and bug reports are welcome!
30 |
31 | Please feel free to contact me through github or on the `#haskell` IRC channel on `irc.freenode.net`.
32 |
33 | -Edward Kmett
34 |
35 | [license-apache]: http://www.apache.org/licenses/LICENSE-2.0
36 | [license-bsd]: https://opensource.org/licenses/BSD-2-Clause
37 |
--------------------------------------------------------------------------------
/bin/retag:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 | fast-tags -R src test
3 | ctags -a -R cbits
4 |
--------------------------------------------------------------------------------
/cabal.project:
--------------------------------------------------------------------------------
1 | packages: .
2 |
--------------------------------------------------------------------------------
/cbits/Makefile:
--------------------------------------------------------------------------------
1 | CXX := g++
2 | CXXFLAGS=-std=c++11 -Wall -g
3 |
4 | SRCS := $(shell find . -name "*.cpp")
5 | OBJS := $(patsubst %.cpp, %.o, $(SRCS))
6 |
7 | all: dxz_queens dlx_queens dlx_capi.o
8 |
9 | clean:
10 | rm -f dlx_queens dxz_queens $(OBJS)
11 |
12 | dist-clean: clean
13 | rm -f .depend
14 |
15 | .PHONY: all clean dist-clean depend
16 |
17 | depend: .depend
18 |
19 | .depend: $(SRCS)
20 | rm -f ./.depend
21 | $(CXX) $(CXXFLAGS) -MM $^>>./.depend;
22 |
23 | include .depend
24 |
25 | dlx_queens: dlx_queens.o dlx.o
26 | $(CXX) $(CXXFLAGS) $(LDFLAGS) -o dlx_queens $^ $(LDLIBS)
27 |
28 | dxz_queens: dxz_queens.o dxz.o
29 | $(CXX) $(CXXFLAGS) $(LDFLAGS) -o dxz_queens $^ $(LDLIBS)
30 |
31 | %.o: %.cpp
32 | $(CXX) $(CXXFLAGS) -c $<
33 |
--------------------------------------------------------------------------------
/cbits/dlx.cpp:
--------------------------------------------------------------------------------
1 | #include "dlx.hpp"
2 |
3 | // compute exact covers using dancing links
4 |
5 | using namespace std;
6 |
7 | dlx::dlx(uint32_t n, uint32_t k) noexcept
8 | : cells(0)
9 | , items(0)
10 | , result(0)
11 | , current_state(state::guessing) {
12 | uint32_t N = n+k;
13 | cells.reserve(N?N+1:2);
14 | items.reserve(N+1);
15 |
16 | for (uint32_t i=0;i values) noexcept {
103 | return add_option(values.begin(),values.end());
104 | }
105 |
106 | option dlx::pick(link c) noexcept {
107 | return for_option_containing(c, [&](link i) noexcept {
108 | auto & x = cells[i];
109 | auto & item = items[x.item];
110 | auto header = item.cell;
111 | items[item.n].p = item.p;
112 | items[item.p].n = item.n;
113 | for (auto j = x.u; j != header; j = cells[j].u)
114 | for_option_containing_exclusive(j, [&](link k) noexcept {
115 | auto & y = cells[k];
116 | cells[y.u].d = y.d;
117 | cells[y.d].u = y.u;
118 | });
119 | for (auto j = x.d; j != header; j = cells[j].d)
120 | for_option_containing_exclusive(j, [&](link k) noexcept {
121 | auto & y = cells[k];
122 | cells[y.u].d = y.d;
123 | cells[y.d].u = y.u;
124 | });
125 | });
126 | }
127 |
128 | void dlx::unpick(link c) noexcept {
129 | for_option_containing(c, [&](link i) noexcept {
130 | auto & x = cells[i];
131 | auto & item = items[x.item];
132 | auto header = item.cell;
133 | items[item.n].p = x.item;
134 | items[item.p].n = x.item;
135 | for (auto j = x.u; j != header; j = cells[j].u)
136 | for_option_containing_exclusive(j, [&](link k) noexcept {
137 | auto & y = cells[k];
138 | cells[y.u].d = k;
139 | cells[y.d].u = k;
140 | });
141 | for (auto j = x.d; j != header; j = cells[j].d)
142 | for_option_containing_exclusive(j, [&](link k) noexcept {
143 | auto & y = cells[k];
144 | cells[y.u].d = k;
145 | cells[y.d].u = k;
146 | });
147 | });
148 | }
149 |
150 | item dlx::best_item() const noexcept {
151 | item best = root();
152 | uint32_t best_count = INT32_MAX;
153 | for (item i = items[root()].n; i != root(); i = items[i].n) {
154 | uint32_t count = items[i].count;
155 | if (count < best_count) {
156 | best_count = count;
157 | best = i;
158 | }
159 | }
160 | return best;
161 | }
162 |
163 | void dlx::reset() noexcept {
164 | for (auto i=stack.size(); i-- > 0;) unpick(stack[i]);
165 | result.clear();
166 | stack.clear();
167 | current_state = state::guessing;
168 | }
169 |
170 | bool dlx::next(item * & results, int & nresults) noexcept {
171 | for (;;)
172 | switch (current_state) {
173 | //case state::done:
174 | // current_state = state::guessing;
175 | // return false;
176 |
177 | case state::guessing:
178 | {
179 | item best = best_item();
180 | if (best == root()) {
181 | current_state = state::backtracking;
182 | results = result.data();
183 | nresults = result.size();
184 | return true;
185 | }
186 | auto header = items[best].cell;
187 | auto candidate = cells[header].d;
188 | if (candidate == header) {
189 | current_state = state::backtracking;
190 | } else {
191 | stack.emplace_back(candidate);
192 | result.emplace_back(pick(candidate));
193 | }
194 | break;
195 | }
196 | case state::backtracking:
197 | if (stack.size() == 0) {
198 | current_state = state::guessing;
199 | return false;
200 | } else {
201 | auto bad_choice = stack[stack.size()-1];
202 | unpick(bad_choice);
203 | auto & bad = cells[bad_choice];
204 | stack.pop_back();
205 | result.pop_back();
206 | auto header = items[bad.item].cell;
207 | if (bad.d != header) {
208 | stack.emplace_back(bad.d);
209 | result.emplace_back(pick(bad.d));
210 | current_state = state::guessing;
211 | }
212 | break;
213 | }
214 | }
215 | }
216 |
217 | int dlx::count() noexcept {
218 | auto item = best_item();
219 | if (item == root()) return 1;
220 | auto header = items[item].cell;
221 | auto candidate = cells[header].d;
222 | int n = 0;
223 | while (candidate != header) {
224 | auto row = pick(candidate);
225 | n += count();
226 | unpick(row);
227 | candidate = cells[candidate].d;
228 | }
229 | return n;
230 | }
231 |
--------------------------------------------------------------------------------
/cbits/dlx.hpp:
--------------------------------------------------------------------------------
1 | #ifndef INCLUDED_DLX_HPP
2 | #define INCLUDED_DLX_HPP
3 |
4 | #include
5 | #include
6 | #include
7 | #include
8 | #include
9 | #include
10 |
11 | // compute exact covers using dancing links
12 |
13 | using namespace std;
14 |
15 | typedef std::uint32_t link;
16 | typedef std::uint32_t item;
17 | typedef std::uint32_t option;
18 |
19 | struct cell {
20 | std::uint32_t parity:1, item:31, u, d;
21 | cell(uint32_t parity=0, std::uint32_t item=0, link u=0, link d=0)
22 | : parity(parity), item(item), u(u), d(d) {}
23 | };
24 |
25 | struct item_info {
26 | std::uint32_t p, n, cell, count;
27 | item_info(item p=0, item n=0, link cell=0, std::uint32_t count=0)
28 | : p(p), n(n), cell(cell), count(count) {}
29 | };
30 |
31 | enum class state {
32 | guessing, backtracking
33 | };
34 |
35 | struct dlx {
36 | std::vector cells;
37 | std::vector items;
38 | std::vector result; // rows
39 | std::vector stack; // actual selections
40 | state current_state;
41 |
42 | dlx(std::uint32_t n=0, std::uint32_t k=0) noexcept;
43 |
44 | item add_items(std::uint32_t k) noexcept;
45 |
46 | item add_optional_items(std::uint32_t k) noexcept;
47 |
48 | // add an option to the
49 | template option add_option(Iterator first, Iterator last);
50 |
51 | template option add_option(T values) {
52 | return add_option(values.begin(),values.end());
53 | }
54 |
55 | option add_option(std::initializer_list- values) noexcept;
56 |
57 | bool next(item * & results, int & nresults) noexcept;
58 |
59 | void reset() noexcept; // reset so that next starts from the start
60 |
61 | int count() noexcept; // count the solutions
62 |
63 | template
void solve(Fn f);
64 |
65 | private:
66 |
67 | template option for_option_containing(link cell, Fn f) noexcept;
68 | template void for_option_containing_exclusive(link cell, Fn f) noexcept;
69 |
70 | option pick(link c) noexcept;
71 | void unpick(link c) noexcept;
72 |
73 | inline item root() const noexcept { return items.size()-1; }
74 | item best_item() const noexcept;
75 |
76 | };
77 |
78 | // --------------------------------------------------------------------------------
79 | // implementation details
80 | // --------------------------------------------------------------------------------
81 |
82 | template
83 | void dlx::for_option_containing_exclusive(link cell, Fn f) noexcept {
84 | auto parity = cells[cell].parity;
85 | auto i=cell-1;
86 | if (parity) {
87 | for (;cells[i].parity;--i) f(i);
88 | for (i=cell+1;cells[i].parity;++i) f(i);
89 | } else {
90 | for (;!cells[i].parity;--i) f(i);
91 | for (i=cell+1;!cells[i].parity;++i) f(i);
92 | }
93 | }
94 |
95 | // returns row# of the row containing the cell
96 | template
97 | option dlx::for_option_containing(link cell, Fn f) noexcept {
98 | auto parity = cells[cell].parity;
99 | auto i=cell;
100 | option option_id=0;
101 | if (parity) {
102 | for (;cells[i].parity;--i) f(i);
103 | option_id = i+1;
104 | for (i=cell+1;cells[i].parity;++i) f(i);
105 | } else {
106 | for (;!cells[i].parity;--i) f(i);
107 | option_id = i+1;
108 | for (i=cell+1;!cells[i].parity;++i) f(i);
109 | }
110 | return option_id; // ok
111 | }
112 |
113 | template
114 | void dlx::solve(Fn f) {
115 | auto item = best_item();
116 | if (item == root()) {
117 | f(const_cast const &>(result)); // otherwise the empty solution is a solution
118 | return;
119 | }
120 | auto header = items[item].cell;
121 | auto candidate = cells[header].d;
122 | while (candidate != header) {
123 | auto row = pick(candidate);
124 | result.emplace_back(row);
125 | solve(f);
126 | result.pop_back();
127 | unpick(row);
128 | candidate = cells[candidate].d;
129 | }
130 | }
131 |
132 | template option dlx::add_option(Iterator first, Iterator last) {
133 | auto base = cells.size()-1;
134 | auto parity = cells[base].parity;
135 | cells.pop_back(); // drop terminating sentinel
136 | std::uint32_t i = 0;
137 | for (Iterator it = first; it != last; ++it) {
138 | item j = *it;
139 | assert(j < items.size()-1); // exclude root
140 | auto u = cells[j].u;
141 | cells.emplace_back(parity,j,u,j);
142 | cells[u].d = cells[j].u = base + i++;
143 | ++items[cells[j].item].count; // bump counts of the items
144 | }
145 | cells.emplace_back(!parity);
146 | return base;
147 | }
148 |
149 | #endif
150 |
--------------------------------------------------------------------------------
/cbits/dlx_capi.cpp:
--------------------------------------------------------------------------------
1 | #include "dlx_capi.h"
2 | #include "dlx.hpp"
3 |
4 | extern "C" {
5 | struct dlx * dlx_new(int n, int k) {
6 | return new dlx(n,k);
7 | }
8 | void dlx_delete(dlx * p) {
9 | delete p;
10 | }
11 | item dlx_add_items(dlx * p, int n) {
12 | return p->add_items(n);
13 | }
14 | item dlx_add_optional_items(dlx * p, int k) {
15 | return p->add_optional_items(k);
16 | }
17 | option dlx_add_option(dlx * p, item * is, int n) {
18 | return p->add_option(is,is+n);
19 | }
20 | int dlx_next(dlx * p, item ** results, int * nresults) {
21 | return p->next(*results,*nresults);
22 | }
23 | void dlx_reset(dlx * p) {
24 | p->reset();
25 | }
26 | int dlx_count(dlx * p) {
27 | return p->count();
28 | }
29 | };
30 |
--------------------------------------------------------------------------------
/cbits/dlx_capi.h:
--------------------------------------------------------------------------------
1 | #ifndef INCLUDED_DLX_CAPI
2 | #define INCLUDED_DLX_CAPI
3 |
4 | #include
5 |
6 | #ifdef __cplusplus
7 | extern "C" {
8 | #endif
9 |
10 | typedef uint32_t item;
11 |
12 | typedef uint32_t option;
13 |
14 | typedef struct dlx dlx;
15 |
16 | extern dlx * dlx_new(int, int);
17 | extern void dlx_delete(dlx *);
18 | extern item dlx_add_items(dlx *, int);
19 | extern item dlx_add_optional_items(dlx *, int);
20 | extern option dlx_add_option(dlx *, item *, int);
21 |
22 | /**
23 | * Extract the next solution.
24 | *
25 | * returns 0 if no solution, otherwise,
26 | * changes the pointers to point to the current solution
27 | * advancing to the next solution invalidates these pointers
28 | */
29 | extern int dlx_next(dlx *, item **, int *);
30 |
31 | extern void dlx_reset(dlx *);
32 | extern int dlx_count(dlx *);
33 |
34 | #ifdef __cplusplus
35 | }
36 | #endif
37 |
38 | #endif
39 |
--------------------------------------------------------------------------------
/cbits/dlx_queens.cpp:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 | #include "dlx.hpp"
4 |
5 | int queens(uint32_t n) {
6 | dlx x;
7 | auto rows = x.add_items(n);
8 | auto cols = x.add_items(n);
9 | uint32_t nn = n+n-2;
10 | auto diagonals1 = x.add_optional_items(nn);
11 | auto diagonals2 = x.add_optional_items(nn);
12 | // "organ pipe" order
13 | auto organ = [=](int i) { return (i&1?n-1-i:n+i)>>1; };
14 | std::vector option;
15 | for(uint8_t j=0;j= 1)
36 | std::cout << queens(n) << "\n";
37 | }
38 |
39 |
--------------------------------------------------------------------------------
/cbits/dxz.cpp:
--------------------------------------------------------------------------------
1 | #include "dxz.hpp"
2 |
3 | // compute exact covers using dancing links
4 | // and zero suppressed binary decision diagrams
5 |
6 | using namespace std;
7 |
8 | dxz::dxz(uint32_t n, uint32_t k) noexcept
9 | : cells(0)
10 | , items(0)
11 | , item_mask(n+k,true)
12 | , heap{zdd_node(),zdd_node()} // reserve terminals
13 | , cache()
14 | , memo() {
15 | uint32_t N = n+k;
16 | cells.reserve(N?N+1:2);
17 | items.reserve(N+1);
18 |
19 | for (uint32_t i=0;i values) noexcept {
108 | return add_option(values.begin(),values.end());
109 | }
110 |
111 | option dxz::pick(link c) noexcept {
112 | return for_option_containing(c, [&](link i) noexcept {
113 | auto & x = cells[i];
114 | auto & item = items[x.item];
115 | auto header = item.cell;
116 | items[item.n].p = item.p;
117 | items[item.p].n = item.n;
118 | item_mask[x.item] = false;
119 | for (auto j = x.u; j != header; j = cells[j].u)
120 | for_option_containing_exclusive(j, [&](link k) noexcept {
121 | auto & y = cells[k];
122 | cells[y.u].d = y.d;
123 | cells[y.d].u = y.u;
124 | });
125 | for (auto j = x.d; j != header; j = cells[j].d)
126 | for_option_containing_exclusive(j, [&](link k) noexcept {
127 | auto & y = cells[k];
128 | cells[y.u].d = y.d;
129 | cells[y.d].u = y.u;
130 | });
131 | });
132 | }
133 |
134 | void dxz::unpick(link c) noexcept {
135 | for_option_containing(c, [&](link i) noexcept {
136 | auto & x = cells[i];
137 | auto & item = items[x.item];
138 | auto header = item.cell;
139 | items[item.n].p = x.item;
140 | items[item.p].n = x.item;
141 | item_mask[x.item] = true;
142 | for (auto j = x.u; j != header; j = cells[j].u)
143 | for_option_containing_exclusive(j, [&](link k) noexcept {
144 | auto & y = cells[k];
145 | cells[y.u].d = k;
146 | cells[y.d].u = k;
147 | });
148 | for (auto j = x.d; j != header; j = cells[j].d)
149 | for_option_containing_exclusive(j, [&](link k) noexcept {
150 | auto & y = cells[k];
151 | cells[y.u].d = k;
152 | cells[y.d].u = k;
153 | });
154 | });
155 | }
156 |
157 | item dxz::best_item() const noexcept {
158 | item best = root();
159 | uint32_t best_count = INT32_MAX;
160 | for (item i = items[root()].n; i != root(); i = items[i].n) {
161 | uint32_t count = items[i].count;
162 | if (count < best_count) {
163 | best_count = count;
164 | best = i;
165 | }
166 | }
167 | return best;
168 | }
169 |
170 | zdd dxz::solve() noexcept {
171 | auto item = best_item();
172 | if (item == root())
173 | return top;
174 | auto it = memo.find(item_mask);
175 | if (it != memo.end()) return it->second;
176 | zdd x = bottom;
177 | auto header = items[item].cell;
178 | auto candidate = cells[header].d;
179 | while (candidate != header) {
180 | auto row = pick(candidate);
181 | zdd y = solve();
182 | if (y != bottom) x = unique(row,x,y);
183 | unpick(row);
184 | candidate = cells[candidate].d;
185 | }
186 | memo.emplace(item_mask, x);
187 | return x;
188 | }
189 |
190 | zdd dxz::unique(option label, zdd lo, zdd hi) noexcept {
191 | auto entry = zdd_node(label,lo,hi);
192 | auto it = cache.find(entry);
193 |
194 | if (it != cache.end())
195 | return it->second;
196 |
197 | zdd slot = heap.size();
198 | heap.emplace_back(entry);
199 | cache.emplace(entry,slot);
200 | return slot;
201 | }
202 |
--------------------------------------------------------------------------------
/cbits/dxz.hpp:
--------------------------------------------------------------------------------
1 | #ifndef INCLUDED_DXZ_HPP
2 | #define INCLUDED_DXZ_HPP
3 |
4 | #include
5 | #include
6 | #include
7 | #include
8 | #include
9 | #include
10 | #include
11 | #include "dlx.hpp"
12 |
13 | // compute exact covers using dancing links
14 |
15 | using namespace std;
16 |
17 | typedef uint32_t zdd;
18 |
19 | struct zdd_node {
20 | uint64_t value;
21 | zdd_node() noexcept : value(0) {}
22 | zdd_node(zdd_node && rhs) noexcept : value(std::move(rhs.value)) {}
23 | zdd_node(const zdd_node & rhs) noexcept : value(rhs.value) {}
24 | zdd_node(option label, zdd lo, zdd hi) noexcept
25 | : value(
26 | (static_cast(label) << 52) |
27 | (static_cast(lo) << 26) |
28 | static_cast(hi)
29 | ) {}
30 |
31 | bool operator == (const zdd_node & rhs) const noexcept {
32 | return value == rhs.value;
33 | }
34 | };
35 |
36 |
37 | namespace std {
38 | template <> struct hash {
39 | std::size_t operator()(const zdd_node & n) const noexcept {
40 | uint64_t k = n.value;
41 | k ^= k >> 33;
42 | k *= 0xff51afd7ed558ccdULL;
43 | k ^= k >> 33;
44 | k *= 0xc4ceb9fe1a85ec53ULL;
45 | k ^= k >> 33;
46 | return k;
47 | }
48 | };
49 | }
50 |
51 | using namespace std;
52 |
53 | struct dxz {
54 | std::vector cells;
55 | std::vector items;
56 | std::vector item_mask;
57 | std::vector heap;
58 | std::unordered_map cache;
59 | std::unordered_map, zdd> memo;
60 |
61 | static constexpr const zdd bottom = 0;
62 | static constexpr const zdd top = 1;
63 |
64 | static constexpr bool terminal(zdd z) noexcept { return z <= top; }
65 |
66 | dxz(std::uint32_t n=0, std::uint32_t k=0) noexcept;
67 |
68 | item add_items(std::uint32_t k) noexcept;
69 |
70 | item add_optional_items(std::uint32_t k) noexcept;
71 |
72 | // add an option to the
73 | template option add_option(Iterator first, Iterator last);
74 |
75 | template option add_option(T values) {
76 | return add_option(values.begin(),values.end());
77 | }
78 |
79 | option add_option(std::initializer_list- values) noexcept;
80 |
81 | zdd solve() noexcept;
82 |
83 | zdd unique(option label, zdd lo, zdd hi) noexcept;
84 |
85 | zdd_node decode(zdd z) const noexcept { return heap[z]; }
86 |
87 | private:
88 |
89 | template
option for_option_containing(link cell, Fn f) noexcept;
90 | template void for_option_containing_exclusive(link cell, Fn f) noexcept;
91 |
92 | option pick(link c) noexcept;
93 | void unpick(link c) noexcept;
94 |
95 | inline item root() const noexcept { return items.size()-1; }
96 | item best_item() const noexcept;
97 |
98 | };
99 |
100 | // --------------------------------------------------------------------------------
101 | // implementation details
102 | // --------------------------------------------------------------------------------
103 |
104 | template
105 | void dxz::for_option_containing_exclusive(link cell, Fn f) noexcept {
106 | auto parity = cells[cell].parity;
107 | auto i=cell-1;
108 | if (parity) {
109 | for (;cells[i].parity;--i) f(i);
110 | for (i=cell+1;cells[i].parity;++i) f(i);
111 | } else {
112 | for (;!cells[i].parity;--i) f(i);
113 | for (i=cell+1;!cells[i].parity;++i) f(i);
114 | }
115 | }
116 |
117 | // returns row# of the row containing the cell
118 | template
119 | option dxz::for_option_containing(link cell, Fn f) noexcept {
120 | auto parity = cells[cell].parity;
121 | auto i=cell;
122 | option option_id=0;
123 | if (parity) {
124 | for (;cells[i].parity;--i) f(i);
125 | option_id = i+1;
126 | for (i=cell+1;cells[i].parity;++i) f(i);
127 | } else {
128 | for (;!cells[i].parity;--i) f(i);
129 | option_id = i+1;
130 | for (i=cell+1;!cells[i].parity;++i) f(i);
131 | }
132 | return option_id; // ok
133 | }
134 |
135 |
136 | template option dxz::add_option(Iterator first, Iterator last) {
137 | auto base = cells.size()-1;
138 | auto parity = cells[base].parity;
139 | cells.pop_back(); // drop terminating sentinel
140 | std::uint32_t i = 0;
141 | for (Iterator it = first; it != last; ++it) {
142 | item j = *it;
143 | assert(j < items.size()-1); // exclude root
144 | auto u = cells[j].u;
145 | cells.emplace_back(parity,j,u,j);
146 | cells[u].d = cells[j].u = base + i++;
147 | ++items[cells[j].item].count; // bump counts of the items
148 | }
149 | cells.emplace_back(!parity);
150 | return base;
151 | }
152 |
153 | #endif
154 |
--------------------------------------------------------------------------------
/cbits/dxz_capi.cpp:
--------------------------------------------------------------------------------
1 | #include "dxz_capi.h"
2 | #include "dxz.hpp"
3 |
4 | extern "C" {
5 | struct dxz * dxz_new(int n, int k) {
6 | return new dxz(n,k);
7 | }
8 | void dxz_delete(dxz * p) {
9 | delete p;
10 | }
11 | item dxz_add_items(dxz * p, int n) {
12 | return p->add_items(n);
13 | }
14 | item dxz_add_optional_items(dxz * p, int k) {
15 | return p->add_optional_items(k);
16 | }
17 | option dxz_add_option(dxz * p, item * is, int n) {
18 | return p->add_option(is,is+n);
19 | }
20 | zdd dxz_solve(dxz * p) {
21 | return p->solve();
22 | }
23 | const uint64_t * dxz_heap(const dxz * p) {
24 | return reinterpret_cast(p->heap.data());
25 | }
26 | };
27 |
--------------------------------------------------------------------------------
/cbits/dxz_capi.h:
--------------------------------------------------------------------------------
1 | #ifndef INCLUDED_DXZ_CAPI
2 | #define INCLUDED_DXZ_CAPI
3 |
4 | #include
5 |
6 | #ifdef __cplusplus
7 | extern "C" {
8 | #endif
9 |
10 | typedef uint32_t item;
11 | typedef uint32_t zdd;
12 | typedef uint32_t option;
13 |
14 | typedef struct dxz dxz;
15 |
16 | extern dxz * dxz_new(int, int);
17 | extern void dxz_delete(dxz *);
18 | extern item dxz_add_items(dxz *, int);
19 | extern item dxz_add_optional_items(dxz *, int);
20 | extern option dxz_add_option(dxz *, item *, int);
21 | extern zdd dxz_solve(dxz *);
22 | extern const uint64_t * dxz_heap(const dxz *);
23 |
24 | #ifdef __cplusplus
25 | }
26 | #endif
27 |
28 | #endif
29 |
--------------------------------------------------------------------------------
/cbits/dxz_queens.cpp:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 | #include "dxz.hpp"
4 |
5 | int queens(uint32_t n) {
6 | dxz x;
7 | auto rows = x.add_items(n);
8 | auto cols = x.add_items(n);
9 | uint32_t nn = n+n-2;
10 | auto diagonals1 = x.add_optional_items(nn);
11 | auto diagonals2 = x.add_optional_items(nn);
12 | // "organ pipe" order
13 | auto organ = [=](int i) { return (i&1?n-1-i:n+i)>>1; };
14 | std::vector option;
15 | for(uint8_t j=0;j= 1) std::cout << queens(n) << " zdd nodes required\n";
36 | }
37 |
--------------------------------------------------------------------------------
/guanxi.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.2
2 | name: guanxi
3 | category: Logic
4 | version: 0
5 | license: BSD-2-Clause OR Apache-2.0
6 | license-file: LICENSE.md
7 | author: Edward A. Kmett
8 | maintainer: Edward A. Kmett
9 | stability: experimental
10 | homepage: http://github.com/ekmett/guanxi/
11 | bug-reports: http://github.com/ekmett/guanxi/issues
12 | copyright: Copyright (C) 2018 Edward A. Kmett
13 | synopsis: Relational programming
14 | description: Propagator-based relational programming in Haskell.
15 | build-type: Simple
16 | tested-with: GHC == 9.10.1
17 | extra-source-files:
18 | .hlint.yaml
19 | CHANGELOG.md
20 | README.md
21 | test/doctest.json
22 | cbits/dlx_queens.cpp
23 | cbits/dxz_queens.cpp
24 | cbits/*.h
25 | cbits/*.hpp
26 | cbits/Makefile
27 |
28 | source-repository head
29 | type: git
30 | location: git://github.com/ekmett/guanxi.git
31 |
32 | --------------------------------------------------------
33 | -- * Library
34 | --------------------------------------------------------
35 |
36 | common base
37 | ghc-options: -Wall -Wextra
38 | default-language: Haskell2010
39 | build-depends: base >= 4.12 && < 5
40 |
41 | common data-default
42 | build-depends: data-default
43 |
44 | common mtl
45 | build-depends: mtl >= 2.2.2 && < 3
46 |
47 | common primitive
48 | build-depends: primitive
49 |
50 | library
51 | import: base, data-default, mtl, primitive
52 | hs-source-dirs: src
53 |
54 | -- C++ bits
55 | cxx-options: -std=c++11 -Wall -g
56 | cxx-sources:
57 | cbits/dlx.cpp cbits/dlx_capi.cpp
58 | cbits/dxz.cpp cbits/dxz_capi.cpp
59 | include-dirs: cbits
60 | extra-libraries: stdc++
61 |
62 | build-depends:
63 | comonad,
64 | containers,
65 | contravariant,
66 | fingertree,
67 | groups >= 0.4 && < 0.5,
68 | ghc-prim,
69 | hashable,
70 | lens,
71 | primitive,
72 | transformers >= 0.5.5 && < 0.7,
73 | unordered-containers
74 |
75 | exposed-modules:
76 | Aligned.Internal
77 | Aligned.Base
78 | Aligned.Free
79 | Aligned.Freer
80 | Cover.DLX
81 | Cover.DXZ
82 | Disjoint
83 | Domain.Internal
84 | Domain.Interval
85 | Domain.Relational
86 | Equality
87 | FD.Monad
88 | FD.Var
89 | Key
90 | Key.Coercible
91 | Log
92 | Logic.Class
93 | Logic.Cont
94 | Logic.Naive
95 | Logic.Reflection
96 | Par.Cont
97 | Par.Class
98 | Par.Future
99 | Par.Promise
100 | Ref
101 | Relative.Base
102 | Relative.Internal
103 | SAT
104 | Sink
105 | Prompt.Class
106 | Prompt.Iterator
107 | Prompt.Reflection
108 | Sharing
109 | Signal
110 | Tactic
111 | Unaligned.Base
112 | Unaligned.Internal
113 | Unification.Class
114 | Unique
115 | Vec
116 |
117 | --------------------------------------------------------
118 | -- * Tests
119 | --------------------------------------------------------
120 |
121 | common test
122 | import: base
123 | build-depends: guanxi
124 | ghc-options: -threaded -rtsopts
125 | hs-source-dirs: test
126 |
127 | test-suite doctests
128 | import: test
129 | buildable: False
130 | type: exitcode-stdio-1.0
131 | main-is: doctest-main.hs
132 | build-depends: doctest
133 | build-tool-depends: doctest-discover:doctest-discover
134 |
135 | test-suite hedgehog
136 | import: test, data-default
137 | type: exitcode-stdio-1.0
138 | main-is: hedgehog-main.hs
139 | build-depends:
140 | hedgehog >= 0.6.1 && < 2
141 |
142 | test-suite spec
143 | import: test, mtl, primitive
144 | type: exitcode-stdio-1.0
145 | main-is: spec.hs
146 | other-modules:
147 | Spec.Cover.DLX
148 | Spec.Domain.Interval
149 | Spec.FD.Monad
150 | Spec.Logic.Reflection
151 | Spec.Prompt.Iterator
152 | Spec.Unaligned.Base
153 | build-depends:
154 | hspec >= 2 && < 3
155 |
156 | test-suite queens
157 | import: test
158 | type: exitcode-stdio-1.0
159 | main-is: queens.hs
160 |
--------------------------------------------------------------------------------
/src/Aligned/Base.hs:
--------------------------------------------------------------------------------
1 | {-# language PatternSynonyms #-}
2 |
3 | -- |
4 | -- Copyright : (c) Edward Kmett 2018
5 | -- License : BSD-2-Clause OR Apache-2.0
6 | -- Maintainer: Edward Kmett
7 | -- Stability : experimental
8 | -- Portability: non-portable
9 | --
10 | -- Type-aligned sequences in the style of Atze van der Ploeg's
11 | --
12 |
13 | module Aligned.Base
14 | ( View(..)
15 | , Cons(..)
16 | , Uncons(..)
17 | , Snoc(..)
18 | , Unsnoc(..)
19 | , Singleton(..)
20 | , Nil(..)
21 | , Op(..)
22 | , Thrist
23 | , Q
24 | , Cat
25 | , Rev(..)
26 | , foldCat
27 | , pattern Cons
28 | , pattern Snoc
29 | , pattern Nil
30 | ) where
31 |
32 | import Aligned.Internal
33 |
--------------------------------------------------------------------------------
/src/Aligned/Free.hs:
--------------------------------------------------------------------------------
1 | {-# language GADTs #-}
2 | {-# language DeriveTraversable #-}
3 | {-# language ViewPatterns #-}
4 | {-# language PatternSynonyms #-}
5 | {-# language LambdaCase #-}
6 | {-# language FlexibleContexts #-}
7 |
8 | -- |
9 | -- Copyright : (c) Edward Kmett 2018
10 | -- License : BSD-2-Clause OR Apache-2.0
11 | -- Maintainer: Edward Kmett
12 | -- Stability : experimental
13 | -- Portability: non-portable
14 |
15 | module Aligned.Free where
16 |
17 | import Aligned.Base
18 | import Control.Applicative
19 | import Control.Arrow (Kleisli(..))
20 | import Control.Monad (ap, liftM, guard, join)
21 | import Control.Category
22 | import Prelude hiding ((.),id)
23 | import Ref
24 | import Unification.Class
25 |
26 |
27 | data Free f a where
28 | F :: FreeView f x -> Rev Cat (Kleisli (Free f)) x b -> Free f b
29 |
30 | data FreeView f a = Pure a | Free (f (Free f a))
31 | deriving (Functor, Foldable, Traversable)
32 |
33 | pattern V :: Functor f => FreeView f a -> Free f a
34 | pattern V a <- (view -> a) where
35 | V b = unview b
36 |
37 | view :: Functor f => Free f a -> FreeView f a
38 | view (F h t) = case h of
39 | pa@(Pure a) -> case unsnoc t of
40 | Empty -> pa
41 | tc :&: hc -> view $ runKleisli hc a ^>>= tc
42 | Free f -> Free $ fmap (^>>= t) f
43 |
44 | unview :: FreeView f a -> Free f a
45 | unview x = F x id
46 |
47 | free :: f (Free f a) -> Free f a
48 | free fx = F (Free fx) id
49 |
50 | (^>>=) :: Free f x -> Rev Cat (Kleisli (Free f)) x b -> Free f b
51 | F h t ^>>= r = F h (r . t)
52 |
53 | instance Functor (Free f) where
54 | fmap = liftM
55 |
56 | instance (Functor f, Foldable f) => Foldable (Free f) where
57 | foldMap f = foldMap f . view
58 |
59 | instance Traversable f => Traversable (Free f) where
60 | traverse f = fmap unview . traverse f . view
61 |
62 | instance Applicative (Free f) where
63 | pure x = F (Pure x) id
64 | (<*>) = ap
65 |
66 | instance Monad (Free f) where
67 | F m r >>= f = F m (cons (Kleisli f) r)
68 |
69 | unifyMeta :: (Alternative m, MonadRef m, ReferenceM m (Maybe (Free f v)) v, Unified f, Eq v) => v -> Free f v -> m (Free f v)
70 | unifyMeta a x = readRef a >>= \case
71 | Nothing -> do
72 | x' <- zonk x
73 | guard $ notElem a x'
74 | x' <$ writeRef a (Just x')
75 | Just y -> do
76 | y' <- unify x y
77 | y' <$ writeRef a (Just y')
78 |
79 | unify :: (Alternative m, MonadRef m, ReferenceM m (Maybe (Free f v)) v, Unified f, Eq v) => Free f v -> Free f v -> m (Free f v)
80 | unify l r = go l (view l) (view r) where
81 | go t (Pure v) (Pure u) | v == u = return t
82 | go _ (Pure a) y = unifyMeta a (unview y) -- TODO: union by rank in the (Pure a) (Pure b) case, requires ranked references, though
83 | go t _ (Pure a) = unifyMeta a t
84 | go _ (Free xs) (Free ys) =
85 | free <$> merge unify xs ys
86 |
87 | -- | zonk/walk-flatten
88 | zonk :: (MonadRef m, ReferenceM m (Maybe (Free f v)) v, Traversable f) => Free f v -> m (Free f v)
89 | zonk = fmap join . traverse go where
90 | go v = readRef v >>= \case
91 | Nothing -> pure $ pure v
92 | Just t -> do
93 | t' <- zonk t
94 | t' <$ writeRef v (Just t') -- path compression
95 |
96 |
--------------------------------------------------------------------------------
/src/Aligned/Freer.hs:
--------------------------------------------------------------------------------
1 | {-# language GADTs #-}
2 | {-# language ExistentialQuantification #-}
3 | {-# language ViewPatterns #-}
4 | {-# language PatternSynonyms #-}
5 | {-# language LambdaCase #-}
6 | {-# language FlexibleContexts #-}
7 |
8 | -- |
9 | -- Copyright : (c) Edward Kmett 2018
10 | -- License : BSD-2-Clause OR Apache-2.0
11 | -- Maintainer: Edward Kmett
12 | -- Stability : experimental
13 | -- Portability: non-portable
14 |
15 | module Aligned.Freer where
16 |
17 | import Aligned.Base
18 | import Control.Applicative
19 | import Control.Arrow (Kleisli(..))
20 | import Control.Monad (ap, liftM, guard, join)
21 | import Control.Category
22 | import Data.Functor
23 | import Prelude hiding ((.),id)
24 | import Ref
25 | import Unification.Class
26 |
27 | data Free f a where
28 | F :: FreeView f x -> Rev Cat (Kleisli (Free f)) x b -> Free f b
29 |
30 | data FreeView f a
31 | = Pure a
32 | | forall x. Free (f x) (x -> Free f a)
33 |
34 | instance Functor (FreeView f) where
35 | fmap f (Pure a) = Pure (f a)
36 | fmap f (Free fx k) = Free fx (fmap f . k)
37 |
38 | instance Foldable f => Foldable (FreeView f) where
39 | foldMap f (Pure a) = f a
40 | foldMap f (Free fx k) = foldMap (foldMap f . k) fx
41 |
42 | instance Traversable f => Traversable (FreeView f) where
43 | traverse f (Pure a) = Pure <$> f a
44 | traverse f (Free fx k)
45 | = traverse (traverse f . k) fx <&> \fx' -> Free fx' id
46 |
47 | view :: Free f a -> FreeView f a
48 | view (F h t) = case h of
49 | pa@(Pure a) -> case unsnoc t of
50 | Empty -> pa
51 | tc :&: hc -> view $ runKleisli hc a ^>>= tc
52 | Free fx k -> Free fx ((^>>= t) . k)
53 |
54 | unview :: FreeView f a -> Free f a
55 | unview x = F x id
56 |
57 | pattern V :: Functor f => FreeView f a -> Free f a
58 | pattern V a <- (view -> a) where
59 | V b = unview b
60 |
61 | free :: f (Free f a) -> Free f a
62 | free fx = F (Free fx id) id
63 |
64 | (^>>=) :: Free f x -> Rev Cat (Kleisli (Free f)) x b -> Free f b
65 | F h t ^>>= r = F h (r . t)
66 |
67 | instance Functor (Free f) where
68 | fmap = liftM
69 |
70 | instance Foldable f => Foldable (Free f) where
71 | foldMap f = foldMap f . view
72 |
73 | instance Traversable f => Traversable (Free f) where
74 | traverse f = fmap unview . traverse f . view
75 |
76 | instance Applicative (Free f) where
77 | pure x = F (Pure x) id
78 | (<*>) = ap
79 |
80 | instance Monad (Free f) where
81 | F m r >>= f = F m (cons (Kleisli f) r)
82 |
83 | instance Unified f => Unified (Free f) where
84 | merge f l r = go (view l) (view r) where
85 | go (Pure a) (Pure b) = pure <$> f a b
86 | go (Free as ka) (Free bs kb) = free <$> merge (\a b -> merge f (ka a) (kb b)) as bs
87 | go _ _ = empty
88 |
89 | unifyMeta :: (MonadRef m, ReferenceM m (Maybe (Free f v)) v, Unified f, Eq v) => v -> Free f v -> m (Free f v)
90 | unifyMeta a x = readRef a >>= \case
91 | Nothing -> do
92 | x' <- zonk x
93 | guard $ notElem a x'
94 | x' <$ writeRef a (Just x')
95 | Just y -> do
96 | y' <- unify x y
97 | y' <$ writeRef a (Just y')
98 |
99 | unify :: (MonadRef m, ReferenceM m (Maybe (Free f v)) v, Unified f, Eq v) => Free f v -> Free f v -> m (Free f v)
100 | unify l r = go l (view l) (view r) where
101 | go t (Pure v) (Pure u) | v == u = return t
102 | go _ (Pure a) y = unifyMeta a (unview y) -- TODO: union by rank in the (Pure a) (Pure b) case, requires ranked references, though
103 | go t _ (Pure a) = unifyMeta a t
104 | go _ (Free xs kx) (Free ys ky) =
105 | free <$> merge (\x y -> unify (kx x) (ky y)) xs ys
106 |
107 | -- | zonk/walk-flatten
108 | zonk :: (MonadRef m, ReferenceM m (Maybe (Free f v)) v, Traversable f) => Free f v -> m (Free f v)
109 | zonk = fmap join . traverse go where
110 | go v = readRef v >>= \case
111 | Nothing -> pure $ pure v
112 | Just t -> do
113 | t' <- zonk t
114 | t' <$ writeRef v (Just t') -- path compression
115 |
--------------------------------------------------------------------------------
/src/Aligned/Internal.hs:
--------------------------------------------------------------------------------
1 | {-# language GADTs #-}
2 | {-# language PolyKinds #-}
3 | {-# language RankNTypes #-}
4 | {-# language ScopedTypeVariables #-}
5 | {-# language PatternSynonyms #-}
6 | {-# language ViewPatterns #-}
7 |
8 | -- |
9 | -- Copyright : (c) Edward Kmett 2018
10 | -- License : BSD-2-Clause OR Apache-2.0
11 | -- Maintainer: Edward Kmett
12 | -- Stability : experimental
13 | -- Portability: non-portable
14 | --
15 | -- Type-aligned sequences in the style of Atze van der Ploeg's
16 | --
17 |
18 | module Aligned.Internal
19 | ( View(..)
20 | , Cons(..)
21 | , Uncons(..)
22 | , Snoc(..)
23 | , Unsnoc(..)
24 | , Singleton(..)
25 | , Nil(..)
26 | , Op(..)
27 | , Thrist(..)
28 | , Q(..)
29 | , Cat(..)
30 | , Rev(..)
31 | , foldCat
32 | , pattern Cons
33 | , pattern Snoc
34 | , pattern Nil
35 | ) where
36 |
37 | import Prelude hiding (id,(.))
38 | import Control.Category
39 | import Data.Kind
40 | import Data.Default
41 |
42 | --------------------------------------------------------------------------------
43 | -- * Interface
44 | --------------------------------------------------------------------------------
45 |
46 | data View l r a b where
47 | (:&:) :: l b c -> r a b -> View l r a c
48 | Empty :: View l r a a
49 |
50 | instance a ~ b => Default (View l r a b) where
51 | def = Empty
52 |
53 | class Cons t where
54 | cons :: f b c -> t f a b -> t f a c
55 |
56 | class Nil t where
57 | nil :: t f a a
58 |
59 | class Uncons t where
60 | uncons :: t f a b -> View f (t f) a b
61 |
62 | class Unsnoc t where
63 | unsnoc :: t f a b -> View (t f) f a b
64 |
65 | class Snoc t where
66 | snoc :: t f b c -> f a b -> t f a c
67 |
68 | class Singleton t where
69 | singleton :: f a b -> t f a b
70 |
71 | pattern Cons :: (Cons t, Uncons t) => f b c -> t f a b -> t f a c
72 | pattern Cons a as <- (uncons -> a :&: as) where
73 | Cons a as = cons a as
74 |
75 | pattern Snoc :: (Snoc t, Unsnoc t) => t f b c -> f a b -> t f a c
76 | pattern Snoc as a <- (unsnoc -> as :&: a) where
77 | Snoc as a = snoc as a
78 |
79 | pattern Nil :: (Nil t, Uncons t) => (a~b) => t f a b
80 | pattern Nil <- (uncons -> Empty) where
81 | Nil = nil
82 |
83 | --------------------------------------------------------------------------------
84 | -- * The opposite category
85 | --------------------------------------------------------------------------------
86 |
87 | newtype Op (f :: k -> k -> Type) (a :: k) (b :: k) = Op { runOp :: f b a }
88 |
89 | instance Category f => Category (Op f) where
90 | id = Op id
91 | Op f . Op g = Op (g . f)
92 |
93 | instance Default (f b a) => Default (Op f a b) where
94 | def = Op def
95 |
96 | --------------------------------------------------------------------------------
97 | -- * Reversing containers
98 | --------------------------------------------------------------------------------
99 |
100 | newtype Rev t f a b = Rev { runRev :: t (Op f) b a }
101 |
102 | instance Default (t (Op f) b a) => Default (Rev t f a b) where
103 | def = Rev def
104 |
105 | instance Category (t (Op f)) => Category (Rev t f) where
106 | id = Rev id
107 | Rev f . Rev g = Rev (g . f)
108 |
109 | instance Nil t => Nil (Rev t) where
110 | nil = Rev nil
111 |
112 | instance Cons t => Snoc (Rev t) where
113 | snoc (Rev t) f = Rev (cons (Op f) t)
114 |
115 | instance Uncons t => Unsnoc (Rev t) where
116 | unsnoc (Rev t) = case uncons t of
117 | Op l :&: r -> Rev r :&: l
118 | Empty -> Empty
119 |
120 | instance Unsnoc t => Uncons (Rev t) where
121 | uncons (Rev t) = case unsnoc t of
122 | l :&: Op r -> r :&: Rev l
123 | Empty -> Empty
124 |
125 | instance Snoc t => Cons (Rev t) where
126 | cons a (Rev b) = Rev (snoc b (Op a))
127 |
128 | instance Singleton t => Singleton (Rev t) where
129 | singleton = Rev . singleton . Op
130 |
131 | --------------------------------------------------------------------------------
132 | -- * Thrists
133 | --------------------------------------------------------------------------------
134 |
135 | data Thrist f a b where
136 | Id :: Thrist f a a
137 | (:.) :: f b c -> !(Thrist f a b) -> Thrist f a c
138 |
139 | infixr 5 :.
140 |
141 | instance a ~ b => Default (Thrist f a b) where
142 | def = Id
143 |
144 | {-# complete Nil, Cons :: Thrist #-}
145 | {-# complete Id , Cons :: Thrist #-}
146 | {-# complete Nil, (:.) :: Thrist #-}
147 |
148 | instance Category (Thrist f) where
149 | id = Id
150 | xs . Id = xs
151 | Id . ys = ys
152 | (x :. xs) . ys = x :. (xs . ys)
153 |
154 | instance Nil Thrist where
155 | nil = Id
156 |
157 | instance Cons Thrist where
158 | cons = (:.)
159 |
160 | instance Uncons Thrist where
161 | uncons (a :. b) = a :&: b
162 | uncons Id = Empty
163 |
164 | instance Singleton Thrist where
165 | singleton a = a :. Id
166 |
167 | --------------------------------------------------------------------------------
168 | -- * Queues
169 | --------------------------------------------------------------------------------
170 |
171 | data Q f a b where
172 | Q :: !(Thrist f b c) -> !(Rev Thrist f a b) -> !(Thrist f b x) -> Q f a c
173 |
174 | {-# complete Nil, Cons :: Q #-}
175 |
176 | instance a ~ b => Default (Q f a b) where
177 | def = nil
178 |
179 | instance Nil Q where
180 | nil = Q nil nil nil
181 |
182 | instance Cons Q where
183 | cons a (Q f r s) = Q (a :. f) r (undefined :. s)
184 |
185 | instance Uncons Q where
186 | uncons (Q Id (Rev Id) _) = Empty
187 | uncons (Q (x :. f) r s) = x :&: exec f r s
188 | uncons _ = error "Q.uncons: invariants violated"
189 |
190 | instance Singleton Q where
191 | singleton a = Q (singleton a) nil nil
192 |
193 | instance Snoc Q where
194 | snoc (Q f r s) a = exec f (snoc r a) s
195 |
196 | exec :: Thrist f b c -> Rev Thrist f a b -> Thrist f b x -> Q f a c
197 | exec xs ys (_ :. t) = Q xs ys t
198 | exec xs ys Id = Q xs' nil xs' where xs' = rotate xs ys nil
199 |
200 | rotate :: Thrist f c d -> Rev Thrist f b c -> Thrist f a b -> Thrist f a d
201 | rotate Id (Rev (Op y :. Id)) a = y :. a
202 | rotate (x :. xs) (Rev (Op y :. ys)) a = x :. rotate xs (Rev ys) (y :. a)
203 | rotate _ _ _ = error "Q.rotate: invariant broken"
204 |
205 | --------------------------------------------------------------------------------
206 | -- * Catenable lists
207 | --------------------------------------------------------------------------------
208 |
209 | data Cat f a b where
210 | E :: Cat f a a
211 | C :: f b c -> !(Q (Cat f) a b) -> Cat f a c
212 |
213 | {-# complete Nil, Cons :: Cat #-}
214 | {-# complete E , Cons :: Cat #-}
215 | {-# complete Nil, C :: Cat #-}
216 |
217 | foldCat
218 | :: forall f g a b. Category g
219 | => (forall x y. f x y -> g x y)
220 | -> Cat f a b -> g a b
221 | foldCat f2g = go where
222 | go :: Cat f x y -> g x y
223 | go E = id
224 | go (Cons f fs) = f2g f . go fs
225 | {-# inline foldCat #-}
226 |
227 | instance a ~ b => Default (Cat f a b) where
228 | def = E
229 |
230 | instance Category (Cat f) where
231 | id = E
232 |
233 | E . xs = xs
234 | xs . E = xs
235 | C x xs . ys = link x xs ys
236 |
237 | link :: f c d -> Q (Cat f) b c -> Cat f a b -> Cat f a d
238 | link x xs ys = C x (snoc xs ys)
239 |
240 | -- O(1+e) where e is the number of empty catenable lists in the Q
241 | linkAll :: Q (Cat f) a b -> Cat f a b
242 | linkAll q = case uncons q of
243 | c@(C a t) :&: q' -> case uncons q' of
244 | Empty -> c
245 | _ -> link a t (linkAll q')
246 | E :&: q' -> linkAll q' -- recursive case in case of empty queues, unused
247 | Empty -> E
248 |
249 | instance Nil Cat where
250 | nil = E
251 |
252 | instance Uncons Cat where
253 | uncons E = Empty
254 | uncons (C a q) = a :&: linkAll q
255 |
256 | instance Cons Cat where
257 | cons a E = C a nil
258 | cons a ys = link a nil ys
259 |
260 | instance Singleton Cat where
261 | singleton a = C a nil
262 |
263 | instance Snoc Cat where
264 | snoc xs a = xs . singleton a
265 |
--------------------------------------------------------------------------------
/src/Cover/DLX.hs:
--------------------------------------------------------------------------------
1 | {-# language ForeignFunctionInterface #-}
2 | {-# language KindSignatures #-}
3 | {-# language MultiParamTypeClasses #-}
4 | {-# language FunctionalDependencies #-}
5 | {-# language MultiWayIf #-}
6 | {-# language LambdaCase #-}
7 | {-# language ScopedTypeVariables #-}
8 | {-# language ViewPatterns #-}
9 | {-# language FlexibleInstances #-}
10 |
11 | -- |
12 | -- Copyright : (c) Edward Kmett 2018-2019
13 | -- License : BSD-2-Clause OR Apache-2.0
14 | -- Maintainer: Edward Kmett
15 | -- Stability : experimental
16 | -- Portability: non-portable
17 | --
18 | -- Dancing Links
19 |
20 | module Cover.DLX
21 | ( Cover
22 | , newCover, newCover_
23 | , addItems
24 | , addOptionalItems
25 | , addOption
26 | , each
27 | , solve
28 | , reset
29 | , count
30 | ) where
31 |
32 | import Control.Applicative
33 | import Control.Lens (ifor_)
34 | import Control.Monad.Primitive
35 | import Data.Kind
36 | import Data.Traversable
37 | import Data.Word
38 | import Foreign.C.Types
39 | import Foreign.ForeignPtr
40 | import Foreign.Marshal.Alloc
41 | import Foreign.Ptr
42 | import Foreign.Storable
43 |
44 | data DLX
45 | type Item = Word32
46 | type Option = Word32
47 |
48 | newtype Cover (m :: Type -> Type) = Cover (ForeignPtr DLX)
49 |
50 | class PrimMonad m => HasCover m s | s -> m where
51 | cover :: s -> Cover m
52 |
53 | instance PrimMonad m => HasCover m (Cover m) where
54 | cover = id
55 |
56 | foreign import ccall unsafe "dlx_capi.h dlx_new" c_new :: Word32 -> Word32 -> IO (Ptr DLX)
57 | foreign import ccall unsafe "dlx_capi.h &dlx_delete" c_delete :: FunPtr (Ptr DLX -> IO ())
58 | foreign import ccall unsafe "dlx_capi.h dlx_add_items" c_add_items :: Ptr DLX -> Word32 -> IO Item
59 | foreign import ccall unsafe "dlx_capi.h dlx_add_optional_items" c_add_optional_items :: Ptr DLX -> Word32 -> IO Item
60 | foreign import ccall unsafe "dlx_capi.h dlx_add_option" c_add_option :: Ptr DLX -> Ptr Item -> Word32 -> IO Option
61 | foreign import ccall unsafe "dlx_capi.h dlx_next" c_next :: Ptr DLX -> Ptr (Ptr Item) -> Ptr Word32 -> IO CInt
62 | foreign import ccall unsafe "dlx_capi.h dlx_reset" c_reset :: Ptr DLX -> IO ()
63 | foreign import ccall unsafe "dlx_capi.h dlx_count" c_count :: Ptr DLX -> IO CInt
64 |
65 | newCover :: PrimMonad m => Int -> Int -> m (Cover m)
66 | newCover n k = unsafeIOToPrim $ do
67 | dlx <- c_new (fromIntegral n) (fromIntegral k)
68 | Cover <$> newForeignPtr c_delete dlx
69 |
70 | newCover_ :: PrimMonad m => m (Cover m)
71 | newCover_ = newCover 0 0
72 |
73 | withCover :: HasCover m s => s -> (Ptr DLX -> IO r) -> m r
74 | withCover (cover -> Cover d) f = unsafeIOToPrim $ withForeignPtr d f
75 |
76 | addItems :: HasCover m s => s -> Int -> m Int -- Item
77 | addItems d i = withCover d $ \p -> fromIntegral <$> c_add_items p (fromIntegral i)
78 |
79 | addOptionalItems :: HasCover m s => s -> Int -> m Int
80 | addOptionalItems d i = withCover d $ \p -> fromIntegral <$> c_add_optional_items p (fromIntegral i)
81 |
82 | addOption :: HasCover m s => s -> [Int] -> m Option
83 | addOption d is = withCover d $ \p -> do
84 | let n = length is
85 | allocaBytes (n * sizeOfItem) $ \ (q :: Ptr Item) -> do
86 | ifor_ is $ \i item -> pokeElemOff q i (fromIntegral item :: Item)
87 | c_add_option p q (fromIntegral n)
88 |
89 | sizeOfPtr, sizeOfItem, sizeOfWord32 :: Int
90 | sizeOfPtr = sizeOf (undefined :: Ptr Item)
91 | sizeOfItem = sizeOf (undefined :: Item)
92 | sizeOfWord32 = sizeOf (undefined :: Word32)
93 |
94 | next :: HasCover m s => s -> m (Maybe [Int])
95 | next d = withCover d $ \p -> allocaBytes (sizeOfPtr + sizeOfWord32) $ \q ->
96 | c_next p (castPtr q) (plusPtr q sizeOfPtr) >>= \ok -> if
97 | | ok /= 0 -> do
98 | (is :: Ptr Item) <- peekByteOff q 0
99 | (n :: Word32) <- peekByteOff q sizeOfPtr
100 | Just <$> for [0..n-1] (fmap fromIntegral . peekElemOff is . fromIntegral)
101 | | otherwise -> pure Nothing;
102 |
103 | reset :: HasCover m s => s -> m ()
104 | reset d = withCover d c_reset
105 |
106 | -- NB: this "consumes" the cover. You can't use it until solve is finished.
107 | each :: (HasCover m s, Alternative m) => s -> m [Int]
108 | each d = next d >>= \case
109 | Nothing -> empty
110 | Just xs -> pure xs <|> each d
111 |
112 | count :: HasCover m s => s -> m Int
113 | count d = withCover d (fmap fromIntegral . c_count)
114 |
115 | -- NB: this "consumes" the cover. You can't use it until solve is finished.
116 | solve :: HasCover m s => s -> ([Int] -> m ()) -> m ()
117 | solve d f = next d >>= \case
118 | Nothing -> pure ()
119 | Just xs -> f xs *> solve d f
120 |
--------------------------------------------------------------------------------
/src/Cover/DXZ.hs:
--------------------------------------------------------------------------------
1 | {-# language ForeignFunctionInterface #-}
2 | {-# language KindSignatures #-}
3 | {-# language MultiParamTypeClasses #-}
4 | {-# language FunctionalDependencies #-}
5 | {-# language MultiWayIf #-}
6 | {-# language ScopedTypeVariables #-}
7 | {-# language ViewPatterns #-}
8 | {-# language FlexibleInstances #-}
9 | {-# language MagicHash #-}
10 | {-# language UnboxedTuples #-}
11 | {-# language PatternSynonyms #-}
12 |
13 | -- |
14 | -- Copyright : (c) Edward Kmett 2018-2019
15 | -- License : BSD-2-Clause OR Apache-2.0
16 | -- Maintainer: Edward Kmett
17 | -- Stability : experimental
18 | -- Portability: non-portable
19 | --
20 | -- Dancing Links sped up with ZDDs
21 |
22 | module Cover.DXZ
23 | ( Cover
24 | -- , ZDD
25 | , Node(..)
26 | , newCover, newCover_
27 | , addItems
28 | , addOptionalItems
29 | , addOption
30 | , count
31 | , solve, counts
32 | , Store(..), extract
33 | ) where
34 |
35 | import Control.Lens (ifor_)
36 | import Control.Monad.Primitive
37 | import Control.Monad.ST
38 | import Data.Bits
39 | import Data.Foldable
40 | import Data.Kind
41 | import Data.Primitive.PrimArray
42 | import Data.Primitive.Ptr
43 | import Data.Primitive.Types
44 | import Data.Word
45 | import Foreign.ForeignPtr
46 | import Foreign.Marshal.Alloc
47 | import Foreign.Ptr
48 | import Foreign.Storable as Storable
49 |
50 | data Store a = Store (PrimArray a) Int
51 |
52 | data DXZ
53 | type ZDD = Word32
54 | type Item = Word32
55 | type Option = Word32
56 |
57 | -- free ZDD nodes
58 | data Node = Node { option :: Option, lo :: Int, hi :: Int }
59 |
60 | mask :: Word64
61 | mask = unsafeShiftL 1 26 - 1
62 |
63 | unpackNode :: Word64 -> Node
64 | unpackNode n = Node
65 | (fromIntegral $ unsafeShiftR n 52)
66 | (fromIntegral $ unsafeShiftR n 26 .&. mask)
67 | (fromIntegral $ n .&. mask)
68 |
69 | packNode :: Node -> Word64
70 | packNode (Node k l h)
71 | = unsafeShiftL (fromIntegral k) 52
72 | .|. unsafeShiftL (fromIntegral l) 26
73 | .|. fromIntegral h
74 |
75 | instance Storable Node where
76 | sizeOf _ = 8
77 | alignment _ = 8
78 | peek p = unpackNode <$> Storable.peek (castPtr p)
79 | poke p a = poke (castPtr p) (packNode a)
80 |
81 | instance Prim Node where
82 | sizeOf# _ = 8#
83 | alignment# _ = 8#
84 | indexByteArray# b i = unpackNode (indexByteArray# b i)
85 | readByteArray# ba i s = case readByteArray# ba i s of
86 | (# s', a #) -> (# s', unpackNode a #)
87 | writeByteArray# ba i a s = writeByteArray# ba i (packNode a) s
88 | setByteArray# ba i j a s = setByteArray# ba i j (packNode a) s
89 | indexOffAddr# p i = unpackNode (indexOffAddr# p i)
90 | readOffAddr# p i s = case readOffAddr# p i s of
91 | (# s', a #) -> (# s', unpackNode a #)
92 | writeOffAddr# p i a s = writeOffAddr# p i (packNode a) s
93 | setOffAddr# p i j a s = setOffAddr# p i j (packNode a) s
94 |
95 | newtype Cover (m :: Type -> Type) = Cover (ForeignPtr DXZ)
96 |
97 | class PrimMonad m => HasCover m s | s -> m where
98 | cover :: s -> Cover m
99 |
100 | instance PrimMonad m => HasCover m (Cover m) where
101 | cover = id
102 |
103 | foreign import ccall unsafe "dxz_capi.h dxz_new" c_new :: Word32 -> Word32 -> IO (Ptr DXZ)
104 | foreign import ccall unsafe "dxz_capi.h &dxz_delete" c_delete :: FunPtr (Ptr DXZ -> IO ())
105 | foreign import ccall unsafe "dxz_capi.h dxz_add_items" c_add_items :: Ptr DXZ -> Word32 -> IO Item
106 | foreign import ccall unsafe "dxz_capi.h dxz_add_optional_items" c_add_optional_items :: Ptr DXZ -> Word32 -> IO Item
107 | foreign import ccall unsafe "dxz_capi.h dxz_add_option" c_add_option :: Ptr DXZ -> Ptr Item -> Word32 -> IO Option
108 | foreign import ccall unsafe "dxz_capi.h dxz_solve" c_solve:: Ptr DXZ -> IO ZDD
109 | foreign import ccall unsafe "dxz_capi.h dxz_heap" c_heap:: Ptr DXZ -> IO (Ptr Node)
110 |
111 | newCover :: PrimMonad m => Int -> Int -> m (Cover m)
112 | newCover n k = unsafeIOToPrim $ do
113 | dxz <- c_new (fromIntegral n) (fromIntegral k)
114 | Cover <$> newForeignPtr c_delete dxz
115 |
116 | newCover_ :: PrimMonad m => m (Cover m)
117 | newCover_ = newCover 0 0
118 |
119 | withCover :: HasCover m s => s -> (Ptr DXZ -> IO r) -> m r
120 | withCover (cover -> Cover d) f = unsafeIOToPrim $ withForeignPtr d f
121 |
122 | addItems :: HasCover m s => s -> Int -> m Int -- Item
123 | addItems d i = withCover d $ \p -> fromIntegral <$> c_add_items p (fromIntegral i)
124 |
125 | addOptionalItems :: HasCover m s => s -> Int -> m Int
126 | addOptionalItems d i = withCover d $ \p -> fromIntegral <$> c_add_optional_items p (fromIntegral i)
127 |
128 | addOption :: HasCover m s => s -> [Int] -> m Option
129 | addOption d is = withCover d $ \p -> do
130 | let n = length is
131 | allocaBytes (n * sizeOfItem) $ \ (q :: Ptr Item) -> do
132 | ifor_ is $ \i item -> pokeElemOff q i (fromIntegral item :: Item)
133 | c_add_option p q (fromIntegral n)
134 |
135 | sizeOfItem :: Int
136 | sizeOfItem = Storable.sizeOf (undefined :: Item)
137 |
138 | solve :: HasCover m s => s -> m (Store Node)
139 | solve d = withCover d $ \p -> do
140 | zdd <- fromIntegral <$> c_solve p
141 | h <- c_heap p
142 | ma <- newPrimArray $ zdd+1
143 | for_ [0..zdd] $ \i -> readOffPtr h i >>= writePrimArray ma i
144 | arr <- unsafeFreezePrimArray ma
145 | return $ Store arr zdd
146 |
147 | extract :: Prim a => Store a -> a
148 | extract (Store f s) = indexPrimArray f s
149 |
150 | counts :: Store Node -> Store Int
151 | counts (Store f s) = runST $ do
152 | let n = sizeofPrimArray f
153 | cs <- newPrimArray n
154 | for_ [0..n-1] $ \ i -> if
155 | | i <= 1 -> writePrimArray cs i i
156 | | Node _ l h <- indexPrimArray f i -> do
157 | x <- readPrimArray cs l
158 | y <- readPrimArray cs h
159 | writePrimArray cs i (x + y)
160 | arr <- unsafeFreezePrimArray cs
161 | return $ Store arr s
162 |
163 | count :: HasCover m s => s -> m Int
164 | count = fmap (extract . counts) . solve
165 |
--------------------------------------------------------------------------------
/src/Disjoint.hs:
--------------------------------------------------------------------------------
1 | {-# language FlexibleInstances #-}
2 | {-# language FlexibleContexts #-}
3 | {-# language MultiParamTypeClasses #-}
4 | {-# language LambdaCase #-}
5 |
6 | -- |
7 | -- Copyright : (c) Edward Kmett 2018
8 | -- License : BSD-2-Clause OR Apache-2.0
9 | -- Maintainer: Edward Kmett
10 | -- Stability : experimental
11 | -- Portability: non-portable
12 | --
13 | -- disjoint set forests with path-compression providing
14 | -- a theory of equality without disequality constraints
15 | module Disjoint where
16 |
17 | import Control.Applicative (liftA2)
18 | import Control.Monad.Primitive
19 | import Ref
20 |
21 | data Content s
22 | = Root {-# unpack #-} !Int
23 | | Child {-# unpack #-} !(Disjoint s)
24 |
25 | newtype Disjoint s = Disjoint { getDisjoint :: Ref s (Content s) }
26 | deriving Eq
27 |
28 | type DisjointM m = Disjoint (PrimState m)
29 |
30 | instance Reference s (Content s) (Disjoint s) where
31 | reference = getDisjoint
32 |
33 | newDisjoint :: MonadRef m => m (DisjointM m)
34 | newDisjoint = Disjoint <$> newRef (Root 0)
35 |
36 | -- return rank as well as result
37 | findEx :: MonadRef m => DisjointM m -> m (Int, DisjointM m)
38 | findEx d = readRef d >>= \case
39 | Root i -> pure (i, d)
40 | Child s -> do
41 | x <- findEx s
42 | x <$ writeRef d (Child $ snd x)
43 |
44 | find :: MonadRef m => DisjointM m -> m (DisjointM m)
45 | find d = readRef d >>= \case
46 | Root _ -> pure d
47 | Child s -> do
48 | x <- find s
49 | x <$ writeRef d (Child x)
50 |
51 | union :: MonadRef m => DisjointM m -> DisjointM m -> m ()
52 | union m n = do
53 | (mrank,mroot) <- findEx m
54 | (nrank,nroot) <- findEx n
55 | case compare mrank nrank of
56 | LT -> writeRef mroot $ Child nroot
57 | GT -> writeRef nroot $ Child mroot
58 | EQ -> do
59 | writeRef mroot $ Child nroot
60 | writeRef nroot $ Root (nrank+1)
61 |
62 | -- | check if currently equal
63 | eq :: MonadRef m => DisjointM m -> DisjointM m -> m Bool
64 | eq m n = liftA2 (==) (find m) (find n)
65 |
--------------------------------------------------------------------------------
/src/Domain/Interval.hs:
--------------------------------------------------------------------------------
1 | module Domain.Interval
2 | ( Interval, Z
3 | , abstract, concrete
4 | , refine
5 | , interval
6 | , bottom
7 | , signumi
8 | , negatei
9 | , absi
10 | -- relations
11 | , lt, le, eq, ne, ge, gt
12 | , zlt, zle, zeq, zne, zge, zgt
13 | , ltz, lez, eqz, nez, gez, gtz
14 | , onceBoundedBelow, onceBoundedAbove
15 | , onceKnown
16 | , from, to, (...)
17 | -- , poly
18 | , onHi, onLo
19 | , deltaHi, deltaLo
20 | , known
21 | ) where
22 |
23 | import Domain.Internal
24 |
--------------------------------------------------------------------------------
/src/Domain/Relational.hs:
--------------------------------------------------------------------------------
1 | {-# language TypeFamilies #-}
2 | {-# language LambdaCase #-}
3 | {-# language BangPatterns #-}
4 | {-# language FlexibleInstances #-}
5 | {-# language MultiParamTypeClasses #-}
6 |
7 | module Domain.Relational where
8 |
9 | import Control.Lens
10 | import Control.Monad
11 | import Control.Monad.Primitive
12 | import Ref
13 |
14 | -- Use path compression, union by size, with a big relational blob at the center
15 | data Content s a
16 | = Child {-# unpack #-} !Int {-# unpack #-} !(Rel s a)
17 | | Root {-# unpack #-} !Int a
18 |
19 | newtype Rel s a = Rel
20 | { domainReference :: Ref s (Content s a)
21 | } deriving Eq
22 |
23 | type ContentM m = Content (PrimState m)
24 | type RelM m = Rel (PrimState m)
25 |
26 | instance Reference s (Content s a) (Rel s a) where
27 | reference = domainReference
28 |
29 | findEx :: MonadRef m => RelM m a -> m (Int, Int, a, RelM m a)
30 | findEx = go 0 where
31 | go !i m = readRef m >>= \case
32 | Root n a -> pure (i, n, a, m)
33 | Child j m' -> do
34 | result <- go (i + j) m'
35 | writeRef m $ Child (result^._1) (result^._4)
36 | return result
37 |
38 | find :: MonadRef m => RelM m a -> m (RelM m a)
39 | find = fmap snd . go 0 where
40 | go !i m = readRef m >>= \case
41 | Root{} -> pure (i, m)
42 | Child j m' -> do
43 | result <- go (i + j) m'
44 | writeRef m $ uncurry Child result
45 | return result
46 |
47 | class Relational m a where
48 | -- merge disjoint relational domains
49 | disjointUnion :: Int -> a -> Int -> a -> m a
50 |
51 | union :: (MonadRef m, Relational m a) => RelM m a -> RelM m a -> m ()
52 | union m n = do
53 | (mpos, msize, ma, mroot) <- findEx m
54 | (npos, nsize, na, nroot) <- findEx n
55 | unless (nroot == mroot) $if msize <= nsize
56 | then do
57 | writeRef mroot $ Child (nsize + mpos) nroot
58 | na' <- disjointUnion nsize na msize ma
59 | writeRef nroot $ Root (msize + nsize) na'
60 | else do
61 | writeRef nroot $ Child (msize + npos) mroot
62 | ma' <- disjointUnion msize ma nsize na
63 | writeRef mroot $ Root (nsize + msize) ma'
64 |
65 | -- TODO: build rational octagons out of these parts?
66 |
--------------------------------------------------------------------------------
/src/Equality.hs:
--------------------------------------------------------------------------------
1 | {-# language FlexibleInstances #-}
2 | {-# language FlexibleContexts #-}
3 | {-# language MultiParamTypeClasses #-}
4 | {-# language LambdaCase #-}
5 |
6 | -- |
7 | -- Copyright : (c) Edward Kmett 2018
8 | -- License : BSD-2-Clause OR Apache-2.0
9 | -- Maintainer: Edward Kmett
10 | -- Stability : experimental
11 | -- Portability: non-portable
12 | --
13 | -- a simple theory of equality/inequality without congruence closure
14 |
15 | module Equality
16 | ( Term
17 | , TermM
18 | , newTerm
19 | , find -- current root
20 | , is
21 | , isn't
22 | , decide
23 | ) where
24 |
25 | import Control.Applicative
26 | import Control.Monad
27 | import Control.Monad.Primitive
28 | import Control.Lens hiding (isn't)
29 | import Data.Foldable (for_)
30 | import Data.Function (on)
31 | import Data.Hashable
32 | import Data.HashSet as HS
33 | import Ref
34 | import Unique
35 |
36 | data Content s
37 | = Root
38 | {-# unpack #-} !Int -- rank
39 | !(HashSet (Term s)) -- roots of known-disjoint terms
40 | | Child !(Term s) -- parent
41 |
42 | data Term s = Term
43 | { equalityId :: {-# unpack #-} !(Unique s)
44 | , equalityReference :: {-# unpack #-} !(Ref s (Content s))
45 | }
46 |
47 | type TermM m = Term (PrimState m)
48 |
49 | instance Eq (Term s) where
50 | (==) = (==) `on` equalityId
51 |
52 | instance Hashable (Term s) where
53 | hash = hash . equalityId
54 | hashWithSalt d = hashWithSalt d . equalityId
55 |
56 | instance Reference s (Content s) (Term s) where
57 | reference = equalityReference
58 |
59 | newTerm :: MonadRef m => m (TermM m)
60 | newTerm = Term <$> newUnique <*> newRef (Root 0 mempty)
61 |
62 | -- returns rank and disjoint set as well as result
63 | findEx :: MonadRef m => TermM m -> m (Int, HashSet (TermM m), TermM m)
64 | findEx d = readRef d >>= \case
65 | Root i xs -> pure (i, xs, d)
66 | Child s -> do
67 | x <- findEx s
68 | x <$ writeRef d (Child $ x^._3)
69 |
70 | find :: MonadRef m => TermM m -> m (TermM m)
71 | find d = readRef d >>= \case
72 | Root{} -> pure d
73 | Child s -> do
74 | x <- find s
75 | x <$ writeRef d (Child x)
76 |
77 | is :: MonadRef m => TermM m -> TermM m -> m ()
78 | is m n = do
79 | (mrank,notm,mroot) <- findEx m
80 | (nrank,notn,nroot) <- findEx n
81 | guard $ not $ member mroot notn
82 | case compare mrank nrank of
83 | LT -> do
84 | writeRef mroot $ Child nroot
85 | for_ notm $ \i -> modifyRef' i $ \(Root irank noti) -> Root irank $ HS.insert nroot $ HS.delete mroot noti
86 | writeRef nroot $ Root nrank $ notm <> notn
87 | GT -> do
88 | writeRef nroot $ Child mroot
89 | for_ notn $ \i -> modifyRef' i $ \(Root irank noti) -> Root irank $ HS.insert mroot $ HS.delete nroot noti
90 | writeRef mroot $ Root mrank $ notm <> notm
91 | EQ -> do
92 | writeRef mroot $ Child nroot
93 | for_ notm $ \i -> modifyRef' i $ \(Root irank noti) -> Root irank $ HS.insert nroot $ HS.delete mroot noti
94 | writeRef nroot $ Root (nrank+1) $ notm <> notn
95 |
96 | isn't :: MonadRef m => TermM m -> TermM m -> m ()
97 | isn't m n = do
98 | (mrank,notm,mroot) <- findEx m
99 | (nrank,notn,nroot) <- findEx n
100 | guard $ mroot /= nroot
101 | writeRef mroot $ Root mrank $ HS.insert nroot notm
102 | writeRef nroot $ Root nrank $ HS.insert mroot notn
103 |
104 | -- | ground out an equality relation
105 | decide :: MonadRef m => TermM m -> TermM m -> m Bool
106 | decide m n
107 | = True <$ is m n
108 | <|> False <$ isn't m n
109 |
--------------------------------------------------------------------------------
/src/FD/Monad.hs:
--------------------------------------------------------------------------------
1 | {-# language GeneralizedNewtypeDeriving #-}
2 | {-# language RankNTypes #-}
3 | {-# language UndecidableInstances #-}
4 | {-# language PolyKinds #-}
5 | {-# language DataKinds #-}
6 | {-# language OverloadedLists #-}
7 | {-# language MultiParamTypeClasses #-}
8 | {-# language FlexibleInstances #-}
9 | {-# language TypeFamilies #-}
10 | {-# language UnboxedTuples #-}
11 |
12 | -- |
13 | -- Copyright : (c) Edward Kmett 2018
14 | -- License : BSD-2-Clause OR Apache-2.0
15 | -- Maintainer: Edward Kmett
16 | -- Stability : experimental
17 | -- Portability: non-portable
18 |
19 | module FD.Monad where
20 |
21 | import Control.Applicative
22 | import Control.Monad (MonadPlus)
23 | import Control.Monad.Primitive
24 | import Control.Monad.Reader
25 | import Control.Monad.State.Strict
26 | import Control.Monad.ST
27 | import Data.Default
28 | import Logic.Class
29 | import Logic.Cont as Cont
30 | import Par.Cont as Cont
31 | import Signal
32 |
33 | type FD' s = ReaderT (SignalEnv (FD s)) (Cont.LogicT (ST s))
34 |
35 | type M = FD
36 |
37 | newtype FD s a = FD { runFD :: Cont.Par (FD' s) a } deriving
38 | ( Functor, Applicative, Alternative
39 | , Monad, MonadPlus
40 | , MonadReader (SignalEnv (FD s))
41 | , PrimMonad
42 | )
43 |
44 | instance MonadLogic (FD s) where
45 | msplit (FD m) = FD $ fmap FD <$> msplit m
46 | interleave = (<|>)
47 |
48 | unFD :: FD s a -> LogicT (ST s) a
49 | unFD m = do
50 | se <- newSignalEnv
51 | runReaderT (evalStateT (statePar (runFD m)) def) se
52 |
53 | run1 :: (forall s. FD s a) -> a
54 | run1 m = runST $ observeT $ unFD m
55 |
56 | runN :: Int -> (forall s. FD s a) -> [a]
57 | runN n m = runST $ observeManyT n $ unFD m
58 |
59 | run :: (forall s. FD s a) -> [a]
60 | run m = runST $ observeAllT $ unFD m
61 |
62 | withMultiplicity :: FD s a -> FD s (a, Maybe Integer)
63 | withMultiplicity m = (,) <$> m <*> currentMultiplicity
64 |
--------------------------------------------------------------------------------
/src/FD/Var.hs:
--------------------------------------------------------------------------------
1 | {-# language TupleSections #-}
2 | {-# language ViewPatterns #-}
3 | {-# language FlexibleContexts #-}
4 | {-# language FlexibleInstances #-}
5 | {-# language MultiParamTypeClasses #-}
6 | {-# language TypeFamilies #-}
7 | {-# language UndecidableInstances #-}
8 |
9 | -- |
10 | -- Copyright : (c) Edward Kmett 2018
11 | -- License : BSD-2-Clause OR Apache-2.0
12 | -- Maintainer: Edward Kmett
13 | -- Stability : experimental
14 | -- Portability: non-portable
15 |
16 | module FD.Var where
17 |
18 | import Control.Applicative as A
19 | import Control.Lens
20 | import Control.Monad (join, when, guard)
21 | import Control.Monad.Primitive
22 | import Data.Set as Set
23 | import Data.Type.Coercion
24 | import Ref
25 | import Signal
26 |
27 | -- finite domains represented as intersection sets with
28 | -- propagators to establish generalized arc consistency,
29 | -- followed by a final concretization pass
30 | data FDVar m a = FDVar (RefM m (Set a)) (Signal m)
31 |
32 | instance Eq (FDVar m a) where
33 | FDVar _ s == FDVar _ t = s == t
34 |
35 | instance TestCoercion (FDVar m) where
36 | testCoercion (FDVar r i) (FDVar s j) = case testCoercion r s of
37 | Just Coercion | i == j -> Just Coercion
38 | _ -> Nothing
39 |
40 | instance HasSignals m (FDVar m a) where
41 | signals (FDVar _ v) = signals v
42 |
43 | instance (s ~ PrimState m) => Reference s (Set a) (FDVar m a) where
44 | reference (FDVar r _) = r
45 |
46 | newFDVar
47 | :: ( MonadSignal e m
48 | , Ord a
49 | ) => Set a -> m (FDVar m a)
50 | newFDVar dom = do
51 | rdom <- newRef dom
52 | let is_ v a = join $ updateRef rdom $ \ s -> (,Set.singleton a) $ when (Set.size s /= 1) $ fire v
53 | fmap (FDVar rdom) $ newSignal $ \v -> readRef rdom >>= Set.foldr ((<|>) . is_ v) A.empty
54 |
55 | val :: MonadSignal e m => FDVar m a -> m a
56 | val r = do
57 | let is_ a = join $ updateRef r $ \ s -> (,Set.singleton a) $ a <$ when (Set.size s /= 1) (fire r)
58 | readRef r >>= Set.foldr ((<|>) . is_) A.empty
59 |
60 | -- unsafe
61 | shrink :: MonadSignal e m => FDVar m a -> (Set a -> Set a) -> m ()
62 | shrink r f = join $ updateRef r $ \d@(f -> d') -> (,d') $ do
63 | guard $ not $ Set.null d' -- ensure there is an answer
64 | when (Set.size d' /= Set.size d) $ fire r
65 |
66 | is :: (MonadSignal e m, Ord a) => FDVar m a -> a -> m ()
67 | is v a = shrink v $ \d -> if Set.member a d then Set.singleton a else Set.empty
68 |
69 | isn't :: (MonadSignal e m, Ord a) => FDVar m a -> a -> m ()
70 | isn't v a = shrink v (Set.delete a)
71 |
72 | lt :: (MonadSignal e m, Ord a) => FDVar m a -> FDVar m a -> m ()
73 | lt l r = do
74 | guard (l /= r)
75 | propagate l r $ readRef l >>= \ xs -> case Set.minView xs of
76 | Nothing -> A.empty
77 | Just (min_x,_) -> shrink r $ \ ys -> Set.splitMember min_x ys ^. _3
78 | propagate r l $ readRef r >>= \ ys -> case Set.maxView ys of
79 | Nothing -> A.empty
80 | Just (max_y,_) -> shrink l $ \ xs -> Set.splitMember max_y xs ^. _1
81 |
--------------------------------------------------------------------------------
/src/Key.hs:
--------------------------------------------------------------------------------
1 | {-# language TypeOperators #-}
2 | {-# language TypeFamilies #-}
3 | {-# language FlexibleContexts #-}
4 | {-# language UndecidableInstances #-}
5 | {-# language ScopedTypeVariables #-}
6 | {-# language RankNTypes #-}
7 | {-# language GADTs #-}
8 | {-# language RoleAnnotations #-}
9 |
10 | -- |
11 | -- Copyright : (c) Edward Kmett 2018
12 | -- License : BSD-2-Clause OR Apache-2.0
13 | -- Maintainer: Edward Kmett
14 | -- Stability : experimental
15 | -- Portability: non-portable
16 | --
17 | -- This construction is based on
18 | --
19 | -- by Atze van der Ploeg, Koen Claessen, and Pablo Buiras
20 |
21 | module Key
22 | ( Key, newKey
23 | , Box(Lock), unlock
24 | ) where
25 |
26 | import Control.Monad.Primitive
27 | import Data.Primitive.MutVar
28 | import Data.Proxy
29 | import Data.Type.Coercion
30 | import Data.Type.Equality
31 | import Unsafe.Coerce
32 |
33 | -- move to Equality.Key?
34 | newtype Key m a = Key (MutVar (PrimState m) (Proxy a))
35 | deriving Eq
36 |
37 | type role Key nominal nominal
38 |
39 | instance TestEquality (Key m) where
40 | testEquality (Key s) (Key t)
41 | | s == unsafeCoerce t = Just (unsafeCoerce Refl)
42 | | otherwise = Nothing
43 | {-# inline testEquality #-}
44 |
45 | instance TestCoercion (Key m) where
46 | testCoercion (Key s :: Key m a) (Key t)
47 | | s == unsafeCoerce t = Just $ unsafeCoerce (Coercion :: Coercion a a)
48 | | otherwise = Nothing
49 | {-# inline testCoercion #-}
50 |
51 | newKey :: PrimMonad m => m (Key m a)
52 | newKey = Key <$> newMutVar Proxy
53 | {-# inline newKey #-}
54 |
55 | data Box m where
56 | Lock :: {-# unpack #-} !(Key m a) -> a -> Box m
57 |
58 | unlock :: Key m a -> Box m -> Maybe a
59 | unlock k (Lock l x) = case testEquality k l of
60 | Just Refl -> Just x
61 | Nothing -> Nothing
62 | {-# inline unlock #-}
63 |
--------------------------------------------------------------------------------
/src/Key/Coercible.hs:
--------------------------------------------------------------------------------
1 | {-# language TypeOperators #-}
2 | {-# language TypeFamilies #-}
3 | {-# language FlexibleContexts #-}
4 | {-# language UndecidableInstances #-}
5 | {-# language ScopedTypeVariables #-}
6 | {-# language RankNTypes #-}
7 | {-# language GADTs #-}
8 | {-# language RoleAnnotations #-}
9 |
10 | -- |
11 | -- Copyright : (c) Edward Kmett 2018
12 | -- License : BSD-2-Clause OR Apache-2.0
13 | -- Maintainer: Edward Kmett
14 | -- Stability : experimental
15 | -- Portability: non-portable
16 | --
17 | -- This construction is based on
18 | --
19 | -- by Atze van der Ploeg, Koen Claessen, and Pablo Buiras
20 | --
21 | -- but it is left Coercible, this should be legal directly using things in base,
22 | -- but we're currently missing a TestCoercion instance for STRefs
23 |
24 | module Key.Coercible
25 | ( Key, newKey
26 | , Box(Lock), unlock
27 | ) where
28 |
29 | import Control.Monad.Primitive
30 | import Data.Coerce
31 | import Data.Primitive.MutVar
32 | import Data.Proxy
33 | import Data.Type.Coercion
34 | import Unsafe.Coerce
35 |
36 | newtype Key m a = Key (MutVar (PrimState m) (Proxy a))
37 | deriving Eq
38 |
39 | instance TestCoercion (Key m) where
40 | testCoercion (Key s :: Key m a) (Key t)
41 | | s == unsafeCoerce t = Just $ unsafeCoerce (Coercion :: Coercion a a)
42 | | otherwise = Nothing
43 | {-# inline testCoercion #-}
44 |
45 | newKey :: PrimMonad m => m (Key m a)
46 | newKey = Key <$> newMutVar Proxy
47 | {-# inline newKey #-}
48 |
49 | data Box m where
50 | Lock :: {-# unpack #-} !(Key m a) -> a -> Box m
51 |
52 | unlock :: Key m a -> Box m -> Maybe a
53 | unlock k (Lock l x) = case testCoercion k l of
54 | Just Coercion -> Just $ coerce x
55 | Nothing -> Nothing
56 | {-# inline unlock #-}
57 |
--------------------------------------------------------------------------------
/src/Log.hs:
--------------------------------------------------------------------------------
1 | {-# language CPP #-}
2 | {-# language FlexibleContexts #-}
3 | {-# language FlexibleInstances #-}
4 | {-# language BangPatterns #-}
5 | {-# language MultiWayIf #-}
6 | {-# language RankNTypes #-}
7 | {-# language GADTs #-}
8 | {-# language DeriveTraversable #-}
9 | {-# language ScopedTypeVariables #-}
10 | {-# language MultiParamTypeClasses #-}
11 |
12 | -- |
13 | -- Copyright : (c) Edward Kmett 2018
14 | -- License : BSD-2-Clause OR Apache-2.0
15 | -- Maintainer: Edward Kmett
16 | -- Stability : experimental
17 | -- Portability: non-portable
18 |
19 | module Log
20 | (
21 | -- * Logs
22 | Log(..)
23 | , newLog, cursors, record
24 | -- * Cursors
25 | , Cursor, newCursor, oldCursor, deleteCursor, advance
26 | ) where
27 |
28 | import Control.Monad.Primitive
29 | import Control.Monad (join)
30 | import Control.Lens
31 | import Data.FingerTree as F
32 | import Data.Foldable as Foldable
33 | import Prelude hiding (log)
34 | import Ref
35 |
36 | -- version # since, ref count, monoidal summary
37 | data LogEntry a = LogEntry
38 | { since, refCount :: {-# unpack #-} !Int
39 | , contents :: a
40 | } deriving (Show, Functor, Foldable, Traversable)
41 |
42 | instance Semigroup a => Measured (LogEntry (Maybe a)) (LogEntry a) where
43 | measure = fmap Just
44 |
45 | instance Semigroup a => Semigroup (LogEntry a) where
46 | LogEntry i c a <> LogEntry j d b = LogEntry (max i j) (c + d) (a <> b)
47 |
48 | instance Monoid a => Monoid (LogEntry a) where
49 | mempty = LogEntry 0 0 mempty
50 |
51 | -- the historical log, the current version number, a reference count and a value
52 | -- the 'since' for the entry we're building here would be (current - ref count)
53 | -- the goal is to use this to track 'fingers' into the changeset for a propagation
54 | -- cell
55 | --
56 | -- TODO: allow some form of properly filtered threshold reads in the log
57 | data LogState a = LogState
58 | { logTree :: !(FingerTree (LogEntry (Maybe a)) (LogEntry a))
59 | , logSince, logRefCount :: {-# UNPACK #-} !Int
60 | , logChanges :: !(Maybe a)
61 | } deriving Show
62 |
63 | -- | Argument tracks if we're persistent or not. If persistent then 'oldCursors' can start at the beginning
64 | -- otherwise we won't collect history beyond what is needed to support active cursors.
65 | newLogState :: Semigroup a => Bool -> LogState a
66 | newLogState p = LogState mempty 0 (fromEnum p) Nothing
67 |
68 | recordState :: Semigroup a => a -> LogState a -> LogState a
69 | recordState a ls@(LogState t v c m)
70 | | F.null t, c == 0 = ls -- nobody is watching
71 | | otherwise = LogState t v c $ Just $ maybe a (<> a) m
72 |
73 | --cursors :: Monoid a => LogState a -> Int
74 | --cursors (LogState t _ c _) = refCount (measure t) + c
75 |
76 | watchNew :: Semigroup a => LogState a -> (Int, LogState a)
77 | watchNew (LogState t v c m) = case m of
78 | Nothing -> (v, LogState t v (c+1) Nothing)
79 | Just a -> (v', LogState (t F.|> LogEntry v c a) v' 1 Nothing) where !v' = v + 1
80 |
81 | -- clone the oldest version in the log, or the beginning of time if newLogState True was used to construct this
82 | watchOld :: Semigroup a => LogState a -> (Int, LogState a)
83 | watchOld (LogState t v c m) = case viewl t of
84 | EmptyL -> (v, LogState t v (c+1) m)
85 | LogEntry ov oc a F.:< t' -> (ov, LogState (LogEntry ov (oc+1) a F.<| t') v c m)
86 |
87 | #ifndef HLINT
88 | data Log u a where
89 | Log :: Semigroup a => { getLog :: Ref u (LogState a) } -> Log u a
90 | #endif
91 |
92 | type LogM m = Log (PrimState m)
93 |
94 | -- log :: HasRefEnv s u => Log u a -> Lens' s (LogState a)
95 | -- log = ref . getLog
96 |
97 | newLog :: (MonadRef m, Semigroup a) => Bool -> m (LogM m a)
98 | newLog = fmap Log . newRef . newLogState
99 |
100 | readLog :: MonadRef m => LogM m a -> m (LogState a)
101 | readLog = readRef . getLog
102 |
103 | -- | Get a snapshot of the # of cursors outstanding
104 | cursors :: MonadRef m => LogM m a -> m Int
105 | cursors l@Log{} = readLog l <&> \(LogState t _ c _) -> refCount (measure t) + c
106 |
107 | record :: MonadRef m => LogM m a -> a -> m ()
108 | record (Log r) a = modifyRef r (recordState a)
109 |
110 | data Cursor s a = Cursor {-# unpack #-} !(Log s a) {-# unpack #-} !(Ref s Int)
111 |
112 | type CursorM m = Cursor (PrimState m)
113 |
114 | -- data Cursor a = Cursor !(Var a) {-# UNPACK #-} !Int
115 |
116 | -- | Subscribe to _new_ updates, but we won't get the history.
117 | newCursor, oldCursor :: MonadRef m => LogM m a -> m (CursorM m a)
118 | newCursor l@(Log r) = Cursor l <$> do
119 | i <- updateRef r watchNew
120 | newRef i
121 |
122 | oldCursor l@(Log r) = Cursor l <$> do
123 | i <- updateRef r watchOld
124 | newRef i
125 |
126 | -- invalidates this cursor
127 | deleteCursor :: MonadRef m => CursorM m a -> m ()
128 | deleteCursor (Cursor (Log rlr) ri) = do
129 | i <- readRef ri
130 | modifyRef rlr $ \ls@(LogState t v c m) -> if
131 | | i >= v -> LogState t v (c-1) m
132 | | otherwise -> case F.split (\(LogEntry j _ _) -> j >= i) t of
133 | (l,r) -> case viewr l of
134 | EmptyR -> ls
135 | l' F.:> LogEntry j c' a -> LogState (nl >< r) v c m where
136 | nl | c' > 1 = l' F.|> LogEntry j (c'-1) a
137 | | otherwise = case viewr l' of
138 | EmptyR -> mempty
139 | l'' F.:> LogEntry k c'' b -> l'' F.|> LogEntry k c'' (b <> a)
140 |
141 | -- (0{2} m) (2{3} m) (3{4}) m {1} Nothing
142 |
143 | -- 0 m 1 m {2 mempty} 3 m 4 m {5 mempty} {6 mempty} {7 mempty} 8 m {9 mempty} 10 Maybe
144 | -- {}'d things are implied
145 | advance :: forall m a. MonadRef m => CursorM m a -> m (Maybe a)
146 | advance (Cursor (Log rlr) ri) = do
147 | i <- readRef ri
148 | join $ updateRef rlr $ \ls@(LogState t v c (m :: Maybe a)) -> if
149 | | i >= v -> case m of
150 | Nothing -> (pure Nothing, ls)
151 | Just a
152 | | c == 1 -> case viewr t of
153 | t' F.:> LogEntry ov oc b -> (pure m, LogState (t' F.|> LogEntry ov oc (b <> a)) v 1 Nothing)
154 | EmptyR -> (pure m, LogState t v c Nothing) -- we're the only one listening
155 | | !v' <- v + 1 -> (m <$ writeRef ri v', LogState (t F.|> LogEntry v (c-1) a) v' 1 Nothing)
156 | | otherwise -> case F.split (\(LogEntry j _ _) -> j >= i) t of
157 | (l,r) -> case viewr l of
158 | EmptyR -> error "advance: missing cursor!"
159 | l' F.:> LogEntry j c' a
160 | | (ls', k) <- watchNew (LogState (nl >< r) v c m) -> ((Just a <> contents (measure r) <> m) <$ writeRef ri ls', k) where
161 | nl | c' > 1 = l' F.|> LogEntry j (c'-1) a
162 | | otherwise = case viewr l' of
163 | l'' F.:> LogEntry k c'' b -> l'' F.|> LogEntry k c'' (b <> a)
164 | EmptyR -> mempty
165 |
--------------------------------------------------------------------------------
/src/Logic/Class.hs:
--------------------------------------------------------------------------------
1 | {-# language RankNTypes #-}
2 | {-# language PatternSynonyms #-}
3 | {-# language FlexibleInstances #-}
4 | {-# language UndecidableInstances #-}
5 | {-# language MultiParamTypeClasses #-}
6 | {-# language LambdaCase #-}
7 |
8 | -- |
9 | -- Copyright : (c) Edward Kmett 2018
10 | -- License : BSD-2-Clause OR Apache-2.0
11 | -- Maintainer: Edward Kmett
12 | -- Stability : experimental
13 | -- Portability: non-portable
14 |
15 | module Logic.Class where
16 |
17 | import Control.Applicative
18 | import Control.Monad
19 | import Control.Monad.Trans
20 | import Control.Monad.State.Strict as Strict
21 | import Control.Monad.State.Lazy as Lazy
22 | import Control.Monad.Reader
23 | import Control.Monad.Writer.Strict as Strict
24 | import Control.Monad.Writer.Lazy as Lazy
25 | import Unaligned.Base
26 |
27 | class MonadPlus m => MonadLogic m where
28 | -- |
29 | -- @
30 | -- msplit empty ≡ pure Empty
31 | -- msplit (pure a <|> m) == pure (a :&: m)
32 | -- @
33 | msplit :: m a -> m (View a (m a))
34 |
35 | -- | fair disjunction
36 | interleave :: m a -> m a -> m a
37 | interleave m1 m2 = msplit m1 >>= \case
38 | Empty -> m2
39 | a :&: m1' -> return a `mplus` interleave m2 m1'
40 |
41 | -- | fair conjunction
42 | (>>-) :: m a -> (a -> m b) -> m b
43 | m >>- f = do
44 | (a, m') <- msplit m >>= \case
45 | Empty -> mzero
46 | a :&: m' -> return (a, m')
47 | interleave (f a) (m' >>- f)
48 |
49 | -- |
50 | -- @
51 | -- ifte (return a) th el == th a
52 | -- ifte mzero th el == el
53 | -- ifte (return a `mplus` m) th el == th a `mplus` (m >>= th)
54 | -- @
55 | ifte :: m a -> (a -> m b) -> m b -> m b
56 | ifte t th el = msplit t >>= \case
57 | Empty -> el
58 | a :&: m -> th a <|> (m >>= th)
59 |
60 | -- | pruning
61 | once :: m a -> m a
62 | once m = msplit m >>= \case
63 | Empty -> empty
64 | a :&: _ -> pure a
65 |
66 | instance MonadLogic [] where
67 | msplit [] = return Empty
68 | msplit (x:xs) = return $ x :&: xs
69 |
70 | instance MonadLogic m => MonadLogic (ReaderT e m) where
71 | msplit rm = ReaderT $ \e -> msplit (runReaderT rm e) >>= \case
72 | Empty -> return Empty
73 | a :&: m -> return (a :&: lift m)
74 |
75 | instance MonadLogic m => MonadLogic (Strict.StateT s m) where
76 | msplit sm = Strict.StateT $ \s -> msplit (Strict.runStateT sm s) >>= \case
77 | Empty -> return (Empty, s)
78 | (a,s') :&: m -> return (a :&: Strict.StateT (\_ -> m), s')
79 |
80 | interleave ma mb = Strict.StateT $ \s ->
81 | Strict.runStateT ma s `interleave` Strict.runStateT mb s
82 |
83 | ma >>- f = Strict.StateT $ \s ->
84 | Strict.runStateT ma s >>- \(a,s') -> Strict.runStateT (f a) s'
85 |
86 | ifte t th el = Strict.StateT $ \s -> ifte
87 | (Strict.runStateT t s)
88 | (\(a,s') -> Strict.runStateT (th a) s')
89 | (Strict.runStateT el s)
90 |
91 | once ma = Strict.StateT $ \s -> once (Strict.runStateT ma s)
92 |
93 | instance MonadLogic m => MonadLogic (Lazy.StateT s m) where
94 | msplit sm = Lazy.StateT $ \s -> msplit (Lazy.runStateT sm s) >>= \case
95 | Empty -> return (Empty , s)
96 | (a,s') :&: m -> return (a :&: Lazy.StateT (\_ -> m), s')
97 |
98 | interleave ma mb = Lazy.StateT $ \s -> Lazy.runStateT ma s `interleave` Lazy.runStateT mb s
99 |
100 | ma >>- f = Lazy.StateT $ \s -> Lazy.runStateT ma s >>- \(a,s') -> Lazy.runStateT (f a) s'
101 |
102 | ifte t th el = Lazy.StateT $ \s -> ifte
103 | (Lazy.runStateT t s)
104 | (\(a,s') -> Lazy.runStateT (th a) s')
105 | (Lazy.runStateT el s)
106 |
107 | once ma = Lazy.StateT $ \s -> once (Lazy.runStateT ma s)
108 |
109 | instance (MonadLogic m, Monoid w) => MonadLogic (Strict.WriterT w m) where
110 | msplit wm = Strict.WriterT $ msplit (Strict.runWriterT wm) >>= \case
111 | Empty -> return (Empty, mempty)
112 | (a,w) :&: m -> return (a :&: Strict.WriterT m, w)
113 |
114 | interleave ma mb = Strict.WriterT $
115 | Strict.runWriterT ma `interleave` Strict.runWriterT mb
116 |
117 | ma >>- f = Strict.WriterT $
118 | Strict.runWriterT ma >>- \(a,w) -> Strict.runWriterT (Strict.tell w >> f a)
119 |
120 | ifte t th el = Strict.WriterT $ ifte
121 | (Strict.runWriterT t)
122 | (\(a,w) -> Strict.runWriterT (Strict.tell w >> th a))
123 | (Strict.runWriterT el)
124 |
125 | once ma = Strict.WriterT $ once (Strict.runWriterT ma)
126 |
127 | instance (MonadLogic m, Monoid w) => MonadLogic (Lazy.WriterT w m) where
128 | msplit wm = Lazy.WriterT $ msplit (Lazy.runWriterT wm) >>= \case
129 | Empty -> return (Empty , mempty)
130 | (a,w) :&: m -> return (a :&: Lazy.WriterT m, w)
131 |
132 | interleave ma mb = Lazy.WriterT $
133 | Lazy.runWriterT ma `interleave` Lazy.runWriterT mb
134 |
135 | ma >>- f = Lazy.WriterT $
136 | Lazy.runWriterT ma >>- \(a,w) -> Lazy.runWriterT (Lazy.tell w >> f a)
137 |
138 | ifte t th el = Lazy.WriterT $ ifte
139 | (Lazy.runWriterT t)
140 | (\(a,w) -> Lazy.runWriterT (Lazy.tell w >> th a))
141 | (Lazy.runWriterT el)
142 |
143 | once ma = Lazy.WriterT $ once (Lazy.runWriterT ma)
144 |
145 | -- |
146 | -- @
147 | -- msplit >=> reflect ≡ id
148 | -- @
149 | reflect :: Alternative m => View a (m a) -> m a
150 | reflect Empty = empty
151 | reflect (a :&: m) = pure a <|> m
152 |
153 | lnot :: MonadLogic m => m a -> m ()
154 | lnot m = ifte (once m) (const mzero) (return ())
155 |
--------------------------------------------------------------------------------
/src/Logic/Cont.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP #-}
2 | {-# LANGUAGE RankNTypes #-}
3 | {-# LANGUAGE PatternSynonyms #-}
4 | {-# LANGUAGE ViewPatterns #-}
5 | {-# LANGUAGE FlexibleInstances #-}
6 | {-# LANGUAGE UndecidableInstances #-}
7 | {-# LANGUAGE MultiParamTypeClasses #-}
8 | {-# LANGUAGE TypeFamilies #-}
9 |
10 | -- |
11 | -- Copyright : (c) Edward Kmett 2018
12 | -- License : BSD-2-Clause OR Apache-2.0
13 | -- Maintainer: Edward Kmett
14 | -- Stability : experimental
15 | -- Portability: non-portable
16 |
17 | module Logic.Cont where
18 |
19 | import Control.Applicative
20 | import Control.Monad
21 | import Control.Monad.Error.Class
22 | import Control.Monad.Fail as Fail
23 | import Control.Monad.Primitive
24 | import Control.Monad.Reader
25 | import Control.Monad.State.Class
26 | import Data.Foldable (fold)
27 | import Data.Functor.Identity
28 | import Logic.Class
29 | import Unaligned.Base
30 |
31 | newtype LogicT m a = LogicT
32 | { runLogicT :: forall r. (a -> m r -> m r) -> m r -> m r
33 | }
34 |
35 | type Logic = LogicT Identity
36 |
37 | runLogic :: Logic a -> forall r. (a -> r -> r) -> r -> r
38 | runLogic l s f = runIdentity $ runLogicT l (fmap . s) (Identity f)
39 |
40 | pattern Logic :: (forall r . (a -> r -> r) -> r -> r) -> Logic a
41 | pattern Logic f <- (runLogic -> f)
42 | where Logic f = LogicT $ \ k -> Identity . f (\ a -> runIdentity . k a . Identity) . runIdentity
43 |
44 | instance Functor (LogicT f) where
45 | fmap f lt = LogicT $ \sk fk -> runLogicT lt (sk . f) fk
46 |
47 | instance Applicative (LogicT f) where
48 | pure a = LogicT $ \sk fk -> sk a fk
49 | f <*> a =
50 | LogicT $ \sk fk -> runLogicT f (\g fk' -> runLogicT a (sk . g) fk') fk
51 |
52 | instance Alternative (LogicT f) where
53 | empty = LogicT $ \_ fk -> fk
54 | f1 <|> f2 = LogicT $ \sk fk -> runLogicT f1 sk (runLogicT f2 sk fk)
55 |
56 | instance Monad (LogicT m) where
57 | return = pure
58 | m >>= f = LogicT $ \sk fk -> runLogicT m (\a fk' -> runLogicT (f a) sk fk') fk
59 | #if __GLASGOW_HASKELL__ < 808
60 | fail _ = LogicT $ \_ fk -> fk
61 | #endif
62 |
63 | instance MonadFail (LogicT m) where
64 | fail _ = LogicT $ \_ fk -> fk
65 |
66 | instance MonadPlus (LogicT m) where
67 | mzero = empty
68 | mplus = (<|>)
69 |
70 | instance MonadTrans LogicT where
71 | lift m = LogicT $ \sk fk -> m >>= \a -> sk a fk
72 |
73 | instance MonadIO m => MonadIO (LogicT m) where
74 | liftIO = lift . liftIO
75 |
76 | instance Monad m => MonadLogic (LogicT m) where
77 | msplit m = lift $ runLogicT m ssk (return Empty)
78 | where ssk a fk = return $ a :&: (lift fk >>= reflect)
79 |
80 | instance (Monad m, Foldable m) => Foldable (LogicT m) where
81 | foldMap f m = fold $ runLogicT m (fmap . mappend . f) (return mempty)
82 |
83 | instance Traversable (LogicT Identity) where
84 | traverse g l = runLogic l (\a ft -> c <$> g a <*> ft) (pure mzero)
85 | where c a l' = return a `mplus` l'
86 |
87 | instance MonadReader r m => MonadReader r (LogicT m) where
88 | ask = lift ask
89 | local f m = LogicT $ \sk fk -> runLogicT m ((local f .) . sk) (local f fk)
90 |
91 | instance MonadState s m => MonadState s (LogicT m) where
92 | get = lift get
93 | put = lift . put
94 |
95 | instance MonadError e m => MonadError e (LogicT m) where
96 | throwError = lift . throwError
97 | catchError m h =
98 | LogicT $ \sk fk ->
99 | let handle r = r `catchError` \e -> runLogicT (h e) sk fk
100 | in handle $ runLogicT m (\a -> sk a . handle) fk
101 |
102 | instance PrimMonad m => PrimMonad (LogicT m) where
103 | type PrimState (LogicT m) = PrimState m
104 | primitive f = lift (primitive f)
105 |
106 | observe :: Logic a -> a
107 | observe lt = runIdentity $ runLogicT lt (const . return) (error "No answer.")
108 |
109 | observeAll :: Logic a -> [a]
110 | observeAll = runIdentity . observeAllT
111 |
112 | observeMany :: Int -> Logic a -> [a]
113 | observeMany i = runIdentity . observeManyT i
114 |
115 | observeT :: Monad m => LogicT m a -> m a
116 | observeT lt = runLogicT lt (const . return) (error "No answer.")
117 |
118 | observeAllT :: Monad m => LogicT m a -> m [a]
119 | observeAllT m = runLogicT m (fmap . (:)) (return [])
120 |
121 | observeManyT :: Monad m => Int -> LogicT m a -> m [a]
122 | observeManyT n m
123 | | n <= 0 = return []
124 | | n == 1 = runLogicT m (\a _ -> return [a]) (return [])
125 | | otherwise = runLogicT (msplit m) sk (return []) where
126 | sk Empty _ = return []
127 | sk (a :&: m') _ = (a :) `liftM` observeManyT (n - 1) m'
128 |
--------------------------------------------------------------------------------
/src/Logic/Naive.hs:
--------------------------------------------------------------------------------
1 | {-# language LambdaCase #-}
2 | {-# language TypeFamilies #-}
3 |
4 | -- |
5 | -- Copyright : (c) Edward Kmett 2018
6 | -- License : BSD-2-Clause OR Apache-2.0
7 | -- Maintainer: Edward Kmett
8 | -- Stability : experimental
9 | -- Portability: non-portable
10 |
11 | module Logic.Naive where
12 |
13 | import Control.Applicative
14 | import Control.Monad
15 | import Control.Monad.Primitive
16 | import Control.Monad.Trans
17 | import Data.Bifunctor
18 | import Data.Bifoldable
19 | import Data.Bitraversable
20 | import Logic.Class
21 | import Unaligned.Base
22 |
23 | type L m a = View a (LogicT m a)
24 |
25 | newtype LogicT m a = LogicT { runLogicT :: m (L m a) }
26 |
27 | instance Functor m => Functor (LogicT m) where
28 | fmap f = LogicT . fmap (bimap f (fmap f)) . runLogicT
29 |
30 | instance Foldable m => Foldable (LogicT m) where
31 | foldMap f = foldMap (bifoldMap f (foldMap f)) . runLogicT
32 |
33 | instance Traversable m => Traversable (LogicT m) where
34 | traverse f = fmap LogicT . traverse (bitraverse f (traverse f)) . runLogicT
35 |
36 | single :: Monad m => a -> m (L m a)
37 | single a = return (a :&: empty)
38 |
39 | instance Monad m => Applicative (LogicT m) where
40 | pure = LogicT . single
41 | (<*>) = ap
42 |
43 | instance Monad m => Monad (LogicT m) where
44 | LogicT m >>= f = LogicT $ m >>= \case
45 | Empty -> return Empty
46 | h :&: t -> runLogicT $ f h <|> (t >>= f)
47 |
48 | instance Monad m => Alternative (LogicT m) where
49 | empty = LogicT $ return Empty
50 | LogicT a <|> b = LogicT $ a >>= \case
51 | Empty -> runLogicT b
52 | h :&: t -> pure $ h :&: (t <|> b)
53 |
54 | instance Monad m => MonadPlus (LogicT m) where
55 | mzero = empty
56 | mplus = (<|>)
57 |
58 | instance MonadTrans LogicT where
59 | lift m = LogicT (m >>= single)
60 |
61 | instance Monad m => MonadLogic (LogicT m) where
62 | msplit (LogicT m) = lift m
63 |
64 | instance PrimMonad m => PrimMonad (LogicT m) where
65 | type PrimState (LogicT m) = PrimState m
66 | primitive f = lift (primitive f)
67 |
--------------------------------------------------------------------------------
/src/Logic/Reflection.hs:
--------------------------------------------------------------------------------
1 | {-# language LambdaCase #-}
2 | {-# language TypeFamilies #-}
3 | {-# language RankNTypes #-}
4 | {-# language CPP #-}
5 |
6 | -- |
7 | -- Copyright : (c) Edward Kmett 2018
8 | -- License : BSD-2-Clause OR Apache-2.0
9 | -- Maintainer: Edward Kmett
10 | -- Stability : experimental
11 | -- Portability: non-portable
12 |
13 | module Logic.Reflection
14 | ( LogicT (LogicT) -- TODO internal
15 | , Logic
16 | , observe, observeMany, observeAll
17 | , observeT, observeManyT, observeAllT
18 | -- TODO internal
19 | , view, unview
20 | ) where
21 |
22 | import Control.Monad
23 | import Control.Monad.Fail as Fail
24 | import Control.Monad.Primitive
25 | import Control.Monad.Trans
26 | import Control.Applicative
27 | import Data.Bifunctor
28 | import Data.Bifoldable
29 | import Data.Bitraversable
30 | import Data.Functor.Identity
31 | import Logic.Class
32 | import Unaligned.Base
33 |
34 | type L m a = View a (LogicT m a)
35 |
36 | type Logic = LogicT Identity
37 |
38 | instance Nil (LogicT m) where
39 | nil = LogicT mempty
40 |
41 | instance Monad m => Cons (LogicT m) where
42 | cons a xs = pure a <|> xs
43 |
44 | instance Monad m => Snoc (LogicT m) where
45 | snoc xs a = xs <|> pure a
46 |
47 | instance m ~ Identity => Uncons (LogicT m) where
48 | uncons = runIdentity . view
49 |
50 | instance Monad m => Semigroup (LogicT m a) where
51 | (<>) = (<|>)
52 | -- LogicT xs <> LogicT ys = LogicT (xs <> ys)
53 |
54 | instance Monad m => Monoid (LogicT m a) where
55 | mempty = LogicT mempty
56 |
57 | newtype LogicT m a = LogicT { runLogicT :: Cat (m (L m a)) }
58 |
59 | instance Functor m => Functor (LogicT m) where
60 | fmap f = LogicT . fmap (fmap (bimap f (fmap f))) . runLogicT
61 |
62 | instance Foldable m => Foldable (LogicT m) where
63 | foldMap f = foldMap (foldMap (bifoldMap f (foldMap f))) . runLogicT
64 |
65 | instance Traversable m => Traversable (LogicT m) where
66 | traverse f = fmap LogicT . traverse (traverse (bitraverse f (traverse f))) . runLogicT
67 |
68 | single :: Monad m => a -> m (L m a)
69 | single a = pure (a :&: empty)
70 |
71 | unview :: m (L m a) -> LogicT m a
72 | unview = LogicT . singleton
73 |
74 | view :: Monad m => LogicT m a -> m (L m a)
75 | view (LogicT s) = case uncons s of
76 | Empty -> return Empty
77 | h :&: t -> h >>= \case
78 | Empty -> view (LogicT t)
79 | hi :&: LogicT ti -> return $ hi :&: LogicT (ti <> t)
80 |
81 | instance Monad m => Applicative (LogicT m) where
82 | pure = unview . single
83 | (<*>) = ap
84 |
85 | instance Monad m => Alternative (LogicT m) where
86 | empty = LogicT mempty
87 | LogicT m <|> LogicT n = LogicT (m <> n)
88 |
89 | instance Monad m => Monad (LogicT m) where
90 | m >>= f = unview $ view m >>= \case
91 | Empty -> return Empty
92 | h :&: t -> view $ f h <|> (t >>= f)
93 |
94 | #if __GLASGOW_HASKELL__ < 808
95 | fail _ = mzero
96 | #endif
97 |
98 | instance Monad m => Fail.MonadFail (LogicT m) where
99 | fail _ = mzero
100 |
101 | instance Monad m => MonadPlus (LogicT m) where
102 | mzero = empty
103 | mplus = (<|>)
104 |
105 | instance MonadTrans LogicT where
106 | lift m = unview $ m >>= single
107 |
108 | instance MonadIO m => MonadIO (LogicT m) where
109 | liftIO = lift . liftIO
110 |
111 | instance Monad m => MonadLogic (LogicT m) where
112 | msplit = lift . view
113 |
114 | instance PrimMonad m => PrimMonad (LogicT m) where
115 | type PrimState (LogicT m) = PrimState m
116 | primitive f = lift $ primitive f
117 |
118 | observe :: Logic a -> a
119 | observe m = runIdentity $ view m >>= go where
120 | go (a :&: _) = return a
121 | go _ = return (error "no results")
122 |
123 | observeMany :: Int -> Logic a -> [a]
124 | observeMany n = runIdentity . observeManyT n
125 |
126 | observeAll :: Logic a -> [a]
127 | observeAll m = go (runIdentity (view m)) where
128 | go :: forall a. View a (Logic a) -> [a]
129 | go (a :&: t) = a : observeAll t
130 | go _ = []
131 |
132 | observeT :: MonadFail m => LogicT m a -> m a
133 | observeT m = view m >>= go where
134 | go (a :&: _) = return a
135 | go _ = Fail.fail "No results"
136 |
137 | observeManyT :: Monad m => Int -> LogicT m a -> m [a]
138 | observeManyT n m
139 | | n <= 0 = return []
140 | | otherwise = view m >>= \case
141 | Empty -> return []
142 | a :&: m1 -> (a:) <$> observeManyT (n-1) m1
143 |
144 | observeAllT :: Monad m => LogicT m a -> m [a]
145 | observeAllT m = view m >>= go where
146 | go (a :&: t) = (a:) <$> observeAllT t
147 | go _ = return []
148 |
--------------------------------------------------------------------------------
/src/Par/Class.hs:
--------------------------------------------------------------------------------
1 | {-# language DefaultSignatures #-}
2 | {-# language TypeFamilies #-}
3 |
4 | -- |
5 | -- Copyright : (c) Edward Kmett 2018
6 | -- License : BSD-2-Clause OR Apache-2.0
7 | -- Maintainer: Edward Kmett
8 | -- Stability : experimental
9 | -- Portability: non-portable
10 |
11 | module Par.Class
12 | ( MonadPar(..)
13 | ) where
14 |
15 | import Control.Monad.Cont.Class
16 | import Control.Monad.Trans.Class
17 | import Control.Monad.Trans.Reader
18 |
19 | class MonadCont m => MonadPar m where
20 | fork :: m () -> m ()
21 |
22 | halt :: m a
23 | default halt :: (m ~ t n, MonadTrans t, MonadPar n) => m a
24 | halt = lift halt
25 |
26 | yield :: m ()
27 | default yield :: (m ~ t n, MonadTrans t, MonadPar n) => m ()
28 | yield = lift yield
29 |
30 | instance MonadPar m => MonadPar (ReaderT e m) where
31 | fork (ReaderT f) = ReaderT (fork . f)
32 |
--------------------------------------------------------------------------------
/src/Par/Cont.hs:
--------------------------------------------------------------------------------
1 | {-# language TemplateHaskell #-}
2 | {-# language LambdaCase #-}
3 | {-# language StandaloneDeriving #-}
4 | {-# language MultiParamTypeClasses #-}
5 | {-# language FunctionalDependencies #-}
6 | {-# language FlexibleInstances #-}
7 | {-# language UndecidableInstances #-}
8 | {-# language FlexibleContexts #-}
9 | {-# language DeriveFunctor #-}
10 | {-# language GeneralizedNewtypeDeriving #-}
11 | {-# language PatternSynonyms #-}
12 | {-# language TypeFamilies #-}
13 |
14 | -- |
15 | -- Copyright : (c) Edward Kmett 2018
16 | -- License : BSD-2-Clause OR Apache-2.0
17 | -- Maintainer: Edward Kmett
18 | -- Stability : experimental
19 | -- Portability: non-portable
20 |
21 | module Par.Cont
22 | ( ParEnv(..), HasParEnv(..)
23 | , Par(Par), runPar
24 | , statePar
25 | , parState
26 | ) where
27 |
28 | import Control.Monad hiding (fail)
29 | import Control.Monad.Cont hiding (fail) -- fix this API!
30 | import Control.Monad.Fail
31 | import Control.Monad.Primitive
32 | import Control.Monad.Reader.Class
33 | import Control.Monad.State.Strict hiding (fail) -- fix this API!
34 | import Control.Applicative
35 | import Control.Lens hiding (Empty, snoc, uncons)
36 | import Data.Default
37 | import Logic.Class
38 | import Par.Class
39 | import Prelude hiding (fail)
40 | import Ref
41 | import Unaligned.Base
42 |
43 | type Task m = ParEnv m -> m (ParEnv m)
44 |
45 | -- TODO: can we just store this in a backtracked reference?
46 | newtype ParEnv m = ParEnv { _todo :: Q (Task m) }
47 |
48 | instance Default (ParEnv m) where
49 | def = ParEnv def
50 |
51 | makeClassy ''ParEnv
52 |
53 | statePar :: (Alternative m, MonadRef m) => Par m a -> StateT (ParEnv m) m a
54 | statePar (Par m) = StateT $ \s -> do
55 | r <- newRef Nothing
56 | s' <- m (\ a s' -> s' <$ writeRef r (Just a)) s
57 | readRef r >>= \case
58 | Nothing -> empty
59 | Just a -> pure (a, s')
60 |
61 | newtype Par m a = Par
62 | { runPar :: (a -> Task m) -> Task m
63 | } deriving Functor
64 |
65 | parState :: Monad m => StateT (ParEnv m) m a -> Par m a
66 | parState (StateT m) = Par $ \k s -> do
67 | (a,s') <- m s
68 | k a s'
69 |
70 | instance Applicative (Par m) where
71 | pure x = Par $ \k -> k x
72 | Par f <*> Par v = Par $ \ c -> f $ \ g -> v (c . g)
73 |
74 | instance Monad (Par m) where
75 | Par m >>= k = Par $ \ c -> m $ \ x -> runPar (k x) c
76 | -- fail s = Par $ \_ -> fail s
77 |
78 | instance MonadTrans Par where
79 | lift m = Par $ \k s -> m >>= \a -> k a s
80 |
81 | instance MonadIO m => MonadIO (Par m) where
82 | liftIO = lift . liftIO
83 |
84 | -- dangerous
85 | instance PrimMonad m => PrimMonad (Par m) where
86 | type PrimState (Par m) = PrimState m
87 | primitive f = lift (primitive f)
88 |
89 | instance MonadState s m => MonadState s (Par m) where
90 | get = lift get
91 | put = lift . put
92 | state = lift . state
93 |
94 | instance MonadReader e m => MonadReader e (Par m) where
95 | ask = lift ask
96 | local f (Par m) = Par $ \k s -> do
97 | r <- ask
98 | local f $ m (\a -> local (const r) . k a) s
99 |
100 | instance
101 | ( MonadRef m
102 | , MonadLogic m
103 | ) => MonadLogic (Par m) where
104 | msplit m = fmap parState <$> parState (msplit (statePar m))
105 |
106 | apply :: (a -> b, a) -> b
107 | apply (f,x) = f x
108 |
109 | -- halt and catch fire
110 | hcf :: Applicative m => Task m -- ParEnv m -> m (ParEnv m)
111 | hcf s = apply $ s & todo %%~ \xss -> case uncons xss of
112 | x :&: xs -> (x, xs)
113 | Empty -> (pure, Nil)
114 |
115 | instance MonadCont (Par m) where
116 | callCC f = Par $ \ c -> runPar (f (\ x -> Par $ \ _ -> c x)) c
117 |
118 | instance Monad m => MonadPar (Par m) where
119 | yield = Par $ \k s ->
120 | apply $ s & todo %%~ \xss -> case uncons xss of
121 | x :&: xs -> (x, xs `snoc` k ())
122 | Empty -> (k (), Nil)
123 |
124 | halt = Par $ \_ -> hcf
125 | fork m = parState $ todo %= \ys -> snoc ys $ runPar m $ \_ -> hcf
126 |
127 | instance MonadFail m => MonadFail (Par m) where
128 | fail s = Par $ \_ _ -> fail s
129 |
130 | instance Alternative m => Alternative (Par m) where
131 | empty = Par $ \_ _ -> empty
132 | Par m <|> Par n = Par $ \k s -> m k s <|> n k s
133 |
134 | instance MonadPlus m => MonadPlus (Par m) where
135 | mzero = Par $ \_ _ -> mzero
136 | Par m `mplus` Par n = Par $ \k s -> m k s `mplus` n k s
137 |
--------------------------------------------------------------------------------
/src/Par/Future.hs:
--------------------------------------------------------------------------------
1 | -- |
2 | -- Copyright : (c) Edward Kmett 2018
3 | -- License : BSD-2-Clause OR Apache-2.0
4 | -- Maintainer: Edward Kmett
5 | -- Stability : experimental
6 | -- Portability: non-portable
7 |
8 | module Par.Future
9 | ( Future
10 | , newFuture
11 | , await
12 | ) where
13 |
14 | import Par.Class
15 | import Par.Promise
16 | import Signal
17 |
18 | newtype Future m a = Future (Promise m a)
19 |
20 | newFuture :: (MonadPar m, MonadSignal e m) => m a -> m (Future m a)
21 | newFuture m = do
22 | p <- newPromise_
23 | fork $ do
24 | a <- m
25 | unsafeFulfill p a
26 | pure $ Future p
27 |
28 | await :: (MonadPar m, MonadSignal e m) => Future m a -> m a
29 | await (Future p) = demand p
30 |
--------------------------------------------------------------------------------
/src/Par/Promise.hs:
--------------------------------------------------------------------------------
1 | {-# language LambdaCase #-}
2 | {-# language FlexibleContexts #-}
3 | {-# language ScopedTypeVariables #-}
4 |
5 | module Par.Promise
6 | ( Promise
7 | , newPromise
8 | , newPromise_
9 | , demand
10 | , fulfill
11 | , unsafeFulfill
12 | ) where
13 |
14 | import Control.Monad (guard, join)
15 | import Control.Monad.Cont.Class
16 | import Control.Monad.Primitive
17 | import Data.Foldable (traverse_)
18 | import Data.Maybe
19 | import Data.Proxy
20 | import Par.Class
21 | import Ref
22 | import Signal
23 |
24 | data Promise m a = Promise
25 | { _promiseVal :: RefM m (Maybe a)
26 | , _promiseSignal :: Signal m
27 | }
28 |
29 | -- | this promise does not require the promise to be fulfilled for the world to be valid
30 | newPromise_ :: PrimMonad m => m (Promise m a)
31 | newPromise_ = do
32 | r <- newRef Nothing
33 | Promise r <$> newSignal_
34 |
35 | -- | Create a new promise that must be fulfilled for the world to be valid
36 | newPromise :: MonadSignal e m => m (Promise m a)
37 | newPromise = do
38 | r <- newRef Nothing
39 | Promise r <$> newSignal (\_ -> readRef r >>= guard . isJust)
40 |
41 | -- | Fulfill a promise
42 | fulfill :: (MonadSignal e m, Eq a) => Promise m a -> a -> m ()
43 | fulfill (Promise r v) a = join $ updateRef r $ \case
44 | Nothing -> (fire v, Just a)
45 | jb@(Just b) -> (guard $ a == b, jb)
46 |
47 | -- fulfill a promise, assumes that any attempts at multiple fulfillment used the same value
48 | unsafeFulfill :: MonadSignal e m => Promise m a -> a -> m ()
49 | unsafeFulfill (Promise r v) a = join $ updateRef r $ \case
50 | Nothing -> (fire v, Just a)
51 | rb -> (pure (), rb)
52 |
53 | -- | Demand that another inhabitant of this world fulfills this promise
54 | demand :: forall m e a. (MonadPar m, MonadSignal e m) => Promise m a -> m a
55 | demand (Promise r v) = callCC $ \k -> join $ updateRef r $ \case
56 | Nothing -> (propagate v (Proxy :: Proxy m) (readRef r >>= traverse_ k) *> halt, Nothing)
57 | ja@(Just a) -> (pure a, ja)
58 |
--------------------------------------------------------------------------------
/src/Prompt/Class.hs:
--------------------------------------------------------------------------------
1 | {-# language TypeFamilies #-}
2 | {-# language FlexibleContexts #-}
3 | {-# language RankNTypes #-}
4 |
5 | module Prompt.Class where
6 |
7 | import Control.Category
8 | import Control.Monad
9 | import Control.Monad.Cont.Class
10 | import Control.Monad.Reader
11 | import Data.Kind
12 | import Data.Type.Coercion
13 | import Data.Type.Equality
14 | import Prelude hiding ((.),id)
15 |
16 | -- delimited continuations
17 | class
18 | ( MonadCont m
19 | , Category (Sub m)
20 | , TestCoercion (Prompt m)
21 | , TestEquality (Prompt m)
22 | ) => MonadPrompt m where
23 |
24 | type Prompt m :: Type -> Type
25 | type Sub m :: Type -> Type -> Type
26 |
27 | newPrompt :: m (Prompt m a)
28 | pushPrompt :: Prompt m a -> m a -> m a
29 | withSub :: Prompt m b -> (Sub m a b -> m b) -> m a
30 | pushSub :: Sub m a b -> m a -> m b
31 |
32 | reset :: MonadPrompt m => (Prompt m a -> m a) -> m a
33 | reset e = do
34 | p <- newPrompt
35 | pushPrompt p (e p)
36 |
37 | shift, shift0, control, control0 :: MonadPrompt m => Prompt m b -> ((a -> m b) -> m b) -> m a
38 | shift p f = withSub p $ \sk -> pushPrompt p $ f $ pushPrompt p . pushSub sk . return
39 | shift0 p f = withSub p $ \sk -> f $ pushPrompt p . pushSub sk . return
40 | control p f = withSub p $ \sk -> pushPrompt p $ f $ pushSub sk . return
41 | control0 p f = withSub p $ \sk -> f $ pushSub sk . return
42 |
43 | -- | proper rank-3 call/cc. This serves two purposes, it provides an
44 | -- implementation of the more general call/cc. It also provides a valid
45 | -- default definition for callCC from MonadCont, justifying having it
46 | -- as a superclass above MonadPrompt
47 | callcc :: MonadPrompt m => ((forall b. a -> m b) -> m a) -> m a
48 | callcc f = do
49 | p <- newPrompt
50 | withSub p $ \sk -> pushSub sk $ f $ abort p . pushSub sk . return
51 |
52 | abort :: MonadPrompt m => Prompt m b -> m b -> m a
53 | abort p = withSub p . const
54 |
55 | -- in the style of CC-delcont
56 | shiftM, shiftM0, controlM, controlM0 :: MonadPrompt m => Prompt m b -> ((m a -> m b) -> m b) -> m a
57 | shiftM p f = withSub p $ \sk -> pushPrompt p $ f $ pushPrompt p . pushSub sk
58 | shiftM0 p f = withSub p $ \sk -> f $ pushPrompt p . pushSub sk
59 | controlM p f = withSub p $ pushPrompt p . f . pushSub
60 | controlM0 p f = withSub p $ f . pushSub
61 |
62 | callccM :: MonadPrompt m => ((forall b. m a -> m b) -> m a) -> m a
63 | callccM f = do
64 | p <- newPrompt
65 | withSub p $ \sk -> pushSub sk $ f $ abort p . pushSub sk
66 |
67 | instance MonadPrompt m => MonadPrompt (ReaderT e m) where
68 | type Prompt (ReaderT e m) = Prompt m
69 | type Sub (ReaderT e m) = Sub m
70 | newPrompt = lift newPrompt
71 | pushPrompt = mapReaderT . pushPrompt
72 | withSub p f = ReaderT $ \e -> withSub p $ \s -> runReaderT (f s) e
73 | pushSub = mapReaderT . pushSub
74 |
--------------------------------------------------------------------------------
/src/Prompt/Iterator.hs:
--------------------------------------------------------------------------------
1 | module Prompt.Iterator where
2 |
3 | import Prompt.Class
4 | import Unaligned.Base
5 |
6 | data Iterator m a = Iterator a (m (Iterator m a)) | Done
7 |
8 | next :: Applicative m => Iterator m a -> View a (m (Iterator m a))
9 | next (Iterator a m) = a :&: m
10 | next Done = Empty
11 |
12 | iterator :: MonadPrompt m => ((a -> m ()) -> m ()) -> m (Iterator m a)
13 | iterator loop = reset $ \p -> Done <$ loop (\a -> shift p $ \k -> return $ Iterator a $ k ())
14 |
--------------------------------------------------------------------------------
/src/Prompt/Reflection.hs:
--------------------------------------------------------------------------------
1 | {-# language FlexibleInstances #-}
2 | {-# language GADTs #-}
3 | {-# language MultiParamTypeClasses #-}
4 | {-# language RankNTypes #-}
5 | {-# language ScopedTypeVariables #-}
6 | {-# language TypeFamilies #-}
7 | {-# language UndecidableInstances #-}
8 | {-# language LambdaCase #-}
9 |
10 | module Prompt.Reflection
11 | ( CC
12 | , runCC
13 | , runCC_
14 | , runPrompt
15 | ) where
16 |
17 | import Aligned.Base
18 | import Control.Arrow (Kleisli(..))
19 | import Control.Category
20 | import Control.Monad as Monad
21 | import Control.Monad.Cont.Class
22 | import Control.Monad.Fail as MonadFail
23 | import Control.Monad.IO.Class
24 | import Control.Monad.Primitive
25 | import Control.Monad.State.Class
26 | import Control.Monad.ST
27 | import Control.Monad.Trans.Class
28 | import Data.Type.Equality
29 | import Key
30 | import Prelude hiding (id,(.))
31 | import Prompt.Class
32 |
33 | -- Thoughts: if we always used prompts in ascending order, which I intend to, in practice, then we could use a
34 | -- type aligned fingertree, rather than Rev Cat in DC, giving slower appends, but giving log
35 | -- time indexing for splitting the continuation. This would require reintroducing the 'P' machinery
36 | -- for producing prompts with an Ord instance, rather than just offering equatable prompts.
37 | --
38 | -- An even fancier version would do something like the Log machinery, but type aligned. There
39 | -- we could delete knowably unnecessary prompts retroactively.
40 |
41 | type P m = Key m -- prompts
42 | type KC m = Rev Cat (Kleisli (CC m))
43 | type DC m = Rev Cat (Del m)
44 |
45 | data Del m a b = Del {-# unpack #-} !(P m b) !(KC m a b)
46 |
47 | data SC m a b where
48 | SC :: !(KC m w b) -> !(DC m a w) -> SC m a b
49 |
50 | data CC m a where
51 | WithSC
52 | :: !(KC m y a) -> !(DC m w y) -> {-# unpack #-} !(P m x) -> (forall z. KC m z x -> DC m w z -> CC m x) -> CC m a
53 | CC :: !(KC m y a) -> !(DC m w y) -> m w -> CC m a
54 |
55 | instance Category (SC m) where
56 | id = SC id id
57 | SC fk fd . SC sk sd = case unsnoc fd of
58 | Empty -> SC (fk . sk) sd
59 | t :&: Del p h -> SC fk (snoc t (Del p (h . sk)) . sd)
60 | {-# inline (.) #-}
61 |
62 | bindk :: KC m a b -> CC m a -> CC m b
63 | bindk fk = \case
64 | WithSC sk sd cp ck -> WithSC (fk . sk) sd cp ck
65 | CC sk sd cc -> CC (fk . sk) sd cc
66 | {-# inline bindk #-}
67 |
68 | bind :: KC m b c -> DC m a b -> CC m a -> CC m c
69 | bind fk fd = case unsnoc fd of
70 | Empty -> bindk fk
71 | t :&: Del p h -> \case
72 | WithSC sk sd cp ck -> WithSC fk (snoc t (Del p (h . sk)) . sd) cp ck
73 | CC sk sd cc -> CC fk (snoc t (Del p (h . sk)) . sd) cc
74 | {-# inline bind #-}
75 |
76 | instance Applicative m => Functor (CC m) where
77 | fmap = liftM
78 | {-# inlineable fmap #-}
79 |
80 | instance Applicative m => Applicative (CC m) where
81 | pure = CC id id . pure
82 | {-# inlineable pure #-}
83 | (<*>) = ap
84 | {-# inlineable (<*>) #-}
85 |
86 | instance Applicative m => Monad (CC m) where
87 | WithSC sk sd cp ck >>= f = WithSC (cons (Kleisli f) sk) sd cp ck
88 | CC sk sd p >>= f = CC (cons (Kleisli f) sk) sd p
89 | {-# inlineable (>>=) #-}
90 | -- fail = CC id id . Monad.fail
91 |
92 | instance MonadFail m => MonadFail (CC m) where
93 | fail = lift . MonadFail.fail
94 |
95 | instance MonadIO m => MonadIO (CC m) where
96 | liftIO = lift . liftIO
97 | {-# inlineable liftIO #-}
98 |
99 | instance PrimMonad m => PrimMonad (CC m) where
100 | type PrimState (CC m) = PrimState m
101 | primitive f = lift (primitive f)
102 | {-# inlineable primitive #-}
103 |
104 | instance MonadTrans CC where
105 | lift = CC id id
106 | {-# inlineable lift #-}
107 |
108 | instance PrimMonad m => MonadCont (CC m) where
109 | callCC = callcc
110 | {-# inline callCC #-}
111 |
112 | instance PrimMonad m => MonadPrompt (CC m) where
113 | type Prompt (CC m) = P m
114 | type Sub (CC m) = SC m
115 |
116 | newPrompt = lift newKey
117 | {-# inlineable newPrompt #-}
118 |
119 | pushPrompt p (WithSC sk sd cp ck) = WithSC id (cons (Del p sk) sd) cp ck
120 | pushPrompt p (CC sk sd cc) = CC id (cons (Del p sk) sd) cc
121 | {-# inlineable pushPrompt #-}
122 |
123 | withSub p f = WithSC id id p (\fk fd -> f (SC fk fd))
124 | {-# inlineable withSub #-}
125 |
126 | pushSub (SC k d) = bind k d
127 | {-# inlineable pushSub #-}
128 |
129 | instance MonadState s m => MonadState s (CC m) where
130 | get = lift get
131 | {-# inline get #-}
132 | put = lift . put
133 | {-# inline put #-}
134 | state = lift . state
135 | {-# inline state #-}
136 |
137 | runCC :: forall m a. Monad m => m a -> CC m a -> m a
138 | runCC e = goCC where
139 | goCC :: CC m a -> m a
140 | goCC (CC l d m) = m >>= goSC l d
141 | goCC (WithSC l d p f) = case split p d of
142 | Split r fk fd -> goCC $ bind l r (f fk fd)
143 | Unsplit -> e
144 |
145 | goSC :: Monad m => KC m x a -> DC m w x -> w -> m a
146 | goSC l d x = case unsnoc d of
147 | Empty -> case unsnoc l of
148 | Empty -> pure x
149 | t :&: Kleisli f -> goCC $ bindk t (f x)
150 | t :&: Del p h -> case unsnoc h of
151 | Empty -> goSC l t x
152 | ti :&: Kleisli f -> goCC $ bind l (t `snoc` Del p ti) (f x)
153 | {-# inlineable runCC #-}
154 |
155 | data Split m w a c where
156 | Split :: DC m w c -> KC m b w -> DC m a b -> Split m w a c
157 | Unsplit :: Split m w a b
158 |
159 | split :: forall m w a b. Key m w -> DC m a b -> Split m w a b
160 | split p = go where
161 | go :: DC m a' b -> Split m w a' b
162 | go q = case unsnoc q of
163 | Empty -> Unsplit
164 | t :&: Del p' sk -> case testEquality p p' of
165 | Just Refl -> Split t sk id
166 | Nothing -> case go t of
167 | Split sk' tl dl -> Split sk' tl (dl `snoc` Del p' sk)
168 | Unsplit -> Unsplit
169 | {-# inline split #-}
170 |
171 | runCC_ :: MonadFail m => CC m a -> m a
172 | runCC_ = runCC $ MonadFail.fail "missing prompt"
173 | {-# inlineable runCC_ #-}
174 |
175 | runPrompt :: (forall m. MonadPrompt m => m a) -> a
176 | runPrompt m = runST $ runCC (error "missing prompt") m
177 | {-# inline runPrompt #-}
178 |
--------------------------------------------------------------------------------
/src/Ref.hs:
--------------------------------------------------------------------------------
1 | {-# language ViewPatterns #-}
2 | {-# language ConstraintKinds #-}
3 | {-# language MultiParamTypeClasses #-}
4 | {-# language FunctionalDependencies #-}
5 | {-# language FlexibleInstances #-}
6 | {-# language FlexibleContexts #-}
7 | {-# language LambdaCase #-}
8 | {-# language ScopedTypeVariables #-}
9 | {-# language Trustworthy #-}
10 | {-# language TupleSections #-}
11 | {-# language TypeFamilies #-}
12 |
13 | module Ref
14 | ( memo
15 | , unwind
16 | , MonadRef, Ref, RefM, Reference(..), ReferenceM
17 | , newRef, newSelfRef
18 | , readRef, writeRef
19 | , updateRef, updateRef'
20 | , modifyRef, modifyRef'
21 | ) where
22 |
23 | import Control.Applicative
24 | import Control.Monad
25 | import Control.Monad.Primitive
26 | import Data.Primitive.MutVar
27 | import Data.Type.Coercion
28 | import Unsafe.Coerce
29 |
30 | -- | Explicitly share a computation. This allows us to branch /now/ but perform
31 | -- the computation /later/, only as we need the value.
32 | --
33 | -- This function obeys the following properties;
34 | --
35 | -- prop> memo (a `mplus` b) = memo a `mplus` memo b
36 | -- prop> memo mzero = return mzero
37 | -- prop> memo undefined = return undefined
38 | --
39 | -- Based on
40 | -- section 5.3.2
41 | memo :: MonadRef m => m a -> m (m a)
42 | memo ma = do
43 | r <- newRef Nothing -- Maybe a
44 | pure $ readRef r >>= \case
45 | Nothing -> do
46 | a <- ma
47 | a <$ writeRef r (Just a)
48 | Just a -> pure a
49 |
50 | -- | A 'MonadRef' is a 'Monad' which supports both references (via the 'PrimMonad' class) and
51 | -- backtracking (via the 'MonadPlus' class).
52 | type MonadRef m = (PrimMonad m, MonadPlus m)
53 |
54 | -- | Morally, this brackets the success continuation with an undo operation to roll back with upon
55 | -- taking the failure continuation. Users of this function should endeavour to guarantee that the
56 | -- second argument does in fact undo the effects of the first.
57 | unwind
58 | :: MonadRef m
59 | => (a -> (b, c))
60 | -> (c -> m d)
61 | -> m a
62 | -> m b
63 | unwind f mu na = na >>= \a -> case f a of
64 | (b, c) -> pure b <|> (mu c *> empty)
65 |
66 | -- | Safely-backtracked 'MutVar's. The write operations on a 'Ref' will be reverted
67 | -- upon a failure due to 'mzero'.
68 | newtype Ref s a = Ref { getRef :: MutVar s a }
69 | deriving Eq
70 |
71 | -- | Type synonym for 'Ref' parameterized by the monad rather than the state type.
72 | type RefM m = Ref (PrimState m)
73 |
74 | instance TestCoercion (Ref s) where
75 | testCoercion (Ref s :: Ref s a) (Ref t)
76 | | s == unsafeCoerce t = Just $ unsafeCoerce (Coercion :: Coercion a a)
77 | | otherwise = Nothing
78 | {-# inline testCoercion #-}
79 |
80 | -- | An instance of 'Reference' can be thought of as a wrapper around 'Ref'.
81 | class Reference s a t | t -> s a where
82 | reference :: t -> Ref s a
83 |
84 | -- | Type synonym for 'Reference' parameterized by the monad rather than the state type.
85 | type ReferenceM m = Reference (PrimState m)
86 |
87 | instance Reference s a (Ref s a) where
88 | reference = id
89 |
90 | -- | Create a new 'RefM' containing a given value.
91 | newRef :: PrimMonad m => a -> m (RefM m a)
92 | newRef = fmap Ref . newMutVar
93 |
94 | -- | Create a new 'RefM' from a function which is passed the new reference itself.
95 | -- This is useful for constructing cycles in a chain of references, for example.
96 | newSelfRef :: PrimMonad m => (RefM m a -> a) -> m (RefM m a)
97 | newSelfRef f = do
98 | x <- newMutVar undefined
99 | Ref x <$ writeMutVar x (f $ Ref x)
100 |
101 | -- | Read the value from a reference.
102 | readRef :: (PrimMonad m, ReferenceM m a t) => t -> m a
103 | readRef = readMutVar . getRef . reference
104 |
105 | -- | Write a value to a reference. This operation will 'unwind' upon a failure.
106 | writeRef :: (MonadRef m, ReferenceM m a t) => t -> a -> m ()
107 | writeRef (reference -> Ref r) a'
108 | = unwind ((),) (writeMutVar r) $ atomicModifyMutVar r (a',)
109 |
110 | -- | Modify and extract a value from a reference in-place. This operation will 'unwind' upon
111 | -- a failure.
112 | updateRef :: (MonadRef m, ReferenceM m a t) => t -> (a -> (b, a)) -> m b
113 | updateRef (reference -> Ref r) f = unwind id (writeMutVar r) $ atomicModifyMutVar r $ \a@(f->(b,a'))->(a',(b,a))
114 |
115 | -- | Strictly modify and extract a value from a reference in-place. This operation will 'unwind'
116 | -- upon a failure.
117 | updateRef' :: (MonadRef m, ReferenceM m a t) => t -> (a -> (b, a)) -> m b
118 | updateRef' (reference -> Ref r) f = unwind id (writeMutVar r) $ atomicModifyMutVar' r $ \a@(f->(b,a'))->(a',(b,a))
119 |
120 | -- | Modify a reference in-place. This operation will 'unwind' upon a failure.
121 | modifyRef :: (MonadRef m, ReferenceM m a t) => t -> (a -> a) -> m ()
122 | modifyRef (reference -> Ref r) f = unwind ((),) (writeMutVar r) $ atomicModifyMutVar r $ \a -> (f a,a)
123 |
124 | -- | Strictly modify a reference in-place. This operation will 'unwind' upon a failure.
125 | modifyRef' :: (MonadRef m, ReferenceM m a t) => t -> (a -> a) -> m ()
126 | modifyRef' (reference -> Ref r) f = unwind ((),) (writeMutVar r) $ atomicModifyMutVar' r $ \a -> (f a,a)
127 |
--------------------------------------------------------------------------------
/src/Relative/Base.hs:
--------------------------------------------------------------------------------
1 | {-# language PatternSynonyms #-}
2 |
3 | -- |
4 | -- Copyright : (c) Edward Kmett 2018
5 | -- License : BSD-2-Clause OR Apache-2.0
6 | -- Maintainer: Edward Kmett
7 | -- Stability : experimental
8 | -- Portability: non-portable
9 | --
10 | -- Catenable structures in the style of Purely Functional Data Structures
11 | -- by Chris Okasaki
12 | --
13 | -- These vesions can be relocated by an offset, using the same techniques as found
14 | --
15 |
16 | module Relative.Base
17 | ( View(..)
18 | , Cons(..)
19 | , Uncons(..)
20 | , Snoc(..)
21 | , Unsnoc(..)
22 | , Nil(..)
23 | , Singleton(..)
24 | , Q
25 | , Cat
26 | , Rev(..)
27 | , plus
28 | , pattern Nil
29 | , pattern Cons
30 | , pattern Snoc
31 | , Relative(..)
32 | , RelativeSemigroup
33 | , RelativeMonoid
34 | ) where
35 |
36 | import Relative.Internal
37 |
--------------------------------------------------------------------------------
/src/Relative/Internal.hs:
--------------------------------------------------------------------------------
1 | {-# language DeriveTraversable #-}
2 | {-# language TypeFamilies #-}
3 | {-# language PatternSynonyms #-}
4 | {-# language ViewPatterns #-}
5 | {-# language GeneralizedNewtypeDeriving #-}
6 |
7 | module Relative.Internal
8 | ( Unit(..)
9 | , Aff(..), utimes
10 | , Relative(..)
11 | , plus
12 | , RelativeSemigroup
13 | , RelativeMonoid
14 | , View(..) -- re-export
15 | , Rev(..) -- re-export
16 | , Cons(..)
17 | , Uncons(..)
18 | , Snoc(..)
19 | , Unsnoc(..)
20 | , Nil(..)
21 | , Singleton(..)
22 | , Q(..)
23 | , Cat(..)
24 | , pattern Nil
25 | , pattern Cons
26 | , pattern Snoc
27 | , foldMapQ
28 | , foldMapCat
29 | ) where
30 |
31 | import Data.Default
32 | import Data.Group
33 | import Data.Semigroup (Semigroup(stimes))
34 | import GHC.Exts as Exts hiding(One)
35 | import Unaligned.Internal (View(..), Rev(..))
36 |
37 | --------------------------------------------------------------------------------
38 | -- * Interface
39 | --------------------------------------------------------------------------------
40 |
41 | data Unit = One | NegativeOne
42 |
43 | instance Semigroup Unit where
44 | One <> x = x
45 | x <> One = x
46 | NegativeOne <> NegativeOne = One
47 |
48 | stimes _ One = One
49 | stimes e NegativeOne | even e = One
50 | | otherwise = NegativeOne
51 |
52 | instance Monoid Unit where
53 | mempty = One
54 |
55 | instance Group Unit where
56 | invert = id
57 | pow = flip stimes
58 |
59 | instance Abelian Unit
60 |
61 | data Aff = Aff !Unit !Integer
62 |
63 | -- group action
64 | utimes :: Unit -> Integer -> Integer
65 | utimes One = id
66 | utimes NegativeOne = negate
67 |
68 | -- a(bx+c)+d = (ab)x + ac+d
69 | instance Semigroup Aff where
70 | Aff a d <> Aff b c = Aff (a<>b) (utimes a c + d)
71 | stimes e (Aff One x) = Aff One (toInteger e * x)
72 | stimes e (Aff NegativeOne x) = Aff (stimes e NegativeOne) $ if even e then 0 else x
73 |
74 | instance Monoid Aff where
75 | mempty = Aff One 0
76 |
77 | -- y = ax+b
78 | -- y-b = ax
79 | -- (y-b)*a^-1 = x
80 | -- (a^-1)y-(a^-1)b = x
81 |
82 | instance Group Aff where
83 | invert (Aff a b) = Aff (invert a) (negate $ invert a `utimes` b)
84 | pow = flip stimes
85 |
86 | -- group action
87 | class Relative a where
88 | rel :: Aff -> a -> a
89 |
90 | instance Relative a => Relative (Maybe a) where
91 | rel = fmap . rel
92 |
93 | instance Relative Integer where
94 | rel (Aff a b) x = utimes a x + b
95 |
96 | plus :: Relative a => a -> Integer -> a
97 | plus r n = rel (Aff One n) r
98 |
99 | -- rel d (a <> b) = rel d a <> rel d b
100 | class (Relative a, Semigroup a) => RelativeSemigroup a where
101 |
102 | -- rel d mempty = mempty
103 | class (Relative a, RelativeSemigroup a, Monoid a) => RelativeMonoid a
104 |
105 | -- TODO: use Control.Lens.Cons?
106 | class Cons t where
107 | cons :: Relative a => a -> t a -> t a
108 |
109 | class Nil t where
110 | nil :: Relative a => t a
111 |
112 | class Uncons t where
113 | uncons :: Relative a => t a -> View a (t a)
114 |
115 | class Unsnoc t where
116 | unsnoc :: Relative a => t a -> View (t a) a
117 |
118 | class Snoc t where
119 | snoc :: Relative a => t a -> a -> t a
120 |
121 | class Singleton t where
122 | singleton :: Relative a => a -> t a
123 |
124 | pattern Nil :: (Nil t, Uncons t, Relative a) => t a
125 | pattern Nil <- (uncons -> Empty) where
126 | Nil = nil
127 |
128 | pattern Cons :: (Cons t, Uncons t, Relative a) => a -> t a -> t a
129 | pattern Cons a as <- (uncons -> a :&: as) where
130 | Cons a as = cons a as
131 |
132 | pattern Snoc :: (Snoc t, Unsnoc t, Relative a) => t a -> a -> t a
133 | pattern Snoc as a <- (unsnoc -> as :&: a) where
134 | Snoc as a = snoc as a
135 |
136 | --------------------------------------------------------------------------------
137 | -- Reversing containers
138 | --------------------------------------------------------------------------------
139 |
140 | instance Relative (f a) => Relative (Rev f a) where
141 | rel d (Rev as) = Rev (rel d as)
142 |
143 | instance Nil t => Nil (Rev t) where
144 | nil = Rev nil
145 |
146 | instance Cons t => Snoc (Rev t) where
147 | snoc (Rev t) f = Rev (cons f t)
148 |
149 | instance Uncons t => Unsnoc (Rev t) where
150 | unsnoc (Rev t) = case uncons t of
151 | l :&: r -> Rev r :&: l
152 | Empty -> Empty
153 |
154 | instance Unsnoc t => Uncons (Rev t) where
155 | uncons (Rev t) = case unsnoc t of
156 | l :&: r -> r :&: Rev l
157 | Empty -> Empty
158 |
159 | instance Snoc t => Cons (Rev t) where
160 | cons a (Rev b) = Rev (snoc b a)
161 |
162 | instance Singleton t => Singleton (Rev t) where
163 | singleton = Rev . singleton
164 |
165 | --------------------------------------------------------------------------------
166 | -- * Queues
167 | --------------------------------------------------------------------------------
168 |
169 | data Q a = Q {-# unpack #-} !Aff [a] (Rev [] a) [a]
170 |
171 | instance Relative (Q a) where
172 | rel (Aff One 0) xs = xs
173 | rel d (Q d' as bs cs) = Q (d <> d') as bs cs
174 |
175 | {-# complete Nil, Cons :: Q #-}
176 |
177 | instance Default (Q a) where
178 | def = Q mempty [] (Rev []) []
179 |
180 | instance (Show a, Relative a) => Show (Q a) where
181 | showsPrec d = showsPrec d . Exts.toList
182 |
183 | instance Relative a => IsList (Q a) where
184 | type Item (Q a) = a
185 | fromList = foldr cons nil
186 | fromListN _ = foldr cons nil
187 | toList = foldMapQ pure
188 |
189 | foldMapQ :: (Relative a, Monoid m) => (a -> m) -> Q a -> m
190 | foldMapQ f (Q d as bs _) = foldMap (f . rel d) as <> foldMap (f . rel d) bs
191 |
192 | instance Nil Q where
193 | nil = Q mempty [] (Rev []) []
194 |
195 | instance Cons Q where
196 | cons a (Q d f r s) = let a' = rel (invert d) a in Q d (a':f) r (a':s)
197 |
198 | instance Uncons Q where
199 | uncons (Q _ [] (Rev []) _) = Empty
200 | uncons (Q d (x:f) r s) = rel d x :&: exec d f r s
201 | uncons _ = error "Q.uncons: invariants violated"
202 |
203 | instance Singleton Q where
204 | singleton a = Q mempty [a] (Rev []) []
205 |
206 | instance Snoc Q where
207 | snoc (Q d f (Rev r) s) a = exec d f (Rev (rel (invert d) a : r)) s
208 |
209 | exec :: Aff -> [a] -> Rev [] a -> [a] -> Q a
210 | exec d xs ys (_:t) = Q d xs ys t
211 | exec d xs ys [] = Q d xs' (Rev []) xs' where xs' = rotate xs ys []
212 |
213 | rotate :: [a] -> Rev [] a -> [a] -> [a]
214 | rotate [] (Rev [y]) a = y:a
215 | rotate (x:xs) (Rev (y:ys)) a = x:rotate xs (Rev ys) (y:a)
216 | rotate _ _ _ = error "Q.rotate: invariant broken"
217 |
218 | --------------------------------------------------------------------------------
219 | -- * Catenable lists
220 | --------------------------------------------------------------------------------
221 |
222 | data Cat a = E | C a !(Q (Cat a))
223 |
224 | instance Relative a => Relative (Cat a) where
225 | rel _ E = E
226 | rel (Aff One 0) as = as
227 | rel d (C a as) = C (rel d a) (rel d as)
228 |
229 | instance Relative a => RelativeSemigroup (Cat a)
230 | instance Relative a => RelativeMonoid (Cat a)
231 |
232 | instance (Relative a, Show a) => Show (Cat a) where
233 | showsPrec d = showsPrec d . Exts.toList
234 |
235 | foldMapCat :: (Relative a, Monoid m) => (a -> m) -> Cat a -> m
236 | foldMapCat _ E = mempty
237 | foldMapCat f (C a as) = f a <> foldMapQ (foldMapCat f) as
238 |
239 | {-# complete Nil, C #-}
240 | {-# complete E, Cons #-}
241 | {-# complete Nil, Cons :: Cat #-}
242 |
243 | instance Default (Cat a) where
244 | def = E
245 |
246 | instance Relative a => Semigroup (Cat a) where
247 | E <> xs = xs
248 | xs <> E = xs
249 | C x xs <> ys = link x xs ys
250 |
251 | instance Relative a => Monoid (Cat a) where
252 | mempty = E
253 |
254 | instance Relative a => IsList (Cat a) where
255 | type Item (Cat a) = a
256 | fromList = foldr cons nil
257 | fromListN _ = foldr cons nil
258 | toList = foldMapCat pure
259 |
260 | link :: Relative a => a -> Q (Cat a) -> Cat a -> Cat a
261 | link x xs ys = C x (snoc xs ys)
262 |
263 | -- O(1+e) where e is the number of empty catenable lists in the Q
264 | linkAll :: Relative a => Q (Cat a) -> Cat a
265 | linkAll q = case uncons q of
266 | c@(C a t) :&: q' -> case uncons q' of
267 | Empty -> c
268 | _ -> link a t (linkAll q')
269 | E :&: q' -> linkAll q' -- recursive case in case of empty queues, unused
270 | Empty -> E
271 |
272 | instance Nil Cat where
273 | nil = E
274 |
275 | instance Uncons Cat where
276 | uncons E = Empty
277 | uncons (C a q) = a :&: linkAll q
278 |
279 | instance Cons Cat where
280 | cons a E = C a nil
281 | cons a ys = link a nil ys
282 |
283 | instance Singleton Cat where
284 | singleton a = C a nil
285 |
286 | instance Snoc Cat where
287 | snoc xs a = xs <> singleton a
288 |
--------------------------------------------------------------------------------
/src/SAT.hs:
--------------------------------------------------------------------------------
1 | {-# language PatternSynonyms #-}
2 | {-# language ImplicitParams #-}
3 | {-# language ConstraintKinds #-}
4 | {-# language ViewPatterns #-}
5 | {-# language GeneralizedNewtypeDeriving #-}
6 | {-# language PolyKinds #-}
7 | {-# language DataKinds #-}
8 | {-# language UnboxedTuples #-}
9 | module SAT where
10 |
11 | import Control.Monad
12 | import Control.Monad.Primitive
13 | import Data.Bits
14 | import Data.Primitive.Types
15 | import Data.Word
16 | import Vec
17 |
18 | newtype Val = Val Word8
19 | deriving (Eq,Ord,Prim)
20 |
21 | pattern FALSE, TRUE, UNKNOWN :: Val
22 | pattern FALSE = Val 0
23 | pattern TRUE = Val 1
24 | pattern UNKNOWN = Val 2
25 |
26 | known :: Val -> Maybe Bool
27 | known UNKNOWN = Nothing
28 | known FALSE = Just False
29 | known TRUE = Just True
30 |
31 | pattern Known :: Bool -> Val
32 | pattern Known v <- (known -> Just v) where
33 | Known b = Val (fromIntegral $ fromEnum b)
34 |
35 | {-# complete TRUE, FALSE, UNKNOWN #-}
36 | {-# complete Known, UNKNOWN #-}
37 |
38 | instance Show Val where
39 | show TRUE = "TRUE"
40 | show FALSE = "FALSE"
41 | show UNKNOWN = "UNKNOWN"
42 |
43 | newtype Lit s = LIT Int
44 | deriving (Eq,Ord,Prim)
45 |
46 | mklit :: Var s -> Bool -> Lit s
47 | mklit (Var i) False = LIT i
48 | mklit (Var i) True = LIT (complement i)
49 |
50 | decode :: Lit s -> (Var s, Bool)
51 | decode (LIT i)
52 | | i < 0 = (Var (complement i), True)
53 | | otherwise = (Var i, False)
54 |
55 | pattern Lit :: Var s -> Bool -> Lit s
56 | pattern Lit i s <- (decode -> (i, s)) where
57 | Lit i s = mklit i s
58 |
59 | data SAT s = SAT
60 | { _assignments :: Vector s Val
61 | , _trail :: Vector s (Lit s)
62 | }
63 |
64 | assignments :: GivenSAT s => Vector s Val
65 | assignments = _assignments ?sat
66 |
67 | trail :: GivenSAT s => Vector s (Lit s)
68 | trail = _trail ?sat
69 |
70 | type GivenSAT s = (?sat :: SAT s)
71 |
72 | newtype Var s = Var Int
73 |
74 | type MonadSAT m = (PrimMonad m, MonadPlus m, GivenSAT (PrimState m))
75 | type ReadMonadSAT m = (PrimMonad m, GivenSAT (PrimState m))
76 |
77 | newVar :: MonadSAT m => m (Var (PrimState m))
78 | newVar = Var <$> addBackVector UNKNOWN assignments
79 | {-# inline newVar #-}
80 |
81 | readVar :: ReadMonadSAT m => Var (PrimState m) -> m Val
82 | readVar (Var i) = readVector assignments i
83 | {-# inline readVar #-}
84 |
85 | -- blow up the universe on contradiction here
86 | writeVar :: MonadSAT m => Var (PrimState m) -> Bool -> Bool -> m ()
87 | writeVar v@(Var i) b entrail = do
88 | let new = Known b
89 | old <- writeBackVector assignments i new
90 | guard (old == UNKNOWN || old == new)
91 | when (old == UNKNOWN && entrail) $
92 | () <$ addBackVector (Lit v b) trail
93 | {-# inline writeVar #-}
94 |
--------------------------------------------------------------------------------
/src/Sharing.hs:
--------------------------------------------------------------------------------
1 | {-# language RankNTypes #-}
2 | {-# language TypeOperators #-}
3 | {-# language UndecidableInstances #-}
4 | {-# language DefaultSignatures #-}
5 | {-# language FlexibleContexts #-}
6 |
7 | -- |
8 | -- Copyright : (c) Edward Kmett 2018
9 | -- License : BSD-2-Clause OR Apache-2.0
10 | -- Maintainer: Edward Kmett
11 | -- Stability : experimental
12 | -- Portability: non-portable
13 | --
14 | -- Based on
15 |
16 | module Sharing where
17 |
18 | import GHC.Generics
19 | import Ref
20 |
21 | class GShareable f where
22 | gsharing
23 | :: MonadRef m
24 | => (forall b. Shareable b => m b -> m (m b))
25 | -> f a -> m (f a)
26 |
27 | instance Shareable c => GShareable (K1 i c) where
28 | gsharing f (K1 m) = K1 <$> sharing f m
29 |
30 | instance GShareable f => GShareable (M1 i c f) where
31 | gsharing f (M1 m) = M1 <$> gsharing f m
32 |
33 | instance (GShareable f, GShareable g) => GShareable (f :*: g) where
34 | gsharing f (x :*: y) = (:*:) <$> gsharing f x <*> gsharing f y
35 |
36 | instance (GShareable f, GShareable g) => GShareable (f :+: g) where
37 | gsharing f (L1 x) = L1 <$> gsharing f x
38 | gsharing f (R1 x) = R1 <$> gsharing f x
39 |
40 | instance (Shareable1 f, GShareable g) => GShareable (f :.: g) where
41 | gsharing f (Comp1 x) = Comp1 <$> sharing1 gsharing f x
42 |
43 | class Shareable a where
44 | sharing
45 | :: MonadRef m
46 | => (forall b. Shareable b => m b -> m (m b))
47 | -> a -> m a
48 | default sharing
49 | :: (Generic a, GShareable (Rep a), MonadRef m)
50 | => (forall b. Shareable b => m b -> m (m b))
51 | -> a -> m a
52 | sharing f m = to <$> gsharing f (from m)
53 |
54 | instance Shareable () where sharing _ = return
55 | instance Shareable Char where sharing _ = return
56 | instance Shareable Bool where sharing _ = return
57 | instance Shareable Int where sharing _ = return
58 | instance (Shareable a, Shareable b) => Shareable (a, b)
59 |
60 | class Shareable1 f where
61 | sharing1
62 | :: MonadRef m
63 | => ((forall b. Shareable b => m b -> m (m b)) -> a -> m a)
64 | -> (forall b. Shareable b => m b -> m (m b)) -> f a -> m (f a)
65 | default sharing1
66 | :: (Generic1 f, Shareable1 (Rep1 f), MonadRef m)
67 | => ((forall b. Shareable b => m b -> m (m b)) -> a -> m a)
68 | -> (forall b. Shareable b => m b -> m (m b)) -> f a -> m (f a)
69 | sharing1 g f m = to1 <$> sharing1 g f (from1 m)
70 |
71 | instance Shareable c => Shareable1 (K1 i c) where
72 | sharing1 _ f (K1 m) = K1 <$> sharing f m
73 |
74 | instance Shareable1 f => Shareable1 (M1 i c f) where
75 | sharing1 g f (M1 m) = M1 <$> sharing1 g f m
76 |
77 | instance (Shareable1 f, Shareable1 g) => Shareable1 (f :*: g) where
78 | sharing1 g f (x :*: y) = (:*:) <$> sharing1 g f x <*> sharing1 g f y
79 |
80 | instance (Shareable1 f, Shareable1 g) => Shareable1 (f :+: g) where
81 | sharing1 g f (L1 x) = L1 <$> sharing1 g f x
82 | sharing1 g f (R1 x) = R1 <$> sharing1 g f x
83 |
84 | instance (Shareable1 f, Shareable1 g) => Shareable1 (f :.: g) where
85 | sharing1 g f (Comp1 x) = Comp1 <$> sharing1 (sharing1 g) f x
86 |
87 | eval :: (MonadRef m, Shareable a) => a -> m a
88 | eval = sharing $ \a -> a >>= eval >>= return . return
89 |
90 | share :: (MonadRef m, Shareable a) => m a -> m (m a)
91 | share m = memo $ m >>= sharing share
92 |
--------------------------------------------------------------------------------
/src/Signal.hs:
--------------------------------------------------------------------------------
1 | {-# language AllowAmbiguousTypes #-}
2 | {-# language DefaultSignatures #-}
3 | {-# language FlexibleContexts #-}
4 | {-# language FlexibleInstances #-}
5 | {-# language ViewPatterns #-}
6 | {-# language UndecidableInstances #-}
7 | {-# language FunctionalDependencies #-}
8 | {-# language RankNTypes #-}
9 | {-# language TupleSections #-}
10 | {-# language GADTs #-}
11 | {-# language BangPatterns #-}
12 | {-# language MultiWayIf #-}
13 | {-# language LambdaCase #-}
14 | {-# language MultiParamTypeClasses #-}
15 | {-# language ScopedTypeVariables #-}
16 | {-# language TemplateHaskell #-}
17 | {-# language TypeApplications #-}
18 | {-# language TypeFamilies #-}
19 | {-# language TypeOperators #-}
20 | {-# language GeneralizedNewtypeDeriving #-}
21 | {-# language RoleAnnotations #-}
22 | {-# language ConstraintKinds #-}
23 |
24 | -- |
25 | -- Copyright : (c) Edward Kmett 2018-2019
26 | -- License : BSD-2-Clause OR Apache-2.0
27 | -- Maintainer: Edward Kmett
28 | -- Stability : experimental
29 | -- Portability: non-portable
30 |
31 | module Signal
32 | ( Signal(..)
33 | , MonadSignal
34 | , newSignal
35 | , newSignal_
36 | , fire, scope
37 | , Signals
38 | , HasSignals(..)
39 | , ground
40 | , grounding
41 | , propagate
42 | , multiplicity -- report an externally indistinguishable result multiple times
43 | , infiniteMultiplicity
44 | , currentMultiplicity
45 | -- * implementation
46 | , HasSignalEnv(signalEnv)
47 | , SignalEnv
48 | , newSignalEnv
49 | ) where
50 |
51 | import Control.Monad (unless, guard)
52 | import Control.Monad.Primitive
53 | import Control.Monad.Reader.Class
54 | import Control.Lens
55 | import Data.Foldable as Foldable
56 | import Data.Function (on)
57 | import Data.Hashable
58 | import Data.HashSet as HashSet -- HashSet?
59 | import Data.Kind
60 | import Data.Proxy
61 | import Ref
62 | import Unique
63 |
64 | type Signals m = HashSet (Signal m)
65 | type Propagators m = HashSet (Propagator m)
66 |
67 | data Propagator m = Propagator
68 | { propagatorAction :: m () -- TODO: return if we should self-delete, e.g. if all inputs are covered by contradiction
69 | , _propSources, _propTargets :: !(Signals m) -- TODO: added for future topological analysis
70 | , propagatorId :: {-# unpack #-} !(UniqueM m)
71 | }
72 |
73 | instance Eq (Propagator m) where
74 | (==) = (==) `on` propagatorId
75 |
76 | instance Hashable (Propagator m) where
77 | hash = hash . propagatorId
78 | hashWithSalt d = hashWithSalt d . propagatorId
79 |
80 | class HasSignals m t | t -> m where
81 | signals :: t -> Signals m
82 |
83 | instance (m ~ n) => HasSignals m (Proxy n) where
84 | signals = mempty
85 |
86 | instance (m ~ n) => HasSignals m (Signals n) where
87 | signals = id
88 |
89 | data Signal (m :: Type -> Type) = Signal
90 | { signalId :: UniqueM m
91 | , signalReference :: RefM m (Propagators m)
92 | }
93 |
94 | instance Eq (Signal m) where
95 | (==) = (==) `on` signalId
96 |
97 | instance Hashable (Signal m) where
98 | hash = hash . signalId
99 | hashWithSalt d = hashWithSalt d . signalId
100 |
101 | data SignalEnv m = SignalEnv
102 | { _signalEnvSafety :: !Bool
103 | , _signalEnvPending :: !(RefM m (Propagators m)) -- pending propagators
104 | , _signalEnvGround :: !(RefM m (m ())) -- final grounding action
105 | , _signalMultiplicity :: !(RefM m Integer) -- count of occurrences of a given solution
106 | }
107 |
108 | makeClassy ''SignalEnv
109 |
110 | type MonadSignal e m = (MonadRef m, MonadReader e m, HasSignalEnv e m)
111 |
112 | newSignalEnv :: (PrimMonad n, Monad m, PrimState m ~ PrimState n) => n (SignalEnv m)
113 | newSignalEnv = SignalEnv False <$> newRef mempty <*> newRef (pure ()) <*> newRef 1
114 |
115 | instance (s ~ PrimState m) => Reference s (Propagators m) (Signal m) where
116 | reference = signalReference
117 |
118 | instance HasSignals m (Signal m) where
119 | signals = HashSet.singleton
120 |
121 | newSignal_ :: PrimMonad m => m (Signal m)
122 | newSignal_ = Signal <$> newUnique <*> newRef mempty
123 |
124 | infiniteMultiplicity :: MonadSignal e m => m ()
125 | infiniteMultiplicity = do
126 | mult <- view signalMultiplicity
127 | writeRef mult 0 -- abuse 0 * anything = 0 = anything * 0 to use 0 as infinity
128 |
129 | multiplicity :: MonadSignal e m => Integer -> m ()
130 | multiplicity n = do
131 | guard (n /= 0) -- blow up now, we're _actually_ repeating 0 times
132 | mult <- view signalMultiplicity
133 | modifyRef mult (*n)
134 |
135 | -- returns the current multiplicity as Nothing if the current solution is repeated an infinite number of times
136 | -- and Just n if the current solution is going to be repeated n times.
137 | currentMultiplicity :: MonadSignal e m => m (Maybe Integer)
138 | currentMultiplicity = do
139 | mult <- view signalMultiplicity
140 | n <- readRef mult
141 | pure $ n <$ guard (n /= 0)
142 |
143 | grounding :: MonadSignal e m => m () -> m ()
144 | grounding strat = do
145 | g <- view signalEnvGround
146 | modifyRef' g (*> strat)
147 |
148 | newSignal :: MonadSignal e m => (Signal m -> m ()) -> m (Signal m)
149 | newSignal strat = do
150 | s <- newSignal_
151 | s <$ grounding (strat s)
152 |
153 | scope :: MonadSignal e m => m a -> m a
154 | scope m = do
155 | a <- local (signalEnvSafety .~ True) m
156 | SignalEnv s p _ _ <- view signalEnv
157 | a <$ unless s (go p)
158 | where
159 | go p = do
160 | hs <- updateRef p (,mempty)
161 | for_ hs propagatorAction
162 | unless (HashSet.null hs) (go p)
163 |
164 | fire :: (MonadSignal e m, HasSignals m v) => v -> m ()
165 | fire v = scope $ do
166 | p <- view signalEnvPending
167 | for_ (signals v) $ \i -> do
168 | ps <- readRef i
169 | unless (HashSet.null ps) $ modifyRef' p (<> ps) -- we could do this with a single write at the end of the scope
170 |
171 | propagate
172 | :: (MonadSignal e m, HasSignals m x, HasSignals m y)
173 | => x -- ^ sources
174 | -> y -- ^ targets
175 | -> m () -- ^ propagator action
176 | -> m ()
177 | propagate (signals -> cs) (signals -> ds) act = do
178 | p <- Propagator act cs ds <$> newUnique
179 | for_ (HashSet.toList cs) $ \c -> modifyRef' c (HashSet.insert p)
180 |
181 | ground :: MonadSignal e m => m ()
182 | ground = do
183 | g <- view signalEnvGround
184 | m <- readRef g
185 | m
186 |
--------------------------------------------------------------------------------
/src/Sink.hs:
--------------------------------------------------------------------------------
1 | {-# language FlexibleInstances #-}
2 | {-# language MultiParamTypeClasses #-}
3 |
4 | module Sink where
5 |
6 | import Control.Monad.Reader.Class
7 | import Data.Functor.Contravariant
8 | import Data.Functor.Contravariant.Divisible
9 | import Data.Void
10 | import Ref
11 | import Signal
12 |
13 | data Sink m a = Sink
14 | { _cellIds :: !(Signals m)
15 | , _cellUpdate :: a -> m () -- update
16 | }
17 |
18 | instance Contravariant (Sink m) where
19 | contramap f (Sink m g) = Sink m (g . f)
20 |
21 | instance Applicative m => Divisible (Sink m) where
22 | conquer = Sink mempty $ \_ -> pure ()
23 | divide f (Sink s g) (Sink t h) = Sink (s <> t) $ \a -> case f a of
24 | (b, c) -> g b *> h c
25 |
26 | instance Applicative m => Decidable (Sink m) where
27 | lose f = Sink mempty (absurd . f)
28 | choose f (Sink s g) (Sink t h) = Sink (s <> t) $ \a -> case f a of
29 | Left b -> g b
30 | Right c -> h c
31 |
32 | instance HasSignals m (Sink m a) where
33 | signals (Sink s _) = s
34 |
35 | writeSink :: (MonadRef m, MonadReader e m, HasSignalEnv e m) => Sink m a -> a -> m ()
36 | writeSink (Sink _ u) a = scope $ u a
37 |
--------------------------------------------------------------------------------
/src/Tactic.hs:
--------------------------------------------------------------------------------
1 | {-# language RankNTypes #-}
2 | {-# language DeriveTraversable #-}
3 |
4 | -- |
5 | -- Copyright : (c) Edward Kmett 2018
6 | -- License : BSD-2-Clause OR Apache-2.0
7 | -- Maintainer: Edward Kmett
8 | -- Stability : experimental
9 | -- Portability: non-portable
10 | --
11 | -- A toy tactic language
12 | --
13 | -- e.g. @Tactic ([Formula],Formula) FD@
14 |
15 | module Tactic where
16 |
17 | import Data.Bifoldable
18 | import Data.Bifunctor
19 | import Data.Bitraversable
20 | import Control.Applicative
21 | import Control.Monad (ap, MonadPlus(..))
22 |
23 | data T s a = Proof a | Goal s | Failed
24 | deriving (Functor,Foldable,Traversable)
25 |
26 | instance Bifunctor T where bimap = bimapDefault
27 | instance Bifoldable T where bifoldMap = bifoldMapDefault
28 | instance Bitraversable T where
29 | bitraverse _ g (Proof b) = Proof <$> g b
30 | bitraverse f _ (Goal a) = Goal <$> f a
31 | bitraverse _ _ Failed = pure Failed
32 |
33 | -- uncps
34 | lower :: Applicative m => Tactic g m a -> g -> m (T g a)
35 | lower m = runTactic m (pure . Proof) (pure Failed) (pure . Goal)
36 |
37 |
38 | -- | Based on
39 | --
40 | newtype Tactic g m a = Tactic
41 | { runTactic :: forall r.
42 | (a -> m r) -> m r -> (g -> m r) -> g -> m r
43 | } deriving Functor
44 |
45 | instance Applicative (Tactic g m) where
46 | pure a = Tactic $ \kp _ _ _ -> kp a
47 | (<*>) = ap
48 |
49 | instance Monad (Tactic g m) where
50 | m >>= f = Tactic $ \kp kf ks g ->
51 | runTactic m (\a -> runTactic (f a) kp kf ks g) kf ks g
52 |
53 | fby :: Tactic g m a -> Tactic g m a -> Tactic g m a
54 | fby m n = Tactic $ \kp kf kc ->
55 | runTactic m kp kf (runTactic n kp kf kc)
56 |
57 | instance Alternative (Tactic g m) where
58 | m <|> n = Tactic $ \kp kf kc g ->
59 | runTactic m kp (runTactic n kp kf kc g) kc g
60 | empty = Tactic $ \_ kf _ _ -> kf
61 |
62 | instance MonadPlus (Tactic g m) where
63 | mplus = (<|>)
64 | mzero = empty
65 |
66 | repeatedly :: Tactic g m a -> Tactic g m a
67 | repeatedly t = t `fby` repeatedly t
68 |
--------------------------------------------------------------------------------
/src/Unaligned/Base.hs:
--------------------------------------------------------------------------------
1 | {-# language PatternSynonyms #-}
2 |
3 | -- |
4 | -- Copyright : (c) Edward Kmett 2018
5 | -- License : BSD-2-Clause OR Apache-2.0
6 | -- Maintainer: Edward Kmett
7 | -- Stability : experimental
8 | -- Portability: non-portable
9 | --
10 | -- Catenable structures in the style of Purely Functional Data Structures
11 | -- by Chris Okasaki
12 |
13 | module Unaligned.Base
14 | ( View(..)
15 | , Cons(..)
16 | , Uncons(..)
17 | , Snoc(..)
18 | , Unsnoc(..)
19 | , Nil(..)
20 | , Singleton(..)
21 | , Q
22 | , Cat
23 | , Rev(..)
24 | , pattern Nil
25 | , pattern Cons
26 | , pattern Snoc
27 | ) where
28 |
29 | import Unaligned.Internal
30 |
--------------------------------------------------------------------------------
/src/Unaligned/Internal.hs:
--------------------------------------------------------------------------------
1 | {-# language DeriveTraversable #-}
2 | {-# language TypeFamilies #-}
3 | {-# language PatternSynonyms #-}
4 | {-# language ViewPatterns #-}
5 |
6 | module Unaligned.Internal
7 | ( View(..)
8 | , Cons(..)
9 | , Uncons(..)
10 | , Snoc(..)
11 | , Unsnoc(..)
12 | , Nil(..)
13 | , Singleton(..)
14 | , Q(..)
15 | , Cat(..)
16 | , Rev(..)
17 | , pattern Nil
18 | , pattern Cons
19 | , pattern Snoc
20 | -- internal
21 | , link
22 | , linkAll
23 | ) where
24 |
25 | import Control.Applicative.Backwards
26 | import Data.Bifunctor
27 | import Data.Bifoldable
28 | import Data.Bitraversable
29 | import Data.Default
30 | import Data.Foldable as Foldable
31 | import Data.Semigroup (Dual(..))
32 | import GHC.Exts
33 |
34 | --------------------------------------------------------------------------------
35 | -- * Interface
36 | --------------------------------------------------------------------------------
37 |
38 | data View a b = Empty | a :&: b
39 | deriving (Eq, Show, Functor, Foldable, Traversable)
40 |
41 | instance Default (View a b) where
42 | def = Empty
43 |
44 | instance Bifunctor View where
45 | bimap _ _ Empty = Empty
46 | bimap f g (a :&: b) = f a :&: g b
47 |
48 | instance Bifoldable View where
49 | bifoldMap _ _ Empty = mempty
50 | bifoldMap f g (a :&: b) = f a <> g b
51 |
52 | instance Bitraversable View where
53 | bitraverse _ _ Empty = pure Empty
54 | bitraverse f g (a :&: b) = (:&:) <$> f a <*> g b
55 |
56 | -- TODO: use Control.Lens.Cons?
57 | class Cons t where
58 | cons :: a -> t a -> t a
59 |
60 | class Nil t where
61 | nil :: t a
62 |
63 | class Uncons t where
64 | uncons :: t a -> View a (t a)
65 |
66 | class Unsnoc t where
67 | unsnoc :: t a -> View (t a) a
68 |
69 | class Snoc t where
70 | snoc :: t a -> a -> t a
71 |
72 | class Singleton t where
73 | singleton :: a -> t a
74 |
75 | pattern Nil :: (Nil t, Uncons t) => t a
76 | pattern Nil <- (uncons -> Empty) where
77 | Nil = nil
78 |
79 | pattern Cons :: (Cons t, Uncons t) => a -> t a -> t a
80 | pattern Cons a as <- (uncons -> a :&: as) where
81 | Cons a as = cons a as
82 |
83 | pattern Snoc :: (Snoc t, Unsnoc t) => t a -> a -> t a
84 | pattern Snoc as a <- (unsnoc -> as :&: a) where
85 | Snoc as a = snoc as a
86 |
87 | --------------------------------------------------------------------------------
88 | -- Reversing containers
89 | --------------------------------------------------------------------------------
90 |
91 | newtype Rev f a = Rev { runRev :: f a }
92 | deriving (Eq, Show, Functor)
93 |
94 | instance Default (f a) => Default (Rev f a) where
95 | def = Rev def
96 |
97 | instance Foldable f => Foldable (Rev f) where
98 | foldMap f = getDual . foldMap (Dual . f) . runRev
99 |
100 | instance Traversable f => Traversable (Rev f) where
101 | traverse f (Rev t) = fmap Rev . forwards $ traverse (Backwards . f) t
102 |
103 | instance Semigroup (f a) => Semigroup (Rev f a) where
104 | Rev a <> Rev b = Rev (b <> a)
105 |
106 | instance Monoid (f a) => Monoid (Rev f a) where
107 | mempty = Rev mempty
108 |
109 | instance Nil t => Nil (Rev t) where
110 | nil = Rev nil
111 |
112 | instance Cons t => Snoc (Rev t) where
113 | snoc (Rev t) f = Rev (cons f t)
114 |
115 | instance Uncons t => Unsnoc (Rev t) where
116 | unsnoc (Rev t) = case uncons t of
117 | l :&: r -> Rev r :&: l
118 | Empty -> Empty
119 |
120 | instance Unsnoc t => Uncons (Rev t) where
121 | uncons (Rev t) = case unsnoc t of
122 | l :&: r -> r :&: Rev l
123 | Empty -> Empty
124 |
125 | instance Snoc t => Cons (Rev t) where
126 | cons a (Rev b) = Rev (snoc b a)
127 |
128 | instance Singleton t => Singleton (Rev t) where
129 | singleton = Rev . singleton
130 |
131 | --------------------------------------------------------------------------------
132 | -- * Lists
133 | --------------------------------------------------------------------------------
134 |
135 | {-# complete Nil, Cons :: [] #-}
136 |
137 | instance Nil [] where
138 | nil = []
139 |
140 | instance Cons [] where
141 | cons = (:)
142 |
143 | instance Uncons [] where
144 | uncons [] = Empty
145 | uncons (a:b) = a :&: b
146 |
147 | instance Singleton [] where
148 | singleton a = [a]
149 |
150 | --------------------------------------------------------------------------------
151 | -- * Queues
152 | --------------------------------------------------------------------------------
153 |
154 | data Q a = Q [a] (Rev [] a) [a]
155 | deriving Eq
156 |
157 | {-# complete Nil, Cons :: Q #-}
158 |
159 | instance Default (Q a) where
160 | def = nil
161 |
162 | instance Show a => Show (Q a) where
163 | showsPrec d = showsPrec d . Foldable.toList
164 |
165 | instance IsList (Q a) where
166 | type Item (Q a) = a
167 | fromList = foldr cons nil
168 | fromListN _ = foldr cons nil
169 | toList = Foldable.toList
170 |
171 | instance Functor Q where
172 | fmap f (Q as bs cs) = Q (fmap f as) (fmap f bs) (undefined <$ cs)
173 |
174 | instance Foldable Q where
175 | foldMap f (Q as bs _) = foldMap f as <> foldMap f bs
176 |
177 | instance Traversable Q where
178 | traverse f (Q as bs cs) = (\as' bs' -> Q as' bs' $ undefined <$ cs)
179 | <$> traverse f as <*> traverse f bs
180 |
181 | instance Nil Q where
182 | nil = Q nil nil nil
183 |
184 | instance Cons Q where
185 | cons a (Q f r s) = Q (a:f) r (a:s)
186 |
187 | instance Uncons Q where
188 | uncons (Q [] (Rev []) _) = Empty
189 | uncons (Q (x:f) r s) = x :&: exec f r s
190 | uncons _ = error "Q.uncons: invariants violated"
191 |
192 | instance Singleton Q where
193 | singleton a = Q [a] nil [a]
194 |
195 | instance Snoc Q where
196 | snoc (Q f r s) a = exec f (snoc r a) s
197 |
198 | exec :: [a] -> Rev [] a -> [a] -> Q a
199 | exec xs ys (_:t) = Q xs ys t
200 | exec xs ys [] = Q xs' (Rev []) xs' where xs' = rotate xs ys nil
201 |
202 | rotate :: [a] -> Rev [] a -> [a] -> [a]
203 | rotate [] (Rev [y]) a = y:a
204 | rotate (x:xs) (Rev (y:ys)) a = x:rotate xs (Rev ys) (y:a)
205 | rotate _ _ _ = error "Q.rotate: invariant broken"
206 |
207 | --------------------------------------------------------------------------------
208 | -- * Catenable lists
209 | --------------------------------------------------------------------------------
210 |
211 | data Cat a = E | C a !(Q (Cat a))
212 | deriving (Eq, Functor, Foldable, Traversable)
213 |
214 | instance Show a => Show (Cat a) where
215 | showsPrec d = showsPrec d . Foldable.toList
216 |
217 | {-# complete Nil, C #-}
218 | {-# complete E, Cons #-}
219 | {-# complete Nil, Cons :: Cat #-}
220 |
221 | instance Default (Cat a) where
222 | def = E
223 |
224 | instance Semigroup (Cat a) where
225 | E <> xs = xs
226 | xs <> E = xs
227 | C x xs <> ys = link x xs ys
228 |
229 | instance Monoid (Cat a) where
230 | mempty = E
231 |
232 | instance IsList (Cat a) where
233 | type Item (Cat a) = a
234 | fromList = foldr cons nil
235 | fromListN _ = foldr cons nil
236 | toList = Foldable.toList
237 |
238 | link :: a -> Q (Cat a) -> Cat a -> Cat a
239 | link x xs ys = C x (snoc xs ys)
240 |
241 | -- O(1+e) where e is the number of empty catenable lists in the Q
242 | linkAll :: Q (Cat a) -> Cat a
243 | linkAll q = case uncons q of
244 | c@(C a t) :&: q' -> case uncons q' of
245 | Empty -> c
246 | _ -> link a t (linkAll q')
247 | E :&: q' -> linkAll q' -- recursive case in case of empty queues, unused
248 | Empty -> E
249 |
250 | instance Nil Cat where
251 | nil = E
252 |
253 | instance Uncons Cat where
254 | uncons E = Empty
255 | uncons (C a q) = a :&: linkAll q
256 |
257 | instance Cons Cat where
258 | cons a E = C a nil
259 | cons a ys = link a nil ys
260 |
261 | instance Singleton Cat where
262 | singleton a = C a nil
263 |
264 | instance Snoc Cat where
265 | snoc xs a = xs <> singleton a
266 |
--------------------------------------------------------------------------------
/src/Unification/Class.hs:
--------------------------------------------------------------------------------
1 | {-# language DefaultSignatures #-}
2 | {-# language TypeOperators #-}
3 | {-# language EmptyCase #-}
4 | {-# language FlexibleInstances #-}
5 | {-# language FlexibleContexts #-}
6 | {-# language BangPatterns #-}
7 | {-# language RankNTypes #-}
8 |
9 | -- |
10 | -- Copyright : (c) Edward Kmett 2018
11 | -- License : BSD-2-Clause OR Apache-2.0
12 | -- Maintainer: Edward Kmett
13 | -- Stability : experimental
14 | -- Portability: non-portable
15 |
16 | module Unification.Class
17 | ( Unified(..)
18 | , GUnified
19 | ) where
20 |
21 | -- import Aligned.Freer
22 | import Control.Applicative
23 | import GHC.Generics
24 | import Data.Functor.Sum
25 | import Data.Functor.Identity
26 | import Data.Functor.Product
27 | import Data.Functor.Compose
28 | import Data.Proxy
29 |
30 | class Traversable f => Unified f where
31 | merge :: Alternative t => (a -> b -> t c) -> f a -> f b -> t (f c)
32 | default merge :: (Generic1 f, GUnified (Rep1 f), Alternative t)
33 | => (a -> b -> t c) -> f a -> f b -> t (f c)
34 | merge f l r = to1 <$> gmerge f (from1 l) (from1 r)
35 |
36 | instance (Unified f, Unified g) => Unified (Sum f g)
37 | instance (Unified f, Unified g) => Unified (Compose f g) where
38 | merge f (Compose l) (Compose r) = Compose <$> merge (merge f) l r
39 |
40 | instance (Unified f, Unified g) => Unified (Product f g)
41 | instance Unified []
42 | instance Unified Maybe
43 | instance Unified Proxy
44 | instance Eq e => Unified (Const e)
45 | instance Eq e => Unified ((,) e)
46 | instance Unified Identity
47 |
48 | class GUnified f where
49 | gmerge :: Alternative t => (a -> b -> t c) -> f a -> f b -> t (f c)
50 |
51 | instance GUnified p => GUnified (M1 i c p) where
52 | gmerge f (M1 a) (M1 b) = M1 <$> gmerge f a b
53 |
54 | instance Eq c => GUnified (K1 i c) where
55 | gmerge _ (K1 a) (K1 b)
56 | | a == b = pure $ K1 a
57 | | otherwise = empty
58 |
59 | instance GUnified U1 where
60 | gmerge _ _ _ = pure U1
61 |
62 | instance GUnified V1 where
63 | gmerge _ !v _ = case v of {}
64 |
65 | instance (GUnified f, GUnified g) => GUnified (f :*: g) where
66 | gmerge f (a :*: b) (c :*: d) = (:*:) <$> gmerge f a c <*> gmerge f b d
67 |
68 | instance (GUnified f, GUnified g) => GUnified (f :+: g) where
69 | gmerge f (L1 l) (L1 r) = L1 <$> gmerge f l r
70 | gmerge f (R1 l) (R1 r) = R1 <$> gmerge f l r
71 | gmerge _ _ _ = empty
72 |
73 | instance (Unified f, GUnified g) => GUnified (f :.: g) where
74 | gmerge f (Comp1 l) (Comp1 r) = Comp1 <$> merge (gmerge f) l r
75 |
76 | instance GUnified Par1 where
77 | gmerge f (Par1 a) (Par1 b) = Par1 <$> f a b
78 |
79 | instance Unified f => GUnified (Rec1 f) where
80 | gmerge f (Rec1 a) (Rec1 b) = Rec1 <$> merge f a b
81 |
--------------------------------------------------------------------------------
/src/Unique.hs:
--------------------------------------------------------------------------------
1 | {-# language MagicHash #-}
2 | {-# language UnboxedTuples #-}
3 |
4 | -- |
5 | -- Copyright : (c) Edward Kmett 2018
6 | -- License : BSD-2-Clause OR Apache-2.0
7 | -- Maintainer: Edward Kmett
8 | -- Stability : experimental
9 | -- Portability: non-portable
10 | --
11 | -- Fast unique symbols
12 | module Unique
13 | ( Unique, UniqueM
14 | , newUnique
15 | ) where
16 |
17 | import Control.Monad.Primitive
18 | import Data.Hashable
19 | import GHC.Exts
20 | import GHC.Types
21 |
22 | data Unique s = Unique !Int (MutableByteArray# s)
23 | type UniqueM m = Unique (PrimState m)
24 |
25 | instance Eq (Unique s) where
26 | Unique _ p == Unique _ q = isTrue# (GHC.Exts.sameMutableByteArray# p q)
27 |
28 | instance Hashable (Unique s) where
29 | hash (Unique i _) = i
30 | hashWithSalt d (Unique i _) = hashWithSalt d i
31 |
32 | newUnique :: PrimMonad m => m (UniqueM m)
33 | newUnique = primitive $ \s -> case newByteArray# 0# s of
34 | (# s', ba #) -> (# s', Unique (I# (addr2Int# (unsafeCoerce# ba))) ba #)
35 |
--------------------------------------------------------------------------------
/src/Vec.hs:
--------------------------------------------------------------------------------
1 | {-# language BlockArguments #-}
2 | {-# language TupleSections #-}
3 | {-# language PatternSynonyms #-}
4 | module Vec where
5 |
6 | import Control.Monad.Primitive
7 | import Control.Monad.ST
8 | import Data.Bits
9 | import Data.Primitive.Types
10 | import Data.Primitive.PrimArray
11 | import Data.Primitive.MutVar
12 | import Ref
13 |
14 | -- transient
15 | data Vec s a = Vec {-# unpack #-} !Int {-# unpack #-} !(MutablePrimArray s a)
16 |
17 | -- non-backtracking writes by default
18 |
19 | -- newtype Vec s a = Vec (MVar s (Slab s a))
20 |
21 | pattern DEFAULT_SIZE :: Int
22 | pattern DEFAULT_SIZE = 4
23 |
24 | newVec_ :: (PrimMonad m, Prim a) => m (Vec (PrimState m) a)
25 | newVec_ = newVec DEFAULT_SIZE
26 |
27 | newVec :: (PrimMonad m, Prim a) => Int -> m (Vec (PrimState m) a)
28 | newVec n = stToPrim do Vec 0 <$> newPrimArray n
29 | {-# inline newVec #-}
30 |
31 | addVec :: (PrimMonad m, Prim a) => a -> Vec (PrimState m) a -> m (Int, Vec (PrimState m) a)
32 | addVec a (Vec i pa) = stToPrim do
33 | n <- getSizeofMutablePrimArray pa
34 | if i < n then do
35 | writePrimArray pa i a
36 | return (i, Vec (i+1) pa)
37 | else do
38 | pa' <- resizeMutablePrimArray pa (n*2)
39 | writePrimArray pa' i a
40 | return (i, Vec (i+1) pa')
41 | {-# inline addVec #-}
42 |
43 | subVec :: (PrimMonad m, Prim a) => Vec (PrimState m) a -> m (Vec (PrimState m) a)
44 | subVec (Vec i pa) = stToPrim do
45 | n <- getSizeofMutablePrimArray pa
46 | let n' = unsafeShiftR n 2
47 | if i >= n' then return $ Vec (i-1) pa
48 | else Vec (i-1) <$> resizeMutablePrimArray pa (n*2)
49 |
50 | readVec :: (PrimMonad m, Prim a) => Vec (PrimState m) a -> Int -> m a
51 | readVec (Vec _ pa) i = readPrimArray pa i
52 | {-# inline readVec #-}
53 |
54 | -- doesn't change shape
55 | writeVec :: (PrimMonad m, Prim a) => Vec (PrimState m) a -> Int -> a -> m ()
56 | writeVec (Vec _ pa) i a = writePrimArray pa i a
57 | {-# inline writeVec #-}
58 |
59 | sizeVec :: Vec s a -> Int
60 | sizeVec (Vec i _ ) = i
61 | {-# inline sizeVec #-}
62 |
63 | -- this would play the role of std::vector, non-transient non-thread-safe version
64 | newtype Vector s a = Vector (MutVar s (Vec s a))
65 |
66 | newVector :: (PrimMonad m, Prim a) => Int -> m (Vector (PrimState m) a)
67 | newVector n = stToPrim do
68 | v <- newVec n
69 | Vector <$> newMutVar v
70 | {-# inline newVector #-}
71 |
72 | -- not thread safe
73 | nonAtomicModifyVector :: PrimMonad m => Vector (PrimState m) a -> (Vec (PrimState m) a -> ST (PrimState m) (r, Vec (PrimState m) a)) -> m r
74 | nonAtomicModifyVector (Vector ref) k = stToPrim do
75 | v <- readMutVar ref
76 | (r, v') <- k v
77 | r <$ writeMutVar ref v'
78 | {-# inline nonAtomicModifyVector #-}
79 |
80 | modifyVector :: PrimMonad m => Vector (PrimState m) a -> (Vec (PrimState m) a -> ST (PrimState m) (Vec (PrimState m) a)) -> m ()
81 | modifyVector (Vector ref) k = stToPrim $ (readMutVar ref >>= k) >>= writeMutVar ref
82 | {-# inline modifyVector #-}
83 |
84 | addVector :: (PrimMonad m, Prim a) => a -> Vector (PrimState m) a -> m Int
85 | addVector a v = nonAtomicModifyVector v \vec -> addVec a vec
86 | {-# inline addVector #-}
87 |
88 | subVector :: (PrimMonad m, Prim a) => Vector (PrimState m) a -> m ()
89 | subVector v = modifyVector v subVec
90 | {-# inline subVector #-}
91 |
92 | readVector :: (PrimMonad m, Prim a) => Vector (PrimState m) a -> Int -> m a
93 | readVector (Vector ref) i = readMutVar ref >>= \(Vec _ pa) -> readPrimArray pa i
94 | {-# inline readVector #-}
95 |
96 | writeVector :: (PrimMonad m, Prim a) => Vector (PrimState m) a -> Int -> a -> m ()
97 | writeVector (Vector ref) i a = readMutVar ref >>= \vec -> writeVec vec i a
98 | {-# inline writeVector #-}
99 |
100 | sizeVector :: PrimMonad m => Vector (PrimState m) a -> m Int
101 | sizeVector (Vector ref) = stToPrim $ sizeVec <$> readMutVar ref
102 | {-# inline sizeVector #-}
103 |
104 | -- safe backtracking operations:
105 | --
106 | -- newVector
107 | -- readVector
108 | -- addBackVector
109 | -- writeBackVector
110 | -- sizeVector
111 |
112 | addBackVector :: (MonadRef m, Prim a) => a -> Vector (PrimState m) a -> m Int
113 | addBackVector a v = unwind (,()) (\_->subVector v) $ stToPrim $ addVector a v
114 | {-# inline addBackVector #-}
115 |
116 | writeBackVector :: (MonadRef m, Prim a) => Vector (PrimState m) a -> Int -> a -> m a -- returns old value
117 | writeBackVector v@(Vector ref) i a = unwind (\x -> (x,x)) (writeVector v i) $ do
118 | vec <- readMutVar ref
119 | old <- readVec vec i
120 | old <$ writeVec vec i a
121 | {-# inline writeBackVector #-}
122 |
--------------------------------------------------------------------------------
/test/Spec/Cover/DLX.hs:
--------------------------------------------------------------------------------
1 | module Spec.Cover.DLX where
2 |
3 | import Cover.DLX
4 | import Data.IORef
5 | import Test.Hspec
6 |
7 | spec :: Spec
8 | spec =
9 | describe "Cover.DLX" $
10 | it "solves" $ do
11 | x <- newCover 4 0
12 | r1 <- addOption x [0,1]
13 | r2 <- addOption x [2,3]
14 | r3 <- addOption x [0,3]
15 | r4 <- addOption x [1,2]
16 |
17 | r1 `shouldBe` 4
18 | r2 `shouldBe` 6
19 | r3 `shouldBe` 8
20 | r4 `shouldBe` 10
21 |
22 | resultRef <- newIORef []
23 | solve x (\is -> modifyIORef resultRef (is:))
24 | result <- reverse <$> readIORef resultRef
25 |
26 | result `shouldBe` [[4,6], [8,10]]
27 |
--------------------------------------------------------------------------------
/test/Spec/Domain/Interval.hs:
--------------------------------------------------------------------------------
1 | {-# language FlexibleContexts #-}
2 | {-# language GeneralizedNewtypeDeriving #-}
3 | {-# language PolyKinds #-}
4 | {-# language DataKinds #-}
5 | {-# language TypeFamilies #-}
6 | {-# language UndecidableInstances #-}
7 |
8 | module Spec.Domain.Interval where
9 |
10 | import Control.Applicative
11 | import Data.Foldable (traverse_)
12 | import Domain.Internal
13 | import FD.Monad
14 | import Relative.Base (plus)
15 | import Test.Hspec
16 |
17 | spec :: Spec
18 | spec = do
19 | describe "Domain.Interval" $ do
20 | describe "known" $ do
21 | it "known bottom = Nothing" $ do
22 | let
23 | result = run $
24 | bottom >>= known
25 | result `shouldBe` [Nothing]
26 | it "known [1..5] = Nothing" $ do
27 | let
28 | result = run $
29 | 1...5 >>= known
30 | result `shouldBe` [Nothing]
31 | it "known . abstract = Just" $ do
32 | let
33 | result = run $
34 | known (abstract 5)
35 | result `shouldBe` [Just 5]
36 |
37 | describe "negatei" $ do
38 | it "negates an interval" $ do
39 | let
40 | result = run $ do
41 | input <- 1...5
42 | r <- bottom
43 | negatei input r
44 | input `gtz` 4
45 | known r
46 | result `shouldBe` [Just (-5)]
47 | it "propagates information backwards" $ do
48 | let
49 | result = run $ do
50 | input <- 1...5
51 | r <- bottom
52 | negatei input r
53 | r `ltz` (-4)
54 | known input
55 | result `shouldBe` [Just 5]
56 |
57 | describe "absi" $ do
58 | it "passes through a positive number unchanged" $ do
59 | let
60 | result = run $ do
61 | let input = abstract 20
62 | output <- bottom
63 | absi input output
64 | known output
65 | result `shouldBe` [Just 20]
66 | it "negates a negative number" $ do
67 | let
68 | result = run $ do
69 | let input = abstract (-30)
70 | output <- bottom
71 | absi input output
72 | known output
73 | result `shouldBe` [Just 30]
74 |
75 | describe "comparisons" $ do
76 | let
77 | pair :: FD s (Interval (FD s))
78 | pair = 1...2
79 | knowns a b = (,) <$> known a <*> known b
80 | concretes a b = (,) <$> concrete a <*> concrete b
81 | it "[1..2] eq [1..2]" $ do
82 | let
83 | result = run $ do
84 | x <- pair; y <- pair
85 | x `eq` y
86 | concretes x y
87 | result `shouldBe` [(1,1), (2,2)]
88 | it "[1] eq [1..2]" $ do
89 | let
90 | result = run $ do
91 | let x = abstract 1
92 | y <- pair
93 | x `eq` y
94 | knowns x y
95 | result `shouldBe` [(Just 1, Just 1)]
96 | it "[1..2] eq [2]" $ do
97 | let
98 | result = run $ do
99 | x <- pair
100 | let y = abstract 2
101 | x `eq` y
102 | knowns x y
103 | result `shouldBe` [(Just 2, Just 2)]
104 | -- it "[1..2] lt [1..2]" $ do
105 | -- let
106 | -- result = run $ do
107 | -- x <- pair; y <- pair
108 | -- x `lt` y
109 | -- knowns x y
110 | -- result `shouldBe` [(Just 1,Just 2)]
111 | -- it "[1..2] gt [1..2]" $ do
112 | -- let
113 | -- result = run $ do
114 | -- x <- pair
115 | -- y <- pair
116 | -- x `gt` y
117 | -- knowns x y
118 | -- result `shouldBe` [(Just 2,Just 1)]
119 | it "x = x+4" $ do
120 | let
121 | result = run $ do
122 | x <- 1...5
123 | x `eq` (x `plus` 4)
124 | concrete x
125 | result `shouldBe` []
126 | it "x+4 = x" $ do
127 | let
128 | result = run $ do
129 | x <- 1...5
130 | (x `plus` 4) `eq` x
131 | concrete x
132 | result `shouldBe` []
133 | it "x+3 = x+3" $ do
134 | let
135 | result = run $ do
136 | input <- 0...5
137 | let added = input `plus` 3
138 | eq added added
139 | concrete added
140 | result `shouldBe` [3,4,5,6,7,8]
141 | it "x = -x overlapping" $ do
142 | let
143 | result = run $ do
144 | input <- (-3)...4
145 | negd <- bottom
146 | negatei input negd
147 | eq input negd
148 | (,) <$> concrete input <*> concrete negd
149 | result `shouldBe` [(0,0)]
150 | it "x = -x non-overlaping" $ do
151 | let
152 | result = run $ do
153 | input <- 2...5
154 | negd <- bottom
155 | negatei input negd
156 | eq input negd
157 | (,) <$> concrete input <*> concrete negd
158 | result `shouldBe` []
159 | it "x = -x+5 (odd case) (no integer solution)" $ do
160 | let
161 | result = run $ do
162 | input <- 2...5 --solution is 2.5
163 | negd <- bottom
164 | negatei input negd
165 | let added = negd `plus` 5
166 | eq input added
167 | (,) <$> concrete input <*> concrete added
168 | result `shouldBe` []
169 | it "x = -x+4 (even case) with solution" $ do
170 | let
171 | result = run $ do
172 | input <- 1...5 --solution is 2
173 | negd <- bottom
174 | negatei input negd
175 | let added = negd `plus` 4
176 | eq input added
177 | (,) <$> concrete input <*> concrete added
178 | result `shouldBe` [(2,2)]
179 | it "-x+4 = x (even case) with solution" $ do
180 | let
181 | result = run $ do
182 | input <- 1...5 --solution is 2
183 | negd <- bottom
184 | negatei input negd
185 | let added = negd `plus` 4
186 | eq added input
187 | (,) <$> concrete input <*> concrete added
188 | result `shouldBe` [(2,2)]
189 | it "x-4 = -x (even case) with solution" $ do
190 | let
191 | result = run $ do
192 | input <- 1...5 --solution is 2
193 | negd <- bottom
194 | negatei input negd
195 | let added = input `plus` (-4)
196 | eq added negd
197 | (,) <$> concrete negd <*> concrete added
198 | result `shouldBe` [(-2,-2)]
199 | it "x = -x+4 (even case) without solution" $ do
200 | let
201 | result = run $ do
202 | input <- 3...5 --solution is 2
203 | negd <- bottom
204 | negatei input negd
205 | let added = negd `plus` 4
206 | eq input added
207 | (,) <$> concrete input <*> concrete added
208 | result `shouldBe` []
209 | it "[1] le [1..2]" $ do
210 | let
211 | result = run $ do
212 | let x = abstract 1
213 | y <- pair
214 | x `le` y
215 | knowns x y
216 | result `shouldBe` [(Just 1, Nothing)]
217 | it "[1..2] le [1]" $ do
218 | let
219 | result = run $ do
220 | x <- pair
221 | let y = abstract 1
222 | x `le` y
223 | knowns x y
224 | result `shouldBe` [(Just 1, Just 1)]
225 | it "1 ne [1..2]" $ do
226 | let
227 | result = run $ do
228 | let x = abstract 1
229 | y <- 1...2
230 | x `ne` y
231 | known y
232 | result `shouldBe` [Just 2]
233 | it "2 ne [1..2]" $ do
234 | let
235 | result = run $ do
236 | let x = abstract 2
237 | y <- 1...2
238 | x `ne` y
239 | known y
240 | result `shouldBe` [Just 1]
241 | -- it "[1..5] ne [1..5]" $ do
242 | -- let
243 | -- result = run $ do
244 | -- x <- 1...5
245 | -- y <- 1...5
246 | -- x `ne` y
247 | -- concrete x
248 | -- result `shouldBe` [1,2,3,4,5]
249 | it "[1..5] ne 5" $ do
250 | let
251 | result = run $ do
252 | x <- 1...5
253 | x `ne` abstract 5
254 | concrete x
255 | result `shouldBe` [1,2,3,4]
256 | it "3 zle [1..5]" $ do
257 | let
258 | result = run $ do
259 | x <- 1...5
260 | 3 `zle` x
261 | concrete x
262 | result `shouldBe` [3,4,5]
263 | it "1 zle [1..5]" $ do
264 | let
265 | result = run $ do
266 | x <- 1...5
267 | 1 `zle` x
268 | concrete x
269 | result `shouldBe` [1,2,3,4,5]
270 | it "5 zle [1..5]" $ do
271 | let
272 | result = run $ do
273 | x <- 1...5
274 | 5 `zle` x
275 | known x
276 | result `shouldBe` [Just 5]
277 | it "6 zle [1..5]" $ do
278 | let
279 | result = run $ do
280 | x <- 1...5
281 | 6 `zle` x
282 | concrete x
283 | result `shouldBe` []
284 | it "0 zle [1..5]" $ do
285 | let
286 | result = run $ do
287 | x <- 1...5
288 | 0 `zle` x
289 | concrete x
290 | result `shouldBe` [1,2,3,4,5]
291 | it "[1..5] lez 3" $ do
292 | let
293 | result = run $ do
294 | x <- 1...5
295 | x `lez` 3
296 | concrete x
297 | result `shouldBe` [1,2,3]
298 | it "[1..5] lez 1" $ do
299 | let
300 | result = run $ do
301 | x <- 1...5
302 | x `lez` 1
303 | concrete x
304 | result `shouldBe` [1]
305 | it "[1..5] lez 5" $ do
306 | let
307 | result = run $ do
308 | x <- 1...5
309 | x `lez` 5
310 | concrete x
311 | result `shouldBe` [1,2,3,4,5]
312 | it "[1..5] lez 6" $ do
313 | let
314 | result = run $ do
315 | x <- 1...5
316 | x `lez` 6
317 | concrete x
318 | result `shouldBe` [1,2,3,4,5]
319 | it "[1..5] lez 0" $ do
320 | let
321 | result = run $ do
322 | x <- 1...5
323 | x `lez` 0
324 | concrete x
325 | result `shouldBe` []
326 |
327 | describe "<|>" $ do
328 | it "right id" $ do
329 | let
330 | result = run $
331 | pure 3 <|> empty
332 | result `shouldBe` [3 :: Integer]
333 | it "left id" $ do
334 | let
335 | result = run $
336 | empty <|> pure 4
337 | result `shouldBe` [4 :: Integer]
338 |
339 | -- Art of the Propagator section 6.3
340 | describe "baker cooper fletcher miller and smith" $ do
341 | it "finds a solution" $ do
342 | let
343 | result = run $ do
344 | let
345 | floors = 1...5
346 | allDistinct [] = pure ()
347 | allDistinct (x:xs) = traverse_ (ne x) xs *> allDistinct xs
348 | notAdjacent a b = a `lt` plus b (-1) <|> a `gt` plus b 1
349 |
350 | -- make all tenants
351 | b <- floors
352 | c <- floors
353 | f <- floors
354 | m <- floors
355 | s <- floors
356 |
357 | -- Nobody lives on the same floor
358 | allDistinct [b,c,f,m,s]
359 |
360 | -- constraints
361 | b `nez` 5
362 | c `nez` 1
363 | f `nez` 5
364 | f `nez` 1
365 | m `gt` c
366 |
367 | -- cooper does not live directly above or below fletcher
368 | -- smith does not live directly above or below fletcher
369 | notAdjacent c f
370 | notAdjacent s f
371 |
372 | traverse concrete [b,c,f,m,s]
373 |
374 | result `shouldBe` [[3,2,4,5,1]]
375 |
--------------------------------------------------------------------------------
/test/Spec/FD/Monad.hs:
--------------------------------------------------------------------------------
1 | {-# language OverloadedLists #-}
2 |
3 | module Spec.FD.Monad where
4 |
5 | import FD.Monad
6 | import FD.Var
7 | import Test.Hspec hiding (example)
8 |
9 | spec :: Spec
10 | spec =
11 | describe "FD.Monad" $
12 | it "solves x <- [1..4], y <- [1..4], x < y" $ do
13 | let result = run example
14 | result `shouldBe` [(1,2),(1,3),(1,4),(2,3),(2,4),(3,4)]
15 |
16 | example :: FD s (Integer, Integer)
17 | example = do
18 | x <- newFDVar [1..4]
19 | y <- newFDVar [1..4]
20 | lt x y
21 | (,) <$> val x <*> val y
22 |
--------------------------------------------------------------------------------
/test/Spec/Logic/Reflection.hs:
--------------------------------------------------------------------------------
1 | {-# language OverloadedLists #-}
2 | module Spec.Logic.Reflection where
3 |
4 | import Control.Applicative
5 | import Data.Functor.Identity
6 | import Logic.Reflection
7 | import Test.Hspec
8 | import Unaligned.Internal
9 |
10 | spec :: Spec
11 | spec = do
12 | describe "Logic.Reflection" $ do
13 | describe "view/unview" $ do
14 | it "empty" $ do
15 | let
16 | x :: Logic Int
17 | x = empty
18 | result = unview (view x)
19 | observeAll result `shouldBe` []
20 | it "empty on left" $ do
21 | let
22 | x :: Logic Int
23 | x = empty <|> pure 5
24 | result = unview (view x)
25 | observeAll result `shouldBe` [5]
26 | it "full" $ do
27 | let
28 | x :: Logic Int
29 | x = pure 1 <|> pure 2 <|> pure 3
30 | result = unview (view x)
31 | observeAll x `shouldBe` [1,2,3]
32 | observeAll result `shouldBe` [1,2,3]
33 | describe "unview" $ do
34 | it "unviews empty" $ do
35 | let
36 | x :: Identity (View Int (LogicT Identity Int)) -- L m a
37 | x = pure Empty
38 | result = unview x
39 | observeAll result `shouldBe` []
40 | it "unviews a singleton" $ do
41 | let
42 | x :: Identity (View Int (LogicT Identity Int))
43 | x = pure (1 :&: empty)
44 | result = unview x
45 | observeAll result `shouldBe` [1]
46 | it "unviews something with multiple elements" $ do
47 | let
48 | x :: Identity (View Int (LogicT Identity Int))
49 | x = pure (1 :&: LogicT (singleton (pure (2 :&: empty))))
50 | result = unview x
51 | observeAll result `shouldBe` [1,2]
52 | it "unviews the result of <>" $ do
53 | let
54 | x :: Identity (View Int (LogicT Identity Int))
55 | x = pure (1 :&: (mempty <> LogicT (singleton (pure (2 :&: empty)))))
56 | result = unview x
57 | observeAll result `shouldBe` [1,2]
58 | describe "Logic <|>" $ do
59 | it "left id" $ do
60 | let result = observeAll $ empty <|> pure 6
61 | result `shouldBe` [6 :: Integer]
62 | it "right id" $ do
63 | let result = observeAll $ pure 5 <|> empty
64 | result `shouldBe` [5 :: Integer]
65 | it "combining" $ do
66 | let
67 | result :: [Int]
68 | result = observeAll $ pure 7 <|> pure 8
69 | result `shouldBe` [7,8]
70 | it "associativity" $ do
71 | let
72 | result1, result2 :: [Int]
73 | result1 = observeAll $ (pure 1 <|> pure 2) <|> pure (3 :: Int)
74 | result2 = observeAll $ pure 1 <|> (pure 2 <|> pure (3 :: Int))
75 | (result1, result2) `shouldBe` ([1,2,3], [1,2,3])
76 |
--------------------------------------------------------------------------------
/test/Spec/Prompt/Iterator.hs:
--------------------------------------------------------------------------------
1 | {-# language LambdaCase #-}
2 | module Spec.Prompt.Iterator where
3 |
4 | import Data.Semigroup
5 | import Data.Foldable
6 | import Prompt.Class
7 | import Prompt.Iterator
8 | import Prompt.Reflection
9 | import Test.Hspec hiding (example)
10 | import Unaligned.Base
11 |
12 | spec :: Spec
13 | spec =
14 | describe "Prompt.Iterator" $
15 | it "iterates [1..5]" $ do
16 | let result = runPrompt example
17 | show result `shouldBe` "[1,2,2,3,3,3,4,4,4,4,5,5,5,5,5]"
18 |
19 | example :: MonadPrompt m => m (Cat Int)
20 | example = do
21 | i <- iterator $ forM_ [1..5]
22 | go Nil i
23 | where
24 | go l = \case
25 | Done -> return l
26 | Iterator a mi' -> mi' >>= go (l <> stimes a (singleton a))
27 |
--------------------------------------------------------------------------------
/test/Spec/Unaligned/Base.hs:
--------------------------------------------------------------------------------
1 | {-# language OverloadedLists #-}
2 | module Spec.Unaligned.Base where
3 |
4 | import Data.Foldable
5 | import Test.Hspec
6 | import Unaligned.Internal
7 |
8 | spec :: Spec
9 | spec = do
10 | describe "Unaligned.Base" $ do
11 | describe "Cat" $ do
12 | describe "Monoid" $ do
13 | it "left id" $ do
14 | E <> [1,2,3] `shouldBe` ([1,2,3] :: Cat Integer)
15 | it "right id" $ do
16 | [4,5,6] <> E `shouldBe` ([4,5,6] :: Cat Integer)
17 | it "associativity" $ do
18 | let l = ([1,2,3] <> [4,5,6]) <> [7,8,9] :: Cat Integer
19 | let r = [1,2,3] <> ([4,5,6] <> [7,8,9]) :: Cat Integer
20 | toList l `shouldBe` toList r
21 | describe "linkAll" $ do
22 | it "preserves the elements" $ do
23 | let x = linkAll [[1,2,3],[4,5,6],[7,8,9] :: Cat Int]
24 | toList x `shouldBe` [1,2,3,4,5,6,7,8,9]
25 | describe "cons" $ do
26 | it "is consistent with list" $ do
27 | let x = cons 1 [2,3,4] :: Cat Int
28 | toList x `shouldBe` [1,2,3,4]
29 | describe "uncons" $ do
30 | it "splits apart cons" $ do
31 | let x = cons 1 [2,3,4] :: Cat Int
32 | uncons x `shouldBe` (1 :&: [2,3,4])
33 | describe "snoc" $ do
34 | it "is consistent with list" $ do
35 | let x = snoc [1,2,3] 4 :: Cat Int
36 | toList x `shouldBe` [1,2,3,4]
37 |
38 | describe "Q" $ do
39 | describe "cons" $ do
40 | it "is consistent with list" $ do
41 | let x = cons 1 [2,3,4] :: Q Int
42 | toList x `shouldBe` [1,2,3,4]
43 | describe "uncons" $ do
44 | it "splits apart cons" $ do
45 | let x = cons 1 [2,3,4] :: Q Int
46 | uncons x `shouldBe` (1 :&: [2,3,4])
47 | describe "snoc" $ do
48 | it "is consistent with list" $ do
49 | let x = snoc [1,2,3] 4 :: Q Int
50 | toList x `shouldBe` [1,2,3,4]
51 |
--------------------------------------------------------------------------------
/test/doctest-main.hs:
--------------------------------------------------------------------------------
1 | {-# options_ghc -F -pgmF doctest-discover -optF test/doctest.json #-}
2 |
--------------------------------------------------------------------------------
/test/doctest.json:
--------------------------------------------------------------------------------
1 | {
2 | "ignore": [],
3 | "sourceFolders": [ "src" ],
4 | "doctestOptions": [ "-fobject-code", "-odir=dist-doctest -hidir=dist-doctest" ]
5 | }
6 |
--------------------------------------------------------------------------------
/test/hedgehog-main.hs:
--------------------------------------------------------------------------------
1 | {-# language OverloadedStrings #-}
2 | {-# language TypeFamilies #-}
3 |
4 | module Main where
5 |
6 | import Control.Monad
7 | import Data.Function (on)
8 | import GHC.Exts
9 | import Hedgehog
10 | import qualified Hedgehog.Gen as Gen
11 | import qualified Hedgehog.Range as Range
12 | import System.Exit (exitFailure)
13 |
14 | import Unaligned.Internal
15 |
16 | main :: IO ()
17 | main = do
18 | result <- checkParallel tests
19 | unless result $
20 | exitFailure
21 |
22 | tests :: Group
23 | tests = Group "tests"
24 | [ ("Cat left id", catLeftId)
25 | , ("Cat right id", catRightId)
26 | , ("Cat assoc", catAssoc)
27 | , ("Cat cons", catCons)
28 | , ("Cat snoc", catSnoc)
29 | , ("Cat singleton", catSingleton)
30 | , ("Cat uncons", catUncons)
31 | , ("Cat link", catLink)
32 | , ("Cat linkAll", catLinkAll)
33 | , ("Q cons", qCons)
34 | , ("Q snoc", qSnoc)
35 | , ("Q singleton", qSingleton)
36 | , ("Q uncons", qUncons)
37 | , ("Q toList/fromList", qToFromList)
38 | , ("Q fromList/toList", qFromToList)
39 | ]
40 |
41 | catLeftId, catRightId, catAssoc, catCons, catSnoc, catSingleton, catUncons, catLink, catLinkAll :: Property
42 | catLeftId = property $ do
43 | c <- forAll genCat
44 | (mempty <> c) === c
45 |
46 | catRightId = property $ do
47 | c <- forAll genCat
48 | (c <> mempty) === c
49 |
50 | catAssoc = property $ do
51 | a <- forAll genCat
52 | b <- forAll genCat
53 | c <- forAll genCat
54 | let l = (a <> b) <> c
55 | let r = a <> (b <> c)
56 | l ==== r
57 |
58 | catCons = property $ do
59 | i <- forAll genInt
60 | c <- forAll genCat
61 | cons i c ===@ (i : toList c)
62 |
63 | catSnoc = property $ do
64 | i <- forAll genInt
65 | c <- forAll genCat
66 | snoc c i ===@ (toList c ++ [i])
67 |
68 | catSingleton = property $ do
69 | i <- forAll genInt
70 | (singleton i :: Cat Int) ===@ [i]
71 |
72 | catUncons = property $ do
73 | c <- forAll genCat
74 | case uncons c of
75 | Empty -> c === nil
76 | h :&: t -> do
77 | c ===@ h:toList t
78 | c ==== cons h t
79 |
80 | catLink = property $ do
81 | i <- forAll genInt
82 | q <- forAll genQ
83 | c <- forAll genCat
84 | link i q c ===@ i : foldMap toList q ++ toList c
85 |
86 | catLinkAll = property $ do
87 | q <- forAll genQ
88 | linkAll q ===@ foldMap toList q
89 |
90 | qCons, qSnoc, qSingleton, qUncons, qToFromList, qFromToList:: Property
91 | qCons = property $ do
92 | c <- forAll genCat
93 | q <- forAll genQ
94 | let expected = fromList (c : toList q)
95 | cons c q === expected
96 |
97 | qSnoc = property $ do
98 | c <- forAll genCat
99 | q <- forAll genQ
100 | let expected = toList q ++ [c] :: [Cat Int]
101 | snoc q c ===@ expected
102 |
103 | qSingleton = property $ do
104 | c <- forAll genCat
105 | let
106 | result :: Q (Cat Int)
107 | result = singleton c
108 | result === fromList [c]
109 | toList result === [c]
110 |
111 | qUncons = property $ do
112 | q <- forAll genQ
113 | case uncons q of
114 | Empty -> q === nil
115 | h :&: t -> do
116 | q === fromList (h : toList t)
117 | q === cons h t
118 |
119 | qFromToList = property $ do
120 | q <- forAll genQ
121 | fromList (toList q) === q
122 |
123 | qToFromList = property $ do
124 | l <- forAll (Gen.list (Range.linear 0 10) genCat)
125 | toList (fromList l :: Q (Cat Int)) === l
126 |
127 |
128 | (===@) :: (Eq a, Show a, IsList (f a), Item (f a) ~ a) => f a -> [a] -> PropertyT IO ()
129 | (===@) = (===) . toList
130 | infix 4 ===@
131 |
132 | (====) :: (Eq a, Show a, IsList (f a), Item (f a) ~ a) => f a -> f a -> PropertyT IO ()
133 | (====) = (===) `on` toList
134 | infix 4 ====
135 |
136 | genIsList :: (IsList (f a), Item (f a) ~ a, Monoid (f a)) => Range Int -> Gen a -> Gen (f a)
137 | genIsList r a =
138 | let naive = fromList <$> Gen.list r a
139 | in mconcat <$> Gen.list (Range.linear 0 10) naive
140 |
141 | genQ :: Gen (Q (Cat Int))
142 | genQ = fromList <$> Gen.list (Range.linear 0 10) genCat
143 |
144 | genCat :: Gen (Cat Int)
145 | genCat = genIsList (Range.linear 0 10) genInt
146 |
147 | genInt :: Gen Int
148 | genInt = Gen.int (Range.linear 0 100)
149 |
--------------------------------------------------------------------------------
/test/queens.hs:
--------------------------------------------------------------------------------
1 | {-# language ViewPatterns #-}
2 | {-# language TupleSections #-}
3 |
4 | module Main where
5 |
6 | import Control.Monad (unless)
7 | import Control.Monad.ST
8 | import Cover.DXZ
9 | import Data.Foldable
10 | import System.Exit
11 |
12 | queens :: Int -> Int
13 | queens n = runST $ do
14 | x <- newCover_
15 | rows <- addItems x n
16 | cols <- addItems x n
17 | diag1 <- addOptionalItems x (n+n)
18 | diag2 <- addOptionalItems x (n+n)
19 | let organ i = fromIntegral $ div (if odd i then n-1-i else n+i) 2
20 | for_ [0..n-1] $ \(organ -> r) ->
21 | for_ [0..n-1] $ \(organ -> c) ->
22 | addOption x [rows+r,cols+c,diag1+r+c,diag2+n-1-r+c]
23 | count x
24 |
25 | main :: IO ()
26 | main = do
27 | let n = queens 12
28 | print n
29 | unless (n == 14200) exitFailure
30 |
--------------------------------------------------------------------------------
/test/spec.hs:
--------------------------------------------------------------------------------
1 | -- TODO: replace this with auto-discovery
2 | module Main where
3 |
4 | import Test.Hspec.Runner
5 | import Test.Hspec.Formatters
6 | import qualified Spec.Cover.DLX
7 | import qualified Spec.FD.Monad
8 | import qualified Spec.Domain.Interval
9 | import qualified Spec.Prompt.Iterator
10 | import qualified Spec.Logic.Reflection
11 | import qualified Spec.Unaligned.Base
12 |
13 | main :: IO ()
14 | main = hspecWith defaultConfig {configFormatter = Just progress} $ do
15 | Spec.Cover.DLX.spec
16 | Spec.Domain.Interval.spec
17 | Spec.FD.Monad.spec
18 | Spec.Logic.Reflection.spec
19 | Spec.Prompt.Iterator.spec
20 | Spec.Unaligned.Base.spec
21 |
--------------------------------------------------------------------------------
/wip/ProbabilisticTree.hs:
--------------------------------------------------------------------------------
1 | {-# language TypeFamilies, DeriveFoldable #-}
2 | -- probabilistic trees
3 | module Prob
4 | ( Tree
5 | , singleton
6 | ) where
7 |
8 | -- I want to take a hash function for elements, and produce a tree
9 |
10 | import Data.Bits
11 | import Data.Foldable as F
12 | import Data.Hashable
13 | import Data.Word
14 | import GHC.Exts
15 |
16 | -- compare level only
17 | lts :: Word -> Word -> Bool
18 | lts a b = a < b && a < xor a b
19 |
20 | -- pugh style probabilistic trees with cached hash values
21 | --
22 | -- this is very similar to a treap.
23 | data Tree a
24 | = Tip
25 | | Leaf a {-# unpack #-} !Word
26 | | Bin !(Tree a) a {-# unpack #-} !Word !(Tree a)
27 | deriving (Show, Eq, Foldable)
28 |
29 | instance Semigroup (Tree a) where
30 | Tip <> a = a
31 | a <> Tip = a
32 | n0@(Leaf a h) <> n1 = go n1 where
33 | go Tip = n0 -- before a i n
34 | go n@(Leaf b i)
35 | | h `lts` i = Bin n0 b i Tip
36 | | otherwise = Bin Tip a h n
37 | go n@(Bin l b i r)
38 | | h `lts` i = Bin (go l) b i r
39 | | otherwise = Bin Tip a h n
40 | n0 <> n1@(Leaf b i) = go n0 where
41 | go Tip = n1
42 | go n@(Leaf a h)
43 | | h `lts` i = Bin n b i Tip
44 | | otherwise = Bin Tip a h n1
45 | go n@(Bin l a h r)
46 | | h `lts` i = Bin n b i Tip
47 | | otherwise = Bin l a h (go r)
48 | x@(Bin l a h r) <> y@(Bin l' b i r') -- this could be deconstructed a _little_ more to avoid full <>'s below
49 | | h `lts` i = Bin (x <> l') b i r'
50 | | otherwise = Bin l a h (r <> y)
51 |
52 | instance Monoid (Tree a) where
53 | mempty = Tip
54 |
55 | singleton :: Hashable a => a -> Tree a
56 | singleton a = Leaf a (fromIntegral (hash a))
57 |
58 | instance Hashable a => IsList (Tree a) where
59 | type Item (Tree a) = a
60 | fromList = foldl (\t a -> after t a (fromIntegral (hash a))) Tip where
61 | after :: Tree a -> a -> Word -> Tree a
62 | after Tip b i = Leaf b i
63 | after n@(Leaf a h) b i
64 | | h `lts` i = Bin n b i Tip
65 | | otherwise = Bin Tip a h (Leaf b i)
66 | after n@(Bin l a h r) b i
67 | | h `lts` i = Bin n b i Tip
68 | | otherwise = Bin l a h (after r b i)
69 | toList = F.toList
70 |
71 | {-
72 | -- extract the leftmost element of the tree
73 |
74 | data Minimal a = NoMin | Minimal a {-# unpack #-} !Word !(Tree a)
75 |
76 | minimal :: Tree a -> Minimal a
77 | minimal Tip = NoMin
78 | minimal (Leaf a h) = Minimal a h Tip
79 | minimal (Bin l a h r) = case minimal l of
80 | NoMin -> Minimal a h r
81 | Minimal a' h' l' -> Minimal a' h' (Bin l' a h r)
82 |
83 | -- extract the rightmost element of the tree
84 |
85 | data Maximal a = NoMax | Maximal !(Tree a) a {-# unpack #-} !Word
86 |
87 | maximal :: Tree a -> Maximal a
88 | maximal Tip = NoMax
89 | maximal (Leaf a h) = Maximal Tip a h
90 | maximal (Bin l a h r) = case maximal r of
91 | NoMax -> Maximal l a h
92 | Maximal r' a' h' -> Maximal (Bin l a h r') a h
93 | -}
94 |
95 |
--------------------------------------------------------------------------------
/wip/RationalArithmetic.hs:
--------------------------------------------------------------------------------
1 | {-# language GADTs #-}
2 | {-# language ViewPatterns #-}
3 | {-# language PatternGuards #-}
4 | {-# language PatternSynonyms #-}
5 | {-# language DeriveFunctor #-}
6 |
7 | module Walk where
8 |
9 | import Control.Applicative
10 | import Control.Monad
11 | import Data.Int
12 | import Data.List (unfoldr)
13 | import Data.Ratio
14 |
15 | -- TODO: use Unaligned.Internal.View
16 | stream :: (s -> Maybe (o, s)) -> (s -> i -> s) -> s -> [i] -> [o]
17 | stream f g z xs = case f z of
18 | Just (y, z') -> y : stream f g z' xs
19 | Nothing -> case xs of
20 | [] -> []
21 | x:xs -> stream f g (g z x) xs
22 |
23 | unstream
24 | :: (s -> Maybe (o, s))
25 | -> (s -> i -> s)
26 | -> (s -> r -> i)
27 | -> (r -> o -> r)
28 | -> s -> r -> [i]
29 | unstream f g h k z w = case f z of
30 | Just (y, z') -> unstream f g h k z' (k w y)
31 | Nothing | x <- h z w -> x : unstream f g h k (g z x) w
32 |
33 | --
34 | -- will be useful here. This is basically just decoding without encoding
35 | -- no?
36 |
37 | -- * rational arithmetic encoding
38 |
39 | type Q = Rational
40 | data I = I Q Q
41 | type Bit = Int -- 0 or 1 only
42 |
43 | unit :: I
44 | unit = I 0 1
45 |
46 | within :: Q -> I -> Bool
47 | within x (I l r) = l <= x && x < r
48 |
49 | pick :: I -> Q
50 | pick (I l r) = (l + r) / 2
51 |
52 | lerp :: I -> Q -> Q
53 | lerp (I l r) p = l + (r-l)*p
54 |
55 | instance Semigroup I where
56 | i <> I p q = I (lerp i p) (lerp i q)
57 |
58 | instance Monoid I where
59 | mempty = I 0 1
60 |
61 | (|>) :: I -> I -> I
62 | (|>) = (<>)
63 |
64 | -- recipriocal interval, for widening
65 | inv :: I -> I
66 | inv (I l r) = I (l/rl) (r/rl) where rl = r-l
67 |
68 | nextBit :: I -> Maybe (Bit, I)
69 | nextBit (I l r)
70 | | r <= 0.5 = Just (0, I (2*l) (2*r))
71 | | 0.5 <= l = Just (1, I (2*l-1) (2*r-1))
72 | | otherwise = Nothing
73 |
74 |
75 | -- |
76 | -- @
77 | -- 'length' ('toBits' ('I' l r) <= - 'logBase' 2 (r-l)
78 | -- @
79 | toBits :: I -> [Bit]
80 | toBits = unfoldr nextBit
81 |
82 | -- |
83 | -- @
84 | -- 'fromBits' ('toInts' i) `'within'` i
85 | -- @
86 | fromBits :: [Bit] -> Q
87 | fromBits = foldr pack 0.5 where
88 | pack :: Bit -> Q -> Q
89 | pack b x = (fromIntegral b + x) / 2
90 |
91 | data EI = EI {-# unpack #-} !Int {-# unpack #-} !Q {-# unpack #-} !Q
92 |
93 | lo, hi :: I -> Q
94 | lo (I l _) = l
95 | hi (I _ r) = r
96 |
97 | pattern E :: Int -> I -> EI
98 | pattern E n ilr <- EI n l (I l -> ilr) where
99 | E n ilr = EI n (lo ilr) (hi ilr)
100 |
101 | -- reports the number of times it had to expand
102 | expand :: EI -> EI
103 | expand (EI n l r)
104 | | 0.25 <= l, r <= 0.75 = expand (EI (n+1) (2*l-0.5) (2*r-0.5))
105 | | otherwise = EI n l r
106 |
107 | -- | @
108 | -- contract . expand = contract
109 | -- contract n (i <> j) = contract n i <> j
110 | -- @
111 | contract :: EI -> I
112 | contract (EI n l r) = I (rescale n l) (rescale n r) where
113 | rescale n x = (x - 0.5)*2^^(-n) + 0.5
114 |
115 | -- | @
116 | -- contract (enarrow ei i) = contract ei |> i
117 | -- @
118 | enarrow :: EI -> I -> EI
119 | enarrow ei int2 = E n (int1 <> int2) where
120 | E n int1 = expand ei
121 |
122 | nextBits :: EI -> Maybe ([Bit], I)
123 | nextBits (EI n l r)
124 | | r <= 0.5 = Just (bits n 0, I (2*l) (2*r))
125 | | 0.5 <= l = Just (bits n 1, I (2*l-1) (2*r-1))
126 | | otherwise = Nothing
127 |
128 | bits :: Int -> Bit -> [Bit]
129 | bits n b = b : replicate n (1-b)
130 |
131 | -- integral arithmetic encoding
132 |
133 | {-
134 | -- 64 bit numbers for intervals
135 | data I = I {-# unpack #-} !Int64 {-# unpack #-} !Int64
136 | data II = II {-# unpack #-} !Int64 {-# unpack #-} !Int64 {-# unpack #-} !Int64
137 |
138 | inarrow :: I -> II -> I
139 | inarrow (I l r) (II p q d) = I (l + div ((r-l)*p) d) (r + div ((r-l)*q) d)
140 |
141 | -- this belongs, morally, in a put monad instead
142 | --encode m ei = concat . stream nextBits enarrow ei . encodeSyms m
143 | --
144 |
145 | decode m ei bs = unstream nextBitsM step nextSym sub (m, ei) (buffer bs)
146 |
147 | buffer bs = (z, rs) where
148 | z = foldl 9\x b -> 2 * x + b) 0 cs
149 | (cs, rs) = splitAt e (bs ++ 1 : replicate (e - 1) 0)
150 |
151 | nextSym (m, ei) (z, rs) = decodeSym m t where
152 | t = ((k-l+1)* denom m - 1) `div` (r -l)
153 | k = fscale n (z,rs)
154 | (n,(l,r)) = expand ei
155 |
156 | -- here we don't want to read a bit, we want a random bit and to build the history tape
157 | sub = foldl unop where
158 | unop (z,r:rs) b = (2*z - w*b + r, rs)
159 |
160 | fscale (n,(z,rs)) = foldl (\x b -> 2*x + b - 32) z (take n rs)
161 | -}
162 |
163 | -- invariant in a
164 | data Model a where
165 | Model :: (s -> a -> (I, s)) -> (s -> Q -> a) -> s -> Model a
166 |
167 | data History = BRANCH History History | Done
168 |
169 | open :: History
170 | open = BRANCH open open
171 |
172 | branch :: History -> History -> History
173 | branch Done Done = Done
174 | branch x y = Branch x y
175 |
176 | pattern Branch :: History -> History -> History
177 | pattern Branch x y <- BRANCH x y where
178 | Branch x y = branch x y
179 |
180 | newtype M m a = M
181 | { runM :: m Bool -> (a -> History -> m History) -> History -> m History
182 | } deriving Functor
183 |
184 | instance Applicative (M m) where
185 | pure a = M $ \ _ k -> k a
186 | (<*>) = ap
187 |
188 | instance Monad (M m) where
189 | m >>= f = M $ \ rand k -> runM m rand $ \ a -> runM (f a) rand k
190 |
191 | instance Monad m => Alternative (M m) where
192 | empty = M $ \ _ _ _ -> pure Done -- ignore the history and continuation
193 | -- would it be better to explicitly manage a zipper?
194 | l <|> r = M $ \ rand k h -> case h of
195 | Done -> pure Done
196 | Branch a Done -> (\a' -> Branch a' Done) <$> runM l rand k a
197 | Branch Done b -> (\b' -> Branch Done b') <$> runM r rand k b
198 | Branch a b -> do
199 | c <- rand
200 | if c then (\a' -> Branch a' b) <$> runM l rand k a
201 | else (\b' -> Branch a b') <$> runM r rand k b
202 |
203 | instance Monad m => MonadPlus (M m) where
204 | mplus = (<|>)
205 | mzero = empty
206 |
207 | {-
208 | invariant: Branch Done Done = Done
209 |
210 | with the idea that these can be used to help inform a
211 | -}
212 |
213 |
--------------------------------------------------------------------------------
| |