├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.markdown ├── LICENSE ├── README.markdown ├── Setup.hs ├── propagators.cabal ├── src └── Data │ ├── Propagator.hs │ └── Propagator │ ├── Cell.hs │ ├── Class.hs │ ├── Name.hs │ ├── Num.hs │ ├── Prop.hs │ └── Supported.hs └── stack.yaml /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '--cabal-install-version' '3.2' '--no-ghcup-cabal' '--no-cabal-check' 'propagators.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.14.3 12 | # 13 | # REGENDATA ("0.14.3",["github","--cabal-install-version","3.2","--no-ghcup-cabal","--no-cabal-check","propagators.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-18.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:bionic 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-7.10.3 32 | compilerKind: ghc 33 | compilerVersion: 7.10.3 34 | setup-method: hvr-ppa 35 | allow-failure: false 36 | fail-fast: false 37 | steps: 38 | - name: apt 39 | run: | 40 | apt-get update 41 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 42 | apt-add-repository -y 'ppa:hvr/ghc' 43 | apt-get update 44 | apt-get install -y "$HCNAME" cabal-install-3.2 45 | env: 46 | HCKIND: ${{ matrix.compilerKind }} 47 | HCNAME: ${{ matrix.compiler }} 48 | HCVER: ${{ matrix.compilerVersion }} 49 | - name: Set PATH and environment variables 50 | run: | 51 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 52 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 53 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 54 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 55 | HCDIR=/opt/$HCKIND/$HCVER 56 | HC=$HCDIR/bin/$HCKIND 57 | echo "HC=$HC" >> "$GITHUB_ENV" 58 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 59 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 60 | echo "CABAL=/opt/cabal/3.2/bin/cabal -vnormal+nowrap" >> "$GITHUB_ENV" 61 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 62 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 63 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 64 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 65 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 66 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 67 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 68 | env: 69 | HCKIND: ${{ matrix.compilerKind }} 70 | HCNAME: ${{ matrix.compiler }} 71 | HCVER: ${{ matrix.compilerVersion }} 72 | - name: env 73 | run: | 74 | env 75 | - name: write cabal config 76 | run: | 77 | mkdir -p $CABAL_DIR 78 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 111 | echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - 112 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 113 | rm -f cabal-plan.xz 114 | chmod a+x $HOME/.cabal/bin/cabal-plan 115 | cabal-plan --version 116 | - name: checkout 117 | uses: actions/checkout@v2 118 | with: 119 | path: source 120 | - name: initial cabal.project for sdist 121 | run: | 122 | touch cabal.project 123 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 124 | cat cabal.project 125 | - name: sdist 126 | run: | 127 | mkdir -p sdist 128 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 129 | - name: unpack 130 | run: | 131 | mkdir -p unpacked 132 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 133 | - name: generate cabal.project 134 | run: | 135 | PKGDIR_propagators="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/propagators-[0-9.]*')" 136 | echo "PKGDIR_propagators=${PKGDIR_propagators}" >> "$GITHUB_ENV" 137 | rm -f cabal.project cabal.project.local 138 | touch cabal.project 139 | touch cabal.project.local 140 | echo "packages: ${PKGDIR_propagators}" >> cabal.project 141 | cat >> cabal.project <> cabal.project.local 144 | cat cabal.project 145 | cat cabal.project.local 146 | - name: dump install plan 147 | run: | 148 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 149 | cabal-plan 150 | - name: cache 151 | uses: actions/cache@v2 152 | with: 153 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 154 | path: ~/.cabal/store 155 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 156 | - name: install dependencies 157 | run: | 158 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 159 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 160 | - name: build w/o tests 161 | run: | 162 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 163 | - name: build 164 | run: | 165 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 166 | - name: haddock 167 | run: | 168 | $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 169 | - name: unconstrained build 170 | run: | 171 | rm -f cabal.project.local 172 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 173 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .hsenv/ 3 | docs 4 | wiki 5 | TAGS 6 | tags 7 | wip 8 | old 9 | .DS_Store 10 | .*.swp 11 | .*.swo 12 | *.o 13 | *.hi 14 | *~ 15 | *# 16 | .cabal-sandbox/ 17 | cabal.sandbox.config 18 | codex.tags 19 | .stack-work -------------------------------------------------------------------------------- /CHANGELOG.markdown: -------------------------------------------------------------------------------- 1 | ## 0 2 | 3 | * Repository Initialized 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2015 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | propagators 2 | =========== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/propagators.svg)](https://hackage.haskell.org/package/propagators) [![Build Status](https://github.com/ekmett/propagators/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/ekmett/propagators/actions/workflows/haskell-ci.yml?query=branch%3Amaster) 5 | 6 | Propagators propagate increases in information from cell to cell. 7 | 8 | They are described (using Scheme) in Alexey Radul and Gerald Sussman's ["The Art of the Propagator"](http://web.mit.edu/~axch/www/art.pdf) as well as in Alexey Radul's thesis on [Propagation Networks](http://groups.csail.mit.edu/genesis/papers/radul%202009.pdf). 9 | 10 | This package explores design options for propagators in Haskell. The primary innovation here (beyond the published work) is the use of observable sharing to let us take a more direct form of programming and transform it back and forth to the propagator style. 11 | 12 | Contact Information 13 | ------------------- 14 | 15 | Contributions and bug reports are welcome! 16 | 17 | Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. 18 | 19 | -Edward Kmett 20 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain -------------------------------------------------------------------------------- /propagators.cabal: -------------------------------------------------------------------------------- 1 | name: propagators 2 | category: Data 3 | version: 0 4 | license: BSD3 5 | cabal-version: >= 1.22 6 | license-file: LICENSE 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: experimental 10 | homepage: http://github.com/ekmett/propagators/ 11 | bug-reports: http://github.com/ekmett/propagators/issues 12 | copyright: Copyright (C) 2015 Edward A. Kmett 13 | build-type: Custom 14 | tested-with: GHC == 7.10.3 15 | synopsis: The Art of the Propagator 16 | description: 17 | 18 | extra-source-files: 19 | CHANGELOG.markdown 20 | README.markdown 21 | 22 | source-repository head 23 | type: git 24 | location: git://github.com/ekmett/propagators.git 25 | 26 | -- You can disable the doctests test suite with -f-test-doctests 27 | flag test-doctests 28 | default: True 29 | manual: True 30 | 31 | -- You can disable the hlint test suite with -f-test-hlint 32 | flag test-hlint 33 | default: True 34 | manual: True 35 | 36 | library 37 | build-depends: 38 | base >= 4.8 && < 5, 39 | data-reify >= 0.6 && < 7, 40 | ghc-prim, 41 | hashable >= 1.2 && < 1.3, 42 | intervals >= 0.7 && < 0.9, 43 | primitive >= 0.5 && < 0.7, 44 | unique >= 0 && < 0.1, 45 | unordered-containers >= 0.2 && < 0.3 46 | 47 | exposed-modules: 48 | Data.Propagator 49 | Data.Propagator.Cell 50 | Data.Propagator.Class 51 | Data.Propagator.Name 52 | Data.Propagator.Num 53 | Data.Propagator.Prop 54 | Data.Propagator.Supported 55 | 56 | ghc-options: -Wall -fwarn-tabs 57 | 58 | hs-source-dirs: src 59 | default-language: Haskell2010 -------------------------------------------------------------------------------- /src/Data/Propagator.hs: -------------------------------------------------------------------------------- 1 | module Data.Propagator 2 | ( Cell 3 | , Change(..) 4 | , Propagated(..) 5 | , PropagatedNum 6 | , PropagatedFloating 7 | , PropagatedInterval 8 | , cell 9 | , cellWith 10 | , known 11 | , write, content, with 12 | , watch 13 | , watch2 14 | , lift1, lift2 15 | , Prop(..) 16 | , lower, arg 17 | , lower1, lower2 18 | , forwards 19 | , backwards 20 | ) where 21 | 22 | import Data.Propagator.Cell 23 | import Data.Propagator.Class 24 | import Data.Propagator.Num 25 | import Data.Propagator.Prop 26 | -------------------------------------------------------------------------------- /src/Data/Propagator/Cell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | 8 | module Data.Propagator.Cell where 9 | 10 | import Control.Monad 11 | import Control.Monad.ST 12 | import Data.Foldable 13 | import qualified Data.HashSet as HashSet 14 | import Data.List (intercalate) 15 | import Data.Primitive.MutVar 16 | import Data.Propagator.Class 17 | 18 | -- | A 'Cell' contains "information about a value" rather than a value per se. 19 | data Cell s a = Cell 20 | (a -> a -> Change a) 21 | {-# UNPACK #-} !(MutVar s (Maybe a, a -> ST s ())) 22 | 23 | instance Eq (Cell s a) where 24 | Cell _ ra == Cell _ rb = ra == rb 25 | 26 | -- | Construct a new 'Cell' with no information. 27 | cell :: Propagated a => ST s (Cell s a) 28 | cell = cellWith merge 29 | 30 | -- | Construct a new 'Cell' with a custom merge strategy. 31 | cellWith :: (a -> a -> Change a) -> ST s (Cell s a) 32 | cellWith mrg = Cell mrg <$> newMutVar (Nothing, \_ -> return ()) 33 | 34 | -- | Construct a 'Cell' with some information 35 | known :: Propagated a => a -> ST s (Cell s a) 36 | known a = Cell merge <$> newMutVar (Just a, \_ -> return ()) 37 | -- known a = do x <- cell; write x a 38 | 39 | -- | Writing to a 'Cell' tells it information about its value. 40 | write :: Cell s a -> a -> ST s () 41 | write (Cell m r) a' = join $ atomicModifyMutVar' r $ \case 42 | (Nothing, ns) -> ((Just a', ns), ns a') 43 | old@(Just a, ns) -> case m a a' of 44 | Contradiction xs e 45 | | HashSet.null xs -> (old, fail e) 46 | | e == "" -> (old, fail "contradiction") 47 | | otherwise -> (old, fail (e ++ ", supported by: " ++ intercalate ", " (show <$> toList xs))) 48 | Change False _ -> (old, return ()) 49 | Change True a'' -> ((Just a'', ns), ns a'') 50 | 51 | -- | Unifying two cells makes them exchange information as if they were one 'Cell'. 52 | unify :: Cell s a -> Cell s a -> ST s () 53 | unify x y = do 54 | watch x (write y) 55 | watch y (write x) 56 | 57 | -- | Extract the 'content' of a 'Cell'. 58 | content :: Cell s a -> ST s (Maybe a) 59 | content (Cell _ c) = fst <$> readMutVar c 60 | 61 | -- | Watching a 'Cell' sets up a callback that will be notified if the cell changes. 62 | watch :: Cell s a -> (a -> ST s ()) -> ST s () 63 | watch (Cell _ r) k = join $ atomicModifyMutVar' r $ \case 64 | (Nothing, ok) -> ((Nothing, \a -> k a >> ok a), return ()) 65 | (ma@(Just a), ok) -> ((ma, \a' -> k a' >> ok a'), k a) 66 | 67 | -- | 'with' will read the current value of a 'Cell' and do something with that result 68 | -- if it is known. If the 'Cell' is currently empty, this will do nothing. Unlike 69 | -- watch it does not install a handler. 70 | with :: Cell s a -> (a -> ST s ()) -> ST s () 71 | with (Cell _ r) k = do 72 | p <- readMutVar r 73 | traverse_ k (fst p) 74 | 75 | -- | 'watch2' will watch two cells. When they both have some information the supplied 76 | -- callback will fire at least once. It will continue to fire each time they get 77 | -- more information from then out. 78 | watch2 :: Cell s a -> Cell s b -> (a -> b -> ST s ()) -> ST s () 79 | watch2 x y f = do 80 | watch x $ \a -> with y $ \b -> f a b 81 | watch y $ \b -> with x $ \a -> f a b 82 | 83 | -- | Lift a unary function into a relationship between two cells. 84 | lift1 :: (a -> b) -> Cell s a -> Cell s b -> ST s () 85 | lift1 f x y = watch x $ \a -> write y (f a) 86 | 87 | -- | Lift a binary function into a relationship between two cells. 88 | lift2 :: (a -> b -> c) -> Cell s a -> Cell s b -> Cell s c -> ST s () 89 | lift2 f x y z = watch2 x y $ \a b -> write z (f a b) 90 | -------------------------------------------------------------------------------- /src/Data/Propagator/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | 8 | module Data.Propagator.Class 9 | ( Change(..) 10 | , Propagated(..) 11 | , mergeDefault 12 | ) where 13 | 14 | import Control.Applicative 15 | import Control.Monad 16 | import Data.HashSet 17 | import Data.Propagator.Name 18 | import Numeric.Interval.Internal (Interval(..)) 19 | import Numeric.Natural 20 | 21 | -- | This represents the sorts of changes we can make as we accumulate information 22 | -- in a 'Data.Propagator.Cell.Cell'. 23 | -- 24 | -- * 'Change' 'False' indicates that this is the old value, and we didn't change anything. 25 | -- 26 | -- * 'Change' 'True' indicates that this is the new value, which gains information over the old. 27 | -- 28 | -- * 'Contradiction' indicates that the updated information is inconsistent with the old. 29 | data Change a 30 | = Change !Bool a 31 | | Contradiction !(HashSet Name) String 32 | deriving (Functor, Foldable, Traversable) 33 | 34 | instance Applicative Change where 35 | pure = Change False 36 | Change m f <*> Change n a = Change (m || n) (f a) 37 | Contradiction m n <*> _ = Contradiction m n 38 | _ <*> Contradiction m n = Contradiction m n 39 | 40 | instance Alternative Change where 41 | empty = Contradiction mempty "contradiction" 42 | Contradiction{} <|> n = n 43 | m <|> _ = m 44 | -- can we (evilly) intersect the contradiction set? 45 | 46 | instance Monad Change where 47 | return = Change False 48 | Change m a >>= f = case f a of 49 | Change n b -> Change (m || n) b 50 | Contradiction s n -> Contradiction s n 51 | Contradiction s n >>= _ = Contradiction s n 52 | fail = Contradiction mempty 53 | 54 | instance MonadPlus Change where 55 | mzero = Control.Applicative.empty 56 | mplus = (<|>) 57 | 58 | -- | This is a viable default definition for 'merge' for most simple values. 59 | mergeDefault :: (Eq a, Show a) => a -> a -> Change a 60 | mergeDefault a b 61 | | a == b = Change False a 62 | | otherwise = Contradiction mempty $ (showString "merge: " . showsPrec 10 a . showString " /= " . showsPrec 10 b) "" 63 | 64 | -- | This class provides the default definition for how to 'merge' values in our information lattice. 65 | -- 66 | class Propagated a where 67 | -- | The first argument represents the old information. The second argument represents the new information. 68 | -- When the new information causes us to learn something this should return a @'Change' 'True'@ with the combined 69 | -- information. When it doesn't, it should return @'Change' 'False'@ with the old information. If new information 70 | -- is inconsistent with the old, it should return 'Contradiction' instead. 71 | merge :: a -> a -> Change a 72 | default merge :: (Eq a, Show a) => a -> a -> Change a 73 | merge = mergeDefault 74 | 75 | instance Propagated () 76 | instance Propagated Bool 77 | instance Propagated Int 78 | instance Propagated Integer 79 | instance Propagated Word 80 | instance Propagated Rational 81 | instance Propagated Natural 82 | 83 | -- | Approximate equality (1e-6) 84 | instance Propagated Float where 85 | merge a b 86 | | isNaN a && isNaN b = Change False a 87 | | isInfinite a && isInfinite b && a == b = Change False a 88 | | abs (a-b) < 1e-6 = Change False a 89 | | otherwise = Contradiction mempty $ (showString "merge: " . showsPrec 10 a . showString " /= " . showsPrec 10 b) "" 90 | 91 | -- | Approximate equality (1e-9) 92 | instance Propagated Double where 93 | merge a b 94 | | isNaN a && isNaN b = Change False a 95 | | isInfinite a && isInfinite b && a == b = Change False a 96 | | abs (a-b) < 1e-9 = Change False a 97 | | otherwise = Contradiction mempty $ (showString "merge: " . showsPrec 10 a . showString " /= " . showsPrec 10 b) "" 98 | 99 | instance (Propagated a, Propagated b) => Propagated (a, b) where 100 | merge (a,b) (c,d) = (,) <$> merge a c <*> merge b d 101 | 102 | instance (Propagated a, Propagated b) => Propagated (Either a b) where 103 | merge (Left a) (Left b) = Left <$> merge a b 104 | merge (Right a) (Right b) = Right <$> merge a b 105 | merge _ _ = fail "Left /= Right" 106 | 107 | -- | Propagated interval arithmetic 108 | instance (Num a, Ord a) => Propagated (Interval a) where 109 | merge (I a b) (I c d) 110 | | b < c || d < a = Change True Empty 111 | | otherwise = Change (a < c || b > d) $ I (max a c) (min b d) 112 | merge Empty _ = Change False Empty 113 | merge _ Empty = Change True Empty 114 | -------------------------------------------------------------------------------- /src/Data/Propagator/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | {-# LANGUAGE MagicHash #-} 4 | -- | Inspired by the names in nominal adapton. 5 | module Data.Propagator.Name 6 | ( Name 7 | , fresh 8 | , stable 9 | , fork 10 | , pair 11 | , child 12 | , children 13 | , height 14 | ) where 15 | 16 | import Control.Concurrent.Unique 17 | import Control.Monad.Primitive 18 | import Data.Bits 19 | import Data.Hashable 20 | import Data.String 21 | import GHC.Prim 22 | import System.Mem.StableName 23 | import GHC.Exts(Any) 24 | 25 | data Name 26 | = U {-# UNPACK #-} !Unique 27 | | SN {-# UNPACK #-} !(StableName Any) 28 | | S {-# UNPACK #-} !Int String 29 | | P {-# UNPACK #-} !Int {-# UNPACK #-} !Int !Name !Name 30 | | C {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int !Name 31 | 32 | instance Eq Name where 33 | U i == U j = i == j 34 | SN i == SN j = i == j 35 | S i s == S j t = i == j && s == t 36 | P i _ p q == P j _ r s = i == j && p == r && q == s 37 | C i _ m p == C j _ n q = i == j && m == n && p == q 38 | _ == _ = False 39 | 40 | instance Show Name where 41 | showsPrec _ (U i) = showString "#" . showsPrec 11 (hash i) 42 | showsPrec _ (SN i) = showString "%" . showsPrec 11 (hashStableName i) 43 | showsPrec d (S _ s) = showsPrec d s 44 | showsPrec d (P i h l r) = showParen (d > 10) $ showString "P " . showsPrec 11 i . showChar ' ' . showsPrec 11 h . showChar ' ' . showsPrec 11 l . showChar ' ' . showsPrec 11 r 45 | showsPrec d (C i h n p) = showParen (d > 10) $ showString "C " . showsPrec 11 i . showChar ' ' . showsPrec 11 h . showChar ' ' . showsPrec 11 n . showChar ' ' . showsPrec 11 p 46 | 47 | -- | Has a negative binomial distribution. Same for any forked children. 48 | height :: Name -> Int 49 | height (U i) = ffs (hash i) 50 | height (SN i) = ffs (hashStableName i) 51 | height (S i _) = ffs i 52 | height (P _ h _ _) = h 53 | height (C _ h _ _) = h 54 | {-# INLINE height #-} 55 | 56 | instance Hashable Name where 57 | hashWithSalt d (U i) = hashWithSalt d i 58 | hashWithSalt d (SN i) = hashWithSalt d i 59 | hashWithSalt d (S i _) = hashWithSalt d i 60 | hashWithSalt d (P i _ _ _) = hashWithSalt d i 61 | hashWithSalt d (C i _ _ _) = hashWithSalt d i 62 | {-# INLINE hashWithSalt #-} 63 | hash (U i) = hash i 64 | hash (SN i) = hashStableName i 65 | hash (S i _) = i 66 | hash (P i _ _ _) = i 67 | hash (C i _ _ _) = i 68 | {-# INLINE hash #-} 69 | 70 | -- | \"find first set\" 71 | ffs :: Int -> Int 72 | ffs 0 = 0 73 | ffs x = countTrailingZeros x + 1 74 | {-# INLINE ffs #-} 75 | 76 | instance IsString Name where 77 | fromString s = S (hash s) s 78 | {-# INLINE fromString #-} 79 | 80 | -- | Generate a fresh name. 81 | fresh :: PrimMonad m => m Name 82 | fresh = unsafePrimToPrim $ U <$> newUnique 83 | {-# INLINE fresh #-} 84 | 85 | -- | Obtain a stable name. 86 | stable :: PrimMonad m => a -> m Name 87 | stable a = unsafePrimToPrim $ SN <$> (unsafeCoerce# makeStableName a :: IO (StableName Any)) 88 | {-# INLINE stable #-} 89 | 90 | -- | Obtain the name of two children deterministically. 91 | fork :: Name -> (Name, Name) 92 | fork n = (child n 1, child n 2) 93 | {-# INLINE fork #-} 94 | 95 | -- | Obtain the name of the kth child. 96 | child :: Name -> Int -> Name 97 | child n d = C (hashWithSalt d n) (height n) d n 98 | {-# INLINE child #-} 99 | 100 | -- | Obtain a list of the names of all children 101 | children :: Name -> [Name] 102 | children n = map (\d -> C (hashWithSalt d i) h d n) [1..] where 103 | i = hash n 104 | h = height n 105 | {-# INLINE children #-} 106 | 107 | -- | build a name based on two existing names 108 | pair :: Name -> Name -> Name 109 | pair m n = P (hash m `hashWithSalt` n) (height m `min` height n) m n 110 | {-# INLINE pair #-} 111 | -------------------------------------------------------------------------------- /src/Data/Propagator/Num.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | module Data.Propagator.Num where 6 | 7 | import Control.Monad 8 | import Control.Monad.ST 9 | import Data.Propagator.Cell 10 | import Data.Propagator.Class 11 | import Data.Propagator.Supported 12 | import Numeric.Natural 13 | import Numeric.Interval.Internal 14 | 15 | class Propagated a => PropagatedNum a where 16 | cplus :: Cell s a -> Cell s a -> Cell s a -> ST s () 17 | default cplus :: Num a => Cell s a -> Cell s a -> Cell s a -> ST s () 18 | cplus x y z = do 19 | lift2 (+) x y z 20 | lift2 (-) z x y 21 | lift2 (-) z y x 22 | 23 | ctimes :: Cell s a -> Cell s a -> Cell s a -> ST s () 24 | default ctimes :: Num a => Cell s a -> Cell s a -> Cell s a -> ST s () 25 | ctimes = lift2 (*) 26 | 27 | cabs :: Cell s a -> Cell s a -> ST s () 28 | default cabs :: (Num a, Eq a) => Cell s a -> Cell s a -> ST s () 29 | cabs x y = do 30 | lift1 abs x y 31 | watch y $ \b -> when (b == 0) $ write x 0 32 | 33 | csignum :: Cell s a -> Cell s a -> ST s () 34 | default csignum :: (Num a, Eq a) => Cell s a -> Cell s a -> ST s () 35 | csignum x y = do 36 | lift1 signum x y 37 | watch y $ \b -> when (b == 0) $ write x 0 38 | 39 | instance PropagatedNum Integer where 40 | ctimes x y z = do 41 | lift2 (*) x y z 42 | watch z $ \c -> 43 | if c == 0 then do 44 | watch x $ \ a -> when (a /= 0) $ write y 0 45 | watch y $ \ b -> when (b /= 0) $ write x 0 46 | else do 47 | watch x $ \ a -> write y (c `div` a) 48 | watch y $ \ b -> write x (c `div` b) 49 | 50 | 51 | -- propagate backwards with div? 52 | 53 | instance PropagatedNum (Supported Integer) where 54 | ctimes x y z = do 55 | lift2 (*) x y z 56 | watch z $ \c -> 57 | when (c == 0) $ do 58 | watch x $ \ a -> when (a /= 0) $ write y 0 59 | watch y $ \ b -> when (b /= 0) $ write x 0 60 | 61 | instance PropagatedNum Natural where 62 | ctimes x y z = do 63 | lift2 (*) x y z 64 | watch z $ \c -> 65 | if c == 0 then do 66 | watch x $ \ a -> when (a /= 0) $ write y 0 67 | watch y $ \ b -> when (b /= 0) $ write x 0 68 | else do 69 | watch x $ \ a -> write y (c `div` a) 70 | watch y $ \ b -> write x (c `div` b) 71 | cabs = unify 72 | 73 | instance PropagatedNum (Supported Natural) where 74 | ctimes x y z = do 75 | lift2 (*) x y z 76 | watch z $ \c -> 77 | when (c == 0) $ do 78 | watch x $ \ a -> when (a /= 0) $ write y 0 79 | watch y $ \ b -> when (b /= 0) $ write x 0 80 | cabs = unify 81 | 82 | instance PropagatedNum Int 83 | instance PropagatedNum (Supported Int) 84 | 85 | instance PropagatedNum Word where 86 | cabs = unify 87 | 88 | instance PropagatedNum (Supported Word) where 89 | cabs = unify 90 | 91 | ctimesFractional :: (Eq a, Fractional a) => Cell s a -> Cell s a -> Cell s a -> ST s () 92 | ctimesFractional x y z = do 93 | watch x $ \a -> 94 | if a == 0 95 | then write z 0 96 | else do 97 | with y $ \b -> write z (a*b) 98 | with z $ \c -> write y (c/a) -- a /= 0 determined above 99 | watch y $ \b -> 100 | if b == 0 101 | then write z 0 102 | else do 103 | with x $ \a -> write z (a*b) 104 | with z $ \c -> write x (c/b) -- b /= 0 determined above 105 | watch z $ \c -> do 106 | with x $ \a -> when (a /= 0) $ write y (c/a) 107 | with y $ \b -> when (b /= 0) $ write x (c/b) 108 | 109 | instance PropagatedNum Rational where 110 | ctimes = ctimesFractional 111 | 112 | instance PropagatedNum (Supported Rational) where 113 | ctimes = ctimesFractional 114 | 115 | instance PropagatedNum Double where 116 | ctimes = ctimesFractional 117 | 118 | instance PropagatedNum (Supported Double) where 119 | ctimes = ctimesFractional 120 | 121 | instance PropagatedNum Float where 122 | ctimes = ctimesFractional 123 | 124 | instance PropagatedNum (Supported Float) where 125 | ctimes = ctimesFractional 126 | 127 | class PropagatedNum a => PropagatedFloating a where 128 | cexp :: Cell s a -> Cell s a -> ST s () 129 | default cexp :: Floating a => Cell s a -> Cell s a -> ST s () 130 | cexp x y = do 131 | lift1 exp x y 132 | lift1 log y x 133 | 134 | csqrt :: Cell s a -> Cell s a -> ST s () 135 | default csqrt :: Floating a => Cell s a -> Cell s a -> ST s () 136 | csqrt x y = do 137 | lift1 sqrt x y 138 | lift1 (\a -> a*a) y x 139 | 140 | csin :: Cell s a -> Cell s a -> ST s () 141 | default csin :: (Floating a, Ord a) => Cell s a -> Cell s a -> ST s () 142 | csin x y = do 143 | lift1 sin x y 144 | watch y $ \b -> do 145 | unless (abs b <= 1) $ fail "output of sin not between -1 and 1" 146 | write x (asin b) 147 | 148 | ccos :: Cell s a -> Cell s a -> ST s () 149 | default ccos :: (Floating a, Ord a) => Cell s a -> Cell s a -> ST s () 150 | ccos x y = do 151 | lift1 cos x y 152 | watch y $ \b -> do 153 | unless (abs b <= 1) $ fail "output of cos not between -1 and 1" 154 | write x (acos b) 155 | 156 | ctan :: Cell s a -> Cell s a -> ST s () 157 | default ctan :: (Floating a, Ord a) => Cell s a -> Cell s a -> ST s () 158 | ctan x y = do 159 | lift1 tan x y 160 | watch y $ \b -> do 161 | unless (abs b <= pi/2) $ fail "output of tan not between -pi/2 and pi/2" 162 | write x (atan b) 163 | 164 | csinh :: Cell s a -> Cell s a -> ST s () 165 | default csinh :: (Floating a, Ord a) => Cell s a -> Cell s a -> ST s () 166 | csinh x y = do 167 | lift1 sinh x y 168 | lift1 asinh y x 169 | 170 | ccosh :: Cell s a -> Cell s a -> ST s () 171 | default ccosh :: (Floating a, Ord a) => Cell s a -> Cell s a -> ST s () 172 | ccosh x y = do 173 | lift1 cosh x y 174 | watch y $ \b -> do 175 | unless (b >= 1) $ fail "output of cosh not >= 1" 176 | lift1 acosh y x 177 | 178 | ctanh :: Cell s a -> Cell s a -> ST s () 179 | default ctanh :: (Floating a, Ord a) => Cell s a -> Cell s a -> ST s () 180 | ctanh x y = do 181 | lift1 tanh x y 182 | watch y $ \b -> do 183 | unless (abs b <= 1) $ fail "output of tanh not between -1 and 1" 184 | write x (tanh b) 185 | 186 | instance PropagatedFloating Float 187 | instance PropagatedFloating (Supported Float) 188 | instance PropagatedFloating Double 189 | instance PropagatedFloating (Supported Double) 190 | 191 | -- Interval arithmetic 192 | 193 | class (Floating a, Ord a) => PropagatedInterval a where 194 | infinity :: a 195 | 196 | 197 | instance PropagatedInterval Double where 198 | infinity = 1/0 199 | 200 | instance PropagatedInterval (Supported Double) where 201 | infinity = 1/0 202 | 203 | instance PropagatedInterval Float where 204 | infinity = 1/0 205 | 206 | instance PropagatedInterval (Supported Float) where 207 | infinity = 1/0 208 | 209 | instance PropagatedInterval a => PropagatedNum (Interval a) where 210 | ctimes = ctimesFractional 211 | 212 | cabs x y = do 213 | write y (0...infinity) 214 | lift1 abs x y 215 | -- todo: use symmetric_positive 216 | watch y $ \case 217 | I _ b -> write x (-b...b) 218 | Empty -> write x Empty 219 | 220 | csignum x y = do 221 | write y (-1...1) 222 | lift1 signum x y 223 | watch y $ \case 224 | I a b | a < 1 && b > -1 -> write x $ I (if a <= -1 then -infinity else 0) (if b >= 1 then infinity else 0) 225 | _ -> write x Empty 226 | 227 | symmetric_positive :: (Num a, Ord a) => (Interval a -> Interval a) -> Cell s (Interval a) -> Cell s (Interval a) -> ST s () 228 | symmetric_positive f x y = do 229 | watch y $ \case 230 | Empty -> write x Empty -- if the result is empty then the input is empty 231 | I a a' -> do 232 | when (a' <= 0) $ with x $ \c -> write y (- f c) 233 | when (a >= 0) $ with x $ \c -> write y (f c) 234 | lift1 (\c -> let d = f c in hull (-d) d) x y 235 | 236 | -- x = f y + p*n 237 | -- n = (x - f y)/p, n is an integer 238 | periodic :: RealFrac a => Interval a -> (Interval a -> Interval a) -> Cell s (Interval a) -> Cell s (Interval a) -> ST s () 239 | periodic p f x y = do 240 | watch2 x y $ \a b -> let c = f b in case (a - c) / p of 241 | Empty -> write x Empty 242 | I l h -> write x (c + p*(fromIntegral (ceiling l :: Integer)...fromIntegral (floor h :: Integer))) 243 | 244 | instance (PropagatedInterval a, RealFloat a) => PropagatedFloating (Interval a) where 245 | cexp x y = do 246 | write y (0...infinity) 247 | lift1 exp x y 248 | lift1 log y x 249 | 250 | csqrt x y = do 251 | write x (0...infinity) 252 | lift1 (\b -> b*b) y x 253 | symmetric_positive sqrt x y 254 | 255 | csin x y = do 256 | write y (-1...1) 257 | lift1 sin x y 258 | periodic (2*pi) asin y x 259 | 260 | ccos x y = do 261 | write y (-1...1) 262 | lift1 cos x y 263 | periodic (2*pi) acos y x 264 | 265 | ctan x y = do 266 | write y (-pi/2...pi/2) 267 | lift1 tan x y 268 | periodic pi atan y x 269 | 270 | csinh x y = do 271 | lift1 sinh x y 272 | lift1 asinh y x 273 | 274 | ccosh x y = do 275 | write y (1...infinity) 276 | lift1 cosh x y 277 | symmetric_positive acosh x y 278 | 279 | ctanh x y = do 280 | write y (-1...1) 281 | lift1 tanh x y 282 | lift1 atanh y x 283 | -------------------------------------------------------------------------------- /src/Data/Propagator/Prop.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE DefaultSignatures #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeSynonymInstances #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE Unsafe #-} 10 | 11 | module Data.Propagator.Prop 12 | ( Prop(..) 13 | , lower, arg 14 | , lower1, lower2 15 | , forwards, backwards 16 | ) where 17 | 18 | import Control.Monad 19 | import Control.Monad.Primitive 20 | import Control.Monad.ST 21 | import Data.Foldable 22 | import qualified Data.HashMap.Strict as HM 23 | import Data.HashMap.Strict (HashMap) 24 | import Data.Propagator.Class 25 | import Data.Propagator.Cell 26 | import Data.Propagator.Num 27 | import Data.Proxy 28 | import Data.Reify 29 | import Unsafe.Coerce 30 | 31 | -- | This type allows us to write seemingly normal functional code and glue it together out of smaller 32 | -- propagator templates. Evaluation of these expressions uses . 33 | -- 34 | -- * 'Nullary' lifts a computation that will produce a 'Cell' into a 'Prop'. 35 | -- 36 | -- * 'Unary' lifts a relationship between 2 cells into 'Prop'. 37 | -- 38 | -- * 'Binary' lifts a relationship between 3 cells into 'Prop'. 39 | data Prop s a where 40 | Nullary :: ST s (Cell s a) -> Prop s a 41 | Unary :: Propagated b => (Cell s a -> Cell s b -> ST s ()) -> Prop s a -> Prop s b 42 | Binary :: Propagated c => (Cell s a -> Cell s b -> Cell s c -> ST s ()) -> Prop s a -> Prop s b -> Prop s c 43 | 44 | instance (PropagatedNum a, Eq a, Num a) => Num (Prop s a) where 45 | (+) = Binary cplus 46 | (-) = Binary $ \z x y -> cplus x y z 47 | (*) = Binary ctimes 48 | negate = Unary $ \x y -> do 49 | lift1 negate x y 50 | lift1 negate y x 51 | signum = Unary $ \x y -> do 52 | lift1 signum x y 53 | watch y $ \b -> when (b == 0) $ write x 0 54 | abs = Unary cabs 55 | fromInteger i = Nullary (known $ fromInteger i) 56 | 57 | instance (PropagatedNum a, Eq a, Fractional a) => Fractional (Prop s a) where 58 | (/) = Binary $ \x y z -> ctimes z y x 59 | recip = Unary $ \ x y -> do 60 | z <- known 1 61 | ctimes x y z 62 | fromRational r = Nullary (known $ fromRational r) 63 | 64 | -- | most of these only spit out the primary branch when run backwards 65 | instance (PropagatedFloating a, Eq a, Floating a) => Floating (Prop s a) where 66 | pi = Nullary (known pi) 67 | 68 | exp = Unary cexp 69 | log = Unary (flip cexp) 70 | 71 | sqrt = Unary csqrt 72 | 73 | x ** y = exp (x * log y) 74 | 75 | logBase a b = log a / log b 76 | 77 | sin = Unary csin 78 | cos = Unary ccos 79 | tan = Unary ctan 80 | 81 | asin = Unary (flip csin) 82 | acos = Unary (flip ccos) 83 | atan = Unary (flip ctan) 84 | 85 | sinh = Unary csinh 86 | cosh = Unary ccosh 87 | tanh = Unary ctanh 88 | 89 | asinh = Unary (flip csinh) 90 | acosh = Unary (flip ccosh) 91 | atanh = Unary (flip ctanh) 92 | 93 | data DerefProp s u where 94 | DerefNullary :: ST s (Cell s a) -> DerefProp s u 95 | DerefUnary :: Propagated b => Proxy b -> (Cell s a -> Cell s b -> ST s ()) -> u -> DerefProp s u 96 | DerefBinary :: Propagated c => Proxy c -> (Cell s a -> Cell s b -> Cell s c -> ST s ()) -> u -> u -> DerefProp s u 97 | 98 | instance Functor (DerefProp s) where 99 | fmap _ (DerefNullary u) = DerefNullary u 100 | fmap f (DerefUnary Proxy k a) = DerefUnary Proxy k (f a) 101 | fmap f (DerefBinary Proxy k a b) = DerefBinary Proxy k (f a) (f b) 102 | 103 | instance Foldable (DerefProp s) where 104 | foldMap _ (DerefNullary _) = mempty 105 | foldMap f (DerefUnary _ _ a) = f a 106 | foldMap f (DerefBinary _ _ a b) = f a `mappend` f b 107 | 108 | instance Traversable (DerefProp s) where 109 | traverse _ (DerefNullary u) = pure $ DerefNullary u 110 | traverse f (DerefUnary Proxy k a) = DerefUnary Proxy k <$> f a 111 | traverse f (DerefBinary Proxy k a b) = DerefBinary Proxy k <$> f a <*> f b 112 | 113 | instance MuRef (Prop s a) where 114 | type DeRef (Prop s a) = DerefProp s 115 | mapDeRef _ (Nullary n) = pure $ DerefNullary n 116 | mapDeRef f (Unary k a) = DerefUnary Proxy k <$> f a 117 | mapDeRef f (Binary k a b) = DerefBinary Proxy k <$> f a <*> f b 118 | 119 | data ACell s where 120 | ACell :: Cell s a -> ACell s 121 | 122 | buildACell :: forall s. DerefProp s Int -> ST s (ACell s) 123 | buildACell (DerefNullary u) = do 124 | x <- u 125 | return (ACell x) 126 | buildACell (DerefUnary (Proxy :: Proxy b) _ _) = do 127 | (x :: Cell s b) <- cell 128 | return (ACell x) 129 | buildACell (DerefBinary (Proxy :: Proxy c) _ _ _) = do 130 | (x :: Cell s c) <- cell 131 | return (ACell x) 132 | 133 | linkACell :: HashMap Int (ACell s) -> (Int, DerefProp s Int) -> ST s () 134 | linkACell m (z,t) = case t of 135 | DerefNullary{} -> return () 136 | DerefUnary (Proxy :: Proxy b) f x -> case m HM.! x of 137 | ACell a -> case m HM.! z of 138 | ACell b -> f (unsafeCoerce a) (unsafeCoerce b) 139 | DerefBinary (Proxy :: Proxy c) f x y -> case m HM.! x of 140 | ACell a -> case m HM.! y of 141 | ACell b -> case m HM.! z of 142 | ACell c -> f (unsafeCoerce a) (unsafeCoerce b) (unsafeCoerce c) 143 | 144 | _2 :: Functor f => (a -> f b) -> (c, a) -> f (c, b) 145 | _2 f (a,b) = (,) a <$> f b 146 | 147 | -- | Lower a 'Prop' to its output 'Cell' by observable sharing. 148 | lower :: Prop s a -> ST s (Cell s a) 149 | lower m = do 150 | Graph kvs root <- unsafePrimToPrim (reifyGraph m) 151 | kvs' <- traverse (_2 buildACell) kvs 152 | let hm = HM.fromList kvs' 153 | traverse_ (linkACell hm) kvs 154 | case hm HM.! root of 155 | ACell a -> return (unsafeCoerce a) 156 | 157 | -- | Lift a 'Cell' into a 'Prop' 158 | arg :: Cell s a -> Prop s a 159 | arg a = Nullary (return a) 160 | 161 | -- | Lower a unary 'Prop' computation to a relationship between two cells. 162 | lower1 :: (Prop s a -> Prop s b) -> Cell s a -> ST s (Cell s b) 163 | lower1 f a = lower (f (arg a)) 164 | 165 | -- | Lower a binary 'Prop' computation to a relationship between three cells. 166 | lower2 :: (Prop s a -> Prop s b -> Prop s c) -> Cell s a -> Cell s b -> ST s (Cell s c) 167 | lower2 f a b = lower (f (arg a) (arg b)) 168 | 169 | -- | Run a 'Prop' formula forwards. 170 | -- 171 | -- >>> forwards (\c -> c * 9/5 + 32) 100 172 | -- Just 212.0 173 | forwards :: (Propagated a, Propagated b) => (forall s. Prop s a -> Prop s b) -> a -> Maybe b 174 | forwards f a = runST $ do 175 | x <- cell 176 | y <- lower1 f x 177 | write x a 178 | content y 179 | 180 | -- | Run a 'Prop' formula backwards. 181 | -- 182 | -- >>> backwards (\c -> c * 9/5 + 32) 212 183 | -- Just 100.0 184 | backwards :: (Propagated a, Propagated b) => (forall s. Prop s a -> Prop s b) -> b -> Maybe a 185 | backwards f b = runST $ do 186 | x <- cell 187 | y <- lower1 f x 188 | write y b 189 | content x 190 | -------------------------------------------------------------------------------- /src/Data/Propagator/Supported.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | module Data.Propagator.Supported where 3 | 4 | import Control.Applicative 5 | import Data.HashSet 6 | import Data.Propagator.Class 7 | import Data.Propagator.Name 8 | 9 | data Supported a = Supported !(HashSet Name) a 10 | deriving (Functor, Foldable, Traversable, Show) 11 | 12 | instance Eq a => Eq (Supported a) where 13 | Supported _ a == Supported _ b = a == b 14 | 15 | instance Ord a => Ord (Supported a) where 16 | Supported _ a `compare` Supported _ b = compare a b 17 | 18 | instance Applicative Supported where 19 | pure = Supported mempty 20 | Supported xs a <* Supported ys _ = Supported (union xs ys) a 21 | Supported xs _ *> Supported ys b = Supported (union xs ys) b 22 | Supported xs f <*> Supported ys a = Supported (union xs ys) (f a) 23 | 24 | instance Monad Supported where 25 | return = Supported mempty 26 | (>>) = (*>) 27 | Supported xs a >>= f = case f a of 28 | Supported ys b -> Supported (union xs ys) b 29 | 30 | instance Propagated a => Propagated (Supported a) where 31 | merge (Supported xs a) (Supported ys b) = case merge a b of 32 | Change False c -> Change False (Supported xs c) 33 | Change True c -> Change True (Supported (union xs ys) c) 34 | Contradiction zs s -> Contradiction (zs `union` xs `union` ys) s 35 | 36 | instance Num a => Num (Supported a) where 37 | (+) = liftA2 (+) 38 | (-) = liftA2 (-) 39 | (*) = liftA2 (*) 40 | abs = fmap abs 41 | signum = fmap signum 42 | negate = fmap negate 43 | fromInteger = pure . fromInteger 44 | 45 | instance Fractional a => Fractional (Supported a) where 46 | (/) = liftA2 (/) 47 | recip = fmap recip 48 | fromRational = pure . fromRational 49 | 50 | instance Floating a => Floating (Supported a) where 51 | pi = pure pi 52 | exp = fmap exp 53 | log = fmap log 54 | sqrt = fmap sqrt 55 | logBase = liftA2 logBase 56 | (**) = liftA2 (**) 57 | sin = fmap sin 58 | cos = fmap cos 59 | tan = fmap tan 60 | asin = fmap asin 61 | acos = fmap acos 62 | atan = fmap atan 63 | sinh = fmap sinh 64 | cosh = fmap cosh 65 | tanh = fmap tanh 66 | asinh = fmap asinh 67 | acosh = fmap acosh 68 | atanh = fmap atanh 69 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.9 2 | extra-deps: [unique-0] 3 | --------------------------------------------------------------------------------