Example Instances of FreeCHR

FreeCHR.py

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
)

FreeCHR_monadic.hs

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

FreeCHR_pure.hs

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