unique-logic-tf 0.5.0.2 → 0.5.1

raw patch · 3 files changed

+91/−7 lines, 3 filesdep ~containersdep ~data-refdep ~transformers

Dependency ranges changed: containers, data-ref, transformers

Files

• src/UniqueLogic/ST/TF/Example/Incremental.hs +65/−0
• src/UniqueLogic/ST/TF/System.hs +22/−4
• unique-logic-tf.cabal +4/−3

@@ -0,0 +1,65 @@+{- |+We have a set of variables and equality relations between them.+We want to assign a distinct number to each group of equal variables.+Eventually every variable shall carry its group identifier.++We solve this by an incremental solution.+For every variable we query its identifier.+If it is still unset we discovered a new group.+In this case we generate a new identifier+and solve the system (again) with an additional+equality constraint with respect to the new identifier.++In general it is not a good idea to solve a system incrementally,+because earlier assignments cannot trigger later added assignments.+In this example it works because we add assignments from constants,+that is, we add only new trigger seeds.+-}+module UniqueLogic.ST.TF.Example.Incremental+{-# WARNING "This module is intended for documentation purposes. Do not import it!" #-}+ where++import qualified UniqueLogic.ST.TF.Rule as Rule+import qualified UniqueLogic.ST.TF.System.Simple as Sys++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import Control.Monad.ST (ST, runST, )+++{- |+> a=c+> d=f+> c=e+> b++Groups: {a,c,e}, {d,f}, {b}++> Incremental> example+> [0,1,0,2,0,2]+-}+example :: [Int]+example =+   runST (do+      a <- Sys.globalVariable+      b <- Sys.globalVariable+      c <- Sys.globalVariable+      d <- Sys.globalVariable+      e <- Sys.globalVariable+      f <- Sys.globalVariable+      Sys.solve $ do+         Rule.equ a c+         Rule.equ d f+         Rule.equ c e+      MS.evalStateT (mapM incQuery [a,b,c,d,e,f]) 0)++incQuery :: Sys.Variable (ST s) Int -> MS.StateT Int (ST s) Int+incQuery v = do+   mk <- MT.lift $ Sys.query v+   case mk of+      Just k -> return k+      Nothing -> do+         k <- MS.get+         MS.put (k+1)+         MT.lift $ Sys.solve $ Rule.equ v =<< Sys.constant k+         return k

@@ -19,7 +19,7 @@    constant,    assignment2,    assignment3,-   Apply, arg, runApply, runApplyMaybe,+   Apply, arg, runApply, runApplyMaybe, runApplyM,    -- * Solution    solve, solveDepthFirst, solveBreadthFirst,    query,@@ -30,13 +30,14 @@ import qualified Control.Monad.Trans.Class  as MT import qualified UniqueLogic.ST.TF.MonadTrans as UMT import qualified Data.Sequence as Seq+import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold import qualified Data.Ref as Ref import Control.Monad.Trans.Writer (WriterT, ) import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT, mapMaybeT, ) import Control.Monad.Trans.Identity (IdentityT, ) import Control.Monad (when, liftM, liftM2, ap, guard, join, )-import Control.Applicative (Applicative, liftA2, pure, (<*>), )+import Control.Applicative (Applicative, liftA2, pure, (<*>), (<$>), ) import Data.Sequence (Seq, (|>), ViewL((:<)), ) import Data.Functor.Compose (Compose(Compose)) @@ -228,7 +229,10 @@ readSTRefM = MaybeT . Ref.read  -assignment2 ::+{- |+> assignment2 f a b = runApply (f <$> arg a) b+-}+assignment2, _assignment2 ::    (UMT.C w, Ref.C s) =>    (a -> b) ->    Variable w s a -> Variable w s b ->@@ -239,7 +243,10 @@    in  lift $        Ref.modify al (addUpdate triggerUpdate) -assignment3 ::+{- |+> assignment3 f a b c = runApply (liftA2 f (arg a) (arg b)) c+-}+assignment3, _assignment3 ::    (UMT.C w, Ref.C s) =>    (a -> b -> c) ->    Variable w s a -> Variable w s b -> Variable w s c ->@@ -252,7 +259,10 @@        Ref.modify al (addUpdate triggerUpdate) >>        Ref.modify bl (addUpdate triggerUpdate) +_assignment2 f a b = runApply (f <$> arg a) b+_assignment3 f a b c = runApply (liftA2 f (arg a) (arg b)) c + newtype Apply w s a =    Apply (Compose (MW.Writer [Ref.T s (Updates w s)]) (MaybeT s) a) @@ -297,6 +307,14 @@    case MW.runWriter w of       (mf, refs) ->          runUpdate a (MaybeT $ liftM join $ runMaybeT mf) refs++runApplyM ::+   (UMT.C w, Ref.C s) =>+   Apply w s (s a) -> Variable w s a -> T w s ()+runApplyM (Apply (Compose w)) a =+   case MW.runWriter w of+      (mf, refs) ->+         runUpdate a (MaybeT $ Trav.sequence =<< runMaybeT mf) refs  runUpdate ::    (Ref.C s) =>

@@ -1,5 +1,5 @@ Name:             unique-logic-tf-Version:          0.5.0.2+Version:          0.5.1 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann@@ -25,7 +25,7 @@   .   * "UniqueLogic.ST.TF.System":     Construct and solve sets of functional dependencies.-    Example: @assignment3 (+) a b c@ meaning dependency @a+b -> c@.+    Example: @assignment3 (+) a b c@ means dependency @a+b -> c@.   .   * "UniqueLogic.ST.TF.Rule":     Combine functional dependencies to rules@@ -66,7 +66,7 @@   Changes.md  Source-Repository this-  Tag:         0.5.0.2+  Tag:         0.5.1   Type:        darcs   Location:    http://hub.darcs.net/thielema/unique-logic-tf/ @@ -99,6 +99,7 @@     UniqueLogic.ST.TF.Example.Expression     UniqueLogic.ST.TF.Example.Verify     UniqueLogic.ST.TF.Example.Term+    UniqueLogic.ST.TF.Example.Incremental  Test-Suite test-unique-logic   Type:    exitcode-stdio-1.0