-
-
Save AlphaHot/9d2f0c9f1eabbafadbf315334ff879bc to your computer and use it in GitHub Desktop.
Example Instances of FreeCHR
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
from itertools import permutations | |
def match(pattern, constraints): | |
return (perm | |
for perm in permutations(constraints, len(pattern)) | |
if all(p(c) for p, c in zip(pattern, perm)) | |
) | |
def rule(k, r, g, b): | |
"""Creates a solver from a single CHR rule""" | |
def solver(constraints): | |
matching = next((matching | |
for matching in match(k+r, constraints) | |
if g(*matching)), None) | |
if not matching: | |
return constraints | |
constraints1 = constraints.copy() | |
for c in matching[len(k):]: | |
constraints1.remove(c) | |
return b(*matching) + constraints1 | |
return solver | |
def compose(*solvers): | |
"""Composes solvers, by sequentially applying them to the store, | |
until application changes the state.""" | |
def composite_solver(constraints): | |
to_return = constraints | |
for s in solvers: | |
to_return = s(constraints) | |
if to_return != constraints: | |
break | |
return to_return | |
return composite_solver | |
def run(solver): | |
"""Runs a solver until a fixed point is reached""" | |
def solve(*constraints): | |
cs = list(constraints) | |
to_return = solver(cs) | |
while True: | |
if to_return == cs: | |
break | |
cs = to_return | |
to_return = solver(to_return) | |
return to_return | |
return solve | |
gcd1 = compose( | |
rule([], [lambda n: n <= 0], lambda _: True, lambda _: []), | |
rule([lambda n: n > 0], [lambda m: m > 0], lambda n, m: n <= m, lambda n, m: [m-n]) | |
) | |
fib = rule([], [lambda t: isinstance(t, tuple) and len(t) == 2], | |
lambda _: True, | |
lambda t: [(t[1],t[0]+t[1])] | |
) | |
nub = rule([lambda a: True], [lambda b: True], lambda a, b: a == b, lambda a, b: []) | |
def false(*args): | |
raise Exception(False) | |
all_different = rule( | |
[lambda a: True, lambda b: True], [], | |
lambda a, b: a == b, | |
false | |
) |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
import Data.List | |
import Data.Functor.Identity | |
import Control.Monad.Writer | |
newtype SolverStep m c = SolverStep { runSolverStep :: [c] -> m [c] } | |
instance (Monad m, Eq c) => Semigroup (SolverStep m c) where | |
solve <> solve' = SolverStep { | |
runSolverStep = \store -> do | |
store' <- runSolverStep solve store | |
if store == store' | |
then runSolverStep solve' store | |
else pure store' | |
} | |
match :: [a -> Bool] -> [a] -> [[a]] | |
match ps as = [ as'' | | |
as' <- subsequences as, | |
length as' == length ps, | |
as'' <- permutations as', | |
and (zipWith ($) ps as'')] | |
rule :: (Monad m, Eq c) | |
=> [c -> Bool] -> [c -> Bool] | |
-> ([c] -> m Bool) | |
-> ([c] -> [m [c]]) | |
-> SolverStep m c | |
rule kept removed guard body = SolverStep { runSolverStep = solver } | |
where | |
solver store = do | |
matching <- findM (\(ks, rs) -> guard $ ks <> rs) heads | |
case matching of | |
Just (ks, rs) -> do | |
query <- concat <$> sequence (body (ks <> rs)) | |
pure $ query <> (store \\ rs) | |
_ -> pure store | |
where | |
heads = [ (ks, rs) | | |
rs <- match removed store, | |
ks <- match kept (store \\ rs) ] | |
(<.>) :: (Monad m, Eq c) => SolverStep m c -> SolverStep m c -> SolverStep m c | |
(<.>) = (<>) | |
run :: (Monad m, Eq c) => SolverStep m c -> [c] -> m [c] | |
run solver query = do | |
result <- runSolverStep solver query | |
if result == query | |
then pure result | |
else run solver result | |
gcd' :: SolverStep Identity Int | |
gcd' = | |
rule [] [(<= 0)] (const (pure True)) (const []) <.> | |
rule [(> 0)] [(> 0)] (\[n, m] -> pure $ n <= m) (\[n, m] -> [pure [m - n]]) | |
allDifferent :: Eq a => SolverStep Maybe a | |
allDifferent = rule [] [const True, const True] | |
(\[a, b] -> pure $ a == b) | |
(const $ [Nothing]) | |
fibs :: SolverStep (Writer [Int]) (Int, Int) | |
fibs = | |
rule [] [const True] (const (pure True)) | |
(\[(x,y)] -> [tell [x] >> pure [(y,x+y)]]) | |
-- Taken from https://hackage.haskell.org/package/extra-1.7.12/docs/src/Control.Monad.Extra.html#findM | |
findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) | |
findM p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing) | |
-- Taken from https://hackage.haskell.org/package/extra-1.7.12/docs/src/Control.Monad.Extra.html#ifM | |
ifM :: Monad m => m Bool -> m a -> m a -> m a | |
ifM b t f = do b <- b; if b then t else f |
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
import Data.List | |
import Data.Functor.Identity | |
newtype SolverStep c = SolverStep { runSolverStep :: [c] -> [c] } | |
instance Eq c => Semigroup (SolverStep c) where | |
solve <> solve' = SolverStep { | |
runSolverStep = \store -> | |
let store' = runSolverStep solve store | |
in if store == store' | |
then runSolverStep solve' store | |
else store' | |
} | |
match :: [a -> Bool] -> [a] -> [[a]] | |
match ps as = [ as'' | | |
as' <- subsequences as, | |
length as' == length ps, | |
as'' <- permutations as', | |
and (zipWith ($) ps as'')] | |
rule :: Eq c | |
=> [c -> Bool] -> [c -> Bool] | |
-> ([c] -> Bool) | |
-> ([c] -> [[c]]) | |
-> SolverStep c | |
rule kept removed guard body = SolverStep { runSolverStep = solver } | |
where | |
solver store = | |
case matching of | |
Just (ks, rs) -> | |
let query = concat (body (ks <> rs)) | |
in query <> (store \\ rs) | |
_ -> store | |
where | |
matching = find (\(ks, rs) -> guard $ ks <> rs) heads | |
heads = [ (ks, rs) | | |
rs <- match removed store, | |
ks <- match kept (store \\ rs) ] | |
(<.>) :: Eq c => SolverStep c -> SolverStep c -> SolverStep c | |
(<.>) = (<>) | |
run :: Eq c => SolverStep c -> [c] -> [c] | |
run solver query | |
| result == query = result | |
| otherwise = run solver result | |
where | |
result = runSolverStep solver query | |
gcd' :: SolverStep Int | |
gcd' = | |
rule [] [(<= 0)] (const True) (const []) <.> | |
rule [(> 0)] [(> 0)] (\[n, m] -> n <= m) (\[n, m] -> [[m - n]]) | |
-- Taken from https://hackage.haskell.org/package/extra-1.7.12/docs/src/Control.Monad.Extra.html#findM | |
findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) | |
findM p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing) | |
-- Taken from https://hackage.haskell.org/package/extra-1.7.12/docs/src/Control.Monad.Extra.html#ifM | |
ifM :: Monad m => m Bool -> m a -> m a -> m a | |
ifM b t f = do b <- b; if b then t else f |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment