ideas 1.5 → 1.6

raw patch · 104 files changed

+2935/−3854 lines, 104 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.txt +22/−0
• ideas.cabal +15/−22
• src/Ideas/Common/Algebra/Boolean.hs +0/−164
• src/Ideas/Common/Algebra/BooleanLaws.hs +0/−108
• src/Ideas/Common/Algebra/Field.hs +0/−237
• src/Ideas/Common/Algebra/FieldLaws.hs +0/−111
• src/Ideas/Common/Algebra/Group.hs +0/−196
• src/Ideas/Common/Algebra/GroupLaws.hs +0/−150
• src/Ideas/Common/Algebra/Law.hs +0/−78
• src/Ideas/Common/Algebra/SmartGroup.hs +0/−198
• src/Ideas/Common/Classes.hs +57/−0
• src/Ideas/Common/Context.hs +8/−9
• src/Ideas/Common/CyclicTree.hs +0/−218
• src/Ideas/Common/Environment.hs +43/−31
• src/Ideas/Common/Exercise.hs +46/−30
• src/Ideas/Common/ExerciseTests.hs +3/−3
• src/Ideas/Common/Id.hs +2/−5
• src/Ideas/Common/Library.hs +2/−1
• src/Ideas/Common/Predicate.hs +1/−1
• src/Ideas/Common/Rewriting/Confluence.hs +1/−1
• src/Ideas/Common/Rewriting/RewriteRule.hs +1/−1
• src/Ideas/Common/Rewriting/Substitution.hs +3/−3
• src/Ideas/Common/Rewriting/Term.hs +51/−17
• src/Ideas/Common/Rewriting/Unification.hs +2/−2
• src/Ideas/Common/Rule.hs +0/−1
• src/Ideas/Common/Rule/Abstract.hs +2/−9
• src/Ideas/Common/Rule/EnvironmentMonad.hs +0/−132
• src/Ideas/Common/Rule/Parameter.hs +100/−25
• src/Ideas/Common/Rule/Recognizer.hs +3/−7
• src/Ideas/Common/Rule/Transformation.hs +59/−57
• src/Ideas/Common/Strategy.hs +1/−1
• src/Ideas/Common/Strategy/Abstract.hs +18/−16
• src/Ideas/Common/Strategy/Combinators.hs +8/−3
• src/Ideas/Common/Strategy/Configuration.hs +8/−8
• src/Ideas/Common/Strategy/CyclicTree.hs +217/−0
• src/Ideas/Common/Strategy/Derived.hs +16/−44
• src/Ideas/Common/Strategy/Location.hs +1/−1
• src/Ideas/Common/Strategy/Prefix.hs +43/−15
• src/Ideas/Common/Strategy/StrategyTree.hs +97/−9
• src/Ideas/Common/Traversal/Navigator.hs +11/−11
• src/Ideas/Common/Traversal/Tests.hs +11/−11
• src/Ideas/Common/Traversal/Utils.hs +5/−5
• src/Ideas/Common/Utils.hs +0/−128
• src/Ideas/Common/Utils/QuickCheck.hs +0/−102
• src/Ideas/Common/Utils/StringRef.hs +0/−136
• src/Ideas/Common/Utils/TestSuite.hs +0/−420
• src/Ideas/Common/Utils/Uniplate.hs +0/−25
• src/Ideas/Common/View.hs +1/−2
• src/Ideas/Encoding/DecoderJSON.hs +9/−8
• src/Ideas/Encoding/DecoderXML.hs +7/−8
• src/Ideas/Encoding/Encoder.hs +117/−99
• src/Ideas/Encoding/EncoderHTML.hs +35/−30
• src/Ideas/Encoding/EncoderJSON.hs +8/−11
• src/Ideas/Encoding/EncoderXML.hs +1/−2
• src/Ideas/Encoding/Evaluator.hs +9/−8
• src/Ideas/Encoding/LinkManager.hs +11/−88
• src/Ideas/Encoding/Logging.hs +187/−0
• src/Ideas/Encoding/ModeJSON.hs +29/−25
• src/Ideas/Encoding/ModeXML.hs +26/−21
• src/Ideas/Encoding/OpenMathSupport.hs +3/−3
• src/Ideas/Encoding/Options.hs +73/−0
• src/Ideas/Encoding/Request.hs +130/−0
• src/Ideas/Encoding/RulePresenter.hs +0/−1
• src/Ideas/Encoding/RulesInfo.hs +0/−1
• src/Ideas/Encoding/StrategyInfo.hs +1/−1
• src/Ideas/Main/BlackBoxTests.hs +0/−116
• src/Ideas/Main/CmdLineOptions.hs +80/−0
• src/Ideas/Main/Default.hs +46/−33
• src/Ideas/Main/Documentation.hs +0/−62
• src/Ideas/Main/Logging.hs +0/−187
• src/Ideas/Main/Options.hs +0/−83
• src/Ideas/Main/Revision.hs +3/−3
• src/Ideas/Service/BasicServices.hs +38/−7
• src/Ideas/Service/Diagnose.hs +16/−11
• src/Ideas/Service/DomainReasoner.hs +3/−9
• src/Ideas/Service/FeedbackScript/Analysis.hs +1/−2
• src/Ideas/Service/FeedbackScript/Parser.hs +1/−1
• src/Ideas/Service/FeedbackScript/Run.hs +6/−7
• src/Ideas/Service/FeedbackScript/Syntax.hs +1/−1
• src/Ideas/Service/FeedbackText.hs +4/−4
• src/Ideas/Service/ProblemDecomposition.hs +1/−1
• src/Ideas/Service/Request.hs +0/−115
• src/Ideas/Service/ServiceList.hs +7/−2
• src/Ideas/Service/Submit.hs +10/−1
• src/Ideas/Service/Types.hs +1/−2
• src/Ideas/Text/HTML.hs +1/−1
• src/Ideas/Text/JSON.hs +8/−8
• src/Ideas/Text/Latex.hs +75/−0
• src/Ideas/Text/OpenMath/Object.hs +4/−4
• src/Ideas/Text/OpenMath/Tests.hs +5/−5
• src/Ideas/Text/Parsing.hs +0/−120
• src/Ideas/Text/UTF8.hs +3/−3
• src/Ideas/Text/XML.hs +6/−3
• src/Ideas/Text/XML/Document.hs +1/−1
• src/Ideas/Text/XML/Interface.hs +1/−1
• src/Ideas/Text/XML/Parser.hs +1/−1
• src/Ideas/Utils/BlackBoxTests.hs +110/−0
• src/Ideas/Utils/Parsing.hs +120/−0
• src/Ideas/Utils/Prelude.hs +127/−0
• src/Ideas/Utils/QuickCheck.hs +102/−0
• src/Ideas/Utils/StringRef.hs +134/−0
• src/Ideas/Utils/TestSuite.hs +420/−0
• src/Ideas/Utils/Typeable.hs +70/−0
• src/Ideas/Utils/Uniplate.hs +25/−0

@@ -1,3 +1,25 @@+Changelog ideas-1.5 => ideas.1.6++* dynamic strategy combinator that uses the current object/term+* more instances for IsTerm (Maybe, Bool, Map, Set)+* exercise-specific properties (that can be parameterized over its type)+* support for encoding exercise terms in JSON (using an exercise property)+* basic support for Latex and MathJax (in html output)+* extended 'apply' feedback service with buggy rules and restarts+* redesigned (parameterized) transformations+* reimplemented strategy combinator split, based on %>>+* new function defaultMainWith, which takes options+* added 'onefinal' feedback service, which returns a final term in context+* layered design for sub-directories: renaming/moving some modules +  (e.g. Ideas.Utils.Prelude)+* Typeable constraint now properly encapsulated in Ref type+* removing (static) documentation generation (unused feature)+* removing Common.Algebra modules (now in the Math domain reasoner)+* fixed escaping of characters in xml+* fixed recognition of exercise IDs in ModeJSON+* fixed processing of Null in EncoderJSON+* fixed rule ordering in function ruleset+  Changelog ideas-1.4 => ideas.1.5  * upgrade to ghc-7.10

@@ -1,5 +1,5 @@ name:                   ideas-version:                1.5+version:                1.6 synopsis:               Feedback services for intelligent tutoring systems homepage:               http://ideas.cs.uu.nl/www/ description:@@ -63,17 +63,8 @@      wl-pprint    Exposed-modules:-    Ideas.Common.Algebra.Boolean-    Ideas.Common.Algebra.BooleanLaws-    Ideas.Common.Algebra.Field-    Ideas.Common.Algebra.FieldLaws-    Ideas.Common.Algebra.Group-    Ideas.Common.Algebra.GroupLaws-    Ideas.Common.Algebra.Law-    Ideas.Common.Algebra.SmartGroup     Ideas.Common.Classes     Ideas.Common.Context-    Ideas.Common.CyclicTree     Ideas.Common.Derivation     Ideas.Common.DerivationTree     Ideas.Common.Environment@@ -92,7 +83,6 @@     Ideas.Common.Rewriting.Unification     Ideas.Common.Rule     Ideas.Common.Rule.Abstract-    Ideas.Common.Rule.EnvironmentMonad     Ideas.Common.Rule.Parameter     Ideas.Common.Rule.Recognizer     Ideas.Common.Rule.Transformation@@ -101,6 +91,7 @@     Ideas.Common.Strategy.Choice     Ideas.Common.Strategy.Combinators     Ideas.Common.Strategy.Configuration+    Ideas.Common.Strategy.CyclicTree     Ideas.Common.Strategy.Derived     Ideas.Common.Strategy.Legacy     Ideas.Common.Strategy.Location@@ -114,11 +105,6 @@     Ideas.Common.Traversal.Navigator     Ideas.Common.Traversal.Tests     Ideas.Common.Traversal.Utils-    Ideas.Common.Utils-    Ideas.Common.Utils.QuickCheck-    Ideas.Common.Utils.StringRef-    Ideas.Common.Utils.TestSuite-    Ideas.Common.Utils.Uniplate     Ideas.Common.View     Ideas.Encoding.DecoderJSON     Ideas.Encoding.DecoderXML@@ -128,17 +114,17 @@     Ideas.Encoding.EncoderXML     Ideas.Encoding.Evaluator     Ideas.Encoding.LinkManager+    Ideas.Encoding.Logging     Ideas.Encoding.ModeJSON     Ideas.Encoding.ModeXML     Ideas.Encoding.OpenMathSupport+    Ideas.Encoding.Options+    Ideas.Encoding.Request     Ideas.Encoding.RulePresenter     Ideas.Encoding.RulesInfo     Ideas.Encoding.StrategyInfo-    Ideas.Main.BlackBoxTests+    Ideas.Main.CmdLineOptions     Ideas.Main.Default-    Ideas.Main.Documentation-    Ideas.Main.Logging-    Ideas.Main.Options     Ideas.Main.Revision     Ideas.Service.BasicServices     Ideas.Service.Diagnose@@ -149,13 +135,13 @@     Ideas.Service.FeedbackScript.Syntax     Ideas.Service.FeedbackText     Ideas.Service.ProblemDecomposition-    Ideas.Service.Request     Ideas.Service.ServiceList     Ideas.Service.State     Ideas.Service.Submit     Ideas.Service.Types     Ideas.Text.HTML     Ideas.Text.JSON+    Ideas.Text.Latex     Ideas.Text.OpenMath.Dictionary.Arith1     Ideas.Text.OpenMath.Dictionary.Calculus1     Ideas.Text.OpenMath.Dictionary.Fns1@@ -170,13 +156,20 @@     Ideas.Text.OpenMath.Object     Ideas.Text.OpenMath.Symbol     Ideas.Text.OpenMath.Tests-    Ideas.Text.Parsing     Ideas.Text.UTF8     Ideas.Text.XML     Ideas.Text.XML.Document     Ideas.Text.XML.Interface     Ideas.Text.XML.Parser     Ideas.Text.XML.Unicode+    Ideas.Utils.BlackBoxTests+    Ideas.Utils.Parsing+    Ideas.Utils.Prelude+    Ideas.Utils.QuickCheck+    Ideas.Utils.StringRef+    Ideas.Utils.TestSuite+    Ideas.Utils.Typeable+    Ideas.Utils.Uniplate  -------------------------------------------------------------------------------- 

@@ -1,164 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Algebra.Boolean
-   ( -- * Boolean algebra
-     BoolValue(..), Boolean(..)
-   , ands, ors, implies, equivalent
-     -- * CoBoolean (matching)
-   , CoBoolean(..), conjunctions, disjunctions
-     -- * Monoids monoid
-   , DualMonoid(..), And(..), Or(..)
-   ) where
-
-import Control.Applicative
-import Ideas.Common.Algebra.Group
-import Ideas.Common.Classes
-import Test.QuickCheck
-
---------------------------------------------------------
--- Boolean algebra
-
--- Minimal complete definitions: (true/false, or fromBool) and isTrue/isFalse
-class BoolValue a where
-   true     :: a
-   false    :: a
-   fromBool :: Bool -> a
-   isTrue   :: a -> Bool
-   isFalse  :: a -> Bool
-   -- default definitions
-   true  = fromBool True
-   false = fromBool False
-   fromBool b = if b then true else false
-
-class BoolValue a => Boolean a where
-   (<&&>)     :: a -> a -> a
-   (<||>)     :: a -> a -> a
-   complement :: a -> a
-
-instance BoolValue Bool where
-   fromBool = id
-   isTrue   = id
-   isFalse  = not
-
-instance BoolValue b => BoolValue (a -> b) where
-   fromBool x = const (fromBool x)
-   isTrue  = error "not implemented"
-   isFalse = error "not implemented"
-
-instance Boolean Bool where
-   (<&&>)     = (&&)
-   (<||>)     = (||)
-   complement = not
-
-instance Boolean b => Boolean (a -> b) where
-   f <&&> g   = \x -> f x <&&> g x
-   f <||> g   = \x -> f x <||> g x
-   complement = (.) complement
-
-ands :: Boolean a => [a] -> a -- or use mconcat with And monoid
-ands xs | null xs   = true
-        | otherwise = foldr1 (<&&>) xs
-
-ors :: Boolean a => [a] -> a
-ors xs | null xs   = false
-       | otherwise = foldr1 (<||>) xs
-
-implies :: Boolean a => a -> a -> a
-implies a b = complement a <||> b
-
-equivalent :: Boolean a => a -> a -> a
-equivalent a b = (a <&&> b) <||> (complement a <&&> complement b)
-
---------------------------------------------------------
--- CoBoolean (matching)
-
-class BoolValue a => CoBoolean a where
-   isAnd        :: a -> Maybe (a, a)
-   isOr         :: a -> Maybe (a, a)
-   isComplement :: a -> Maybe a
-
-instance CoBoolean a => CoMonoid (And a) where
-   isEmpty  = isTrue . fromAnd
-   isAppend = fmap (mapBoth And) . isAnd . fromAnd
-
-instance CoBoolean a => CoMonoidZero (And a) where
-   isMonoidZero = isFalse . fromAnd
-
-instance CoBoolean a => CoMonoid (Or a) where
-   isEmpty  = isFalse . fromOr
-   isAppend = fmap (mapBoth Or) . isOr . fromOr
-
-instance CoBoolean a => CoMonoidZero (Or a) where
-   isMonoidZero = isTrue . fromOr
-
-conjunctions :: CoBoolean a => a -> [a]
-conjunctions = map fromAnd . associativeList . And
-
-disjunctions :: CoBoolean a => a -> [a]
-disjunctions = map fromOr . associativeList . Or
-
---------------------------------------------------------
--- Dual monoid for a monoid (and for or, and vice versa)
-
-class MonoidZero a => DualMonoid a where
-   (><)      :: a -> a -> a
-   dualCompl :: a -> a
-
---------------------------------------------------------
--- And monoid
-
-newtype And a = And {fromAnd :: a}
-   deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)
-
-instance Functor And where -- could be derived
-   fmap f = And . f . fromAnd
-
-instance Applicative And where
-   pure            = And
-   And f <*> And a = And (f a)
-
-instance Boolean a => Monoid (And a) where
-   mempty  = pure true
-   mappend = liftA2 (<&&>)
-
-instance Boolean a => MonoidZero (And a) where
-   mzero = pure false
-
-instance Boolean a => DualMonoid (And a) where
-   (><)      = liftA2 (<||>)
-   dualCompl = liftA complement
-
---------------------------------------------------------
--- Or monoid
-
-newtype Or a  = Or {fromOr :: a}
-   deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)
-
-instance Functor Or where -- could be derived
-   fmap f = Or . f . fromOr
-
-instance Applicative Or where
-   pure          = Or
-   Or f <*> Or a = Or (f a)
-
-instance Boolean a => Monoid (Or a) where
-   mempty  = pure false
-   mappend = liftA2 (<||>)
-
-instance Boolean a => MonoidZero (Or a) where
-   mzero = pure true
-
-instance Boolean a => DualMonoid (Or a) where
-   (><)      = liftA2 (<&&>)
-   dualCompl = liftA complement

@@ -1,108 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Algebra.BooleanLaws
-   ( -- * Boolean laws
-     andOverOrLaws, orOverAndLaws
-   , complementAndLaws, complementOrLaws
-   , absorptionAndLaws, absorptionOrLaws
-   , deMorganAnd, deMorganOr
-   , doubleComplement, complementTrue, complementFalse
-   , booleanLaws
-     -- * Law transformer
-   , fromAndLaw, fromOrLaw
-     -- * Properties
-   , propsBoolean
-   ) where
-
-import Ideas.Common.Algebra.Boolean
-import Ideas.Common.Algebra.Group
-import Ideas.Common.Algebra.GroupLaws
-import Ideas.Common.Algebra.Law
-import Test.QuickCheck hiding ((><))
-
---------------------------------------------------------
--- Boolean laws
-
-andOverOrLaws, orOverAndLaws :: Boolean a => [Law a]
-andOverOrLaws = map fromAndLaw dualDistributive
-orOverAndLaws = map fromOrLaw  dualDistributive
-
-complementAndLaws, complementOrLaws :: Boolean a => [Law a]
-complementAndLaws = map fromAndLaw dualComplement
-complementOrLaws  = map fromOrLaw  dualComplement
-
-absorptionAndLaws, absorptionOrLaws :: Boolean a => [Law a]
-absorptionAndLaws = map fromAndLaw dualAbsorption
-absorptionOrLaws  = map fromOrLaw  dualAbsorption
-
-deMorganAnd, deMorganOr :: Boolean a => Law a
-deMorganAnd = fromAndLaw deMorgan
-deMorganOr  = fromOrLaw  deMorgan
-
-doubleComplement :: Boolean a => Law a
-doubleComplement = law "double-complement" $ \a ->
-   complement (complement a) :==: a
-
-complementTrue, complementFalse :: Boolean a => Law a
-complementTrue  = fromAndLaw dualTrueFalse
-complementFalse = fromOrLaw  dualTrueFalse
-
-booleanLaws :: Boolean a => [Law a]
-booleanLaws =
-   map fromAndLaw (idempotent : zeroLaws ++ commutativeMonoidLaws) ++
-   map fromOrLaw  (idempotent : zeroLaws ++ commutativeMonoidLaws) ++
-   andOverOrLaws ++ orOverAndLaws ++ complementAndLaws ++ complementOrLaws ++
-   absorptionAndLaws ++ absorptionOrLaws ++
-   [deMorganAnd, deMorganOr, doubleComplement, complementTrue, complementFalse]
-
---------------------------------------------------------
--- Dual laws
-
-dualDistributive :: DualMonoid a => [Law a]
-dualDistributive =
-   [leftDistributiveFor (<>) (><), rightDistributiveFor (<>) (><)]
-
-dualAbsorption :: DualMonoid a => [Law a]
-dualAbsorption =
-   [ law "absorption" $ \a b -> a `f` (a `g` b) :==: a
-   | f <- [(<>), flip (<>)]
-   , g <- [(><), flip (><)]
-   ]
-
-dualComplement :: DualMonoid a => [Law a]
-dualComplement =
-   [ law "complement" $ \a -> dualCompl a <> a :==: mzero
-   , law "complement" $ \a -> a <> dualCompl a :==: mzero
-   ]
-
-dualTrueFalse :: DualMonoid a => Law a
-dualTrueFalse = law "true-false" $ dualCompl mempty :==: mzero
-
-deMorgan :: DualMonoid a => Law a
-deMorgan = law "demorgan" $ \a b ->
-   dualCompl (a <> b) :==: dualCompl a >< dualCompl b
-
---------------------------------------------------------
--- And laws
-
-fromAndLaw :: Law (And a) -> Law a
-fromAndLaw = mapLaw And fromAnd
-
-fromOrLaw :: Law (Or a) -> Law a
-fromOrLaw = mapLaw Or fromOr
-
---------------------------------------------------------
--- Tests for Bool instance
-
-propsBoolean :: [Property]
-propsBoolean = map property (booleanLaws :: [Law Bool])

@@ -1,237 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Algebra.Field
-   ( -- * Semi-ring
-     SemiRing(..)
-     -- * Ring
-   , Ring(..)
-     -- * Field
-   , Field(..)
-     -- * Additive monoid
-   , Additive(..)
-     -- * Multiplicative monoid
-   , Multiplicative(..)
-     -- * Datatype for safe numeric operators
-   , SafeNum, safeNum
-     -- * CoSemiRing, CoRing, and CoField (for matching)
-   , CoSemiRing(..), CoRing(..), CoField(..)
-   ) where
-
-import Control.Monad
-import Ideas.Common.Algebra.Group
-import Ideas.Common.Classes (mapBoth)
-import Test.QuickCheck
-import qualified Control.Applicative as A
-import qualified Control.Applicative as Applicative
-
---------------------------------------------------------
--- Semi-ring
-
-infixl 6 |+|
-infixl 7 |*|
-
-class SemiRing a where
-   -- additive
-   (|+|) :: a -> a -> a
-   zero  :: a
-   sum   :: [a] -> a
-   -- multiplicative
-   (|*|)   :: a -> a -> a
-   one     :: a
-   product :: [a] -> a
-   -- default implementation
-   sum     [] = zero
-   sum     xs = foldl1 (|+|) xs
-   product [] = one
-   product xs = foldl1 (|*|) xs
-
---------------------------------------------------------
--- Ring
-
-infixl 6 |-|
-
--- Minimal complete definition: plusInverse or <->
-class SemiRing a => Ring a where
-   plusInverse :: a -> a
-   (|-|)       :: a -> a -> a
-   -- default definitions
-   plusInverse = (zero |-|)
-   a |-| b     = a |+| plusInverse b
-
---------------------------------------------------------
--- Field
-
-infixl 7 |/|
-
--- Minimal complete definition: mulInverse or </>
-class Ring a => Field a where
-   timesInverse :: a -> a
-   (|/|)        :: a -> a -> a
-   -- default definitions
-   timesInverse = (one |/|)
-   a |/| b      = a |*| timesInverse b
-
---------------------------------------------------------
--- Additive monoid
-
-newtype Additive a = Additive {fromAdditive :: a}
-   deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)
-
-instance Functor Additive where -- could be derived
-   fmap f = Additive . f . fromAdditive
-
-instance A.Applicative Additive where
-   pure = Additive
-   Additive f <*> Additive a = Additive (f a)
-
-instance SemiRing a => Monoid (Additive a) where
-   mempty  = A.pure zero
-   mappend = A.liftA2 (|+|)
-
-instance Ring a => Group (Additive a) where
-   inverse   = A.liftA plusInverse
-   appendInv = A.liftA2 (|-|)
-
---------------------------------------------------------
--- Multiplicative monoid
-
-newtype Multiplicative a = Multiplicative {fromMultiplicative :: a}
-   deriving (Show, Eq, Ord, Arbitrary, CoArbitrary)
-
-instance Functor Multiplicative where -- could be derived
-   fmap f = Multiplicative . f . fromMultiplicative
-
-instance A.Applicative Multiplicative where
-   pure = Multiplicative
-   Multiplicative f <*> Multiplicative a = Multiplicative (f a)
-
-instance SemiRing a => Monoid (Multiplicative a) where
-   mempty  = A.pure one
-   mappend = A.liftA2 (|*|)
-
-instance Field a => Group (Multiplicative a) where
-   inverse   = A.liftA timesInverse
-   appendInv = A.liftA2 (|/|)
-
-instance SemiRing a => MonoidZero (Multiplicative a) where
-   mzero = Multiplicative zero
-
---------------------------------------------------------
--- Datatype for safe numeric operators
-
-data SafeNum a = Ok a | Exception String
-
-safeNum :: SafeNum a -> Either String a
-safeNum (Ok a)        = Right a
-safeNum (Exception s) = Left s
-
-instance Arbitrary a => Arbitrary (SafeNum a) where
-   arbitrary = liftM return arbitrary
-
-instance Eq a => Eq (SafeNum a) where
-   Ok a == Ok b = a == b
-   _    == _    = True
-
-instance Ord a => Ord (SafeNum a) where
-   Ok a `compare` Ok b = a `compare` b
-   _    `compare` _    = EQ
-
-instance Show a => Show (SafeNum a) where
-   show = either ("Exception: " ++) show . safeNum
-
-instance Functor SafeNum where
-   fmap f = either Exception (return . f) . safeNum
-
-instance Applicative.Applicative SafeNum where
-   pure  = return
-   (<*>) = ap
-
-instance Monad SafeNum where
-   return  = Ok
-   fail    = Exception
-   m >>= f = either Exception f (safeNum m)
-
-instance Num a => Num (SafeNum a) where
-   (+) = liftM2 (+)
-   (*) = liftM2 (*)
-   (-) = liftM2 (-)
-   negate = liftM negate
-   abs    = liftM abs
-   signum = liftM signum
-   fromInteger = return . fromInteger
-
-instance (Eq a, Fractional a) => Fractional (SafeNum a) where
-   a / b = liftM2 (/) a (safeDivisor b)
-   recip = liftM recip . safeDivisor
-   fromRational = return . fromRational
-
-instance Num a => SemiRing (SafeNum a) where
-   (|+|) = (+)
-   (|*|) = (*)
-   zero  = 0
-   one   = 1
-
-instance Num a => Ring (SafeNum a) where
-   plusInverse = negate
-   (|-|)       = (-)
-
-instance (Eq a, Fractional a) => Field (SafeNum a) where
-   timesInverse = recip
-   (|/|)        = (/)
-
-safeDivisor :: (Eq a, Num a) => SafeNum a -> SafeNum a
-safeDivisor m = m >>= \a ->
-   if a == 0 then fail "division by zero" else return a
-
-------------------------------------------------------------
-
-class CoSemiRing a where
-   -- additive
-   isPlus  :: a -> Maybe (a, a)
-   isZero  :: a -> Bool
-   -- multiplicative
-   isTimes :: a -> Maybe (a, a)
-   isOne   :: a -> Bool
-
--- Minimal complete definition: plusInverse or <->
-class CoSemiRing a => CoRing a where
-   isNegate :: a -> Maybe a
-   isMinus  :: a -> Maybe (a, a)
-   -- default definition
-   isMinus _ = Nothing
-
-class CoRing a => CoField a where
-   isRecip    :: a -> Maybe a
-   isDivision :: a -> Maybe (a, a)
-   -- default definition
-   isDivision _ = Nothing
-
-instance CoSemiRing a => CoMonoid (Additive a) where
-   isEmpty  = isZero . fromAdditive
-   isAppend = fmap (mapBoth Additive) . isPlus . fromAdditive
-
-instance CoRing a => CoGroup (Additive a) where
-   isInverse   = fmap Additive . isNegate . fromAdditive
-   isAppendInv = fmap (mapBoth Additive) . isMinus . fromAdditive
-
-instance CoSemiRing a => CoMonoid (Multiplicative a) where
-   isEmpty  = isOne . fromMultiplicative
-   isAppend = fmap (mapBoth Multiplicative) . isTimes . fromMultiplicative
-
-instance CoField a => CoGroup (Multiplicative a) where
-   isInverse   = fmap Multiplicative . isRecip . fromMultiplicative
-   isAppendInv = fmap (mapBoth Multiplicative) . isDivision . fromMultiplicative
-
-instance CoSemiRing a => CoMonoidZero (Multiplicative a) where
-   isMonoidZero = isZero . fromMultiplicative

@@ -1,111 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Algebra.FieldLaws
-   ( -- * Semi-ring laws
-     leftDistributive, rightDistributive
-   , distributiveLaws, semiRingLaws
-     -- * Ring laws
-   , leftNegateTimes, rightNegateTimes
-   , negateTimesLaws, ringLaws, commutativeRingLaws
-   , distributiveSubtractionLaws
-     -- * Field laws
-   , exchangeInverses, fieldLaws
-     -- * Laws for additive monoid
-   , fromAdditiveLaw
-     -- * Laws for multiplicative monoid
-   , fromMultiplicativeLaw
-     -- * Properties
-   , propsField
-   ) where
-
-import Ideas.Common.Algebra.Field
-import Ideas.Common.Algebra.GroupLaws
-import Ideas.Common.Algebra.Law
-import Test.QuickCheck
-
---------------------------------------------------------
--- Semi-ring laws
-
-leftDistributive :: SemiRing a => Law a
-leftDistributive = leftDistributiveFor (|*|) (|+|)
-
-rightDistributive :: SemiRing a => Law a
-rightDistributive = rightDistributiveFor (|*|) (|+|)
-
-distributiveLaws :: SemiRing a => [Law a]
-distributiveLaws = [leftDistributive, rightDistributive]
-
-semiRingLaws :: SemiRing a => [Law a]
-semiRingLaws =
-   map fromAdditiveLaw commutativeMonoidLaws ++
-   map fromMultiplicativeLaw monoidZeroLaws ++
-   distributiveLaws
-
---------------------------------------------------------
--- Ring laws
-
-leftNegateTimes :: Ring a => Law a
-leftNegateTimes = law "left-negate-times" $ \a b ->
-   plusInverse a |*| b :==: plusInverse (a |*| b)
-
-rightNegateTimes :: Ring a => Law a
-rightNegateTimes = law "right-negate-times" $ \a b ->
-   a |*| plusInverse b :==: plusInverse (a |*| b)
-
-negateTimesLaws :: Ring a => [Law a]
-negateTimesLaws = [leftNegateTimes, rightNegateTimes]
-
-ringLaws :: Ring a => [Law a]
-ringLaws =
-   map fromAdditiveLaw abelianGroupLaws ++
-   map fromMultiplicativeLaw monoidZeroLaws ++
-   distributiveLaws ++ negateTimesLaws
-
-commutativeRingLaws :: Ring a => [Law a]
-commutativeRingLaws =
-   fromMultiplicativeLaw commutative : ringLaws
-
-distributiveSubtractionLaws :: Ring a => [Law a]
-distributiveSubtractionLaws =
-   [leftDistributiveFor (|*|) (|-|), rightDistributiveFor (|*|) (|-|)]
-
---------------------------------------------------------
--- Field laws
-
-exchangeInverses :: Field a => Law a
-exchangeInverses = law "exchange-inverses" $ \a ->
-   timesInverse (plusInverse a) :==: plusInverse (timesInverse a)
-
-fieldLaws :: Field a => [Law a]
-fieldLaws =
-   map fromAdditiveLaw abelianGroupLaws ++
-   map fromMultiplicativeLaw abelianGroupLaws ++
-   distributiveLaws ++ negateTimesLaws ++ [exchangeInverses]
-
---------------------------------------------------------
--- Laws for additive monoid
-
-fromAdditiveLaw :: Law (Additive a) -> Law a
-fromAdditiveLaw = mapLaw Additive fromAdditive
-
---------------------------------------------------------
--- Laws for multiplicative monoid
-
-fromMultiplicativeLaw :: Law (Multiplicative a) -> Law a
-fromMultiplicativeLaw = mapLaw Multiplicative fromMultiplicative
-
---------------------------------------------------------
--- Properties
-
-propsField :: [Property]
-propsField = map property (fieldLaws :: [Law (SafeNum Rational)])

@@ -1,196 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Algebra.Group
-   ( -- * Monoids
-     Monoid(..), (<>)
-     -- * Groups
-   , Group(..), (<>-)
-     -- * Monoids with a zero element
-   , MonoidZero(..), WithZero, fromWithZero
-     -- * CoMonoid, CoGroup, and CoMonoidZero (for matching)
-   , CoMonoid(..), CoGroup(..), CoMonoidZero(..)
-   , associativeList
-   ) where
-
-import Control.Applicative
-import Control.Monad (liftM2)
-import Data.Maybe
-import Data.Monoid
-import Ideas.Common.Classes
-import qualified Data.Set as S
-
---------------------------------------------------------
--- Groups
-
--- | Minimal complete definition: inverse or appendInverse
-class Monoid a => Group a where
-   inverse   :: a -> a
-   appendInv :: a -> a -> a
-   -- default definitions
-   inverse = (mempty <>-)
-   appendInv a b = a <> inverse b
-
-infixl 6 <>-
-
-(<>-) :: Group a => a -> a -> a
-(<>-) = appendInv
-
---------------------------------------------------------
--- Monoids with a zero element
--- This element could be the additive identity from a (semi-)ring for
--- the multiplicative monoid
-
-class Monoid a => MonoidZero a where
-   mzero :: a
-
--- Type that adds a zero element
-newtype WithZero a = WZ { fromWithZero :: Maybe a }
-   deriving (Eq, Ord, Functor, Foldable, Applicative)
-
-instance Monoid a => Monoid (WithZero a) where
-   mempty = WZ (Just mempty)
-   mappend x y = WZ (liftM2 mappend (fromWithZero x) (fromWithZero y))
-
-instance Monoid a => MonoidZero (WithZero a) where
-   mzero = WZ Nothing
-
-instance Traversable WithZero where
-   traverse f = liftA WZ . traverse f . fromWithZero
-
---------------------------------------------------------
--- Groups
-
-class CoMonoid a where
-   isEmpty  :: a -> Bool
-   isAppend :: a -> Maybe (a, a)
-
-class CoMonoid a => CoGroup a where
-   isInverse   :: a -> Maybe a
-   isAppendInv :: a -> Maybe (a, a)
-   -- default definition
-   isAppendInv = const Nothing
-
-class CoMonoid a => CoMonoidZero a where
-   isMonoidZero :: a -> Bool
-
-fromSemiGroup :: (CoMonoid a, Monoid b) => (a -> b) -> a -> b
-fromSemiGroup f = rec
- where
-   rec a = maybe (f a) make (isAppend a)
-   make (x, y) = rec x <> rec y
-{-
-fromMonoid :: (CoMonoid a, Monoid b) => (a -> b) -> a -> b
-fromMonoid f = fromSemiGroup $ \a ->
-   if isEmpty a then mempty else f a
-
-fromGroup :: (CoGroup a, Group b) => (a -> b) -> a -> b
-fromGroup f = rec
- where
-   rec = fromMonoid $ \a ->
-      case isInverse a of
-         Just x  -> inverse (rec x)
-         Nothing ->
-            case isAppendInverse a of
-               Just (x, y) -> rec x <>- rec y
-               Nothing     -> f a
-
-fromMonoidZero :: (CoMonoidZero a, MonoidZero b) => (a -> b) -> a -> b
-fromMonoidZero f = fromMonoid $ \a ->
-   if isZero a then zero else f a
-
-----------------------
--}
-associativeList :: CoMonoid a => a -> [a]
-associativeList = fromSemiGroup singleton
-{-
-monoidList :: CoMonoid a => a -> [a]
-monoidList = fromMonoid singleton
-
--- For commutative (and associative) monoids
-monoidMultiSet :: (CoMonoid a, Ord a) => a -> MultiSet a
-monoidMultiSet = fromMonoid singleton
-
--- For associative, commutative, idempotent (ACI) monoids
-monoidSet :: (CoMonoid a, Ord a) => a -> S.Set a
-monoidSet = fromMonoid singleton
-
-groupSequence :: (CoGroup a, Eq a) => a -> GroupSequence a
-groupSequence = fromGroup singleton
-
-abelianMultiSet :: (CoGroup a, Ord a) => a -> MultiSet a
-abelianMultiSet = fromGroup singleton
-
-monoidZeroList :: CoMonoidZero a => a -> WithZero [a]
-monoidZeroList = fromMonoidZero (pure . singleton)
-
-----------------------
-
-newtype MultiSet a = MS (M.Map a Int)
-
-instance Collection MultiSet where
-   singleton a = MS (M.singleton a 1)
-
-instance Ord a => Monoid (MultiSet a) where
-   mempty  = MS mempty
-   mappend (MS m1) (MS m2) = MS (M.unionWith (+) m1 m2)
-
-instance Ord a => Group (MultiSet a) where
-   inverse (MS m) = MS (fmap negate m)
-
-----------------------
-
-newtype GroupSequence a = GS (Q.Seq (a, Bool))
-
-instance Collection GroupSequence where
-   singleton a = GS (Q.singleton (a, False))
-
-instance Eq a => Monoid (GroupSequence a) where
-   mempty = GS mempty
-   mappend (GS xs) (GS ys) =
-      case (Q.viewr xs, Q.viewl ys) of
-         (as Q.:> (a, ai), (b, bi) Q.:< bs) | a == b && ai /= bi ->
-            mappend (GS as) (GS bs)
-         _ -> GS (xs <> ys)
-
-instance Eq a => Group (GroupSequence a) where
-   inverse (GS xs) = GS (fmap (second not) xs) -- actually: reverse order!!
--}
-----------------------
-
-instance CoMonoid [a] where
-   isEmpty = null
-   isAppend (x:xs@(_:_)) = Just ([x], xs)
-   isAppend _            = Nothing
-
-instance CoMonoid (S.Set a) where
-   isEmpty = S.null
-   isAppend s
-      | S.size s > 1 = Just (mapFirst S.singleton (S.deleteFindMin s))
-      | otherwise    = Nothing
-
-{-
-instance CoMonoid (Q.Seq a) where
-   isEmpty = Q.null
-   isAppend xs
-      | n > 1     = Just (Q.splitAt (n `div` 2) xs)
-      | otherwise = Nothing
-    where
-      n = Q.length xs
--}
-instance CoMonoid a => CoMonoid (WithZero a) where
-   isEmpty    = maybe False isEmpty . fromWithZero
-   isAppend a = fromWithZero a >>= fmap (mapBoth pure) . isAppend
-
-instance CoMonoid a => CoMonoidZero (WithZero a) where
-   isMonoidZero = isNothing . fromWithZero

@@ -1,150 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Algebra.GroupLaws
-   ( -- * Monoid laws
-     associative, leftIdentity
-   , rightIdentity, identityLaws, monoidLaws, commutativeMonoidLaws
-   , idempotent
-     -- * Group laws
-   , leftInverse, rightInverse, doubleInverse
-   , inverseIdentity, inverseDistrFlipped, inverseLaws, groupLaws
-   , appendInverseLaws
-     -- * Abelian group laws
-   , commutative, inverseDistr, abelianGroupLaws
-     -- * Laws for monoids with a zero element
-   , leftZero, rightZero, zeroLaws, monoidZeroLaws
-     -- * Generalized laws
-   , associativeFor, commutativeFor, idempotentFor
-   , leftDistributiveFor, rightDistributiveFor
-   ) where
-
-import Ideas.Common.Algebra.Group
-import Ideas.Common.Algebra.Law
-import Prelude hiding ((<*>))
-
---------------------------------------------------------
--- Monoids
-
-associative :: Monoid a => Law a
-associative = associativeFor (<>)
-
-leftIdentity :: Monoid a => Law a
-leftIdentity = law "left-identity" $ \a -> mempty <> a :==: a
-
-rightIdentity :: Monoid a => Law a
-rightIdentity = law "right-identity" $ \a -> a <> mempty :==: a
-
-identityLaws :: Monoid a => [Law a]
-identityLaws = [leftIdentity, rightIdentity]
-
-monoidLaws :: Monoid a => [Law a]
-monoidLaws = associative : identityLaws
-
-commutativeMonoidLaws :: Monoid a => [Law a]
-commutativeMonoidLaws = monoidLaws ++ [commutative]
-
--- | Not all monoids are idempotent (see: idempotentFor)
-idempotent :: Monoid a => Law a
-idempotent = idempotentFor (<>)
-
---------------------------------------------------------
--- Groups
-
-leftInverse :: Group a => Law a
-leftInverse = law "left-inverse" $ \a -> inverse a <> a :==: mempty
-
-rightInverse :: Group a => Law a
-rightInverse = law "right-inverse" $ \a -> a <> inverse a :==: mempty
-
-doubleInverse :: Group a => Law a
-doubleInverse = law "double-inverse" $ \a -> inverse (inverse a) :==: a
-
-inverseIdentity :: Group a => Law a
-inverseIdentity = law "inverse-identity" $ inverse mempty :==: mempty
-
-inverseDistrFlipped :: Group a => Law a
-inverseDistrFlipped = law "inverse-distr-flipped" $ \a b ->
-   inverse (a <> b) :==: inverse b <> inverse a
-
-inverseLaws :: Group a => [Law a]
-inverseLaws = [leftInverse, rightInverse]
-
-groupLaws :: Group a => [Law a]
-groupLaws = monoidLaws ++ inverseLaws ++
-   [doubleInverse, inverseIdentity, inverseDistrFlipped]
-
-appendInverseLaws :: Group a => [Law a]
-appendInverseLaws =
-   [ make 1 $ \a b   ->           a <>- b :==: a <> inverse b
-   , make 2 $ \a     ->           a <>- a :==: mempty
-   , make 3 $ \a     ->      a <>- mempty :==: a
-   , make 4 $ \a     ->      mempty <>- a :==: inverse a
-   , make 5 $ \a b c ->    a <>- (b <> c) :==: (a <>- b) <>- c
-   , make 6 $ \a b c ->   a <>- (b <>- c) :==: (a <>- b) <> c
-   , make 7 $ \a b c ->    a <> (b <>- c) :==: (a <> b) <>- c
-   , make 8 $ \a b   ->   a <>- inverse b :==: a <> b
-   , make 9 $ \a b   -> inverse (a <>- b) :==: inverse a <> b
-   ]
- where
-    make n = law ("append-inverse-law" ++ show (n :: Int))
-
---------------------------------------------------------
--- Abelian groups
-
-commutative :: Monoid a => Law a
-commutative = commutativeFor (<>)
-
-inverseDistr :: Group a => Law a
-inverseDistr = law "inverse-distr" $ \a b ->
-    inverse (a <> b) :==: (inverse a <> inverse b)
-
-abelianGroupLaws :: Group a => [Law a]
-abelianGroupLaws = groupLaws ++ [commutative, inverseDistr]
-
---------------------------------------------------------
--- Monoids with a zero element
--- This element could be the additive identity from a (semi-)ring for
--- the multiplicative monoid
-
-leftZero :: MonoidZero a => Law a
-leftZero = law "left-zero" $ \a -> mzero <> a :==: mzero
-
-rightZero:: MonoidZero a => Law a
-rightZero = law "right-zero" $ \a -> a <> mzero :==: mzero
-
-zeroLaws :: MonoidZero a => [Law a]
-zeroLaws = [leftZero, rightZero]
-
-monoidZeroLaws :: MonoidZero a => [Law a]
-monoidZeroLaws = monoidLaws ++ zeroLaws
-
---------------------------------------------------------
--- Generalized laws
-
-associativeFor :: (a -> a -> a) -> Law a
-associativeFor (?) = law "associative" $ \a b c ->
-   a ? (b ? c) :==: (a ? b) ? c
-
-commutativeFor :: (a -> a -> a) -> Law a
-commutativeFor (?) = law "commutative" $ \a b -> a ? b :==: b ? a
-
-idempotentFor :: (a -> a -> a) -> Law a
-idempotentFor (?) = law "idempotent" $ \a -> a ? a :==: a
-
-leftDistributiveFor :: (a -> a -> a) -> (a -> a -> a) -> Law a
-leftDistributiveFor (<*>) (<+>) = law "left-distributive" $ \a b c ->
-   a <*> (b <+> c) :==: (a <*> b) <+> (a <*> c)
-
-rightDistributiveFor :: (a -> a -> a) -> (a -> a -> a) -> Law a
-rightDistributiveFor (<*>) (<+>) = law "right-distributive" $ \a b c ->
-   (a <+> b) <*> c :==: (a <*> c) <+> (b <*> c)

@@ -1,78 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ExistentialQuantification #-}
------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Algebra.Law
-   ( Law, LawSpec((:==:)), law, lawAbs, mapLaw
-   , propertyLaw, rewriteLaw
-   ) where
-
-import Ideas.Common.Rewriting
-import Test.QuickCheck
-
-infix 1 :==:
-
-data Law a = Law String (LawSpec a)
-
-instance Show (Law a) where
-   show (Law s _) = s
-
-data LawSpec a
-   = AbsMono (a -> LawSpec a) -- simple abstraction (fewer classes needed)
-   | forall b . (Arbitrary b, Show b, Different b) => Abs (b -> LawSpec a) -- generalized abstraction
-   | a :==: a
-
-law :: LawBuilder l a => String -> l -> Law a
-law s l = Law s (lawSpec l)
-
-lawAbs :: (Different b, Arbitrary b, Show b) => (b -> LawSpec a) -> LawSpec a
-lawAbs = Abs
-
-class LawBuilder l a | l -> a where
-   lawSpec :: l -> LawSpec a
-
-instance LawBuilder (LawSpec a) a where
-   lawSpec = id
-
-instance LawBuilder (Law a) a where
-   lawSpec = getLawSpec
-
-instance LawBuilder b a => LawBuilder (a -> b) a where
-   lawSpec f = AbsMono (lawSpec . f)
-
-instance (Show a, Eq a, Arbitrary a) => Testable (Law a) where
-   property = propertyLaw (==)
-
-mapLaw :: (b -> a) -> (a -> b) -> Law a -> Law b
-mapLaw to from (Law s l) = Law s (rec l)
- where
-   rec (AbsMono f) = AbsMono (rec . f . to)
-   rec (Abs f)     = Abs (rec . f)
-   rec (a :==: b)  = from a :==: from b
-
-propertyLaw :: (Arbitrary a, Show a, Testable b) => (a -> a -> b) -> Law a -> Property
-propertyLaw eq = rec . getLawSpec
- where
-   rec (AbsMono f) = property (rec . f)
-   rec (Abs f)     = property (rec . f)
-   rec (a :==: b)  = property (eq a b)
-
-rewriteLaw :: (Different a, IsTerm a, Arbitrary a, Show a) => Law a -> RewriteRule a
-rewriteLaw (Law s l) = makeRewriteRule s l
-
-instance (Arbitrary a, IsTerm a, Show a, Different a) => RuleBuilder (LawSpec a) a where
-   buildRuleSpec i (a :==: b)  = buildRuleSpec i (a :~> b)
-   buildRuleSpec i (AbsMono f) = buildRuleSpec i f
-   buildRuleSpec i (Abs f)     = buildRuleSpec i f
-
-getLawSpec :: Law a -> LawSpec a
-getLawSpec (Law _ l) = l

@@ -1,198 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-}
------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Algebra.SmartGroup
-   ( -- * Smart datatypes
-     Smart(..), SmartZero(..), SmartGroup(..)
-     --- * Smart field
-   , SmartField(..), (.+.), (.-.), neg, (.*.), (./.)
-     -- * Smart booleans
-   , (.&&.), (.||.)
-   ) where
-
-import Control.Applicative
-import Control.Monad (mplus)
-import Data.Maybe
-import Ideas.Common.Algebra.Boolean
-import Ideas.Common.Algebra.Field
-import Ideas.Common.Algebra.Group
-
-newtype Smart a = Smart {fromSmart :: a}
-   deriving (Show, Eq, Ord, CoMonoid, MonoidZero, CoMonoidZero)
-
-instance Functor Smart where -- could be derived
-   fmap f = Smart . f . fromSmart
-
-instance Applicative Smart where
-   pure = Smart
-   Smart f <*> Smart a = Smart (f a)
-
-instance (CoMonoid a, Monoid a) => Monoid (Smart a) where
-   mempty = Smart mempty
-   mappend a b
-      | isEmpty a = b
-      | isEmpty b = a
-      | otherwise = liftA2 (<>) a b
-
---------------------------------------------------------------
-
-newtype SmartZero a = SmartZero {fromSmartZero :: a}
-   deriving (Show, Eq, Ord, MonoidZero, CoMonoid, CoMonoidZero)
-
-instance Functor SmartZero where -- could be derived
-   fmap f = SmartZero . f . fromSmartZero
-
-instance Applicative SmartZero where
-   pure = SmartZero
-   SmartZero f <*> SmartZero a = SmartZero (f a)
-
-instance (CoMonoidZero a, MonoidZero a) => Monoid (SmartZero a) where
-   mempty = SmartZero mempty
-   mappend a b
-      | isMonoidZero a || isMonoidZero b = mzero
-      | otherwise = liftA2 (<>) a b
-
---------------------------------------------------------------
-
-newtype SmartGroup a = SmartGroup {fromSmartGroup :: a}
-   deriving (Show, Eq, Ord, CoMonoid, CoGroup, CoMonoidZero, MonoidZero)
-
-instance Functor SmartGroup where -- could be derived
-   fmap f = SmartGroup . f . fromSmartGroup
-
-instance Applicative SmartGroup where
-   pure = SmartGroup
-   SmartGroup f <*> SmartGroup a = SmartGroup (f a)
-
-instance (CoGroup a, Group a) => Monoid (SmartGroup a) where
-   mempty  = SmartGroup mempty
-   mappend a b
-      | isEmpty a = b
-      | otherwise = fromMaybe (liftA2 (<>) a b) (matchGroup alg b)
-    where
-      alg = (a, \x y -> (a <> x) <> y, \x -> a <>- x, \x y -> (a <> x) <>- y)
-
-instance (CoGroup a, Group a) => Group (SmartGroup a) where
-   inverse a = fromMaybe (liftA inverse a) (matchGroup alg a)
-    where
-      alg = (mempty, \x y -> inverse x <>- y, id, \x y -> inverse x <> y)
-   appendInv a b
-      | isEmpty a = inverse b
-      | otherwise = fromMaybe (liftA2 (<>-) a b) (matchGroup alg b)
-    where
-      alg = (a, \x y -> (a <>- x) <>- y, \x -> a <> x, \x y -> (a <>- x) <> y)
-
---------------------------------------------------------------
-
-type GroupMatch a b = (b, a -> a -> b, a -> b, a -> a -> b)
-
-matchGroup :: CoGroup a => GroupMatch a b -> a -> Maybe b
-matchGroup (emp, app, inv, appinv) a =
-   (if isEmpty a then Just emp else Nothing) `mplus`
-   fmap (uncurry app) (isAppend a)  `mplus`
-   fmap inv (isInverse a) `mplus`
-   fmap (uncurry appinv) (isAppendInv a)
-
---------------------------------------------------------------
--- Smart Field
-
-newtype SmartField a = SmartField {fromSmartField :: a}
-   deriving (CoSemiRing, CoRing, CoField)
-
-instance Functor SmartField where -- could be derived
-   fmap f = SmartField . f . fromSmartField
-
-instance Applicative SmartField where
-   pure = SmartField
-   SmartField f <*> SmartField a = SmartField (f a)
-
-instance (CoField a, Field a) => SemiRing (SmartField a) where
-   zero = SmartField zero
-   one  = SmartField one
-   SmartField a |+| SmartField b = SmartField $ fromAdditive $ fromSmartGroup $
-      SmartGroup (Additive a) <> SmartGroup (Additive b)
-   a |*| b
-      | Just x <- isNegate a = plusInverse (x |*| b)
-      | Just x <- isNegate b = plusInverse (a |*| x)
-      | isZero a || isZero b = zero
-      | isOne a = b
-      | isOne b = a
-      | Just (x, y) <- isTimes b = (a |*| x) |*| y
-      | Just (x, y) <- isDivision b = (a |*| x) |/| y
-      | otherwise = liftA2 (|*|) a b
-
-instance (CoField a, Field a) => Ring (SmartField a) where
-   plusInverse = SmartField . fromAdditive . fromSmartGroup . inverse
-               . SmartGroup . Additive . fromSmartField
-   SmartField a |-| SmartField b = SmartField $ fromAdditive $ fromSmartGroup $
-      SmartGroup (Additive a) <>- SmartGroup (Additive b)
-
-instance (CoField a, Field a) => Field (SmartField a) where
-   timesInverse a
-      | Just x <- isNegate a = plusInverse (timesInverse x)
-      | Just (x, y) <- isDivision a, isOne y = x
-      | otherwise = liftA timesInverse a
-   a |/| b
-      | Just x <- isNegate a = plusInverse (x |/| b)
-      | Just x <- isNegate b = plusInverse (a |/| x)
-      | isOne b = a
-      | Just (x, y) <- isDivision a = x |/| (y |*| b)
-      | otherwise = liftA2 (|/|) a b
-
-------------------------------------------------------------------
-
-infixl 7 .*., ./.
-infixl 6 .-., .+.
-
-(.+.) :: (CoField a, Field a) => a -> a -> a
-a .+. b = fromSmartField $ SmartField a |+| SmartField b
-
-(.-.) :: (CoField a, Field a) => a -> a -> a
-a .-. b = fromSmartField $ SmartField a |-| SmartField b
-
-neg :: (CoField a, Field a) => a -> a
-neg = fromSmartField . plusInverse . SmartField
-
-(.*.) :: (CoField a, Field a) => a -> a -> a
-a .*. b = fromSmartField $ SmartField a |*| SmartField b
-
-(./.) :: (CoField a, Field a) => a -> a -> a
-a ./. b = fromSmartField $ SmartField a |/| SmartField b
-
--- myrecip :: (CoField a, Field a) => a -> a
--- myrecip = fromSmartField . timesInverse . SmartField
-
---------------------------------------------------------------
--- Smart booleans
-
-instance BoolValue a => BoolValue (Smart a) where
-   fromBool = Smart   . fromBool
-   isTrue   = isTrue  . fromSmart
-   isFalse  = isFalse . fromSmart
-
-instance (Boolean a, CoBoolean a) => Boolean (Smart a) where
-   a <&&> b = fmap fromAnd $ fromSmartZero $
-      SmartZero (fmap And a) <> SmartZero (fmap And b)
-   a <||> b = fmap fromOr $ fromSmartZero $
-      SmartZero (fmap Or a) <> SmartZero (fmap Or b)
-   complement (Smart a)
-      | isTrue  a = false
-      | isFalse a = true
-      | otherwise = Smart $ fromMaybe (complement a) (isComplement a)
-
-infixr 4 .||.
-infixr 5 .&&.
-
-(.&&.), (.||.) :: (Boolean a, CoBoolean a) => a -> a -> a
-a .&&. b = fromSmart $ Smart a <&&> Smart b
-a .||. b = fromSmart $ Smart a <||> Smart b

@@ -23,6 +23,9 @@    , BiFunctor(biMap, mapFirst, mapSecond), mapBoth
      -- * Type class Fix
    , Fix(..)
+     -- * Boolean Algebra
+   , BoolValue(..), Boolean(..)
+   , ands, ors, implies, equivalent
      -- * Buggy and Minor properties
    , Buggy(..), Minor(..)
    ) where
@@ -120,6 +123,60 @@   fix :: (a -> a) -> a
   -- default implementation
   fix f = let a = f a in a
+
+--------------------------------------------------------
+-- Boolean algebra
+
+-- Minimal complete definitions: (true/false, or fromBool) and isTrue/isFalse
+class BoolValue a where
+   true     :: a
+   false    :: a
+   fromBool :: Bool -> a
+   isTrue   :: a -> Bool
+   isFalse  :: a -> Bool
+   -- default definitions
+   true  = fromBool True
+   false = fromBool False
+   fromBool b = if b then true else false
+
+class BoolValue a => Boolean a where
+   (<&&>)     :: a -> a -> a
+   (<||>)     :: a -> a -> a
+   complement :: a -> a
+
+instance BoolValue Bool where
+   fromBool = id
+   isTrue   = id
+   isFalse  = not
+
+instance BoolValue b => BoolValue (a -> b) where
+   fromBool x = const (fromBool x)
+   isTrue  = error "not implemented"
+   isFalse = error "not implemented"
+
+instance Boolean Bool where
+   (<&&>)     = (&&)
+   (<||>)     = (||)
+   complement = not
+
+instance Boolean b => Boolean (a -> b) where
+   f <&&> g   = \x -> f x <&&> g x
+   f <||> g   = \x -> f x <||> g x
+   complement = (.) complement
+
+ands :: Boolean a => [a] -> a -- or use mconcat with And monoid
+ands xs | null xs   = true
+        | otherwise = foldr1 (<&&>) xs
+
+ors :: Boolean a => [a] -> a
+ors xs | null xs   = false
+       | otherwise = foldr1 (<||>) xs
+
+implies :: Boolean a => a -> a -> a
+implies a b = complement a <||> b
+
+equivalent :: Boolean a => a -> a -> a
+equivalent a b = (a <&&> b) <||> (complement a <&&> complement b)
 
 -----------------------------------------------------------
 -- Buggy and Minor properties

@@ -29,15 +29,14 @@    , currentTerm, changeTerm, replaceInContext, currentInContext, changeInContext
    ) where
 
-import Control.Monad
 import Data.Maybe
 import Ideas.Common.Environment
 import Ideas.Common.Id
 import Ideas.Common.Rewriting
 import Ideas.Common.Traversal.Navigator
 import Ideas.Common.Traversal.Utils
-import Ideas.Common.Utils.Uniplate
 import Ideas.Common.View hiding (left, right)
+import Ideas.Utils.Uniplate
 
 ----------------------------------------------------------
 -- Abstract data type
@@ -53,13 +52,13 @@    currentNavigator . getNavigator . top
 
 fromContextWith :: Monad m => (a -> b) -> Context a -> m b
-fromContextWith f = liftM f . fromContext
+fromContextWith f = fmap f . fromContext
 
 fromContextWith2 :: Monad m => (a -> b -> c) -> Context a -> Context b -> m c
-fromContextWith2 f a b = liftM2 f (fromContext a) (fromContext b)
+fromContextWith2 f a b = f <$> fromContext a <*> fromContext b
 
 instance Eq a => Eq (Context a) where
-   x == y = fromMaybe False $ liftM2 (==) (fromContext x) (fromContext y)
+   x == y = fromMaybe False $ (==) <$> fromContext x <*> fromContext y
 
 instance Show a => Show (Context a) where
    show c@(C env a) =
@@ -103,8 +102,8 @@ 
 liftCN :: Monad m => (forall b . Navigator b => b -> m b)
                   -> Context a -> m (Context a)
-liftCN f (C env (TermNav a)) = liftM (C env . TermNav) (f a)
-liftCN f (C env (Simple a))  = liftM (C env . Simple)  (f a)
+liftCN f (C env (TermNav a)) = (C env . TermNav) <$> f a
+liftCN f (C env (Simple a))  = (C env . Simple)  <$> f a
 liftCN _ (C _   (NoNav _))   = fail "noNavigator"
 
 navLocation :: ContextNavigator a -> Location
@@ -127,7 +126,7 @@ currentT _           = Nothing
 
 changeT :: (Term -> Maybe Term) -> ContextNavigator a -> Maybe (ContextNavigator a)
-changeT f (TermNav a) = fmap TermNav (changeM f a)
+changeT f (TermNav a) = TermNav <$> changeM f a
 changeT _ _           = Nothing
 
 castT :: IsTerm b => ContextNavigator a -> Maybe (ContextNavigator b)
@@ -160,7 +159,7 @@ useC = liftViewIn (makeView f g)
  where
    f old@(C env a) = castT a >>= \b -> return (C env b, old)
-   g (C env a, old) = fromMaybe old (liftM (C env) (castT a))
+   g (C env a, old) = fromMaybe old (C env <$> castT a)
 
 currentTerm :: Context a -> Maybe Term
 currentTerm = currentT . getNavigator

@@ -1,218 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Ideas.Common.CyclicTree
-   ( -- * Data type
-     CyclicTree
-     -- * Constructor functions
-   , node, node0, node1, node2, leaf, label
-     -- * Querying
-   , isNode, isLeaf, isLabel
-     -- * Replace functions
-   , replaceNode, replaceLeaf, replaceLabel, shrinkTree
-     -- * Fold and algebra
-   , fold, foldUnwind
-   , CyclicTreeAlg, fNode, fLeaf, fLabel, fRec, fVar
-   , emptyAlg, monoidAlg
-   ) where
-
-import Control.Applicative
-import Control.Monad
-import Data.List (intercalate)
-import Ideas.Common.Classes
-import Ideas.Common.Id
-import Test.QuickCheck hiding (label)
-
---------------------------------------------------------------
--- Data type
-
-data CyclicTree a b
-   = Node a [CyclicTree a b]
-   | Leaf b
-   | Label Id (CyclicTree a b)
-   | Rec Int (CyclicTree a b)
-   | Var Int
-
-instance (Show a, Show b) => Show (CyclicTree a b) where
-   show = fold Alg
-      { fNode  = \a xs -> show a ++ par xs
-      , fLeaf  = show
-      , fLabel = \l s -> show l ++ ":" ++ s
-      , fRec   = \n s -> '#' : show n ++ "=" ++ s
-      , fVar   = \n   -> '#' : show n
-      }
-
-instance BiFunctor CyclicTree where
-   biMap f g = fold idAlg {fNode = Node . f, fLeaf = Leaf . g}
-
-instance Functor (CyclicTree d) where
-   fmap = mapSecond
-
-instance Applicative (CyclicTree d) where
-   pure    = leaf
-   p <*> q = fold idAlg {fLeaf = (`fmap` q)} p
-
-instance Monad (CyclicTree d) where
-   return = leaf
-   (>>=)  = flip replaceLeaf
-
-instance Foldable (CyclicTree d) where
-   foldMap f = fold monoidAlg {fLeaf = f}
-
-instance Traversable (CyclicTree d) where
-   traverse f = fold emptyAlg
-      { fNode  = \a -> liftA (node a) . sequenceA
-      , fLeaf  = liftA leaf . f
-      , fLabel = liftA . label
-      , fRec   = liftA . Rec
-      , fVar   = pure . Var
-      }
-
-instance Fix (CyclicTree a b) where
-   fix f = Rec n (f (Var n))
-    where
-      vs = vars (f (Var (-1)))
-      n  = maximum (-1 : vs) + 1
-
-instance (Arbitrary a, Arbitrary b) => Arbitrary (CyclicTree a b) where
-   arbitrary = sized arbTree
-   shrink    = shrinkTree
-
-arbTree :: (Arbitrary a, Arbitrary b) => Int -> Gen (CyclicTree a b)
-arbTree = rec 0
- where
-   rec vi 0 = frequency $
-      (3, liftM leaf arbitrary)
-      : [ (1, elements (map Var [1..vi])) | vi > 0 ]
-   rec vi n = frequency
-      [ (3, liftM2 node arbitrary ms)
-      , (2, rec vi 0)
-      , (1, liftM2 label genId m)
-      , (1, liftM (Rec (vi+1)) (rec (vi+1) (n `div` 2)))
-      ]
-    where
-      m = rec vi (n `div` 2)
-      genId = elements [ newId [c] | c <- ['A' .. 'Z']]
-      ms = choose (0, 3) >>= \i -> replicateM i m
-
-shrinkTree :: CyclicTree a b -> [CyclicTree a b]
-shrinkTree tree =
-   case tree of
-      Node a ts -> ts ++ map (node a) (shrinkTrees ts)
-      Label l t -> t : map (Label l) (shrinkTree t)
-      Rec n t   -> map (Rec n) (shrinkTree t)
-      _ -> []
-
--- shrink exactly one tree
-shrinkTrees :: [CyclicTree a b] -> [[CyclicTree a b]]
-shrinkTrees []    = []
-shrinkTrees (t:ts) = map (:ts) (shrinkTree t) ++ map (t:) (shrinkTrees ts)
-
--- local helpers
-par :: [String] -> String
-par xs | null xs   = ""
-       | otherwise = "(" ++ intercalate ", " xs ++ ")"
-
-vars :: CyclicTree a b -> [Int]
-vars = fold monoidAlg {fVar = return}
-
---------------------------------------------------------------
--- Constructor functions
-
-node :: a -> [CyclicTree a b] -> CyclicTree a b
-node = Node
-
-node0 :: a -> CyclicTree a b
-node0 a = node a []
-
-node1 :: a -> CyclicTree a b -> CyclicTree a b
-node1 a x = node a [x]
-
-node2 :: a -> CyclicTree a b -> CyclicTree a b -> CyclicTree a b
-node2 a x y = node a [x, y]
-
-leaf :: b -> CyclicTree a b
-leaf = Leaf
-
-label :: IsId n => n -> CyclicTree a b -> CyclicTree a b
-label = Label . newId
-
---------------------------------------------------------------
--- Querying
-
-isNode :: CyclicTree a b -> Maybe (a, [CyclicTree a b])
-isNode (Node a xs) = Just (a, xs)
-isNode _ = Nothing
-
-isLeaf :: CyclicTree a b -> Maybe b
-isLeaf (Leaf b) = Just b
-isLeaf _ = Nothing
-
-isLabel :: CyclicTree a b -> Maybe (Id, CyclicTree a b)
-isLabel (Label l t) = Just (l, t)
-isLabel _ = Nothing
-
---------------------------------------------------------------
--- Replace functions
-
-replaceNode :: (a -> [CyclicTree a b] -> CyclicTree a b) -> CyclicTree a b -> CyclicTree a b
-replaceNode f = fold idAlg {fNode = f}
-
-replaceLabel :: (Id -> CyclicTree a b -> CyclicTree a b) -> CyclicTree a b -> CyclicTree a b
-replaceLabel f = fold idAlg {fLabel = f}
-
-replaceLeaf :: (b -> CyclicTree a c) -> CyclicTree a b -> CyclicTree a c
-replaceLeaf f = fold idAlg {fLeaf = f}
-
---------------------------------------------------------------
--- Fold and algebra
-
-fold :: CyclicTreeAlg a b t -> CyclicTree a b -> t
-fold alg = rec
- where
-   rec (Node a ts) = fNode alg a (map rec ts)
-   rec (Leaf b)    = fLeaf alg b
-   rec (Label l t) = fLabel alg l (rec t)
-   rec (Rec n t)   = fRec alg n (rec t)
-   rec (Var n)     = fVar alg n
-
-foldUnwind :: CyclicTreeAlg a b t -> CyclicTree a b -> t
-foldUnwind alg = start . fold Alg
-   { fNode  = \a fs sub -> fNode alg a (map ($ sub) fs)
-   , fLeaf  = \b _      -> fLeaf alg b
-   , fLabel = \l f sub  -> fLabel alg l (f sub)
-   , fRec   = \n f sub  -> let this = f (extend n this sub)
-                           in this
-   , fVar   = \n sub    -> sub n
-   }
- where
-   start f = f (error "foldUnwind: unbound var")
-   extend n a sub i
-      | i == n    = a
-      | otherwise = sub i
-
-data CyclicTreeAlg a b t = Alg
-   { fNode  :: a -> [t] -> t
-   , fLeaf  :: b -> t
-   , fLabel :: Id -> t -> t
-   , fRec   :: Int -> t -> t
-   , fVar   :: Int -> t
-   }
-
-idAlg :: CyclicTreeAlg a b (CyclicTree a b)
-idAlg = Alg Node Leaf Label Rec Var
-
-emptyAlg :: CyclicTreeAlg a b t
-emptyAlg = let f = error "emptyAlg: uninitialized" in Alg f f f f f
-
-monoidAlg :: Monoid m => CyclicTreeAlg a b m
-monoidAlg = Alg (const mconcat) mempty (const id) (const id) mempty

@@ -15,7 +15,7 @@ 
 module Ideas.Common.Environment
    ( -- * Reference
-     Ref, Reference(..)
+     Ref, Reference(..), mapRef
      -- * Binding
    , Binding, makeBinding
    , fromBinding, showValue, getTermValue
@@ -28,11 +28,11 @@ import Control.Monad
 import Data.Function
 import Data.List
-import Data.Typeable
 import Ideas.Common.Id
 import Ideas.Common.Rewriting.Term
-import Ideas.Common.Utils
 import Ideas.Common.View
+import Ideas.Utils.Prelude
+import Ideas.Utils.Typeable
 import qualified Data.Map as M
 
 -----------------------------------------------------------
@@ -40,10 +40,11 @@ 
 -- | A data type for references (without a value)
 data Ref a = Ref
-   { identifier :: Id                -- ^ Identifier
-   , printer    :: a -> String       -- ^ A pretty-printer
-   , parser     :: String -> Maybe a -- ^ A parser
-   , refView    :: View Term a       -- ^ Conversion to/from term
+   { identifier :: Id                -- Identifier
+   , printer    :: a -> String       -- Pretty-printer
+   , parser     :: String -> Maybe a -- Parser
+   , refView    :: View Term a       -- Conversion to/from term
+   , refType    :: IsTypeable a
    }
 
 instance Show (Ref a) where
@@ -56,20 +57,23 @@    getId = identifier
    changeId f d = d {identifier = f (identifier d)}
 
+instance HasTypeable Ref where
+   getTypeable = Just . refType
+
 -- | A type class for types as references
 class (IsTerm a, Typeable a, Show a, Read a) => Reference a where
    makeRef     :: IsId n => n -> Ref a
    makeRefList :: IsId n => n -> Ref [a]
    -- default implementation
-   makeRef n     = Ref (newId n) show readM termView
-   makeRefList n = Ref (newId n) show readM termView
+   makeRef n     = Ref (newId n) show readM termView typeable
+   makeRefList n = Ref (newId n) show readM termView typeable
 
 instance Reference Int
 
 instance Reference Term
 
 instance Reference Char where
-   makeRefList n = Ref (newId n) id Just variableView
+   makeRefList n = Ref (newId n) id Just variableView typeable
 
 instance Reference ShowString
 
@@ -78,33 +82,41 @@ 
 instance (Reference a, Reference b) => Reference (a, b)
 
+mapRef :: Typeable b => Isomorphism a b -> Ref a -> Ref b
+mapRef iso r = r
+   { printer = printer r . to iso
+   , parser  = fmap (from iso) . parser r
+   , refView = refView r >>> toView iso
+   , refType = typeable
+   }
+
 -----------------------------------------------------------
 -- Binding
 
-data Binding = forall a . Typeable a => Binding (Ref a) a
+data Binding = forall a . Binding (Ref a) a
 
 instance Show Binding where
    show a = showId a ++ "=" ++ showValue a
 
 instance Eq Binding where
-   (==) = let f (Binding ref a) = (getId ref, build (refView ref) a)
+   (==) = let f (Binding r a) = (getId r, build (refView r) a)
           in (==) `on` f
 
 instance HasId Binding where
-   getId (Binding ref _ ) = getId ref
-   changeId f (Binding ref a) = Binding (changeId f ref) a
+   getId (Binding r _ ) = getId r
+   changeId f (Binding r a) = Binding (changeId f r) a
 
-makeBinding :: Typeable a => Ref a -> a -> Binding
+makeBinding :: Ref a -> a -> Binding
 makeBinding = Binding
 
 fromBinding :: Typeable a => Binding -> Maybe (Ref a, a)
-fromBinding (Binding ref a) = liftM2 (,) (gcast ref) (cast a)
+fromBinding (Binding r a) = liftM2 (,) (gcastFrom r r) (castFrom r a)
 
 showValue :: Binding -> String
-showValue (Binding ref a) = printer ref a
+showValue (Binding r a) = printer r a
 
 getTermValue :: Binding -> Term
-getTermValue (Binding ref a) = build (refView ref) a
+getTermValue (Binding r a) = build (refView r) a
 
 -----------------------------------------------------------
 -- Heterogeneous environment
@@ -125,22 +137,22 @@ makeEnvironment :: [Binding] -> Environment
 makeEnvironment xs = Env $ M.fromList [ (getId a, a) | a <- xs ]
 
-singleBinding :: Typeable a => Ref a -> a -> Environment
-singleBinding ref = makeEnvironment . return . Binding ref
+singleBinding :: Ref a -> a -> Environment
+singleBinding r = makeEnvironment . return . Binding r
 
 class HasEnvironment env where
    environment    :: env -> Environment
    setEnvironment :: Environment -> env -> env
    deleteRef      :: Ref a -> env -> env
-   insertRef      :: Typeable a => Ref a -> a -> env -> env
-   changeRef      :: Typeable a => Ref a -> (a -> a) -> env -> env
+   insertRef      :: Ref a -> a -> env -> env
+   changeRef      :: Ref a -> (a -> a) -> env -> env
    -- default definitions
    deleteRef a = changeEnv (Env . M.delete (getId a) . envMap)
-   insertRef ref =
+   insertRef r =
       let f b = Env . M.insert (getId b) b . envMap
-      in changeEnv . f . Binding ref
-   changeRef ref f env  =
-      maybe id (insertRef ref . f) (ref ? env) env
+      in changeEnv . f . Binding r
+   changeRef r f env  =
+      maybe id (insertRef r . f) (r ? env) env
 
 -- local helper
 changeEnv :: HasEnvironment env => (Environment -> Environment) -> env -> env
@@ -168,11 +180,11 @@ noBindings :: HasEnvironment env => env -> Bool
 noBindings = M.null . envMap . environment
 
-(?) :: (HasEnvironment env, Typeable a) => Ref a -> env -> Maybe a
+(?) :: HasEnvironment env => Ref a -> env -> Maybe a
 ref ? env = do
    let m = envMap (environment env)
-   Binding _ a <- M.lookup (getId ref) m
-   msum [ cast a                         -- typed value
-        , cast a >>= parser ref          -- value as string
-        , cast a >>= match (refView ref) -- value as term
+   Binding r a <- M.lookup (getId ref) m
+   msum [ castBetween r ref a                  -- typed value
+        , castFrom r a >>= parser ref          -- value as string
+        , castFrom r a >>= match (refView ref) -- value as term
         ]

@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, DeriveDataTypeable #-}
+{-# LANGUAGE Rank2Types, ExistentialQuantification #-}
 -----------------------------------------------------------------------------
 -- Copyright 2016, Ideas project team. This file is distributed under the
 -- terms of the Apache License 2.0. For more information, see the files
@@ -32,7 +32,7 @@      -- * Type casting
    , useTypeable, castFrom, castTo
      -- * Exercise properties
-   , setProperty, getProperty
+   , setProperty, getProperty, setPropertyF, getPropertyF
      -- * Random generators
    , simpleGenerator, useGenerator, randomTerm, randomTerms
      -- * Derivations
@@ -41,8 +41,6 @@    ) where
 
 import Data.Char
-import Data.Data
-import Data.Dynamic
 import Data.List
 import Data.Maybe
 import Data.Ord
@@ -55,8 +53,9 @@ import Ideas.Common.Rewriting
 import Ideas.Common.Rule
 import Ideas.Common.Strategy hiding (not, fail, repeat, replicate)
-import Ideas.Common.Utils (ShowString(..))
 import Ideas.Common.View
+import Ideas.Utils.Prelude (ShowString(..))
+import Ideas.Utils.Typeable
 import System.Random
 import Test.QuickCheck hiding (label)
 import Test.QuickCheck.Gen
@@ -129,7 +128,7 @@    , hasTypeable :: Maybe (IsTypeable a)
      -- | Extra exercise-specific properties, not used by the default
      -- feedback services.
-   , properties :: M.Map String Dynamic -- extra, domain-specific properties
+   , properties :: M.Map Id (Dynamic a) -- extra, domain-specific properties
    }
 
 instance Eq (Exercise a) where
@@ -202,7 +201,7 @@ 
 -- | Returns a sorted list of rules, without duplicates.
 ruleset :: Exercise a -> [Rule (Context a)]
-ruleset ex = nub (sortBy compareId list)
+ruleset ex = nub (sortBy (ruleOrdering ex) list)
  where
    list = extraRules ex ++ rulesInStrategy (strategy ex)
 
@@ -252,7 +251,7 @@ type Examples a = [(Difficulty, a)]
 
 data Difficulty = VeryEasy | Easy | Medium | Difficult | VeryDifficult
-   deriving (Eq, Ord, Enum, Data, Typeable)
+   deriving (Eq, Ord, Enum)
 
 instance Show Difficulty where
    show = (xs !!) . fromEnum
@@ -310,38 +309,55 @@ -----------------------------------------------------------------------------
 -- Type casting
 
-data IsTypeable a = IT (forall b . Typeable b => a -> Maybe b)
-                       (forall b . Typeable b => b -> Maybe a)
+instance HasTypeable Exercise where
+   getTypeable = hasTypeable
 
 -- | Encapsulates a type representation (use for 'hasTypeable' field).
 useTypeable :: Typeable a => Maybe (IsTypeable a)
-useTypeable = Just (IT cast cast)
-
--- | Cast from polymorphic type (to exercise-specific type).
--- This only works if 'hasTypeable' contains the right type representation.
-castFrom :: Typeable b => Exercise a -> a -> Maybe b
-castFrom ex a = do
-   IT f _ <- hasTypeable ex
-   f a
-
--- | Cast to polymorphic type (from exercise-specific type).
--- This only works if 'hasTypeable' contains the right type representation.
-castTo :: Typeable b => Exercise a -> b -> Maybe a
-castTo ex a = do
-   IT _ g <- hasTypeable ex
-   g a
+useTypeable = Just typeable
 
 -----------------------------------------------------------------------------
 -- Exercise-specific properties
 
 -- | Set an exercise-specific property (with a dynamic type)
-setProperty :: Typeable val => String -> val -> Exercise a -> Exercise a
-setProperty key a ex =
-   ex { properties = M.insert key (toDyn a) (properties ex) }
+setProperty :: (IsId n, Typeable val) => n -> val -> Exercise a -> Exercise a
+setProperty key a = insertProperty key (Dyn (cast a))
 
+-- | Set an exercise-specific property (with a dynamic type) that is
+-- parameterized over the exercise term.
+setPropertyF :: (IsId n, Typeable f) => n -> f a -> Exercise a -> Exercise a
+setPropertyF key a = insertProperty key (DynF (castF a))
+
+insertProperty :: IsId n => n -> Dynamic a -> Exercise a -> Exercise a
+insertProperty key d ex =
+   ex { properties = M.insert (newId key) d (properties ex) }
+
 -- | Get an exercise-specific property (of a dynamic type)
-getProperty :: Typeable val => String -> Exercise a -> Maybe val
-getProperty key ex = M.lookup key (properties ex) >>= fromDynamic
+getProperty :: (IsId n, Typeable val) => n -> Exercise a -> Maybe val
+getProperty key ex = lookupProperty key ex >>= \d ->
+   case d of
+      Dyn m -> m
+      _     -> Nothing
+
+-- | Get an exercise-specific property (of a dynamic type) that is
+-- parameterized over the exercise term.
+getPropertyF :: (IsId n, Typeable f) => n -> Exercise a -> Maybe (f a)
+getPropertyF key ex = lookupProperty key ex >>= \d ->
+   case d of
+      DynF m -> m
+      _      -> Nothing
+
+lookupProperty :: IsId n => n -> Exercise a -> Maybe (Dynamic a)
+lookupProperty key = M.lookup (newId key) . properties
+
+-- | Values with a dynamic type that is parameterized over the exercise term.
+data Dynamic a = Dyn  (forall b . Typeable b => Maybe b)
+               | DynF (forall f . Typeable f => Maybe (f a))
+
+castF :: (Typeable f, Typeable g) => f a -> Maybe (g a)
+castF = fmap fromIdentity . gcast1 . Identity
+
+newtype Identity a = Identity { fromIdentity :: a}
 
 ---------------------------------------------------------------
 -- Random generators

@@ -23,8 +23,8 @@ import Ideas.Common.Exercise
 import Ideas.Common.Id
 import Ideas.Common.Rule
-import Ideas.Common.Utils.TestSuite
 import Ideas.Common.View
+import Ideas.Utils.TestSuite
 import Test.QuickCheck
 import Test.QuickCheck.Random
 
@@ -54,7 +54,7 @@               checkParserPrettyEx ex . inContext ex . fromS
          , suite "Soundness non-buggy rules" $
                  let eq a b = equivalence ex (fromS a) (fromS b)
-                     myGen  = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen)
+                     myGen  = showAs (prettyPrinterContext ex) (inContext ex <$> gen)
                      myView = makeView (Just . fromS) (S (prettyPrinterContext ex))
                      args   = stdArgs {maxSize = 10, maxSuccess = 10}
                  in [ usePropertyWith (showId r) args $
@@ -81,7 +81,7 @@    show a = showS a (fromS a)
 
 showAs :: (a -> String) -> Gen a -> Gen (ShowAs a)
-showAs f = liftM (S f)
+showAs f = fmap (S f)
 
 -- check combination of parser and pretty-printer
 checkParserPretty :: (a -> a -> Bool) -> (String -> Either String a) -> (a -> String) -> a -> Bool

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}
 -----------------------------------------------------------------------------
 -- Copyright 2016, Ideas project team. This file is distributed under the
 -- terms of the Apache License 2.0. For more information, see the files
@@ -45,13 +44,12 @@ 
 import Control.Monad
 import Data.Char
-import Data.Data
 import Data.List
 import Data.Monoid
 import Data.Ord
 import Ideas.Common.Classes
-import Ideas.Common.Utils (splitsWithElem)
-import Ideas.Common.Utils.StringRef
+import Ideas.Utils.Prelude (splitsWithElem)
+import Ideas.Utils.StringRef
 import Test.QuickCheck
 
 ---------------------------------------------------------------------
@@ -64,7 +62,6 @@    , idDescription :: String
    , idRef         :: !StringRef
    }
- deriving (Data, Typeable)
 
 instance Show Id where
    show = intercalate "." . idList

@@ -15,6 +15,7 @@ module Ideas.Common.Library
    ( module Export
    , failS, notS, repeatS, replicateS, sequenceS, untilS
+   , Some(..)
    ) where
 
 import Ideas.Common.Classes as Export
@@ -28,8 +29,8 @@ import Ideas.Common.Rule as Export
 import Ideas.Common.Strategy as Export hiding (fail, not, repeat, replicate, sequence, until)
 import Ideas.Common.Traversal.Navigator as Export (Location, location, toLocation, fromLocation, arity, top)
-import Ideas.Common.Utils as Export (readM)
 import Ideas.Common.View as Export
+import Ideas.Utils.Prelude as Export (readM, Some(..))
 
 import qualified Ideas.Common.Strategy as S
 

@@ -22,7 +22,7 @@    , ands, ors, implies, equivalent
    ) where
 
-import Ideas.Common.Algebra.Boolean
+import Ideas.Common.Classes
 import Ideas.Common.Id
 import Ideas.Common.View
 

@@ -24,7 +24,7 @@ import Ideas.Common.Rewriting.Unification
 import Ideas.Common.Traversal.Navigator
 import Ideas.Common.Traversal.Utils
-import Ideas.Common.Utils.Uniplate hiding (rewriteM)
+import Ideas.Utils.Uniplate hiding (rewriteM)
 
 normalForm :: [RewriteRule a] -> Term -> Term
 normalForm rs = run []

@@ -32,8 +32,8 @@ import Ideas.Common.Rewriting.Substitution
 import Ideas.Common.Rewriting.Term
 import Ideas.Common.Rewriting.Unification
-import Ideas.Common.Utils.Uniplate (descend)
 import Ideas.Common.View hiding (match)
+import Ideas.Utils.Uniplate (descend)
 import qualified Data.IntSet as IS
 import qualified Data.Map as M
 

@@ -22,8 +22,8 @@ import Data.List
 import Data.Maybe
 import Ideas.Common.Rewriting.Term
-import Ideas.Common.Utils.TestSuite
-import Ideas.Common.Utils.Uniplate
+import Ideas.Utils.TestSuite
+import Ideas.Utils.Uniplate
 import Test.QuickCheck
 import qualified Data.IntMap as IM
 import qualified Data.IntSet as IS
@@ -91,7 +91,7 @@ infix 6 @+@
 
 (@+@) :: Substitution -> Substitution -> Maybe Substitution
-s1 @+@ s2 = liftM S $ foldM op (unS s1) $ IM.toList $ unS s2
+s1 @+@ s2 = fmap S $ foldM op (unS s1) $ IM.toList $ unS s2
  where
    op m (i, a) =
       case IM.lookup i m of

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}
 {-# OPTIONS -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 -- Copyright 2016, Ideas project team. This file is distributed under the
@@ -18,6 +17,7 @@    ( -- * Symbols
      Symbol, newSymbol
    , isAssociative, makeAssociative
+   , nothingSymbol, trueSymbol, falseSymbol
      -- * Terms
    , Term(..), IsTerm(..), termView
    , fromTermM, fromTermWith
@@ -34,15 +34,15 @@    ) where
 
 import Control.Monad
-import Data.Data
 import Data.Function
 import Data.Maybe
 import Ideas.Common.Id
-import Ideas.Common.Utils (ShowString(..))
-import Ideas.Common.Utils.QuickCheck
-import Ideas.Common.Utils.Uniplate
 import Ideas.Common.View
+import Ideas.Utils.Prelude (ShowString(..))
+import Ideas.Utils.QuickCheck
+import Ideas.Utils.Uniplate
 import qualified Data.IntSet as IS
+import qualified Data.Map as M
 import qualified Data.Set as S
 
 -----------------------------------------------------------
@@ -84,7 +84,7 @@           | TNum   Integer
           | TFloat Double
           | TMeta  Int
- deriving (Show, Read, Eq, Ord, Typeable)
+ deriving (Show, Read, Eq, Ord)
 
 instance Uniplate Term where
    uniplate (TCon x xs)   = plate (function x) ||* xs
@@ -95,8 +95,14 @@ -- * Type class for conversion to/from terms
 
 class IsTerm a where
-   toTerm   :: a -> Term
-   fromTerm :: MonadPlus m => Term -> m a
+   toTerm       :: a -> Term
+   toTermList   :: [a] -> Term
+   fromTerm     :: MonadPlus m => Term -> m a
+   fromTermList :: MonadPlus m => Term -> m [a]
+   -- default implementation
+   toTermList   = TList . map toTerm
+   fromTermList (TList xs) = mapM fromTerm xs
+   fromTermList _ = fail "fromTermList: not a list"
 
 termView :: IsTerm a => View Term a
 termView = makeView fromTerm toTerm
@@ -112,18 +118,18 @@ 
 instance (IsTerm a, IsTerm b) => IsTerm (a, b) where
    toTerm (a, b) = TList [toTerm a, toTerm b]
-   fromTerm (TList [a, b]) = liftM2 (,) (fromTerm a) (fromTerm b)
+   fromTerm (TList [a, b]) =  (,) <$> fromTerm a <*> fromTerm b
    fromTerm _              = fail "fromTerm"
 
 instance (IsTerm a, IsTerm b) => IsTerm (Either a b) where
    toTerm = either toTerm toTerm
    fromTerm expr =
-      liftM Left  (fromTerm expr) `mplus`
-      liftM Right (fromTerm expr)
+      fmap Left  (fromTerm expr) `mplus`
+      fmap Right (fromTerm expr)
 
 instance IsTerm Int where
    toTerm = TNum . fromIntegral
-   fromTerm = liftM fromInteger . fromTerm
+   fromTerm = fmap fromInteger . fromTerm
 
 instance IsTerm Integer where
    toTerm = TNum
@@ -137,13 +143,41 @@ 
 instance IsTerm Char where
    toTerm c = TVar [c]
-   fromTerm (TVar [c]) = return c
-   fromTerm _          = fail "fromTerm"
+   toTermList = TVar
+   fromTerm (TVar [c])   = return c
+   fromTerm _            = fail "fromTerm: not a TVar"
+   fromTermList (TVar s) = return s
+   fromTermList _        = fail "fromTermList: not a TVar"
 
+instance IsTerm Bool where
+   toTerm True  = symbol trueSymbol
+   toTerm False = symbol falseSymbol
+   fromTerm (TCon s [])
+      | s == trueSymbol  = return True
+      | s == falseSymbol = return False
+   fromTerm _ = fail "fromTerm: not a Bool"
+
 instance IsTerm a => IsTerm [a] where
-   toTerm = TList . map toTerm
-   fromTerm (TList xs) = mapM fromTerm xs
-   fromTerm _ = fail "fromTerm"
+   toTerm = toTermList
+   fromTerm = fromTermList
+
+instance (IsTerm a, Ord a) => IsTerm (S.Set a) where
+   toTerm   = toTerm . S.toList
+   fromTerm = fmap S.fromList . fromTerm
+
+instance (IsTerm a, IsTerm b, Ord a) => IsTerm (M.Map a b) where
+   toTerm   = toTerm . M.toList
+   fromTerm = fmap M.fromList . fromTerm
+
+trueSymbol, falseSymbol, nothingSymbol :: Symbol
+trueSymbol    = newSymbol "true"
+falseSymbol   = newSymbol "false"
+nothingSymbol = newSymbol "Nothing"
+
+instance IsTerm a => IsTerm (Maybe a) where
+   toTerm = maybe (symbol nothingSymbol) toTerm
+   fromTerm (TCon s []) | s == nothingSymbol = return Nothing
+   fromTerm t = fmap Just (fromTerm t)
 
 fromTermM :: (Monad m, IsTerm a) => Term -> m a
 fromTermM = maybe (fail "fromTermM") return . fromTerm

@@ -21,7 +21,7 @@ import Ideas.Common.Rewriting.AC (pairingsMatchA)
 import Ideas.Common.Rewriting.Substitution
 import Ideas.Common.Rewriting.Term
-import Ideas.Common.Utils.TestSuite
+import Ideas.Utils.TestSuite
 import qualified Data.Map as M
 
 -----------------------------------------------------------
@@ -141,7 +141,7 @@ safeZipWith f = rec
  where
    rec []     []     = Just []
-   rec (a:as) (b:bs) = liftM (f a b:) (rec as bs)
+   rec (a:as) (b:bs) = fmap (f a b:) (rec as bs)
    rec _      _      = Nothing
 
 products :: [[Substitution]] -> [Substitution]

@@ -13,7 +13,6 @@ module Ideas.Common.Rule (module Export) where
 
 import Ideas.Common.Rule.Abstract as Export
-import Ideas.Common.Rule.EnvironmentMonad as Export
 import Ideas.Common.Rule.Parameter as Export
 import Ideas.Common.Rule.Recognizer as Export
 import Ideas.Common.Rule.Transformation as Export

@@ -25,10 +25,10 @@    , idRule, checkRule, emptyRule
      -- * Rule properties
    , ruleSiblings, siblingOf
-   , isRewriteRule, isRecognizer, doAfter
+   , isRewriteRule, doAfter
      -- * Recognizer
    , addRecognizer, addRecognizerBool
-   , addTransRecognizer, addRecognizerEnvMonad
+   , addTransRecognizer
    ) where
 
 import Control.Arrow
@@ -37,7 +37,6 @@ import Ideas.Common.Environment
 import Ideas.Common.Id
 import Ideas.Common.Rewriting
-import Ideas.Common.Rule.EnvironmentMonad
 import Ideas.Common.Rule.Recognizer
 import Ideas.Common.Rule.Transformation
 import Ideas.Common.View
@@ -155,9 +154,6 @@ isRewriteRule :: Rule a -> Bool
 isRewriteRule = not . null . getRewriteRules . transformation
 
-isRecognizer :: Rule a -> Bool
-isRecognizer = isZeroTrans . transformation
-
 siblingOf :: HasId b => b -> Rule a -> Rule a
 siblingOf sib r = r { ruleSiblings = getId sib : ruleSiblings r }
 
@@ -173,9 +169,6 @@ 
 addRecognizerBool :: (a -> a -> Bool) -> Rule a -> Rule a
 addRecognizerBool eq = addRecognizer (makeRecognizer eq)
-
-addRecognizerEnvMonad :: (a -> a -> EnvMonad ()) -> Rule a -> Rule a
-addRecognizerEnvMonad = addRecognizer . makeRecognizerEnvMonad
 
 addTransRecognizer :: (a -> a -> Bool) -> Rule a -> Rule a
 addTransRecognizer eq r = flip addRecognizer r $

@@ -1,132 +0,0 @@-{-# LANGUAGE GADTs #-}
------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- State monad for environments
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Rule.EnvironmentMonad
-   ( -- * Environment Monad
-     EnvMonad((:=), (:~), (:?))
-   , getRef, updateRefs
-     -- * Running the monad
-   , runEnvMonad, execEnvMonad, evalEnvMonad
-     -- * Extracting used references
-   , envMonadRefs, envMonadFunctionRefs
-   ) where
-
-import Control.Applicative (Alternative(..))
-import Control.Monad
-import Data.Maybe
-import Data.Typeable
-import Ideas.Common.Environment
-import Ideas.Common.Utils
-import System.IO.Unsafe
-import qualified Control.Exception as C
-
------------------------------------------------------------
--- Environment Monad
-
-infix 2 :=, :~, :?
-
-data EnvMonad a where
-   -- Monad operations
-   Return :: a -> EnvMonad a
-   Bind   :: EnvMonad a -> (a -> EnvMonad b) -> EnvMonad b
-   Then   :: EnvMonad a -> EnvMonad b -> EnvMonad b
-   Fail   :: String -> EnvMonad b
-   -- MonadPlus operations
-   Zero   :: EnvMonad a
-   Plus   :: EnvMonad a -> EnvMonad a -> EnvMonad a
-   -- References (special)
-   (:=)   :: Typeable a => Ref a -> a -> EnvMonad ()
-   (:~)   :: Typeable a => Ref a -> (a -> a) -> EnvMonad ()
-   (:?)   :: Typeable a => Ref a -> a -> EnvMonad a
-   GetRef :: Typeable a => Ref a -> EnvMonad a
-
-instance Functor EnvMonad where
-   fmap = liftM
-
-instance Applicative EnvMonad where
-   pure  = return
-   (<*>) = ap
-
-instance Alternative EnvMonad where
-   empty = Zero
-   (<|>) = Plus
-
-instance Monad EnvMonad where
-   return = Return
-   (>>=)  = Bind
-   fail   = Fail
-
-instance MonadPlus EnvMonad where
-   mzero = Zero
-   mplus = Plus
-
-getRef :: Typeable a => Ref a -> EnvMonad a
-getRef = GetRef
-
-updateRefs :: MonadPlus m => [EnvMonad a] -> Environment -> m Environment
-updateRefs xs = msum . map return . execEnvMonad (sequence_ xs)
-
------------------------------------------------------------
--- Environment Monad
-
-runEnvMonad :: EnvMonad a -> Environment -> [(a, Environment)]
-runEnvMonad envMonad env =
-   case envMonad of
-      Return a   -> [(a, env)]
-      Bind m f   -> concat [ runEnvMonad (f a) e | (a, e) <- runEnvMonad m env ]
-      Then m n   -> concat [ runEnvMonad n e     | (_, e) <- runEnvMonad m env ]
-      Fail _     -> []
-      Zero       -> []
-      Plus m n   -> runEnvMonad m env ++ runEnvMonad n env
-      ref := a   -> [((), insertRef ref a env)]
-      ref :~ f   -> [((), changeRef ref f env)]
-      ref :? a   -> [(fromMaybe a (ref ? env), env)]
-      GetRef ref -> case ref ? env of
-                       Just a  -> [(a, env)]
-                       Nothing -> []
-
-execEnvMonad :: EnvMonad a -> Environment -> [Environment]
-execEnvMonad m = liftM snd . runEnvMonad m
-
-evalEnvMonad :: EnvMonad a -> Environment -> [a]
-evalEnvMonad m = liftM fst . runEnvMonad m
-
------------------------------------------------------------
--- Extracting used references
-
-envMonadRefs :: EnvMonad a -> [Some Ref]
-envMonadRefs = unsafePerformIO . safeIO . envMonadRefsIO
-
-envMonadFunctionRefs :: (a -> EnvMonad b) -> [Some Ref]
-envMonadFunctionRefs = unsafePerformIO . safeIO . envMonadFunctionRefsIO
-
-envMonadRefsIO :: EnvMonad a -> IO [Some Ref]
-envMonadRefsIO monad =
-   case monad of
-      Bind m f -> envMonadRefsIO m ++++ envMonadFunctionRefsIO f
-      Then a b -> envMonadRefsIO a ++++ envMonadRefsIO b
-      Plus a b -> envMonadRefsIO a ++++ envMonadRefsIO b
-      r := _   -> return [Some r]
-      r :~ _   -> return [Some r]
-      r :? _   -> return [Some r]
-      _        -> return []
- where
-   a ++++ b = liftM2 (++) (safeIO a) (safeIO b)
-
-envMonadFunctionRefsIO :: (a -> EnvMonad b) -> IO [Some Ref]
-envMonadFunctionRefsIO = safeIO . envMonadRefsIO . ($ error "catch me")
-
-safeIO :: IO [a] -> IO [a]
-safeIO m = m `C.catch` \(C.SomeException _) -> return []

@@ -17,44 +17,119 @@ -----------------------------------------------------------------------------
 
 module Ideas.Common.Rule.Parameter
-   ( ParamTrans
-   , supplyParameters, supplyContextParameters
+   ( -- * Reading inputs
+     input, inputWith
+   , transInput1, transInput2, transInput3, transInputWith
+   , readRef2, readRef3
+     -- * Writing outputs
+   , output, outputWith
+   , outputOnly, outputOnly2, outputOnly3, outputOnlyWith
+   , writeRef2, writeRef3, writeRef2_, writeRef3_
+     -- * Named parameters
+   , ParamTrans
    , parameter1, parameter2, parameter3
+   , transRef
+   , supplyParameters
    ) where
 
 import Control.Arrow
+import Data.Maybe
 import Ideas.Common.Context
 import Ideas.Common.Environment
-import Ideas.Common.Id
-import Ideas.Common.Rule.EnvironmentMonad
 import Ideas.Common.Rule.Transformation
 import Ideas.Common.View
 
------------------------------------------------------------
---- Bindables
+----------------------------------------------------------------------------
+-- Reading inputs
 
-type ParamTrans a b = Trans (a, b) b
+input :: Ref i -> Trans (i, a) b -> Trans a b
+input = inputWith . readRef
 
-supplyParameters :: ParamTrans b a -> (a -> Maybe b) -> Transformation a
-supplyParameters f g = transMaybe g &&& identity >>> f
+inputWith :: Trans a i -> Trans (i, a) b -> Trans a b
+inputWith f g = (f &&& identity) >>> g
 
-supplyContextParameters :: ParamTrans b a -> (a -> EnvMonad b) -> Transformation (Context a)
-supplyContextParameters f g = transLiftContextIn $
-   transUseEnvironment (transEnvMonad g &&& identity) >>> first f
+transInput1 :: Ref i -> (i -> a -> Maybe b) -> Trans a b
+transInput1 = transInputWith . readRef
 
-parameter1 :: (IsId n1, Reference a) => n1 -> (a -> Transformation b) -> ParamTrans a b
-parameter1 n1 f = first (bindValue n1 >>> arr f) >>> app
+transInput2 :: Ref i1 -> Ref i2 -> (i1 -> i2 -> a -> Maybe b) -> Trans a b
+transInput2 r1 r2 = transInputWith (readRef2 r1 r2) . uncurry
 
-parameter2 :: (IsId n1, IsId n2, Reference a, Reference b)
-           => n1 -> n2 -> (a -> b -> Transformation c) -> ParamTrans (a, b) c
-parameter2 n1 n2 f = first (bindValue n1 *** bindValue n2 >>> arr (uncurry f)) >>> app
+transInput3 :: Ref i1 -> Ref i2 -> Ref i3 -> (i1 -> i2 -> i3 -> a -> Maybe b) -> Trans a b
+transInput3 r1 r2 r3 = transInputWith (readRef3 r1 r2 r3) . uncurry3
 
-parameter3 :: (IsId n1, IsId n2, IsId n3, Reference a, Reference b, Reference c)
-           => n1 -> n2 -> n3 -> (a -> b -> c -> Transformation d) -> ParamTrans (a, b, c) d
-parameter3 n1 n2 n3 f = first ((\(a, b, c) -> (a, (b, c))) ^>>
-   bindValue n1 *** (bindValue n2 *** bindValue n3) >>^
-   (\(a, (b, c)) -> f a b c))
-           >>> app
+transInputWith :: MakeTrans f => Trans a i -> (i -> a -> f b) -> Trans a b
+transInputWith t = inputWith t . makeTrans . uncurry
 
-bindValue :: (IsId n, Reference a) => n -> Trans a a
-bindValue = transRef . makeRef+readRef2 :: Ref a -> Ref b -> Trans x (a, b)
+readRef2 r1 r2 = readRef r1 &&& readRef r2
+
+readRef3 :: Ref a -> Ref b -> Ref c -> Trans x (a, b, c)
+readRef3 r1 r2 r3 = readRef r1 &&& readRef2 r2 r3 >>^ to3
+
+----------------------------------------------------------------------------
+-- Writing outputs
+
+output :: Ref o -> Trans a (b, o) -> Trans a b
+output = outputWith . writeRef
+
+outputWith :: Trans o x -> Trans a (b, o) -> Trans a b
+outputWith f g = g >>> second f >>^ fst
+
+outputOnly :: Ref o -> Trans a o -> Trans a a
+outputOnly = outputOnlyWith . writeRef
+
+outputOnly2 :: Ref o1 -> Ref o2 -> Trans a (o1, o2) -> Trans a a
+outputOnly2 r1 = outputOnlyWith . writeRef2 r1
+
+outputOnly3 :: Ref o1 -> Ref o2 -> Ref o3 -> Trans a (o1, o2, o3) -> Trans a a
+outputOnly3 r1 r2 = outputOnlyWith . writeRef3 r1 r2
+
+outputOnlyWith :: Trans o x -> Trans a o -> Trans a a
+outputOnlyWith f g = ((g >>> f) &&& identity) >>^ snd
+
+writeRef2 :: Ref a -> Ref b -> Trans (a, b) (a, b)
+writeRef2 r1 r2 = writeRef r1 *** writeRef r2
+
+writeRef2_ :: Ref a -> Ref b -> Trans (a, b) ()
+writeRef2_ r1 r2 = writeRef2 r1 r2 >>^ const ()
+
+writeRef3 :: Ref a -> Ref b -> Ref c -> Trans (a, b, c) (a, b, c)
+writeRef3 r1 r2 r3 = from3 ^>> writeRef r1 *** writeRef2 r2 r3 >>^ to3
+
+writeRef3_ :: Ref a -> Ref b -> Ref c -> Trans (a, b, c) ()
+writeRef3_ r1 r2 r3 = writeRef3 r1 r2 r3 >>^ const ()
+
+----------------------------------------------------------------------------
+-- Named parameters
+
+type ParamTrans i a = Trans (i, a) a
+
+parameter1 :: Ref a -> (a -> b -> Maybe b) -> ParamTrans a b
+parameter1 r1 f = first (transRef r1) >>> makeTrans (uncurry f)
+
+parameter2 :: Ref a -> Ref b -> (a -> b -> c -> Maybe c) -> ParamTrans (a, b) c
+parameter2 r1 r2 f = first (transRef r1 *** transRef r2) >>> makeTrans (uncurry (uncurry f))
+
+parameter3 :: Ref a -> Ref b -> Ref c -> (a -> b -> c -> d -> Maybe d) -> ParamTrans (a, b, c) d
+parameter3 r1 r2 r3 f = first (from3 ^>> t >>^ to3) >>> makeTrans (uncurry (\(a, b, c) -> f a b c))
+ where
+   t = transRef r1 *** (transRef r2 *** transRef r3)
+
+transRef :: Ref a -> Trans a a
+transRef r = (identity &&& readRefMaybe r) >>> uncurry fromMaybe ^>> writeRef r
+
+supplyParameters :: ParamTrans b a -> Trans a b -> Transformation (Context a)
+supplyParameters f g = transLiftContextIn $
+   transUseEnvironment (g &&& identity) >>> first f
+
+-----------------------------------------------------------------
+-- helpers
+
+from3 :: (a, b, c) -> (a, (b, c))
+from3 (a, b, c) = (a, (b, c))
+
+to3 :: (a, (b, c)) -> (a, b, c)
+to3 (a, (b, c)) = (a, b, c)
+
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c

@@ -14,13 +14,11 @@    ( -- * data type and type class
      Recognizable(..), Recognizer
      -- * Constructor functions
-   , makeRecognizer, makeRecognizerEnvMonad, makeRecognizerTrans
+   , makeRecognizer, makeRecognizerTrans
    ) where
 
-import Control.Monad
 import Data.Maybe
 import Ideas.Common.Environment
-import Ideas.Common.Rule.EnvironmentMonad
 import Ideas.Common.Rule.Transformation
 import Ideas.Common.View
 
@@ -58,10 +56,8 @@ --- Constructor functions
 
 makeRecognizer :: (a -> a -> Bool) -> Recognizer a
-makeRecognizer eq = makeRecognizerEnvMonad $ \a b -> guard (eq a b)
-
-makeRecognizerEnvMonad :: (a -> a -> EnvMonad ()) -> Recognizer a
-makeRecognizerEnvMonad = makeRecognizerTrans . makeTrans . uncurry
+makeRecognizer eq = makeRecognizerTrans $ transMaybe $ \(x, y) ->
+   if eq x y then Just () else Nothing
 
 makeRecognizerTrans :: Trans (a, a) () -> Recognizer a
 makeRecognizerTrans = R

@@ -19,46 +19,48 @@      Transformation, Trans
      -- * Constructor functions
    , MakeTrans(..)
-   , transPure, transMaybe, transList, transEnvMonad
-   , transRewrite, transRef
+   , transPure, transMaybe, transList, transGuard, transRewrite
+     -- * Reading and writing (with references)
+   , readRef, readRefDefault, readRefMaybe
+   , writeRef, writeRef_, writeRefMaybe
      -- * Lifting transformations
    , transUseEnvironment
    , transLiftView, transLiftViewIn
    , transLiftContext, transLiftContextIn
-   , makeTransLiftContext, makeTransLiftContext_
      -- * Using transformations
    , transApply, transApplyWith
-   , getRewriteRules, isZeroTrans
+   , getRewriteRules
    ) where
 
+import Control.Applicative
 import Control.Arrow
 import Data.Maybe
-import Data.Typeable
 import Ideas.Common.Classes
 import Ideas.Common.Context
 import Ideas.Common.Environment
 import Ideas.Common.Rewriting
-import Ideas.Common.Rule.EnvironmentMonad
-import Ideas.Common.Utils
 import Ideas.Common.View
+import Ideas.Utils.Prelude
 import qualified Control.Category as C
 
 -----------------------------------------------------------
 --- Trans data type and instances
 
+type Transformation a = Trans a a
+
 data Trans a b where
    Zero     :: Trans a b
    List     :: (a -> [b]) -> Trans a b
    Rewrite  :: RewriteRule a -> Trans a a
-   EnvMonad :: (a -> EnvMonad b) -> Trans a b
-   Ref      :: Typeable a => Ref a -> Trans a a
    UseEnv   :: Trans a b -> Trans (a, Environment) (b, Environment)
    (:>>:)   :: Trans a b -> Trans b c -> Trans a c
    (:**:)   :: Trans a c -> Trans b d -> Trans (a, b) (c, d)
    (:++:)   :: Trans a c -> Trans b d -> Trans (Either a b) (Either c d)
-   Apply    :: Trans (Trans a b, a) b
    Append   :: Trans a b -> Trans a b -> Trans a b
 
+   ReadRefM  :: Ref a -> Trans x (Maybe a)
+   WriteRefM :: Ref a -> Trans (Maybe a) ()
+
 instance C.Category Trans where
    id  = arr id
    (.) = flip (:>>:)
@@ -80,15 +82,21 @@    left f  = f :++: identity
    right f = identity :++: f
 
-instance ArrowApply Trans where
-   app = Apply
-
 instance Monoid (Trans a b) where
    mempty  = zeroArrow
    mappend = (<+>)
 
-type Transformation a = Trans a a
+instance Functor (Trans a) where
+   fmap f t = t >>^ f
 
+instance Applicative (Trans a) where
+   pure    = transPure . const
+   s <*> t = (s &&& t) >>^ uncurry ($)
+
+instance Alternative (Trans a) where
+   empty = zeroArrow
+   (<|>) = (<+>)
+
 -----------------------------------------------------------
 --- Constructor functions
 
@@ -103,9 +111,6 @@ instance MakeTrans [] where
    makeTrans = transList
 
-instance MakeTrans EnvMonad where
-   makeTrans = transEnvMonad
-
 transPure :: (a -> b) -> Trans a b
 transPure f = transList (return . f)
 
@@ -115,17 +120,35 @@ transList :: (a -> [b]) -> Trans a b
 transList = List
 
-transEnvMonad :: (a -> EnvMonad b) -> Trans a b
-transEnvMonad = EnvMonad
+transGuard :: (a -> Bool) -> Trans a a
+transGuard p = transMaybe $ \x -> if p x then Just x else Nothing
 
 transRewrite :: RewriteRule a -> Trans a a
 transRewrite = Rewrite
 
-transRef :: Typeable a => Ref a -> Trans a a
-transRef = Ref
+-----------------------------------------------------------
+-- Reading and writing (with references)
 
+readRef :: Ref a -> Trans x a
+readRef r = readRefMaybe r >>> transMaybe id
+
+readRefDefault :: a -> Ref a -> Trans x a
+readRefDefault a r = readRefMaybe r >>^ fromMaybe a
+
+readRefMaybe  :: Ref a -> Trans x (Maybe a)
+readRefMaybe = ReadRefM
+
+writeRef :: Ref a -> Trans a a
+writeRef r = (identity &&& writeRef_ r) >>^ fst
+
+writeRef_ :: Ref a -> Trans a ()
+writeRef_ r = Just ^>> writeRefMaybe r
+
+writeRefMaybe :: Ref a -> Trans (Maybe a) ()
+writeRefMaybe = WriteRefM
+
 -----------------------------------------------------------
---- Lifting transformations
+-- Lifting transformations
 
 transUseEnvironment :: Trans a b -> Trans (a, Environment) (b, Environment)
 transUseEnvironment = UseEnv
@@ -134,7 +157,7 @@ transLiftView v = transLiftViewIn (v &&& identity)
 
 transLiftViewIn :: View a (b, c) -> Transformation b -> Transformation a
-transLiftViewIn v f = makeTrans (match v) >>> first f >>> arr (build v)
+transLiftViewIn v f = makeTrans (match v) >>> first f >>^ build v
 
 transLiftContext :: Transformation a -> Transformation (Context a)
 transLiftContext = transLiftContextIn . transUseEnvironment
@@ -145,14 +168,6 @@    f (a, c)        = ((a, environment c), c)
    g ((a, env), c) = (a, setEnvironment env c)
 
--- | Overloaded variant of @transLiftContext@
-makeTransLiftContext :: MakeTrans f => (a -> f a) -> Transformation (Context a)
-makeTransLiftContext = transLiftContext . makeTrans
-
--- | Overloaded variant of @transLiftContext@; ignores result
-makeTransLiftContext_ :: MakeTrans f => (a -> f ()) -> Transformation (Context a)
-makeTransLiftContext_ f = transLiftContext (identity &&& makeTrans f >>> arr fst)
-
 -----------------------------------------------------------
 --- Using transformations
 
@@ -165,21 +180,18 @@       Zero       -> []
       List f     -> [ (b, env) | b <- f a ]
       Rewrite r  -> [ (b, env) | b <- applyAll r a ]
-      EnvMonad f -> runEnvMonad (f a) env
-      Ref ref    -> case ref ? env of
-                       Just b  -> [(b, env)]
-                       Nothing -> [(a, insertRef ref a env)]
       UseEnv f   -> do (b, envb) <- transApplyWith (snd a) f (fst a)
                        return ((b, envb), env)
       f :>>: g   -> do (b, env1) <- transApplyWith env  f a
                        (c, env2) <- transApplyWith env1 g b
                        return (c, env2)
       f :**: g   -> do (b, env1) <- transApplyWith env f (fst a)
-                       (c, env2) <- transApplyWith env g (snd a)
-                       return ((b, c), env2 `mappend` env1)
+                       (c, env2) <- transApplyWith env1 g (snd a)
+                       return ((b, c), env2)
       f :++: g   -> either (make Left f) (make Right g) a
-      Apply      -> uncurry (transApplyWith env) a
       Append f g -> transApplyWith env f a ++ transApplyWith env g a
+      ReadRefM r  -> [(r ? env, env)]
+      WriteRefM r -> [((), maybe (deleteRef r) (insertRef r) a env)]
  where
    make :: (b -> c) -> Trans a b -> a -> [(c, Environment)]
    make f g = map (mapFirst f) . transApplyWith env g
@@ -193,27 +205,17 @@ instance HasRefs (Trans a b) where
    allRefs trans =
       case trans of
-         Ref r      -> [Some r]
-         EnvMonad f -> envMonadFunctionRefs f
-         _          -> descendTrans allRefs trans
-
-isZeroTrans :: Trans a b -> Bool
-isZeroTrans = or . rec
- where
-   rec :: Trans a b -> [Bool]
-   rec trans =
-      case trans of
-         Zero       -> [True]
-         Append f g -> [isZeroTrans f && isZeroTrans g]
-         _          -> descendTrans rec trans
+         ReadRefM r  -> [Some r]
+         WriteRefM r -> [Some r]
+         _           -> descendTrans allRefs trans
 
 -- General recursion function (existentially quantified)
 descendTrans :: Monoid m => (forall x y . Trans x y -> m) -> Trans a b -> m
 descendTrans make trans =
    case trans of
-      UseEnv f   -> make f
-      f :>>: g   -> make f `mappend` make g
-      f :**: g   -> make f `mappend` make g
-      f :++: g   -> make f `mappend` make g
-      Append f g -> make f `mappend` make g
-      _          -> mempty+      UseEnv f     -> make f
+      f :>>: g     -> make f `mappend` make g
+      f :**: g     -> make f `mappend` make g
+      f :++: g     -> make f `mappend` make g
+      Append f g   -> make f `mappend` make g
+      _            -> mempty

@@ -31,7 +31,7 @@    , many, many1, replicate, option
      -- ** Negation and greedy combinators
    , check, not, repeat, repeat1, try, (|>), (./.)
-   , exhaustive, while, until
+   , exhaustive, while, until, dynamic
      -- ** Graph
    , DependencyGraph, dependencyGraph
      -- ** Traversal combinators

@@ -33,22 +33,22 @@    ) where
 
 import Data.Foldable (toList)
+import Data.Maybe
 import Ideas.Common.Classes
-import Ideas.Common.CyclicTree hiding (label)
 import Ideas.Common.Derivation
 import Ideas.Common.Environment
 import Ideas.Common.Id
 import Ideas.Common.Rewriting (RewriteRule)
 import Ideas.Common.Rule
 import Ideas.Common.Strategy.Choice
+import Ideas.Common.Strategy.CyclicTree hiding (label)
 import Ideas.Common.Strategy.Prefix
 import Ideas.Common.Strategy.Process
 import Ideas.Common.Strategy.Sequence (Sequence(..), ready)
 import Ideas.Common.Strategy.StrategyTree
-import Ideas.Common.Strategy.Symbol
 import Ideas.Common.View
 import Prelude hiding (sequence)
-import qualified Ideas.Common.CyclicTree as Tree
+import qualified Ideas.Common.Strategy.CyclicTree as Tree
 
 -----------------------------------------------------------
 --- Strategy data-type
@@ -99,11 +99,14 @@   toStrategy (LS info (S t)) = S (Tree.label info t)
 
 instance IsStrategy Rule where
-   toStrategy = S . leaf
+   toStrategy = S . leaf . LeafRule
 
 instance IsStrategy RewriteRule where
    toStrategy = toStrategy . ruleRewrite
 
+instance IsStrategy Dynamic where
+   toStrategy = S . leaf . LeafDyn
+
 liftS :: IsStrategy f => (Strategy a -> Strategy a) -> f a -> Strategy a
 liftS f = f . toStrategy
 
@@ -184,20 +187,23 @@ 
 -- | Returns a list of all major rules that are part of a labeled strategy
 rulesInStrategy :: IsStrategy f => f a -> [Rule a]
-rulesInStrategy s = [ r | r <- toList (toStrategyTree s), isMajor r ]
+rulesInStrategy s = concatMap f (toList (toStrategyTree s))
+ where
+   f (LeafRule r) | isMajor r = [r]
+   f _ = []
 
 instance LiftView LabeledStrategy where
-   liftViewIn = mapRules . liftViewIn
+   liftViewIn v (LS n s) = LS n (liftViewIn v s)
 
 instance LiftView Strategy where
-   liftViewIn = mapRulesS . liftViewIn
+   liftViewIn v = S . fmap (liftViewIn v) . toStrategyTree
 
 -- | Apply a function to all the rules that make up a labeled strategy
-mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b
+mapRules :: (Rule a -> Rule a) -> LabeledStrategy a -> LabeledStrategy a
 mapRules f (LS n s) = LS n (mapRulesS f s)
 
-mapRulesS :: (Rule a -> Rule b) -> Strategy a -> Strategy b
-mapRulesS f = S . fmap f . unS
+mapRulesS :: (Rule a -> Rule a) -> Strategy a -> Strategy a
+mapRulesS = onStrategyTree . mapRulesInTree
 
 -- | Use a function as do-after hook for all rules in a labeled strategy, but
 -- also use the function beforehand
@@ -219,12 +225,8 @@ onStrategyTree :: IsStrategy f => (StrategyTree a -> StrategyTree a) -> f a -> Strategy a
 onStrategyTree f = S . f . toStrategyTree
 
-getProcess :: IsStrategy f => f a -> Process (Rule a)
-getProcess = foldUnwind emptyAlg
-   { fNode  = fromNary . combinator
-   , fLeaf  = single
-   , fLabel = \l p -> enterRule l ~> p .*. (exitRule l ~> done)
-   } . toStrategyTree
+getProcess :: IsStrategy f => f a -> Process (Leaf a)
+getProcess = treeToProcess . toStrategyTree
 
 -------------------------
 

@@ -18,13 +18,14 @@ import Data.Graph
 import Data.List ((\\))
 import Data.Maybe
-import Ideas.Common.CyclicTree hiding (label)
 import Ideas.Common.Id
+import Ideas.Common.Rewriting (IsTerm)
 import Ideas.Common.Rule
 import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.CyclicTree hiding (label)
 import Ideas.Common.Strategy.Process
 import Ideas.Common.Strategy.StrategyTree
-import Ideas.Common.Utils (fst3, thd3)
+import Ideas.Utils.Prelude (fst3, thd3)
 import Prelude hiding (not, repeat, fail, sequence)
 import qualified Ideas.Common.Strategy.Choice as Choice
 import qualified Ideas.Common.Strategy.Derived as Derived
@@ -132,7 +133,7 @@ --   strategy only succeeds if this is not the case (otherwise it fails).
 not :: IsStrategy f => f a -> Strategy a
 not = decl1 $ "not" .=. Unary (\x ->
-   Sequence.single $ checkRule "core.not" $ null . runProcess x)
+   Sequence.single $ LeafRule $ checkRule "core.not" $ null . runProcess x)
 
 -- | Repeat a strategy zero or more times (greedy version of 'many')
 repeat :: IsStrategy f => f a -> Strategy a
@@ -168,6 +169,10 @@ -- | Apply the strategies from the list exhaustively (until this is no longer possible)
 exhaustive :: IsStrategy f => [f a] -> Strategy a
 exhaustive = declN $ "exhaustive" .=. Nary Derived.exhaustive
+
+-- | The structure of a dynamic strategy depends on the current term
+dynamic :: (IsId n, IsStrategy f, IsTerm a) => n -> (a -> f a) -> Strategy a
+dynamic n f = toStrategy $ makeDynamic n (toStrategyTree . f)
 
 -- Graph to strategy ----------------------
 

@@ -23,17 +23,17 @@ 
 import Data.Char
 import Ideas.Common.Classes
-import Ideas.Common.CyclicTree hiding (label)
 import Ideas.Common.Id
 import Ideas.Common.Rule
 import Ideas.Common.Strategy.Abstract
 import Ideas.Common.Strategy.Choice
+import Ideas.Common.Strategy.CyclicTree hiding (label)
 import Ideas.Common.Strategy.Derived (repeat1)
 import Ideas.Common.Strategy.Process hiding (fold)
 import Ideas.Common.Strategy.Sequence
 import Ideas.Common.Strategy.StrategyTree
 import Ideas.Common.Strategy.Symbol
-import qualified Ideas.Common.CyclicTree as Tree
+import qualified Ideas.Common.Strategy.CyclicTree as Tree
 
 ---------------------------------------------------------------------
 -- Types and constructors
@@ -48,7 +48,7 @@    mconcat xs = Cfg [ y | Cfg ys <- xs, y <- ys ]
    mappend (Cfg xs) (Cfg ys) = Cfg (xs ++ ys)
 
-data ConfigLocation = ByName Id
+newtype ConfigLocation = ByName Id
 
 instance Show ConfigLocation where
    show (ByName a) = show a
@@ -137,13 +137,13 @@ removeDecl = "removed" .=. Unary (const empty)
 
 collapseDecl :: Decl Unary
-collapseDecl = "collapsed" .=. Unary (\a ->
-   case firsts a of
-      [(r, _)] -> maybe empty (`collapseWith` a) (isEnterRule r)
-      _        -> empty)
+collapseDecl = "collapsed" .=. Unary f
  where
+   f a = case firsts a of
+            [(LeafRule r, _)] -> maybe empty (`collapseWith` a) (isEnterRule r)
+            _ -> empty
    collapseWith l =
-      single . makeRule l . runProcess
+      single . LeafRule . makeRule l . runProcess
 
 hideDecl :: Decl Unary
 hideDecl = "hidden" .=. Unary (fmap minor)

@@ -0,0 +1,217 @@+-----------------------------------------------------------------------------
+-- Copyright 2016, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Common.Strategy.CyclicTree
+   ( -- * Data type
+     CyclicTree
+     -- * Constructor functions
+   , node, node0, node1, node2, leaf, label
+     -- * Querying
+   , isNode, isLeaf, isLabel
+     -- * Replace functions
+   , replaceNode, replaceLeaf, replaceLabel, shrinkTree
+     -- * Fold and algebra
+   , fold, foldUnwind
+   , CyclicTreeAlg, fNode, fLeaf, fLabel, fRec, fVar
+   , emptyAlg, monoidAlg
+   ) where
+
+import Control.Monad
+import Data.List (intercalate)
+import Ideas.Common.Classes
+import Ideas.Common.Id
+import Test.QuickCheck hiding (label)
+
+--------------------------------------------------------------
+-- Data type
+
+data CyclicTree a b
+   = Node a [CyclicTree a b]
+   | Leaf b
+   | Label Id (CyclicTree a b)
+   | Rec Int (CyclicTree a b)
+   | Var Int
+
+instance (Show a, Show b) => Show (CyclicTree a b) where
+   show = fold Alg
+      { fNode  = \a xs -> show a ++ par xs
+      , fLeaf  = show
+      , fLabel = \l s -> show l ++ ":" ++ s
+      , fRec   = \n s -> '#' : show n ++ "=" ++ s
+      , fVar   = \n   -> '#' : show n
+      }
+
+instance BiFunctor CyclicTree where
+   biMap f g = fold idAlg {fNode = Node . f, fLeaf = Leaf . g}
+
+instance Functor (CyclicTree d) where
+   fmap = mapSecond
+
+instance Applicative (CyclicTree d) where
+   pure    = leaf
+   p <*> q = fold idAlg {fLeaf = (<$> q)} p
+
+instance Monad (CyclicTree d) where
+   return = leaf
+   (>>=)  = flip replaceLeaf
+
+instance Foldable (CyclicTree d) where
+   foldMap f = fold monoidAlg {fLeaf = f}
+
+instance Traversable (CyclicTree d) where
+   traverse f = fold emptyAlg
+      { fNode  = \a -> fmap (node a) . sequenceA
+      , fLeaf  = fmap leaf . f
+      , fLabel = fmap . label
+      , fRec   = fmap . Rec
+      , fVar   = pure . Var
+      }
+
+instance Fix (CyclicTree a b) where
+   fix f = Rec n (f (Var n))
+    where
+      vs = vars (f (Var (-1)))
+      n  = maximum (-1 : vs) + 1
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (CyclicTree a b) where
+   arbitrary = sized arbTree
+   shrink    = shrinkTree
+
+arbTree :: (Arbitrary a, Arbitrary b) => Int -> Gen (CyclicTree a b)
+arbTree = rec 0
+ where
+   rec vi 0 = frequency $
+      (3, leaf <$> arbitrary)
+      : [ (1, elements (map Var [1..vi])) | vi > 0 ]
+   rec vi n = frequency
+      [ (3, node <$> arbitrary <*> ms)
+      , (2, rec vi 0)
+      , (1, label <$> genId <*> m)
+      , (1, Rec (vi+1) <$> rec (vi+1) (n `div` 2))
+      ]
+    where
+      m = rec vi (n `div` 2)
+      genId = elements [ newId [c] | c <- ['A' .. 'Z']]
+      ms = choose (0, 3) >>= \i -> replicateM i m
+
+shrinkTree :: CyclicTree a b -> [CyclicTree a b]
+shrinkTree tree =
+   case tree of
+      Node a ts -> ts ++ map (node a) (shrinkTrees ts)
+      Label l t -> t : map (Label l) (shrinkTree t)
+      Rec n t   -> map (Rec n) (shrinkTree t)
+      _ -> []
+
+-- shrink exactly one tree
+shrinkTrees :: [CyclicTree a b] -> [[CyclicTree a b]]
+shrinkTrees []    = []
+shrinkTrees (t:ts) = map (:ts) (shrinkTree t) ++ map (t:) (shrinkTrees ts)
+
+-- local helpers
+par :: [String] -> String
+par xs | null xs   = ""
+       | otherwise = "(" ++ intercalate ", " xs ++ ")"
+
+vars :: CyclicTree a b -> [Int]
+vars = fold monoidAlg {fVar = return}
+
+--------------------------------------------------------------
+-- Constructor functions
+
+node :: a -> [CyclicTree a b] -> CyclicTree a b
+node = Node
+
+node0 :: a -> CyclicTree a b
+node0 a = node a []
+
+node1 :: a -> CyclicTree a b -> CyclicTree a b
+node1 a x = node a [x]
+
+node2 :: a -> CyclicTree a b -> CyclicTree a b -> CyclicTree a b
+node2 a x y = node a [x, y]
+
+leaf :: b -> CyclicTree a b
+leaf = Leaf
+
+label :: IsId n => n -> CyclicTree a b -> CyclicTree a b
+label = Label . newId
+
+--------------------------------------------------------------
+-- Querying
+
+isNode :: CyclicTree a b -> Maybe (a, [CyclicTree a b])
+isNode (Node a xs) = Just (a, xs)
+isNode _ = Nothing
+
+isLeaf :: CyclicTree a b -> Maybe b
+isLeaf (Leaf b) = Just b
+isLeaf _ = Nothing
+
+isLabel :: CyclicTree a b -> Maybe (Id, CyclicTree a b)
+isLabel (Label l t) = Just (l, t)
+isLabel _ = Nothing
+
+--------------------------------------------------------------
+-- Replace functions
+
+replaceNode :: (a -> [CyclicTree a b] -> CyclicTree a b) -> CyclicTree a b -> CyclicTree a b
+replaceNode f = fold idAlg {fNode = f}
+
+replaceLabel :: (Id -> CyclicTree a b -> CyclicTree a b) -> CyclicTree a b -> CyclicTree a b
+replaceLabel f = fold idAlg {fLabel = f}
+
+replaceLeaf :: (b -> CyclicTree a c) -> CyclicTree a b -> CyclicTree a c
+replaceLeaf f = fold idAlg {fLeaf = f}
+
+--------------------------------------------------------------
+-- Fold and algebra
+
+fold :: CyclicTreeAlg a b t -> CyclicTree a b -> t
+fold alg = rec
+ where
+   rec (Node a ts) = fNode alg a (map rec ts)
+   rec (Leaf b)    = fLeaf alg b
+   rec (Label l t) = fLabel alg l (rec t)
+   rec (Rec n t)   = fRec alg n (rec t)
+   rec (Var n)     = fVar alg n
+
+foldUnwind :: CyclicTreeAlg a b t -> CyclicTree a b -> t
+foldUnwind alg = start . fold Alg
+   { fNode  = \a fs sub -> fNode alg a (map ($ sub) fs)
+   , fLeaf  = \b _      -> fLeaf alg b
+   , fLabel = \l f sub  -> fLabel alg l (f sub)
+   , fRec   = \n f sub  -> let this = f (extend n this sub)
+                           in this
+   , fVar   = \n sub    -> sub n
+   }
+ where
+   start f = f (error "foldUnwind: unbound var")
+   extend n a sub i
+      | i == n    = a
+      | otherwise = sub i
+
+data CyclicTreeAlg a b t = Alg
+   { fNode  :: a -> [t] -> t
+   , fLeaf  :: b -> t
+   , fLabel :: Id -> t -> t
+   , fRec   :: Int -> t -> t
+   , fVar   :: Int -> t
+   }
+
+idAlg :: CyclicTreeAlg a b (CyclicTree a b)
+idAlg = Alg Node Leaf Label Rec Var
+
+emptyAlg :: CyclicTreeAlg a b t
+emptyAlg = let f = error "emptyAlg: uninitialized" in Alg f f f f f
+
+monoidAlg :: Monoid m => CyclicTreeAlg a b m
+monoidAlg = Alg (const mconcat) mempty (const id) (const id) mempty

@@ -30,29 +30,19 @@ import Prelude hiding (sequence, replicate, repeat)
 import qualified Prelude
 
-split :: (AtomicSymbol a, Choice b)
-      => (Process a -> Process a -> b) -> b -> Process a -> b
-split op = split2 (op . single) op
-
--- Specialized version of split that also takes an operator for the special case
--- that the left part of the split is a single symbol.
-split2 :: (AtomicSymbol a, Choice b)
-       => (a -> Process a -> b) -> (Process a -> Process a -> b) -> b -> Process a -> b
-split2 op1 op2 = withMenu f
+split :: AtomicSymbol a => (a -> Bool) -> (Process a -> Process a) -> Process a -> Process a
+split skipCond cont = rec (0 :: Int)
  where
-   f a | a == atomicOpen = rec (op2 . (a ~>)) 1
-       | otherwise       = op1 a
-
-   rec acc n
-      | n == 0    = acc done
-      | otherwise = withMenu g empty
+   rec n = withMenu op empty
     where
-      g a = rec (acc . (a ~>)) (pm a n)
-
-   pm :: AtomicSymbol a => a -> Int -> Int
-   pm a | a == atomicOpen  = succ
-        | a == atomicClose = pred
-        | otherwise        = id
+      op a = a ~> rest
+       where
+         next | a == atomicOpen  = n+1
+              | a == atomicClose = n-1
+              | otherwise        = n
+         rest | skipCond a       = rec next
+              | next > 0         = rec next
+              | otherwise        = cont
 
 -- atomic prefix
 (!*>) :: AtomicSymbol a => Process a -> Process a -> Process a
@@ -81,21 +71,7 @@  where
    bothAreDone = withMenu stop2 . withMenu stop2 done
    stop2 _ _   = empty
-
--- left-interleaving
-(%>>) :: (AtomicSymbol a, LabelSymbol a) => Process a -> Process a -> Process a
-p %>> q = rec (0 :: Int) p
- where
-   rec n = withMenu op empty
-    where
-      op a = a ~> rest
-       where
-         next | a == atomicOpen  = n+1
-              | a == atomicClose = n-1
-              | otherwise        = n
-         rest | isEnterSymbol a  = rec next
-              | next > 0         = rec next
-              | otherwise        = (<%> q)
+   r %>> s     = split isEnterSymbol (<%> s) r
 
 -- | Allows all permutations of the list
 permute :: (Choice a, Sequence a) => [a] -> a
@@ -109,17 +85,13 @@ 
 -- Alternate combinator
 (<@>) :: AtomicSymbol a => Process a -> Process a -> Process a
-p0 <@> q0 = rec q0 p0
+p <@> q = bothOk p q .|. (p @>> q)
  where
-   rec q  = let op b r = b .*. rec r q
-            in split op (bothOk q)
-   bothOk = withMenu (\_ _ -> empty) done
+   bothOk  = withMenu (\_ _ -> empty) done
+   r @>> s = split (const False) (s <@>) r
 
 inits :: AtomicSymbol a => Process a -> Process a
-inits = rec
- where
-   rec p = done .|. split op empty p
-   op x  = (x .*.) . rec
+inits p = done .|. split (const False) inits p
 
 many :: (Sequence a, Fix a, Choice a) => a -> a
 many s = fix $ \x -> done .|. (s .*. x)

@@ -18,9 +18,9 @@    ) where
 
 import Data.Maybe
-import Ideas.Common.CyclicTree
 import Ideas.Common.Id
 import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.CyclicTree
 
 -----------------------------------------------------------
 --- Strategy locations

@@ -27,15 +27,18 @@    , Path, emptyPath, readPath, readPaths
    ) where
 
-import Control.Monad
+import Data.Char
 import Data.List (intercalate)
+import Data.Maybe
 import Ideas.Common.Classes
 import Ideas.Common.Environment
+import Ideas.Common.Rewriting.Term
 import Ideas.Common.Rule
 import Ideas.Common.Strategy.Choice
 import Ideas.Common.Strategy.Process
 import Ideas.Common.Strategy.Sequence
-import Ideas.Common.Utils (splitsWithElem, readM)
+import Ideas.Common.Strategy.StrategyTree
+import Ideas.Utils.Prelude (splitsWithElem, readM)
 
 --------------------------------------------------------------------------------
 -- Prefix datatype
@@ -72,30 +75,41 @@ noPrefix = Prefix [] empty
 
 -- | Make a prefix from a core strategy and a start term.
-makePrefix :: Process (Rule a) -> a -> Prefix a
+makePrefix :: Process (Leaf a) -> a -> Prefix a
 makePrefix = snd . replayProcess emptyPath
 
 -- | Construct a prefix by replaying a path in a core strategy: the third
 -- argument is the current term.
-replayProcess :: Path -> Process (Rule a) -> ([Rule a], a -> Prefix a)
-replayProcess (Path is) = replay [] is
+replayProcess :: Path -> Process (Leaf a) -> ([Rule a], a -> Prefix a)
+replayProcess (Path is) = fromMaybe ([], const noPrefix) . replay [] is
  where
-   replay acc []     p = (reverse acc, createPrefix p)
-   replay acc (n:ns) p =
-      case getByIndex n (menu p) of
-         Just (a, r) -> replay (a:acc) ns r
-         _ -> ([], const noPrefix)
+   replay acc path p =
+      case path of
+         []         -> return (reverse acc, createPrefix p)
+         Input _:_  -> Nothing
+         Index n:ns -> do
+            (leaf, q) <- getByIndex n (menu p)
+            case (leaf, ns) of
+               (LeafRule r, _) -> replay (r:acc) ns q
+               (LeafDyn d, Input t:ns2) -> do
+                  a <- dynamicFromTerm d t
+                  replay acc ns2 (treeToProcess a .*. q)
+               _ -> Nothing
 
    createPrefix p = Prefix [Path is] . flip (rec []) p
 
    rec ns a = cut . onMenuWithIndex f doneMenu . menu
     where
-      f n r p = choice
+      f n (LeafDyn d) p = fromMaybe empty $ do
+         t <- dynamicToTerm d a
+         s <- dynamicFromTerm d t
+         return (rec (Input t:Index n:ns) a (treeToProcess s .*. p))
+      f n (LeafRule r) p = choice
          [ r ?~> (b, env, mk b)
          | (b, env) <- transApply (transformation r) a
          ]
        where
-         ms   = n:ns
+         ms   = Index n:ns
          path = Path (is ++ reverse ms)
          mk b = Prefix [path] (rec ms b p)
 
@@ -153,19 +167,33 @@ -- Path
 
 -- | A path encodes a location in a strategy. Paths are represented as a list
--- of integers.
-newtype Path = Path [Int]
+-- of integers and terms (the latter act as input for the dynamic strategies).
+newtype Path = Path [PathItem]
    deriving Eq
 
+data PathItem = Index Int | Input Term
+   deriving Eq
+
+instance Show PathItem where
+   show (Index n) = show n
+   show (Input t) = show t
+
+instance Read PathItem where
+   readsPrec n s =
+      case dropWhile isSpace s of
+         s2@(c:_) | isDigit c -> map (mapFirst Index) (readsPrec n s2)
+         s2 -> map (mapFirst Input) (readsPrec n s2)
+
 instance Show Path where
    show (Path is) = show is
+   showList = (++) . intercalate ";" . map show
 
 -- | The empty path.
 emptyPath :: Path
 emptyPath = Path []
 
 readPath :: Monad m => String -> m Path
-readPath = liftM Path . readM
+readPath = fmap Path . readM
 
 readPaths :: Monad m => String -> m [Path]
 readPaths = mapM readPath . splitsWithElem ';'

@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes, ExistentialQuantification #-}
 -----------------------------------------------------------------------------
 -- Copyright 2016, Ideas project team. This file is distributed under the
 -- terms of the Apache License 2.0. For more information, see the files
@@ -16,29 +16,90 @@ 
 module Ideas.Common.Strategy.StrategyTree
    ( -- * StrategyTree type synonym
-     StrategyTree
+     StrategyTree, Leaf(..), treeToProcess, mapRulesInTree
      -- * Declarations (named combinators)
    , Decl, Combinator, associative, isAssociative, combinator
    ,  (.=.), applyDecl
+     -- * Dynamic strategies
+   , Dynamic, makeDynamic, dynamicToTerm, dynamicTree, dynamicFromTerm
      -- * Arities
    , Arity(..), Nullary(..), Unary(..), Binary(..), Nary(..)
    ) where
 
+import Control.Monad
 import Data.Function
 import Data.Maybe
-import Ideas.Common.CyclicTree
+import Ideas.Common.Classes
 import Ideas.Common.Id
+import Ideas.Common.Rewriting.Term (Term, IsTerm(..))
 import Ideas.Common.Rule
 import Ideas.Common.Strategy.Choice
+import Ideas.Common.Strategy.CyclicTree
 import Ideas.Common.Strategy.Process
+import Ideas.Common.Strategy.Sequence
+import Ideas.Common.Strategy.Symbol
 import Ideas.Common.View
 
 infix 1 .=.
 
 ------------------------------------------------------------------------------
 
-type StrategyTree a = CyclicTree (Decl Nary) (Rule a)
+type StrategyTree a = CyclicTree (Decl Nary) (Leaf a)
 
+data Leaf a = LeafRule (Rule a)
+            | LeafDyn  (Dynamic a)
+
+instance Show (Leaf a) where
+   show = showId
+
+instance Eq (Leaf a) where
+   x == y = getId x == getId y
+
+instance HasId (Leaf a) where
+   getId      (LeafRule r) = getId r
+   getId      (LeafDyn d)  = getId d
+   changeId f (LeafRule r) = LeafRule (changeId f r)
+   changeId f (LeafDyn d)  = LeafDyn (changeId f d)
+
+instance AtomicSymbol (Leaf a) where
+   atomicOpen  = LeafRule atomicOpen
+   atomicClose = LeafRule atomicClose
+
+instance LabelSymbol (Leaf a) where
+   isEnterSymbol (LeafRule r) = isEnterSymbol r
+   isEnterSymbol (LeafDyn _)  = False
+
+instance Minor (Leaf a) where
+   isMinor    (LeafRule r)   = isMinor r
+   isMinor    (LeafDyn _)    = False
+   setMinor b (LeafRule r)   = LeafRule (setMinor b r)
+   setMinor _ lf@(LeafDyn _) = lf
+
+instance Apply Leaf where
+   applyAll (LeafRule r) a    = applyAll r a
+   applyAll (LeafDyn d) a = applyAll d a
+
+instance LiftView Leaf where
+   liftViewIn v (LeafRule r) = LeafRule (liftViewIn v r)
+   liftViewIn v (LeafDyn d)  = LeafDyn  (liftViewIn v d)
+
+treeToProcess :: StrategyTree a -> Process (Leaf a)
+treeToProcess = foldUnwind emptyAlg
+   { fNode  = fromNary . combinator
+   , fLeaf  = single
+   , fLabel = \l p -> LeafRule (enterRule l) ~> p .*. (LeafRule (exitRule l) ~> done)
+   }
+
+mapRulesInTree :: (Rule a -> Rule a) -> StrategyTree a -> StrategyTree a
+mapRulesInTree f = inTree
+ where
+   inTree = fmap inLeaf
+
+   inLeaf (LeafRule r) = LeafRule (f r)
+   inLeaf (LeafDyn d)  = LeafDyn (inDyn d)
+
+   inDyn d = d { dynamicFromTerm = fmap inTree . dynamicFromTerm d }
+
 applyDecl :: Arity f => Decl f -> f (StrategyTree a)
 applyDecl d = toArity (node (d {combinator = op}) . make)
  where
@@ -54,8 +115,35 @@ 
 ------------------------------------------------------------------------------
 
-type Combinator f = forall a . f (Process (Rule a))
+data Dynamic a = Dyn
+   { dynamicId       :: Id
+   , dynamicToTerm   :: a -> Maybe Term
+   , dynamicFromTerm :: Term -> Maybe (StrategyTree a)
+   }
 
+instance HasId (Dynamic a) where
+   getId = dynamicId
+   changeId f d = d { dynamicId = changeId f (dynamicId d) }
+
+instance Apply Dynamic where
+   applyAll d a = maybe [] ((`runProcess` a) . treeToProcess) (dynamicTree d a)
+
+instance LiftView Dynamic where
+   liftViewIn v d = d
+      { dynamicToTerm   = fmap fst . match v >=> dynamicToTerm d
+      , dynamicFromTerm = fmap (fmap (liftViewIn v)) . dynamicFromTerm d
+      }
+
+makeDynamic :: (IsId n, IsTerm a) => n -> (a -> StrategyTree a) -> Dynamic a
+makeDynamic n f = Dyn (newId n) (Just . toTerm) (fmap f . fromTerm)
+
+dynamicTree :: Dynamic a -> a -> Maybe (StrategyTree a)
+dynamicTree d = dynamicToTerm d >=> dynamicFromTerm d
+
+------------------------------------------------------------------------------
+
+type Combinator f = forall a . f (Process (Leaf a))
+
 data Decl f = C
    { declId        :: Id
    , combinator    :: Combinator f
@@ -85,10 +173,10 @@    toArity :: ([a] -> a) -> f a
    liftIso :: Isomorphism a b -> f a -> f b
 
-data Nullary a = Nullary { fromNullary :: a }
-data Unary   a = Unary   { fromUnary   :: a -> a }
-data Binary  a = Binary  { fromBinary  :: a -> a -> a }
-data Nary    a = Nary    { fromNary    :: [a] -> a }
+newtype Nullary a = Nullary { fromNullary :: a }
+newtype Unary   a = Unary   { fromUnary   :: a -> a }
+newtype Binary  a = Binary  { fromBinary  :: a -> a -> a }
+newtype Nary    a = Nary    { fromNary    :: [a] -> a }
 
 instance Arity Nullary where
    listify (Nullary a) [] = Just a

@@ -37,7 +37,7 @@ import Data.Maybe
 import Ideas.Common.Traversal.Iterator
 import Ideas.Common.Traversal.Utils
-import Ideas.Common.Utils.Uniplate
+import Ideas.Utils.Uniplate
 import Test.QuickCheck
 
 ---------------------------------------------------------------
@@ -69,7 +69,7 @@    childnr  :: a -> Int
    location :: a -> Location
    -- default definitions
-   downLast = liftM (fixp right) . down
+   downLast = fmap (fixp right) . down
    childnr  = pred . length . fixpl left
    location = toLocation . map childnr . drop 1 . reverse . fixpl up
 
@@ -173,7 +173,7 @@    update a = (unwrap a, wrap)
 
 instance Navigator a => Iterator (PreOrder a) where
-   previous = liftWrapper ((liftM rightMostLeaf . left) >|< up)
+   previous = liftWrapper ((fmap rightMostLeaf . left) >|< up)
    next     = let rec = right >|< (up >=> rec)
               in liftWrapper (down >|< rec)
    first    = mapWrapper top
@@ -249,10 +249,10 @@ instance Navigator a => Iterator (Leafs a) where
    previous = liftWrapper $
       let rec = left >|< (up >=> rec)
-      in liftM rightMostLeaf . rec
+      in fmap rightMostLeaf . rec
    next = liftWrapper $
       let rec = right >|< (up >=> rec)
-      in liftM leftMostLeaf . rec
+      in fmap leftMostLeaf . rec
    first = mapWrapper (leftMostLeaf . top)
    final = mapWrapper (rightMostLeaf . top)
 
@@ -300,8 +300,8 @@    }
 
 instance Iterator (StrIterator a) where
-   next     (SI n a) = liftM (SI (n+1)) $ searchNext ok a
-   previous (SI n a) = liftM (SI (n-1)) $ searchPrevious ok a
+   next     (SI n a) = SI (n+1) <$> searchNext ok a
+   previous (SI n a) = SI (n-1) <$> searchPrevious ok a
    first    (SI _ a) = SI 0 $ safe (searchForward ok) (first a)
    final    (SI _ a) = finalSI $ safe (searchBackward ok) (final a)
    position          = posSI
@@ -350,8 +350,8 @@    down     = downWith focusM
    downLast = downWith lastStrIterator
 
-   left  (U fs a) = liftM (U fs) (previous a)
-   right (U fs a) = liftM (U fs) (next a)
+   left  (U fs a) = U fs <$> previous a
+   right (U fs a) = U fs <$> next a
 
    childnr (U _ a) = position a
 
@@ -364,7 +364,7 @@    unfocus = current . top
 
 instance (Arbitrary a, Uniplate a) => Arbitrary (UniplateNavigator a) where
-   arbitrary = liftM focus arbitrary >>= genNav
+   arbitrary = fmap focus arbitrary >>= genNav
     where
       genNav a =
          case map genNav (downs a) of
@@ -373,7 +373,7 @@ 
 downWith :: Uniplate a => (Str a -> Maybe (StrIterator a))
                        -> UniplateNavigator a -> Maybe (UniplateNavigator a)
-downWith make (U fs a) = liftM (U (f:fs)) (make cs)
+downWith make (U fs a) = U (f:fs) <$> make cs
  where
    (cs, g) = uniplate (current a)
    f = (`replace` a) . g . unfocus

@@ -20,8 +20,8 @@ import Ideas.Common.Traversal.Iterator
 import Ideas.Common.Traversal.Navigator
 import Ideas.Common.Traversal.Utils
-import Ideas.Common.Utils.TestSuite
-import Ideas.Common.Utils.Uniplate
+import Ideas.Utils.TestSuite
+import Ideas.Utils.Uniplate
 import Test.QuickCheck hiding ((===))
 
 testIterator :: (Show a, Eq a, Iterator a) => String -> Gen a -> TestSuite
@@ -72,8 +72,8 @@         ]
 
    , suite "down/downLast"
-        [ prop gen "down; rightMost"       $  liftM rightMost . down === downLast
-        , prop gen "downLast; leftMost"    $  liftM leftMost . downLast === down
+        [ prop gen "down; rightMost"       $  fmap rightMost . down === downLast
+        , prop gen "downLast; leftMost"    $  fmap leftMost . downLast === down
         , prop gen "down is leftMost"      $  isNothing . (down >=> left)
         , prop gen "downLast is rightMost" $  isNothing . (downLast >=> right)
         ]
@@ -104,16 +104,16 @@ tests =
    suite "Iterators"
       [ testIterator "List" listGen
-      , testIterator "Mirror"     $ liftM makeMirror     listGen
-      , testIterator "Leafs"      $ liftM makeLeafs      uniGen
-      , testIterator "PreOrder"   $ liftM makePreOrder   uniGen
-      , testIterator "PostOrder"  $ liftM makePostOrder  uniGen
-      , testIterator "Horizontal" $ liftM makeHorizontal uniGen
-      , testIterator "LevelOrder" $ liftM makeLevelOrder uniGen
+      , testIterator "Mirror"     $ makeMirror     <$> listGen
+      , testIterator "Leafs"      $ makeLeafs      <$> uniGen
+      , testIterator "PreOrder"   $ makePreOrder   <$> uniGen
+      , testIterator "PostOrder"  $ makePostOrder  <$> uniGen
+      , testIterator "Horizontal" $ makeHorizontal <$> uniGen
+      , testIterator "LevelOrder" $ makeLevelOrder <$> uniGen
       ] <>
    suite "Navigators"
       [ testNavigator "Uniplate" uniGen
-      , testNavigator "Mirror" $ liftM makeMirror uniGen
+      , testNavigator "Mirror" $ makeMirror <$> uniGen
       ]
 
 _go :: IO ()

@@ -46,7 +46,7 @@ changeM = changeG
 
 changeG :: (Update f, Monad g) => (a -> g a) -> f a -> g (f a)
-changeG f a = liftM (`replace` a) (f (current a))
+changeG f a = (`replace` a) <$> f (current a)
 
 ---------------------------------------------------------------
 -- Focus type class
@@ -61,10 +61,10 @@    focusM = Just . focus
 
 liftFocus :: Focus a => (Unfocus a -> Maybe (Unfocus a)) -> a -> Maybe a
-liftFocus f = liftM focus . f . unfocus
+liftFocus f = fmap focus . f . unfocus
 
 unliftFocus :: Focus a => (a -> Maybe a) -> Unfocus a -> Maybe (Unfocus a)
-unliftFocus f = liftM unfocus . f . focus
+unliftFocus f = fmap unfocus . f . focus
 
 ---------------------------------------------------------------
 -- Wrapper type class
@@ -74,10 +74,10 @@    unwrap :: f a -> a
 
 liftWrapper :: (Monad m, Wrapper f) => (a -> m a) -> f a -> m (f a)
-liftWrapper f = liftM wrap . f . unwrap
+liftWrapper f = fmap wrap . f . unwrap
 
 unliftWrapper :: (Monad m, Wrapper f) => (f a -> m (f a)) -> a -> m a
-unliftWrapper f = liftM unwrap . f . wrap
+unliftWrapper f = fmap unwrap . f . wrap
 
 mapWrapper :: Wrapper f => (a -> a) -> f a -> f a
 mapWrapper f = wrap . f . unwrap

@@ -1,128 +0,0 @@-{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}
------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A collection of general utility functions
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Utils
-   ( Some(..), ShowString(..), readInt, readM
-   , subsets, isSubsetOf
-   , cartesian, distinct, allsame
-   , fixpoint
-   , splitAtElem, splitsWithElem
-   , timedSeconds
-   , fst3, snd3, thd3
-   , headM, findIndexM
-   , elementAt, changeAt, replaceAt
-   , list
-   ) where
-
-import Data.Char
-import Data.List
-import Data.Typeable
-import System.Timeout
-
-data Some f = forall a . Some (f a)
-
-data ShowString = ShowString { fromShowString :: String }
-   deriving (Eq, Ord, Typeable)
-
-instance Show ShowString where
-   show = fromShowString
-
-instance Read ShowString where
-   readsPrec n s = [ (ShowString x, y) | (x, y) <- readsPrec n s ]
-
-readInt :: String -> Maybe Int
-readInt xs
-   | null xs                = Nothing
-   | any (not . isDigit) xs = Nothing
-   | otherwise              = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- '
-
-readM :: (Monad m, Read a) => String -> m a
-readM s = case reads s of
-             [(a, xs)] | all isSpace xs -> return a
-             _ -> fail ("no read: " ++ s)
-
-subsets :: [a] -> [[a]]
-subsets = foldr op [[]]
- where op a xs = xs ++ map (a:) xs
-
-isSubsetOf :: Eq a => [a] -> [a] -> Bool
-isSubsetOf xs ys = all (`elem` ys) xs
-
-cartesian :: [a] -> [b] -> [(a, b)]
-cartesian as bs = [ (a, b) | a <- as, b <- bs ]
-
-distinct :: Eq a => [a] -> Bool
-distinct []     = True
-distinct (x:xs) = notElem x xs && distinct xs
-
-allsame :: Eq a => [a] -> Bool
-allsame []     = True
-allsame (x:xs) = all (==x) xs
-
-fixpoint :: Eq a => (a -> a) -> a -> a
-fixpoint f = rec . iterate f
- where
-   rec [] = error "Ideas.Common.Utils: empty list"
-   rec (x:xs)
-      | x == head xs = x
-      | otherwise    = rec xs
-
-splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a])
-splitAtElem c s =
-   case break (==c) s of
-      (xs, _:ys) -> Just (xs, ys)
-      _          -> Nothing
-
-splitsWithElem :: Eq a => a -> [a] -> [[a]]
-splitsWithElem c s =
-   case splitAtElem c s of
-      Just (xs, ys) -> xs : splitsWithElem c ys
-      Nothing       -> [s]
-
-timedSeconds :: Int -> IO a -> IO a
-timedSeconds n m = timeout (n * 10^(6 :: Int)) m >>=
-   maybe (fail ("Timeout after " ++ show n ++ " seconds")) return
-
-fst3 :: (a, b, c) -> a
-fst3 (x, _, _) = x
-
-snd3 :: (a, b, c) -> b
-snd3 (_, x, _) = x
-
-thd3 :: (a, b, c) -> c
-thd3 (_, _, x) = x
-
--- generalized list functions (results in monad)
-headM :: Monad m => [a] -> m a
-headM (a:_) = return a
-headM _     = fail "headM"
-
-findIndexM :: Monad m => (a -> Bool) -> [a] -> m Int
-findIndexM p = maybe (fail "findIndexM") return . findIndex p
-
-elementAt :: Monad m => Int -> [a] -> m a
-elementAt i = headM . drop i
-
-changeAt :: Monad m => Int -> (a -> a) -> [a] -> m [a]
-changeAt i f as =
-   case splitAt i as of
-      (xs, y:ys) -> return (xs ++ f y : ys)
-      _          -> fail "changeAt"
-
-replaceAt :: Monad m => Int -> a -> [a] -> m [a]
-replaceAt i = changeAt i . const
-
-list :: b -> ([a] -> b) -> [a] -> b
-list b f xs = if null xs then b else f xs

@@ -1,102 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Extensions to the QuickCheck library
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Utils.QuickCheck
-   ( module Test.QuickCheck
-     -- * Data type
-   , ArbGen, generator, generators
-     -- * Constructors
-   , arbGen, constGen, constGens, unaryGen, unaryGens
-   , unaryArbGen, binaryGen, binaryGens, toArbGen
-     -- * Frequency combinators
-   , common, uncommon, rare, changeFrequency
-   ) where
-
-import Control.Arrow
-import Control.Monad
-import Data.Ratio
-import Test.QuickCheck
-
----------------------------------------------------------
--- @ArbGen@ datatype
-
-newtype ArbGen a = AG [(Rational, (Int, Gen ([a] -> a)))]
-
-instance Monoid (ArbGen a) where
-   mempty = AG mempty
-   AG xs `mappend` AG ys = AG (xs `mappend` ys)
-
-generator :: ArbGen a -> Gen a
-generator (AG pairs) = sized rec
- where
-   factor = foldr (lcm . denominator . fst) 1 pairs
-   rec n  = frequency (map make (select pairs))
-    where
-      select
-         | n == 0    = filter ((==0) . fst . snd)
-         | otherwise = id
-      make (r, (a, gf)) =
-         let m  = round (fromInteger factor*r)
-             xs = replicateM a $ rec $ n `div` 2
-         in (m, liftM2 ($) gf xs)
-
-generators :: [ArbGen a] -> Gen a
-generators = generator . mconcat
-
----------------------------------------------------------
--- Constructors
-
-arbGen :: Arbitrary b => (b -> a) -> ArbGen a
-arbGen f = newGen 0 (liftM (const . f) arbitrary)
-
-constGen :: a -> ArbGen a
-constGen = pureGen 0 . const
-
-constGens :: [a] -> ArbGen a
-constGens = mconcat . map constGen
-
-unaryGen :: (a -> a) -> ArbGen a
-unaryGen f = pureGen 1 (f . head)
-
-unaryArbGen :: Arbitrary b => (b -> a -> a) -> ArbGen a
-unaryArbGen f = newGen 1 $ liftM (\a -> f a . head) arbitrary
-
-unaryGens :: [a -> a] -> ArbGen a
-unaryGens = mconcat . map unaryGen
-
-binaryGen :: (a -> a -> a) -> ArbGen a
-binaryGen f = pureGen 2 (\xs -> f (head xs) (xs !! 1))
-
-binaryGens :: [a -> a -> a] -> ArbGen a
-binaryGens = mconcat . map binaryGen
-
-pureGen :: Int -> ([a] -> a) -> ArbGen a
-pureGen n = newGen n . return
-
-toArbGen :: Gen a -> ArbGen a
-toArbGen = newGen 0 . liftM const
-
-newGen :: Int -> Gen ([a] -> a) -> ArbGen a
-newGen n f = AG [(1, (n, f))]
-
----------------------------------------------------------
--- Frequency combinators
-
-common, uncommon, rare :: ArbGen a -> ArbGen a
-common   = changeFrequency 2
-uncommon = changeFrequency (1/2)
-rare     = changeFrequency (1/5)
-
-changeFrequency :: Rational -> ArbGen a -> ArbGen a
-changeFrequency r (AG xs) = AG (map (first (*r)) xs)

@@ -1,136 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}
------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- References to Strings, proving a fast comparison implementation (Eq and
--- Ord) that uses a hash function. Code is based on Daan Leijen's Lazy
--- Virutal Machine (LVM) identifiers.
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Utils.StringRef
-   ( StringRef, stringRef, toString, tableStatus
-   ) where
-
-import Data.Bits
-import Data.Data
-import Data.IORef
-import Data.List
-import System.IO.Unsafe
-import qualified Data.IntMap as IM
-
-----------------------------------------------------------------
--- StringRef datatype and instance declarations
-
-data StringRef = S !Int
-   deriving (Eq, Ord, Data, Typeable)
-
-----------------------------------------------------------------
--- Hash table
-
-type HashTable = IM.IntMap [String]
-
-{-# NOINLINE tableRef #-}
-tableRef :: IORef HashTable
-tableRef = unsafePerformIO (newIORef IM.empty)
-
-----------------------------------------------------------------
--- Conversion to and from strings
-
-stringRef :: String -> StringRef
-stringRef s = unsafePerformIO $ do
-   let hash = hashString s
-   m <- readIORef tableRef
-   case IM.insertLookupWithKey (const combine) hash [s] m of
-      (Nothing, new) -> do
-         writeIORef tableRef new
-         return (S (encodeIndexZero hash))
-      (Just old, new) ->
-         case elemIndex s old of
-            Just index ->
-               return (S (encode hash index))
-            Nothing -> do
-               let index = length old
-               writeIORef tableRef new
-               return (S (encode hash index))
-
-toString :: StringRef -> String
-toString (S i) = unsafePerformIO $ do
-   m <- readIORef tableRef
-   case IM.lookup (extractHash i) m of
-      Just xs -> return (atIndex (extractIndex i) xs)
-      Nothing -> intErr "id not found"
-
-----------------------------------------------------------------
--- Bit encoding
-
-encode :: Int -> Int -> Int
-encode hash index = hash + index `shiftL` 12
-
-encodeIndexZero :: Int -> Int
-encodeIndexZero hash = hash
-
-extractHash :: Int -> Int
-extractHash i = i `mod` 4096
-
-extractIndex :: Int -> Int
-extractIndex i = i `shiftR` 12
-
-----------------------------------------------------------------
--- Hash function
-
--- simple hash function that performs quite good in practice
-hashString :: String -> Int
-hashString s = (f s `mod` prime) `mod` maxHash
- where
-   f        = foldl' next 0   -- ' strict fold
-   next n c = n*65599 + fromEnum c
-   prime    = 32537 --65599   -- require: prime < maxHash
-
-maxHash :: Int
-maxHash = 0xFFF -- 12 bits
-
-----------------------------------------------------------------
--- Utility functions
-
-atIndex :: Int -> [a] -> a
-atIndex 0 (x:_)  = x
-atIndex i (_:xs) = atIndex (i-1) xs
-atIndex _ _      = intErr "corrupt symbol table"
-
-combine :: Eq a => [a] -> [a] -> [a]
-combine [a] = rec
- where
-   rec [] = [a]
-   rec this@(x:xs)
-      | a == x    = this
-      | otherwise = x:rec xs
-combine _ = intErr "combine"
-
-intErr :: String -> a
-intErr s = error ("Internal error in Ideas.Common.StringRef: " ++ s)
-
-----------------------------------------------------------------
--- Testing and debugging
-
-tableStatus :: IO String
-tableStatus = readIORef tableRef >>= \m ->
-   let xs = map f (IM.assocs m)
-       f (i, ys) = '#' : show i ++ ": " ++ intercalate ", " (map g (frequency ys)) ++
-                   "  [total = " ++ show (length ys) ++ "]"
-       g (a, n)  | n == 1    = show a
-                 | otherwise = show a ++ " (" ++ show n ++ ")"
-   in return $ unlines xs
-
-frequency :: Eq a => [a] -> [(a, Int)]
-frequency [] = []
-frequency (x:xs) =
-   let (ys, zs) = partition (==x) xs
-   in (x, 1+length ys) : frequency zs

@@ -1,420 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A lightweight wrapper for organizing tests (including QuickCheck tests). It
--- introduces the notion of a test suite, and it stores the test results for
--- later inspection (e.g., for the generation of a test report). A TestSuite
--- is a monoid.
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Utils.TestSuite
-   ( -- * TestSuite
-     TestSuite, module Data.Monoid
-   , suite, useProperty, usePropertyWith
-   , assertTrue, assertNull, assertEquals, assertIO
-   , assertMessage, assertMessageIO
-   , onlyWarnings, rateOnError
-     -- * Running a test suite
-   , runTestSuite, runTestSuiteResult
-     -- * Test Suite Result
-   , Result, subResults, findSubResult
-   , justOneSuite, allMessages, topMessages
-   , nrOfTests, nrOfErrors, nrOfWarnings
-   , timeInterval, makeSummary, printSummary
-     -- * Message
-   , Message, message, warning, messageLines
-     -- * Status
-   , Status, HasStatus(..)
-   , isError, isWarning, isOk
-     -- * Rating
-   , Rating, HasRating(..)
-   ) where
-
-import Control.Exception
-import Control.Monad
-import Data.Foldable (toList)
-import Data.IORef
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import Data.Time
-import System.IO
-import Test.QuickCheck hiding (Result)
-import qualified Data.Sequence as S
-
-----------------------------------------------------------------
--- Test Suite
-
-newtype TestSuite = TS (S.Seq Test)
-
-data Test = Case  String (IO Message)
-          | Suite String TestSuite
-
-instance Monoid TestSuite where
-   mempty = TS mempty
-   TS xs `mappend` TS ys = TS (xs <> ys)
-
-tests :: TestSuite -> [Test]
-tests (TS xs) = toList xs
-
-makeTestSuite :: Test -> TestSuite
-makeTestSuite = TS . S.singleton
-
-----------------------------------------------------------------
--- Test suite constructors
-
--- | Construct a (named) test suite containing test cases and other suites
-suite :: String -> [TestSuite] -> TestSuite
-suite s = makeTestSuite . Suite s . mconcat
-
--- | Turn a QuickCheck property into the test suite. The first argument is
--- a label for the property
-useProperty :: Testable prop => String -> prop -> TestSuite
-useProperty = flip usePropertyWith stdArgs
-
--- | Turn a QuickCheck property into the test suite, also providing a test
--- configuration (Args)
-usePropertyWith :: Testable prop => String -> Args -> prop -> TestSuite
-usePropertyWith s args =
-   makeTestSuite . Case s . liftM make . quickCheckWithResult args {chatty=False}
- where
-   make qc =
-      case qc of
-         Success {} ->
-            mempty
-         Failure {reason = msg} ->
-            message msg
-         NoExpectedFailure {} ->
-            message "no expected failure"
-         GaveUp {numTests = i} ->
-            warning ("passed only " ++ show i ++ " tests")
-         InsufficientCoverage {numTests = i} ->
-            warning ("only performed " ++ show i ++ " tests")
-
-assertTrue :: String -> Bool -> TestSuite
-assertTrue s = assertIO s . return
-
-assertNull :: Show a => String -> [a] -> TestSuite
-assertNull s xs = assertMessages s (null xs) (map show xs)
-
-assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite
-assertEquals s x y = assertMessage s (x==y) $
-   "not equal " ++ show x ++ " and " ++ show y
-
-assertMessage :: String -> Bool -> String -> TestSuite
-assertMessage s b = assertMessages s b . return
-
-assertMessages :: String -> Bool -> [String] -> TestSuite
-assertMessages s b xs = makeTestSuite . Case s $ return $
-   if b then mempty else mconcat (map message xs)
-
-assertIO :: String -> IO Bool -> TestSuite
-assertIO s = makeTestSuite . Case s . liftM f
- where
-   f b = if b then mempty else message "assertion failed"
-
-assertMessageIO :: String -> IO Message -> TestSuite
-assertMessageIO s = makeTestSuite . Case s
-
--- | All errors are turned into warnings
-onlyWarnings :: TestSuite -> TestSuite
-onlyWarnings = changeMessages $ \m ->
-   m { messageStatus = messageStatus m  `min` Warning
-     , messageRating = mempty
-     }
-
-rateOnError :: Int -> TestSuite -> TestSuite
-rateOnError n = changeMessages $ \m ->
-   if isError m then m { messageRating = Rating n } else m
-
-changeMessages :: (Message -> Message) -> TestSuite -> TestSuite
-changeMessages f = changeTS
- where
-   changeTS   (TS xs)     = TS (fmap changeTest xs)
-   changeTest (Case s io) = Case s (liftM f io)
-   changeTest (Suite s t) = Suite s (changeTS t)
-
-----------------------------------------------------------------
--- Running a test suite
-
-runTestSuite :: Bool -> TestSuite -> IO ()
-runTestSuite chattyIO = void . runTestSuiteResult chattyIO
-
-runTestSuiteResult :: Bool -> TestSuite -> IO Result
-runTestSuiteResult chattyIO ts = do
-   hSetBuffering stdout NoBuffering
-   ref <- newIORef 0
-   result <- runner ref chattyIO ts
-   newline ref
-   return result
-
-runner :: IORef Int -> Bool -> TestSuite -> IO Result
-runner ref chattyIO = runTS
- where
-   runTS :: TestSuite -> IO Result
-   runTS ts = do
-      (res, dt) <- getDiffTime (foldM addTest mempty (tests ts))
-      returnStrict res { diffTime = dt }
-
-   runTest :: Test -> IO Result
-   runTest t =
-      case t of
-         Suite s xs -> runSuite s xs
-         Case s io  -> runTestCase s io
-
-   runSuite ::String -> TestSuite -> IO Result
-   runSuite s ts = do
-      when chattyIO $ do
-         newline ref
-         putStrLn s
-         reset ref
-      result <- runTS ts
-      returnStrict (suiteResult s result)
-
-   runTestCase :: String -> IO Message -> IO Result
-   runTestCase s io = do
-      msg <- io `catch` handler
-      case messageStatus msg of
-         _ | not chattyIO -> return ()
-         Ok -> dot ref
-         _  -> do
-            newlineIndent ref
-            print msg
-            reset ref
-      returnStrict (caseResult (s, msg))
-    where
-      handler :: SomeException -> IO Message
-      handler = return . message . show
-
-   addTest :: Result -> Test -> IO Result
-   addTest res t = liftM (res <>) (runTest t)
-
--- formatting helpers
-type WriteIO a = IORef Int -> IO a
-
-newline :: WriteIO ()
-newline ref = do
-   i <- readIORef ref
-   when (i>0) (putChar '\n')
-   reset ref
-
-newlineIndent :: WriteIO ()
-newlineIndent ref = do
-   newline ref
-   putStr "   "
-   writeIORef ref 3
-
-dot :: WriteIO ()
-dot ref = do
-   i <- readIORef ref
-   unless (i>0 && i<60) (newlineIndent ref)
-   putChar '.'
-   modifyIORef ref (+1)
-
-reset :: WriteIO ()
-reset = (`writeIORef` 0)
-
-----------------------------------------------------------------
--- Test Suite Result
-
-data Result = Result
-   { suites       :: S.Seq (String, Result)
-   , cases        :: S.Seq (String, Message)
-   , diffTime     :: !NominalDiffTime
-   , nrOfTests    :: !Int
-   , nrOfWarnings :: !Int
-   , nrOfErrors   :: !Int
-   , resultRating :: !Rating
-   }
-
--- one-line summary
-instance Show Result where
-   show result =
-      "(tests: "     ++ show (nrOfTests result)    ++
-      ", errors: "   ++ show (nrOfErrors result)   ++
-      ", warnings: " ++ show (nrOfWarnings result) ++
-      ", "           ++ show (diffTime result)     ++ ")"
-
-instance Monoid Result where
-   mempty = Result mempty mempty 0 0 0 0 mempty
-   x `mappend` y = Result
-      { suites       = suites x <> suites y
-      , cases        = cases x  <> cases y
-      , diffTime     = diffTime x     + diffTime y
-      , nrOfTests    = nrOfTests x    + nrOfTests y
-      , nrOfWarnings = nrOfWarnings x + nrOfWarnings y
-      , nrOfErrors   = nrOfErrors x   + nrOfErrors y
-      , resultRating = resultRating x <> resultRating y
-      }
-
-instance HasStatus Result where
-   getStatus r | nrOfErrors r   > 0 = Error
-               | nrOfWarnings r > 0 = Warning
-               | otherwise          = Ok
-
-instance HasRating Result where
-   rating   = rating . resultRating
-   rate n a = a {resultRating = Rating n}
-
-suiteResult :: String -> Result -> Result
-suiteResult s res = mempty
-   { suites       = S.singleton (s, res)
-   , nrOfTests    = nrOfTests res
-   , nrOfWarnings = nrOfWarnings res
-   , nrOfErrors   = nrOfErrors res
-   , resultRating = resultRating res
-   }
-
-caseResult :: (String, Message) -> Result
-caseResult x@(_, msg) =
-   case getStatus msg of
-      Ok      -> new
-      Warning -> new { nrOfWarnings = 1 }
-      Error   -> new { nrOfErrors   = 1 }
- where
-   new = mempty
-      { cases        = S.singleton x
-      , nrOfTests    = 1
-      , resultRating = messageRating msg
-      }
-
-subResults :: Result -> [(String, Result)]
-subResults = toList . suites
-
-topMessages :: Result -> [(String, Message)]
-topMessages = toList . cases
-
-allMessages :: Result -> [(String, Message)]
-allMessages res =
-   topMessages res ++ concatMap (allMessages . snd) (subResults res)
-
-findSubResult :: String -> Result -> Maybe Result
-findSubResult name = listToMaybe . recs
- where
-   recs = concatMap rec . subResults
-   rec (n, t)
-      | n == name = [t]
-      | otherwise = recs t
-
-justOneSuite :: Result -> Maybe (String, Result)
-justOneSuite res =
-   case subResults res of
-      [x] | S.null (cases res) -> Just x
-      _ -> Nothing
-
-timeInterval :: Result -> Double
-timeInterval = fromRational . toRational . diffTime
-
-printSummary :: Result -> IO ()
-printSummary = putStrLn . makeSummary
-
-makeSummary :: Result -> String
-makeSummary result = unlines $
-   [ line
-   , "Tests    : " ++ show (nrOfTests result)
-   , "Errors   : " ++ show (nrOfErrors result)
-   , "Warnings : " ++ show (nrOfWarnings result)
-   , ""
-   , "Time     : " ++ show (diffTime result)
-   , ""
-   , "Suites: "
-   ] ++ map f (subResults result)
-     ++ [line]
- where
-   line = replicate 75 '-'
-   f (name, r) = "   " ++ name ++ "   " ++ show r
-
------------------------------------------------------
--- Message
-
-data Message = M
-   { messageStatus :: !Status
-   , messageRating :: !Rating
-   , messageLines  :: [String]
-   }
- deriving Eq
-
-instance Show Message where
-   show a = st ++ sep ++ msg
-    where
-      msg = intercalate ", " (messageLines a)
-      sep = if null st || null msg then "" else ": "
-      st | isError a             = "error"
-         | isWarning a           = "warning"
-         | null (messageLines a) = "ok"
-         | otherwise             = ""
-
-instance Monoid Message where
-   mempty = M mempty mempty mempty
-   M s r xs `mappend` M t q ys = M (s <> t) (r <> q) (xs <> ys)
-
-instance HasStatus Message where
-   getStatus = messageStatus
-
-instance HasRating Message where
-   rating   = rating . messageRating
-   rate n a = a {messageRating = Rating n}
-
-message :: String -> Message
-message = M Error (Rating 0) . return
-
-warning :: String -> Message
-warning = M Warning mempty . return
-
------------------------------------------------------
--- Status
-
-data Status = Ok | Warning | Error
-   deriving (Eq, Ord)
-
-instance Monoid Status where
-   mempty  = Ok
-   mappend = max
-
-class HasStatus a where
-   getStatus :: a -> Status
-
-isOk, isWarning, isError :: HasStatus a => a -> Bool
-isOk      = (== Ok)      . getStatus
-isWarning = (== Warning) . getStatus
-isError   = (== Error)   . getStatus
-
------------------------------------------------------
--- Rating
-
-data Rating = Rating !Int | MaxRating
-   deriving (Eq, Ord)
-
-instance Monoid Rating where
-   mempty  = MaxRating
-   mappend = min
-
-class HasRating a where
-   rating :: a -> Maybe Int
-   rate   :: Int -> a -> a
-
-instance HasRating Rating where
-   rating (Rating n) = Just n
-   rating MaxRating  = Nothing
-   rate = const . Rating
-
------------------------------------------------------
--- Utility function
-
-getDiffTime :: IO a -> IO (a, NominalDiffTime)
-getDiffTime action = do
-   t0 <- getCurrentTime
-   a  <- action
-   t1 <- getCurrentTime
-   return (a, diffUTCTime t1 t0)
-
-returnStrict :: Monad m => a -> m a
-returnStrict a = a `seq` return a

@@ -1,25 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Exports a subset of Data.Generics.Uniplate.Direct (the @Uniplate@ type
--- class and its utility plus constructor functions)
---
------------------------------------------------------------------------------
-
-module Ideas.Common.Utils.Uniplate
-   ( -- * Uniplate type class and utility functions
-     Uniplate
-   , children, contexts, descend, descendM, holes, para
-   , rewrite, rewriteM, transform, transformM, uniplate, universe
-     -- * Instance constructors
-   , (|-), (|*), (||*), plate
-   ) where
-
-import Data.Generics.Uniplate.Direct

@@ -39,7 +39,6 @@    ) where
 
 import Control.Arrow
-import Control.Monad
 import Data.Maybe
 import Ideas.Common.Classes
 import Ideas.Common.Id
@@ -101,7 +100,7 @@ 
 canonicalWithM :: IsView f => (b -> Maybe b) -> f a b -> a -> Maybe a
 canonicalWithM f view a =
-   match view a >>= liftM (build view) . f
+   match view a >>= fmap (build view) . f
 
 isCanonical :: (IsView f, Eq a) => f a b -> a -> Bool
 isCanonical = isCanonicalWith (==)

@@ -40,14 +40,14 @@ decodeType tp =
    case tp of
       Tag _ t -> decodeType t
-      Iso p t -> liftM (from p) (decodeType t)
+      Iso p t -> from p <$> decodeType t
       Pair t1 t2 -> do
          a <- decodeType t1
          b <- decodeType t2
          return (a, b)
       t1 :|: t2 ->
-         liftM Left  (decodeType t1) `mplus`
-         liftM Right (decodeType t2)
+         (Left  <$> decodeType t1) `mplus`
+         (Right <$> decodeType t2)
       Unit         -> return ()
       Const QCGen  -> getQCGen
       Const Script -> getScript
@@ -86,7 +86,7 @@ decodeLocation :: JSONDecoder a Location
 decodeLocation = decoderFor $ \json ->
    case json of
-      String s -> liftM toLocation (readM s)
+      String s -> toLocation <$> readM s
       _        -> fail "expecting a string for a location"
 
 decodeState :: JSONDecoder a (State a)
@@ -126,7 +126,7 @@       case json of
          String p
             | p ~= "noprefix" -> return (\_ _ -> noPrefix)
-            | otherwise       -> liftM replayPaths (readPaths p)
+            | otherwise       -> replayPaths <$> readPaths p
          _ -> fail "invalid prefixes"
  where
    x ~= y = filter isAlphaNum (map toLower x) == y
@@ -145,14 +145,15 @@ decodeContext :: JSONDecoder a (Context a)
 decodeContext = do
    ex <- getExercise
-   liftM (inContext ex) decodeExpression
+   inContext ex <$> decodeExpression
 
 decodeExpression :: JSONDecoder a a
 decodeExpression = withJSONTerm $ \b -> getExercise >>= decoderFor . f b
  where
    f True ex json =
-      let Just v = hasTermView ex
-      in matchM v (jsonToTerm json)
+      case hasJSONView ex of
+         Just v  -> matchM v json
+         Nothing -> fail "JSON encoding not supported by exercise"
    f False ex json =
       case json of
          String s -> either fail return (parser ex s)

@@ -23,7 +23,7 @@ import Ideas.Common.Traversal.Navigator
 import Ideas.Encoding.Encoder
 import Ideas.Encoding.OpenMathSupport
-import Ideas.Service.Request
+import Ideas.Encoding.Request
 import Ideas.Service.State
 import Ideas.Service.Types
 import Ideas.Text.OpenMath.Object
@@ -43,14 +43,14 @@               maybe (fail "unknown difficulty level") (return . g) (readDifficulty a)
          | otherwise ->
               decodeChild s (xmlDecoder t)
-      Iso p t  -> liftM (from p) (xmlDecoder t)
+      Iso p t  -> from p <$> xmlDecoder t
       Pair t1 t2 -> do
          x <- xmlDecoder t1
          y <- xmlDecoder t2
          return (x, y)
       t1 :|: t2 ->
-         liftM Left  (xmlDecoder t1) `mplus`
-         liftM Right (xmlDecoder t2)
+         (Left  <$> xmlDecoder t1) `mplus`
+         (Right <$> xmlDecoder t2)
       Unit -> return ()
       Const ctp ->
          case ctp of
@@ -112,7 +112,7 @@        locRef = makeRef "location"
    case locRef ? env of
       Just s  -> maybe (fail "invalid location") return $ do
-         loc <- liftM toLocation (readM s)
+         loc <- toLocation <$> readM s
          navigateTo loc (deleteRef locRef ctx)
       Nothing ->
          return ctx
@@ -159,8 +159,7 @@ decodeConfiguration :: XMLDecoder a StrategyCfg
 decodeConfiguration = decodeChild "configuration" $
    decoderFor $ \xml ->
-      liftM mconcat $
-         mapM decodeAction (children xml)
+      mconcat <$> mapM decodeAction (children xml)
  where
    decodeAction item = do
       guard (null (children item))
@@ -170,7 +169,7 @@ 
 decodeArgEnvironment :: XMLDecoder a Environment
 decodeArgEnvironment = decoderFor $
-   liftM makeEnvironment . mapM (decodeBinding //) . findChildren "argument"
+   fmap makeEnvironment . mapM (decodeBinding //) . findChildren "argument"
 
 decodeBinding :: XMLDecoder a Binding
 decodeBinding = decoderFor $ \xml -> do

@@ -14,12 +14,14 @@ module Ideas.Encoding.Encoder
    ( -- * Converter type class
      Converter(..)
-   , getExercise, getQCGen, getScript, getRequest
+   , getExercise, getBaseUrl, getQCGen, getScript, getRequest
    , withExercise, withOpenMath, withJSONTerm, (//)
-     -- * JSON terms
-   , termToJSON, jsonToTerm, jsonTermView
-     -- * Options
-   , Options, simpleOptions, makeOptions
+     -- * JSON support
+   , hasJSONView, addJSONView, jsonEncoding
+   , termToJSON, jsonToTerm
+     -- * Latex support
+   , hasLatexEncoding, latexPrinter, latexPrinterContext
+   , latexEncoding, latexEncodingWith
      -- * Encoder datatype
    , Encoder, TypedEncoder
    , makeEncoder, encoderFor, exerciseEncoder
@@ -35,14 +37,15 @@ import Control.Applicative as Export hiding (Const)
 import Control.Arrow as Export
 import Control.Monad
+import Data.Maybe
 import Data.Monoid as Export
 import Ideas.Common.Library hiding (exerciseId, symbol)
-import Ideas.Common.Utils (Some(..))
-import Ideas.Service.DomainReasoner
-import Ideas.Service.FeedbackScript.Parser (parseScriptSafe, Script)
-import Ideas.Service.Request
+import Ideas.Encoding.Options
+import Ideas.Encoding.Request
+import Ideas.Service.FeedbackScript.Parser (Script)
 import Ideas.Service.Types
 import Ideas.Text.JSON hiding (String)
+import Ideas.Text.Latex
 import Ideas.Text.XML
 import Test.QuickCheck.Random
 import qualified Control.Category as C
@@ -53,14 +56,18 @@ -- Converter type class
 
 class Converter f where
-   fromOptions :: (Options a -> t) -> f a s t
-   run  :: Monad m => f a s t -> Options a -> s -> m t
+   fromExercise :: (Exercise a -> t) -> f a s t
+   fromOptions  :: (Options -> t) -> f a s t
+   run :: Monad m => f a s t -> Exercise a -> Options -> s -> m t
 
 getExercise :: Converter f => f a s (Exercise a)
-getExercise = fromOptions exercise
+getExercise = fromExercise id
 
+getBaseUrl :: Converter f => f a s String
+getBaseUrl = fromOptions (fromMaybe "http://ideas.cs.uu.nl/" . baseUrl)
+
 getQCGen :: Converter f => f a s QCGen
-getQCGen = fromOptions qcGen
+getQCGen = fromOptions (fromMaybe (mkQCGen 0) . qcGen)
 
 getScript :: Converter f => f a s Script
 getScript = fromOptions script
@@ -72,19 +79,32 @@ withExercise = (getExercise >>=)
 
 withOpenMath :: (Converter f, Monad (f a s)) => (Bool -> f a s t) -> f a s t
-withOpenMath = (liftM useOpenMath getRequest >>=)
+withOpenMath = (fmap useOpenMath getRequest >>=)
 
 withJSONTerm :: (Converter f, Monad (f a s)) => (Bool -> f a s t) -> f a s t
-withJSONTerm = (liftM useJSONTerm getRequest >>=)
+withJSONTerm = (fmap useJSONTerm getRequest >>=)
 
 (//) :: (Converter f, Monad (f a s2)) => f a s t -> s -> f a s2 t
 p // a = do
-   xs <- fromOptions id
-   run p xs a
+   opts <- fromOptions id
+   ex   <- getExercise
+   run p ex opts a
 
 -------------------------------------------------------------------
 -- JSON terms
 
+jsonProperty :: Id
+jsonProperty = describe "Support for JSON encoding" $ newId "json"
+
+hasJSONView :: Exercise a -> Maybe (View JSON a)
+hasJSONView = getPropertyF jsonProperty
+
+addJSONView :: View JSON a -> Exercise a -> Exercise a
+addJSONView = setPropertyF jsonProperty
+
+jsonEncoding :: InJSON a => Exercise a -> Exercise a
+jsonEncoding = addJSONView (makeView fromJSON toJSON)
+
 termToJSON :: Term -> JSON
 termToJSON term =
    case term of
@@ -120,55 +140,44 @@  where
    f (s, x) = [TVar s, jsonToTerm x]
 
-jsonTermView :: InJSON a => View Term a
-jsonTermView = makeView (fromJSON . termToJSON) (jsonToTerm . toJSON)
-
-trueSymbol, falseSymbol, nullSymbol, objectSymbol :: Symbol
-trueSymbol   = newSymbol "true"
-falseSymbol  = newSymbol "false"
+nullSymbol, objectSymbol :: Symbol
 nullSymbol   = newSymbol "null"
 objectSymbol = newSymbol "object"
 
 -------------------------------------------------------------------
--- Options
+-- Latex support
 
-data Options a = Options
-   { exercise :: Exercise a -- the current exercise
-   , request  :: Request    -- meta-information about the request
-   , qcGen    :: QCGen      -- random number generator
-   , script   :: Script     -- feedback script
-   }
+latexProperty :: Id
+latexProperty = describe "Support for LaTeX encoding" $ newId "latex"
 
-simpleOptions :: Exercise a -> Options a
-simpleOptions ex =
-   let req = emptyRequest {encoding = [EncHTML]}
-       gen = mkQCGen 0
-   in Options ex req gen mempty
+newtype F a = F { unF :: a -> Latex }
 
-makeOptions :: DomainReasoner -> Request -> IO (Some Options)
-makeOptions dr req = do
-   Some ex  <-
-      case exerciseId req of
-         Just code -> findExercise dr code
-         Nothing   -> return (Some emptyExercise)
+getF :: Exercise a -> Maybe (F a)
+getF = getPropertyF latexProperty
 
-   scr <- case feedbackScript req of
-             Just s -> parseScriptSafe s
-             Nothing
-                | getId ex == mempty -> return mempty
-                | otherwise          -> defaultScript dr (getId ex)
-   gen <- maybe newQCGen (return . mkQCGen) (randomSeed req)
-   return $ Some Options
-      { exercise = ex
-      , request  = req
-      , qcGen    = gen
-      , script   = scr
-      }
+hasLatexEncoding :: Exercise a -> Bool
+hasLatexEncoding = isJust . getF
 
+-- | Uses exercise pretty-printer in case latex encoding is missing.
+latexPrinter :: Exercise a -> a -> Latex
+latexPrinter ex = maybe (toLatex . prettyPrinter ex) unF (getF ex)
+
+-- | Uses exercise pretty-printer in case latex encoding is missing.
+latexPrinterContext :: Exercise a -> Context a -> Latex
+latexPrinterContext ex ctx =
+   let def = toLatex (prettyPrinterContext ex ctx)
+   in fromMaybe def (unF <$> getF ex <*> fromContext ctx)
+
+latexEncoding :: ToLatex a => Exercise a -> Exercise a
+latexEncoding = latexEncodingWith toLatex
+
+latexEncodingWith :: (a -> Latex) -> Exercise a -> Exercise a
+latexEncodingWith = setPropertyF latexProperty . F
+
 -------------------------------------------------------------------
 -- Encoder datatype
 
-newtype Encoder a s t = Enc { runEnc :: Options a -> s -> Error t }
+newtype Encoder a s t = Enc { runEnc :: (Exercise a, Options) -> s -> Error t }
 
 type TypedEncoder a = Encoder a (TypedValue (Type a))
 
@@ -180,32 +189,35 @@    arr   f = Enc $ \_ -> return . f
    first f = Enc $ \xs (a, b) -> runEnc f xs a >>= \c -> return (c, b)
 
+instance Functor (Encoder a s) where
+   fmap f p = Enc $ \xs s -> f <$> runEnc p xs s
+
+instance Applicative (Encoder a s) where
+   pure a  = Enc $ \_ _ -> return a
+   p <*> q = Enc $ \xs s -> do
+      f <- runEnc p xs s
+      f <$> runEnc q xs s
+
 instance Alternative (Encoder a s) where
-   empty = mzero
-   (<|>) = mplus
+   empty = fail "Encoder: emptu"
+   p <|> q = Enc $ \xs s ->
+      runEnc p xs s <|> runEnc q xs s
 
 instance Monad (Encoder a s) where
-   return a = Enc $ \_ _ -> return a
+   return   = pure
    fail s   = Enc $ \_ _ -> fail s
    p >>= f  = Enc $ \xs s -> do
       a <- runEnc p xs s
       runEnc (f a) xs s
 
 instance MonadPlus (Encoder a s) where
-   mzero = fail "Decoder: mzero"
-   mplus p q = Enc $ \xs s ->
-      runEnc p xs s `mplus` runEnc q xs s
-
-instance Functor (Encoder a s) where
-   fmap = liftM
-
-instance Applicative (Encoder a s) where
-   pure  = return
-   (<*>) = liftM2 ($)
+   mzero = fail "Encoder: mzero"
+   mplus = (<|>)
 
 instance Converter Encoder where
-   fromOptions f = Enc $ \xs _ -> return (f xs)
-   run f xs = runErrorM . runEnc f xs
+   fromExercise f = Enc $ \(ex, _) _ -> return (f ex)
+   fromOptions  f = Enc $ \(_, opts) _ -> return (f opts)
+   run f ex opts  = runErrorM . runEnc f (ex, opts)
 
 instance Monoid t => Monoid (Encoder a s t) where
    mempty  = pure mempty
@@ -215,7 +227,7 @@    n .=. s   = pure (n .=. s)
    unescaped = pure . unescaped
    builder   = pure . builder
-   tag       = liftA . tag
+   tag       = fmap . tag
 
 makeEncoder :: (s -> t) -> Encoder a s t
 makeEncoder = arr
@@ -242,12 +254,25 @@ -------------------------------------------------------------------
 -- Decoder datatype
 
-newtype Decoder a s t = Dec { runDec :: Options a -> s -> Error (t, s) }
+newtype Decoder a s t = Dec { runDec :: (Exercise a, Options) -> s -> Error (t, s) }
 
 type TypedDecoder a s = forall t . Type a t -> Decoder a s t
 
+instance Functor (Decoder a s) where
+   fmap f p = Dec $ \xs s -> mapFirst f <$> runDec p xs s
+
+instance Applicative (Decoder a s) where
+   pure a  = Dec $ \_ s -> return (a, s)
+   p <*> q = Dec $ \xs s1 -> do
+      (f, s2) <- runDec p xs s1
+      mapFirst f <$> runDec q xs s2
+
+instance Alternative (Decoder a s) where
+   empty   = fail "Decoder: empty"
+   p <|> q = Dec $ \xs s -> runDec p xs s <|> runDec q xs s
+
 instance Monad (Decoder a s) where
-   return a = Dec $ \_ s -> return (a, s)
+   return   = pure
    fail s   = Dec $ \_ _ -> fail s
    p >>= f  = Dec $ \xs s1 -> do
       (a, s2) <- runDec p xs s1
@@ -255,19 +280,7 @@ 
 instance MonadPlus (Decoder a s) where
    mzero = fail "Decoder: mzero"
-   mplus p q = Dec $ \xs s ->
-      runDec p xs s `mplus` runDec q xs s
-
-instance Functor (Decoder a s) where
-   fmap = liftM
-
-instance Applicative (Decoder a s) where
-   pure  = return
-   (<*>) = liftM2 ($)
-
-instance Alternative (Decoder a s) where
-   empty = fail "Decoder: empty"
-   (<|>) = mplus
+   mplus = (<|>)
 
 get :: Decoder a s s
 get = Dec $ \_ s -> return (s, s)
@@ -276,8 +289,9 @@ put s = Dec $ \_ _ -> return ((), s)
 
 instance Converter Decoder where
-   fromOptions f = Dec $ \xs s -> return (f xs, s)
-   run f xs = liftM fst . runErrorM . runDec f xs
+   fromExercise f = Dec $ \(ex, _) s -> return (f ex, s)
+   fromOptions  f = Dec $ \(_, opts) s -> return (f opts, s)
+   run f ex opts  = fmap fst . runErrorM . runDec f (ex, opts)
 
 split :: (s -> Either String (t, s)) -> Decoder a s t
 split f = get >>= either fail (\(a, s2) -> put s2 >> return a) . f
@@ -303,28 +317,32 @@ newtype Error a = Error { runError :: Either String a }
 
 instance Functor Error where
-   fmap = (<$>)
+   fmap f = Error . fmap f . runError
 
 instance Applicative Error where
-   pure  = return
-   (<*>) = ap
+   pure    = Error . Right
+   p <*> q = Error $
+      case (runError p, runError q) of
+         (Left s, _)  -> Left s
+         (_, Left s)  -> Left s
+         (Right f, Right x) -> Right (f x)
 
 instance Alternative Error where
-   empty = mzero
-   (<|>) = mplus
+   empty   = Error (Left "empty")
+   p <|> q = Error $
+      case (runError p, runError q) of
+         (Right a, _) -> Right a
+         (_, Right a) -> Right a
+         (Left s, _)  -> Left s
 
 instance Monad Error where
    fail    = Error . Left
-   return  = Error . Right
+   return  = pure
    m >>= f = Error $ either Left (runError . f) (runError m)
 
 instance MonadPlus Error where
-   mzero     = fail "mzero"
-   mplus p q = Error $
-      case (runError p, runError q) of
-         (Right a, _) -> Right a
-         (_, Right a) -> Right a
-         (Left s, _)  -> Left s
+   mzero = fail "mzero"
+   mplus = (<|>)
 
 runErrorM :: Monad m => Error a -> m a
 runErrorM = either fail return . runError

@@ -13,7 +13,7 @@ --
 -----------------------------------------------------------------------------
 
-module Ideas.Encoding.EncoderHTML (htmlEncoder, htmlEncoderAt) where
+module Ideas.Encoding.EncoderHTML (htmlEncoder) where
 
 import Data.Char
 import Data.List
@@ -21,40 +21,38 @@ import Data.Ord
 import Ideas.Common.Library hiding (alternatives)
 import Ideas.Common.Strategy.Symbol
-import Ideas.Common.Utils
-import Ideas.Common.Utils.TestSuite
 import Ideas.Encoding.Encoder
 import Ideas.Encoding.LinkManager
+import Ideas.Encoding.Request
 import Ideas.Encoding.RulePresenter
 import Ideas.Encoding.RulesInfo
 import Ideas.Encoding.StrategyInfo
 import Ideas.Service.BasicServices
 import Ideas.Service.Diagnose
 import Ideas.Service.DomainReasoner
-import Ideas.Service.Request
 import Ideas.Service.State
 import Ideas.Service.Types
 import Ideas.Text.HTML
 import Ideas.Text.OpenMath.FMP
 import Ideas.Text.OpenMath.Object
 import Ideas.Text.XML
+import Ideas.Utils.TestSuite
 import System.IO.Unsafe
 
 type HTMLEncoder a t = Encoder a t HTMLBuilder
 
 htmlEncoder :: DomainReasoner -> TypedEncoder a HTMLPage
-htmlEncoder = htmlEncoderAt 0
-
-htmlEncoderAt :: Int -> DomainReasoner -> TypedEncoder a HTMLPage
-htmlEncoderAt n dr = do
-   req <- getRequest
-   let lm = f (maybe staticLinks dynamicLinks (cgiBinary req))
-       f  = if n==0 then id else linksUp n
-   makePage lm dr <$> encodeType lm dr
+htmlEncoder dr = do
+   req  <- getRequest
+   base <- getBaseUrl
+   let lm = makeLinkManager base (fromMaybe "" (cgiBinary req))
+   ex <- getExercise
+   makePage lm dr ex <$> encodeType lm dr
 
-makePage :: LinkManager -> DomainReasoner -> HTMLBuilder -> HTMLPage
-makePage lm dr a =
+makePage :: LinkManager -> DomainReasoner -> Exercise a -> HTMLBuilder -> HTMLPage
+makePage lm dr ex a =
    addCSS (urlForCSS lm "ideas.css") $
+   (if hasLatexEncoding ex then addScript mathJaxUrl else id) $
    htmlPage "Ideas: documentation pages" $ mconcat
       [ divClass "page-header" $ mconcat
            [ divClass  "ideas-logo" space
@@ -67,6 +65,9 @@       , divClass "page-footer" $
            string (fullVersion dr)
       ]
+ where
+   mathJaxUrl =
+      "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-MML-AM_CHTML"
 
 encodeType :: LinkManager -> DomainReasoner -> HTMLEncoder a (TypedValue (Type a))
 encodeType lm dr =
@@ -234,9 +235,7 @@                   ]
           | isJust (randomExercise ex)
           ] ++
-          [ para $ submitStateInfo lm ex
-          | not (isStatic lm)
-          ]
+          [ para $ submitStateInfo lm ex ]
    ]
  where
    generalInfo ex = keyValueTable
@@ -416,15 +415,14 @@ encodeExampleList lm = exerciseEncoder $ \ex pairs -> mconcat $
    h2 "Examples" :
    [ h3 (s ++ " (" ++ show (length xs) ++ ")")
-       <> (if isStatic lm then ul else mconcat) (map (make ex) xs)
+       <> mconcat (map (make ex) xs)
    | (_, s, xs) <- orderedGroupsWith show fst pairs
    ]
  where
    make ex (_, x) = para $
-      munless (isStatic lm) (
-         let st = emptyStateContext ex x
-         in spanClass "statelink" $ linkToState lm st $ external lm)
-      <> spanClass "term" (string (prettyPrinterContext ex x))
+      ( let st = emptyStateContext ex x
+        in spanClass "statelink" $ linkToState lm st $ external lm)
+      <> htmlContext False ex x
 
 external :: BuildXML a => LinkManager -> a
 external lm = element "img"
@@ -457,23 +455,30 @@              , showEnv env1 -- local environment
              , showEnv env2 -- global environment (diff)
              ]
-       textLines = mconcat . intersperse br . map string . lines
-       forTerm a =
-          divClass "term" $ textLines $ prettyPrinterContext ex a
+       forTerm = htmlContext True ex
    in htmlDerivationWith before forStep forTerm (diffEnvironment d)
 
 htmlState :: LinkManager -> HTMLEncoder a (State a)
 htmlState lm = makeEncoder $ \state ->
    para $ divClass "state" $
       stateLink lm state
-      <> divClass "term" (string $ prettyPrinterContext (exercise state) (stateContext state))
+      <> htmlContext True (exercise state) (stateContext state)
       <> string "ready: " <> bool (finished state)
 
+htmlContext :: Bool -> Exercise a -> Context a -> HTMLBuilder
+htmlContext useDiv ex = f "term" . textLines . printer
+ where
+   textLines = mconcat . intersperse br . map string . lines
+   f = if useDiv then divClass else spanClass
+
+   inline s = "\\(" ++ s ++ "\\)"
+   printer
+      | hasLatexEncoding ex = inline . show . latexPrinterContext ex
+      | otherwise = prettyPrinterContext ex
+
 stateLink :: LinkManager -> State a -> HTMLBuilder
-stateLink lm st
-   | isStatic lm = mempty
-   | otherwise =
-        spanClass "derivation-statelink" $ linkToState lm st $ external lm
+stateLink lm st =
+   spanClass "derivation-statelink" $ linkToState lm st $ external lm
 
 encodeState :: LinkManager -> DomainReasoner -> HTMLEncoder a (State a)
 encodeState lm dr =

@@ -17,11 +17,11 @@ 
 import Data.Maybe
 import Ideas.Common.Library hiding (exerciseId)
-import Ideas.Common.Utils (Some(..), distinct)
 import Ideas.Encoding.Encoder hiding (symbol)
 import Ideas.Service.State
 import Ideas.Service.Types hiding (String)
 import Ideas.Text.JSON
+import Ideas.Utils.Prelude (distinct)
 import qualified Ideas.Service.Diagnose as Diagnose
 import qualified Ideas.Service.Submit as Submit
 import qualified Ideas.Service.Types as Tp
@@ -60,7 +60,7 @@    tupleList (p ::: Tp.Pair t1 t2) =
       tupleList (fst p ::: t1) ++ tupleList (snd p ::: t2)
    tupleList (x ::: Tag s t)
-      | s `elem` ["Message"] = tupleList (x ::: t)
+      | s == "Message" = tupleList (x ::: t)
    tupleList (ev ::: (t1 :|: t2)) =
       either (\x -> tupleList (x ::: t1))
              (\x -> tupleList (x ::: t2)) ev
@@ -94,12 +94,8 @@ encodeContext :: JSONEncoder a (Context a)
 encodeContext = withJSONTerm (exerciseEncoder . f)
  where
-   f True ex ctx = fromMaybe Null $ do
-      v <- hasTermView ex
-      a <- fromContext ctx
-      return (termToJSON (build v a))
-   f False ex ctx =
-      String $ prettyPrinterContext ex ctx
+   f True  ex = fromMaybe Null . liftA2 build (hasJSONView ex) . fromContext
+   f False ex = String . prettyPrinterContext ex
 
 encodeState :: JSONEncoder a (State a)
 encodeState = encoderFor $ \st ->
@@ -187,7 +183,7 @@       Diagnose.Unknown b st ->
          make "unknown" [fromReady b, fromState st]
  where
-   make s = liftA (\xs -> Object [(s, Array xs)]) . sequence
+   make s = fmap (\xs -> Object [(s, Array xs)]) . sequence
    fromEnv env      = jsonEncoder // (env ::: tEnvironment)
    fromRule r       = pure (toJSON (showId r))
    fromMaybeRule mr = pure (maybe Null (toJSON . showId) mr)
@@ -208,11 +204,12 @@ 
 jsonTuple :: [JSON] -> JSON
 jsonTuple xs =
-   case mapM f xs of
+   case catMaybes <$> mapM f xs of
       Just ys | distinct (map fst ys) -> Object ys
       _ -> Array xs
  where
-   f (Object [p]) = Just p
+   f (Object [p]) = Just (Just p)
+   f Null = Just Nothing
    f _ = Nothing
 
 ruleShortInfo :: Rule a -> JSON

@@ -21,8 +21,7 @@ import Data.Char
 import Data.Maybe
 import Data.Monoid
-import Ideas.Common.Library hiding (exerciseId, (:=), alternatives)
-import Ideas.Common.Utils (Some(..))
+import Ideas.Common.Library hiding (exerciseId, alternatives)
 import Ideas.Encoding.Encoder
 import Ideas.Encoding.OpenMathSupport
 import Ideas.Encoding.RulesInfo (rulesInfoXML)

@@ -15,7 +15,8 @@ 
 import Ideas.Common.Library
 import Ideas.Encoding.Encoder
-import Ideas.Main.Logging
+import Ideas.Encoding.Logging
+import Ideas.Encoding.Options
 import Ideas.Service.Diagnose
 import Ideas.Service.Types
 
@@ -36,16 +37,16 @@       []   -> return ()
       hd:_ -> changeLog logRef (f hd)
 
-evalService :: LogRef -> Options a -> Evaluator a b c -> Service -> b -> IO c
-evalService logRef opts f srv b = do
-   res <- eval opts f b (serviceFunction srv)
+evalService :: LogRef -> Exercise a -> Options -> Evaluator a b c -> Service -> b -> IO c
+evalService logRef ex opts f srv b = do
+   res <- eval ex opts f b (serviceFunction srv)
    logType logRef res tState addState
    logType logRef res tRule $ \rl r -> r {ruleid = showId rl}
    logType logRef res tDiagnosis $ \d r -> r {serviceinfo = show d}
    return (evalResult res)
 
-eval :: Options a -> Evaluator a b c -> b -> TypedValue (Type a) -> IO (EvalResult a c)
-eval opts (Evaluator dec enc) b = rec
+eval :: Exercise a -> Options -> Evaluator a b c -> b -> TypedValue (Type a) -> IO (EvalResult a c)
+eval ex opts (Evaluator dec enc) b = rec
  where
    rec tv@(val ::: tp) =
       case tp of
@@ -56,7 +57,7 @@          t1 :-> t2 :-> t3 ->
             rec (uncurry val ::: Pair t1 t2 :-> t3)
          t1 :-> t2 -> do
-            a   <- run (dec t1) opts b
+            a   <- run (dec t1) ex opts b
             res <- rec (val a ::: t2)
             return res { inputValues = (a ::: t1) : inputValues res }
          -- perform IO
@@ -64,5 +65,5 @@             a <- val
             rec (a ::: t)
          _ -> do
-            c <- run enc opts tv
+            c <- run enc ex opts tv
             return $ EvalResult [] tv c

@@ -14,9 +14,9 @@ -----------------------------------------------------------------------------
 
 module Ideas.Encoding.LinkManager
-   ( LinkManager(..)
-   , dynamicLinks, stateToXML
-   , staticLinks, linksUp, pathLevel, (</>)
+   ( LinkManager(..), makeLinkManager
+   , stateToXML
+   -- , pathLevel, (</>)
      -- links to services and exercises
    , linkToIndex, linkToExercises, linkToServices, linkToService
      -- links to exercise information
@@ -31,6 +31,7 @@ import Ideas.Common.Library
 import Ideas.Encoding.Encoder
 import Ideas.Encoding.EncoderXML
+import Ideas.Encoding.Options
 import Ideas.Service.State
 import Ideas.Service.Types
 import Ideas.Text.HTML
@@ -40,7 +41,6 @@    { urlForCSS           :: String -> String
    , urlForImage         :: String -> String
    , urlForRequest       :: String
-   , isStatic            :: Bool
      -- links to services and exercises
    , urlForIndex         :: String
    , urlForExercises     :: String
@@ -130,12 +130,11 @@ ---------------------------------------------------------------------
 -- Dynamic links
 
-dynamicLinks :: String -> LinkManager
-dynamicLinks cgiBinary = LinkManager
-   { isStatic        = False
-   , urlForRequest   = prefix
-   , urlForCSS       = ("http://ideas.cs.uu.nl/css/" ++)
-   , urlForImage     = ("http://ideas.cs.uu.nl/images/" ++)
+makeLinkManager :: String -> String -> LinkManager
+makeLinkManager base cgiBinary = LinkManager
+   { urlForRequest   = prefix
+   , urlForCSS       = \s -> base ++ "css/" ++ s
+   , urlForImage     = \s -> base ++ "images/" ++ s
    , urlForIndex     = url $ simpleRequest "index"
    , urlForExercises = url $ simpleRequest "exerciselist"
    , urlForServices  = url $ simpleRequest "servicelist"
@@ -186,7 +185,7 @@ -- assume nothing goest wrong
 stateToXML :: State a -> XMLBuilder
 stateToXML st = fromMaybe (error "LinkManager: Invalid state") $
-   run encodeState (simpleOptions (exercise st)) st
+   run encodeState (exercise st) optionHtml st
 
 linkWith :: (a -> String) -> a -> HTMLBuilder -> HTMLBuilder
 linkWith f = link . escapeInURL . f
@@ -200,80 +199,4 @@    f '%' = "%25"
    f '#' = "%23"
    f ';' = "%3B"
-   f c   = [c]
-
----------------------------------------------------------------------
--- Static links
-
-staticLinks :: LinkManager
-staticLinks = LinkManager
-   { isStatic        = True
-   , urlForCSS       = id
-   , urlForImage     = id
-   , urlForRequest   = ""
-   , -- links to services and exercises
-     urlForIndex     = "index.html"
-   , urlForExercises = "exercises.html"
-   , urlForServices  = "services.html"
-   , urlForService   = \srv -> "services" </> idToFilePath srv
-     -- links to exercise information
-   , urlForExercise    = idToFilePath
-   , urlForStrategy    = idToFilePathWith "-strategy.html"
-   , urlForRules       = idToFilePathWith "-rules.html"
-   , urlForExamples    = idToFilePathWith "-examples.html"
-   , urlForDerivations = idToFilePathWith "-derivations.html"
-   , urlForRule        = \ex r -> idToFilePathWith ("/" ++ showId r ++ ".html") ex
-   , urlForTestReport  = idToFilePathWith "-testreport.html"
-     -- dynamic exercise information
-   , urlForRandomExample = \_ _ -> ""
-     -- dynamic state information
-   , urlForState        = const ""
-   , urlForFirsts       = const ""
-   , urlForApplications = const ""
-   , urlForDerivation   = const ""
-   , urlForMicrosteps   = const ""
-   }
-
-linksUp :: Int -> LinkManager -> LinkManager
-linksUp n lm = lm
-   { isStatic        = isStatic lm
-     -- links to services and exercises
-   , urlForIndex     = f0 urlForIndex
-   , urlForExercises = f0 urlForExercises
-   , urlForServices  = f0 urlForServices
-   , urlForService   = f1 urlForService
-     -- links to exercise information
-   , urlForExercise    = f1 urlForExercise
-   , urlForStrategy    = f1 urlForStrategy
-   , urlForRules       = f1 urlForRules
-   , urlForExamples    = f1 urlForExamples
-   , urlForDerivations = f1 urlForDerivations
-   , urlForRule        = f2 urlForRule
-     -- dynamic exercise information
-   , urlForRandomExample = f2 urlForRandomExample
-     -- dynamic state information
-   , urlForState        = f1 urlForState
-   , urlForFirsts       = f1 urlForFirsts
-   , urlForApplications = f1 urlForApplications
-   , urlForDerivation   = f1 urlForDerivation
-   , urlForMicrosteps   = f1 urlForMicrosteps
-   }
- where
-   f0 g   = pathUp n $ g lm
-   f1 g   = pathUp n . g lm
-   f2 g x = pathUp n . g lm x
-
-pathUp :: Int -> FilePath -> FilePath
-pathUp n file = concat (replicate n "../") ++ file
-
-pathLevel :: FilePath -> Int
-pathLevel = length . filter (=='/')
-
-idToFilePath :: HasId a => a -> FilePath
-idToFilePath = idToFilePathWith ".html"
-
-idToFilePathWith :: HasId a => String -> a -> FilePath
-idToFilePathWith suffix a = foldr (</>) (unqualified a ++ suffix) (qualifiers a)
-
-(</>) :: String -> FilePath -> FilePath
-x </> y = x ++ "/" ++ y+   f c   = [c]

@@ -0,0 +1,187 @@+{-# LANGUAGE CPP, FlexibleContexts #-}
+-----------------------------------------------------------------------------
+-- Copyright 2016, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Facilities to create a log database
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Encoding.Logging
+   ( Record(..), addRequest, addState
+   , LogRef, newLogRef, noLogRef, changeLog
+   , logEnabled, logRecord, printLog
+   ) where
+
+import Data.IORef
+import Data.Maybe
+import Data.Time
+import Ideas.Encoding.Request (Request, Schema(..))
+import Ideas.Service.State
+import qualified Ideas.Encoding.Request as R
+
+#ifdef DB
+import Data.List
+import Database.HDBC
+import Database.HDBC.Sqlite3 (connectSqlite3)
+#endif
+
+type Diff = NominalDiffTime
+type Time = UTCTime
+
+-- | The Record datatype is based on the Ideas Request Logging Schema version 2.
+data Record = Record
+   { -- request attributes
+     service      :: String  -- name of feedback service
+   , exerciseid   :: String  -- exercise identifier
+   , source       :: String  -- tool/learning environment that makes request
+   , script       :: String  -- name of feedback script (for textual feedback)
+   , requestinfo  :: String  -- additional information from client (only for logging)
+     -- request format
+   , dataformat   :: String  -- xml, json
+   , encoding     :: String  -- options for encoding (e.g. OpenMath, string)
+   , -- grouping requests
+     userid       :: String  -- user identifier (e.g. student number)
+   , sessionid    :: String  -- session identifier (grouping requests for one task)
+   , taskid       :: String  -- task identifier (default: start term)
+     -- meta-information
+   , time         :: Time    -- date and time of request
+   , responsetime :: Diff    -- time needed for processing request
+   , ipaddress    :: String  -- IP address of client
+   , binary       :: String  -- name of (cgi) binary that is being executed
+   , version      :: String  -- version (and revision) information
+   , errormsg     :: String  -- internal error message (default: empty string)
+     -- service info
+   , serviceinfo  :: String  -- summary of reply (customized for each service)
+   , ruleid       :: String  -- rule identifier (customized for each service)
+     -- raw data
+   , input        :: String  -- raw input (request)
+   , output       :: String  -- raw output (reply)
+   }
+ deriving Show
+
+record :: Record
+record = Record "" "" "" "" "" "" "" "" "" "" t0 0 "" "" "" "" "" "" "" ""
+ where t0 = UTCTime (toEnum 0) 0
+
+makeRecord :: IO Record
+makeRecord = do
+   now <- getCurrentTime
+   return record { time = now }
+
+-- | Add record information from the Request datatype
+addRequest :: Request -> Record -> Record
+addRequest req r = r
+   { service     = maybe (service r) show (R.serviceId req)
+   , exerciseid  = maybe (exerciseid r) show (R.exerciseId req)
+   , source      = fromMaybe (source r) (R.source req)
+   , script      = fromMaybe (script r) (R.feedbackScript req)
+   , requestinfo = fromMaybe (requestinfo r) (R.requestInfo req)
+   , dataformat  = show (R.dataformat req)
+   , encoding    = show (R.encoding req)
+   , binary      = fromMaybe (binary r) (R.cgiBinary req)
+   }
+
+-- | Add record information from the state (userid, sessionid, taskid)
+addState :: State a -> Record -> Record
+addState st r = r
+   { userid    = fromMaybe (userid r)    (stateUser st)
+   , sessionid = fromMaybe (sessionid r) (stateSession st)
+   , taskid    = fromMaybe (taskid r)    (stateStartTerm st)
+   }
+
+---------------------------------------------------------------------
+
+newtype LogRef = L { mref :: Maybe (IORef Record) }
+
+noLogRef :: LogRef
+noLogRef = L Nothing
+
+newLogRef :: IO LogRef
+newLogRef = do
+   r   <- makeRecord
+   ref <- newIORef r
+   return (L (Just ref))
+
+getRecord :: LogRef -> IO Record
+getRecord = maybe (return record) readIORef . mref
+
+changeLog :: LogRef -> (Record -> Record) -> IO ()
+changeLog = maybe (\_ -> return ()) modifyIORef . mref
+
+printLog :: LogRef -> IO ()
+printLog logRef = do
+   putStrLn "-- log information"
+   getRecord logRef >>= print
+
+--------------------------------------------------------------------------------
+
+logEnabled :: Bool
+logRecord  :: Schema -> LogRef -> IO ()
+
+#ifdef DB
+logEnabled = True
+logRecord schema logRef =
+   case schema of
+      V1 -> connectSqlite3 "service.db"  >>= logRecordWith V1 logRef
+      V2 -> connectSqlite3 "requests.db" >>= logRecordWith V2 logRef
+      NoLogging -> return ()
+#else
+-- without logging
+logEnabled    = False
+logRecord _ _ = return ()
+#endif
+
+--------------------------------------------------------------------------------
+
+#ifdef DB
+nameOfTable :: Schema -> String
+nameOfTable V1 = "log"
+nameOfTable _  = "requests"
+
+columnsInTable :: Schema -> Record -> [SqlValue]
+columnsInTable V1 = values_v1
+columnsInTable _  = values_v2
+
+values_v1 :: Record -> [SqlValue]
+values_v1 r =
+   let get f = toSql (f r)
+   in [ get service, get exerciseid, get source, get dataformat, get encoding
+      , get input, get output, get ipaddress, get time, get responsetime
+      ]
+
+values_v2 :: Record -> [SqlValue]
+values_v2 r =
+   let get f = toSql (f r)
+   in [ get service, get exerciseid, get source, get script, get requestinfo
+      , get dataformat, get encoding, get userid, get sessionid, get taskid
+      , get time, get responsetime, get ipaddress, get binary, get version
+      , get errormsg, get serviceinfo, get ruleid, get input, get output
+      ]
+
+logRecordWith :: IConnection c => Schema -> LogRef -> c -> IO ()
+logRecordWith schema logRef conn = do
+   -- calculate duration
+   r   <- getRecord logRef
+   end <- getCurrentTime
+   let diff = diffUTCTime end (time r)
+   -- insert data into database
+   insertRecord schema r {responsetime = diff} conn
+   -- close the connection to the database
+   disconnect conn
+ `catchSql` \err ->
+   putStrLn $ "Error in logging to database: " ++ show err
+
+insertRecord :: IConnection c => Schema -> Record -> c ->  IO ()
+insertRecord schema r conn =
+   let cols = columnsInTable schema r
+       pars = "(" ++ intercalate "," (replicate (length cols) "?") ++ ")"
+       stm  = "INSERT INTO " ++ nameOfTable schema ++ " VALUES " ++ pars
+   in run conn stm cols >> commit conn
+#endif

@@ -18,22 +18,22 @@ import Data.Char
 import Data.Maybe
 import Ideas.Common.Library hiding (exerciseId)
-import Ideas.Common.Utils (Some(..), timedSeconds)
 import Ideas.Encoding.DecoderJSON
-import Ideas.Encoding.Encoder (makeOptions)
 import Ideas.Encoding.EncoderJSON
 import Ideas.Encoding.Evaluator
-import Ideas.Main.Logging (LogRef, changeLog, errormsg)
+import Ideas.Encoding.Logging (LogRef, changeLog, errormsg)
+import Ideas.Encoding.Options (Options, makeOptions, maxTime, cgiBin)
+import Ideas.Encoding.Request
 import Ideas.Service.DomainReasoner
-import Ideas.Service.Request
 import Ideas.Text.JSON
+import Ideas.Utils.Prelude (timedSeconds)
 
-processJSON :: Maybe Int -> Maybe String -> DomainReasoner -> LogRef -> String -> IO (Request, String, String)
-processJSON maxTime cgiBin dr logRef input = do
-   json <- either fail return (parseJSON input)
-   req  <- jsonRequest cgiBin json
+processJSON :: Options -> DomainReasoner -> LogRef -> String -> IO (Request, String, String)
+processJSON options dr logRef txt = do
+   json <- either fail return (parseJSON txt)
+   req  <- jsonRequest options json
    resp <- jsonRPC json $ \fun arg ->
-              maybe id timedSeconds maxTime (myHandler dr logRef req fun arg)
+              maybe id timedSeconds (maxTime options) (myHandler options dr logRef req fun arg)
    unless (responseError resp == Null) $
       changeLog logRef (\r -> r {errormsg = show (responseError resp)})
    let f   = if compactOutput req then compactJSON else show
@@ -51,7 +51,7 @@       Array (hd:_) -> extractExerciseId hd
       _ -> fail "no code"
  where
-   p c = not (isAlphaNum c || isSpace c || c `elem` ".-")
+   p c = not (isAlphaNum c || isSpace c || c `elem` ".-_")
 
 addVersion :: String -> JSON -> JSON
 addVersion str json =
@@ -61,32 +61,32 @@  where
    info = ("version", String str)
 
-jsonRequest :: Monad m => Maybe String -> JSON -> m Request
-jsonRequest cgiBin json = do
+jsonRequest :: Monad m => Options -> JSON -> m Request
+jsonRequest options json = do
    let exId = lookupM "params" json >>= extractExerciseId
    srv  <- stringOption  "method"      json newId
    src  <- stringOption  "source"      json id
    rinf <- stringOption  "requestinfo" json id
-   seed <- stringOptionM "randomseed"  json (defaultSeed cgiBin) (return . readM)
+   seed <- stringOptionM "randomseed"  json (defaultSeed options) (return . readM)
    enc  <- stringOptionM "encoding"    json [] readEncoding
-   sch  <- stringOptionM "logging"     json Nothing (liftM Just . readSchema)
-   return emptyRequest
+   sch  <- stringOptionM "logging"     json Nothing (fmap Just . readSchema)
+   return mempty
       { serviceId   = srv
       , exerciseId  = exId
       , source      = src
-      , cgiBinary   = cgiBin
+      , cgiBinary   = cgiBin options
       , requestInfo = rinf
       , logSchema   = sch
       , randomSeed  = seed
-      , dataformat  = JSON
+      , dataformat  = Just JSON
       , encoding    = enc
       }
 
 -- Use a fixed seed for random number generation for command-line invocations
-defaultSeed :: Maybe String -> Maybe Int
-defaultSeed cgiBin
-   | isJust cgiBin = Nothing
-   | otherwise     = Just 2805 -- magic number
+defaultSeed :: Options -> Maybe Int
+defaultSeed options
+   | isJust (cgiBin options) = Nothing
+   | otherwise = Just 2805 -- magic number
 
 stringOption :: Monad m => String -> JSON -> (String -> a) -> m (Maybe a)
 stringOption attr json f = stringOptionM attr json Nothing (return . Just . f)
@@ -98,11 +98,15 @@       Just _  -> fail $ "Invalid value for " ++ attr ++ " (expecting string)"
       Nothing -> return a
 
-myHandler :: DomainReasoner -> LogRef -> Request -> RPCHandler
-myHandler dr logRef request fun json = do
+myHandler :: Options -> DomainReasoner -> LogRef -> Request -> RPCHandler
+myHandler opt1 dr logRef request fun json = do
    srv <- findService dr (newId fun)
-   Some options <- makeOptions dr request
-   evalService logRef options jsonEvaluator srv json
+   Some ex <- case exerciseId request of
+                 Just a  -> findExercise dr a
+                 Nothing -> return (Some emptyExercise)
+   opt2 <- makeOptions dr ex request
+   let options = opt1 <> opt2
+   evalService logRef ex options jsonEvaluator srv json
 
 jsonEvaluator :: Evaluator a JSON JSON
 jsonEvaluator = Evaluator jsonDecoder jsonEncoder

@@ -16,25 +16,25 @@ 
 import Control.Exception
 import Control.Monad
-import Ideas.Common.Library hiding (exerciseId, (:=))
-import Ideas.Common.Utils (Some(..), timedSeconds)
+import Ideas.Common.Library hiding (exerciseId)
 import Ideas.Encoding.DecoderXML
-import Ideas.Encoding.Encoder (makeOptions)
 import Ideas.Encoding.EncoderHTML
 import Ideas.Encoding.EncoderXML
 import Ideas.Encoding.Evaluator
-import Ideas.Main.Logging (LogRef, changeLog, errormsg)
+import Ideas.Encoding.Logging (LogRef, changeLog, errormsg)
+import Ideas.Encoding.Options (Options, makeOptions, maxTime, cgiBin)
+import Ideas.Encoding.Request
 import Ideas.Service.DomainReasoner
-import Ideas.Service.Request
 import Ideas.Text.HTML
 import Ideas.Text.XML
+import Ideas.Utils.Prelude (timedSeconds)
 import System.IO.Error
 
-processXML :: Maybe Int -> Maybe String -> DomainReasoner -> LogRef -> String -> IO (Request, String, String)
-processXML maxTime cgiBin dr logRef input = do
-   xml  <- either fail return (parseXML input)
-   req  <- xmlRequest cgiBin xml
-   resp <- maybe id timedSeconds maxTime (xmlReply dr logRef req xml)
+processXML :: Options -> DomainReasoner -> LogRef -> String -> IO (Request, String, String)
+processXML options dr logRef txt = do
+   xml  <- either fail return (parseXML txt)
+   req  <- xmlRequest (cgiBin options) xml
+   resp <- maybe id timedSeconds (maxTime options) (xmlReply options dr logRef req xml)
     `catch` handler
    let showXML | compactOutput req = compactXML
                | otherwise = show
@@ -52,23 +52,23 @@    in xml { attributes = attributes xml ++ info }
 
 xmlRequest :: Monad m => Maybe String -> XML -> m Request
-xmlRequest cgiBin xml = do
+xmlRequest ms xml = do
    unless (name xml == "request") $
       fail "expected xml tag request"
    enc  <- case findAttribute "encoding" xml of
               Just s  -> readEncoding s
               Nothing -> return []
-   return emptyRequest
+   return mempty
       { serviceId      = newId <$> findAttribute "service" xml
       , exerciseId     = extractExerciseId xml
       , source         = findAttribute "source" xml
-      , cgiBinary      = cgiBin
+      , cgiBinary      = ms
       , requestInfo    = findAttribute "requestinfo" xml
       , logSchema      = findAttribute "logging" xml >>= readSchema
       , feedbackScript = findAttribute "script" xml
-      , randomSeed     = defaultSeed cgiBin $
+      , randomSeed     = defaultSeed ms $
                             findAttribute "randomseed" xml >>= readM
-      , dataformat     = XML
+      , dataformat     = Just XML
       , encoding       = enc
       }
 
@@ -77,22 +77,27 @@ defaultSeed Nothing Nothing = Just 2805 -- magic number
 defaultSeed _ m = m
 
-xmlReply :: DomainReasoner -> LogRef -> Request -> XML -> IO XML
-xmlReply dr logRef request xml = do
+xmlReply :: Options -> DomainReasoner -> LogRef -> Request -> XML -> IO XML
+xmlReply opt1 dr logRef request xml = do
    srv <- case serviceId request of
              Just a  -> findService dr a
              Nothing -> fail "No service"
 
-   Some options <- makeOptions dr request
+   Some ex <- case exerciseId request of
+                 Just a  -> findExercise dr a
+                 Nothing -> return (Some emptyExercise)
 
+   opt2 <- makeOptions dr ex request
+   let options = opt1 <> opt2
+
    if htmlOutput request
       -- HTML evaluator
-      then liftM toXML $ evalService logRef options (htmlEvaluator dr) srv xml
+      then toXML <$> evalService logRef ex options (htmlEvaluator dr) srv xml
       -- xml evaluator
-      else liftM resultOk $ evalService logRef options xmlEvaluator srv xml
+      else resultOk <$> evalService logRef ex options xmlEvaluator srv xml
 
 extractExerciseId :: Monad m => XML -> m Id
-extractExerciseId = liftM newId . findAttribute "exerciseid"
+extractExerciseId = fmap newId . findAttribute "exerciseid"
 
 resultOk :: XMLBuilder -> XML
 resultOk body = makeXML "reply" $

@@ -21,10 +21,10 @@ import Data.Char
 import Data.List
 import Ideas.Common.Library
-import Ideas.Common.Utils.Uniplate
 import Ideas.Text.OpenMath.Dictionary.Arith1
 import Ideas.Text.OpenMath.Dictionary.Fns1
 import Ideas.Text.OpenMath.Object
+import Ideas.Utils.Uniplate
 import qualified Ideas.Text.OpenMath.Dictionary.List1 as OM
 import qualified Ideas.Text.OpenMath.Symbol as OM
 
@@ -72,8 +72,8 @@          OMI n  -> return (TNum n)
          OMF a  -> return (TFloat a)
          OMA xs -> case xs of
-                      OMS s:ys | s == OM.listSymbol -> liftM TList (mapM rec ys)
-                               | otherwise -> liftM (function (newSymbol s)) (mapM rec ys)
+                      OMS s:ys | s == OM.listSymbol -> TList <$> mapM rec ys
+                               | otherwise -> function (newSymbol s) <$> mapM rec ys
                       _ -> fail "Invalid OpenMath object"
          OMBIND binder xs body ->
             rec (OMA (binder:map OMV xs++[body]))

@@ -0,0 +1,73 @@+-----------------------------------------------------------------------------
+-- Copyright 2016, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Encoding.Options
+   ( Options, makeOptions, optionBaseUrl
+   , script, request, qcGen, baseUrl, maxTime
+   , cgiBin, optionCgiBin, optionHtml
+   ) where
+
+import Control.Applicative
+import Data.Monoid
+import Ideas.Common.Library (Exercise, getId)
+import Ideas.Encoding.Request
+import Ideas.Service.DomainReasoner
+import Ideas.Service.FeedbackScript.Parser (parseScriptSafe, Script)
+import Test.QuickCheck.Random
+
+-------------------------------------------------------------------
+-- Options
+
+cgiBin :: Options -> Maybe String
+cgiBin = cgiBinary . request
+
+optionCgiBin :: String -> Options
+optionCgiBin s = mempty {request = mempty {cgiBinary = Just s}}
+
+data Options = Options
+   { request  :: Request      -- meta-information about the request
+   , qcGen    :: Maybe QCGen  -- random number generator
+   , script   :: Script       -- feedback script
+   , baseUrl  :: Maybe String -- for html-encoder's css and image files
+   , maxTime  :: Maybe Int    -- timeout for services, in seconds
+   }
+
+instance Monoid Options where
+   mempty = Options mempty Nothing mempty Nothing Nothing
+   mappend x y = Options
+      { request  = request x <> request y
+      , qcGen    = make qcGen
+      , script   = script x <> script y
+      , baseUrl  = make baseUrl
+      , maxTime  = make maxTime
+      }
+    where
+      make f = f x <|> f y
+
+optionHtml :: Options
+optionHtml = mempty
+   { request = mempty {encoding = [EncHTML]} }
+
+optionBaseUrl :: String -> Options
+optionBaseUrl base = mempty {baseUrl = Just base}
+
+makeOptions :: DomainReasoner -> Exercise a -> Request -> IO Options
+makeOptions dr ex req = do
+   gen <- maybe newQCGen (return . mkQCGen) (randomSeed req)
+   scr <- case feedbackScript req of
+             Just s  -> parseScriptSafe s
+             Nothing -> defaultScript dr (getId ex)
+   return $ mempty
+      { request  = req
+      , qcGen    = Just gen
+      , script   = scr
+      }

@@ -0,0 +1,130 @@+-----------------------------------------------------------------------------
+-- Copyright 2016, Ideas project team. This file is distributed under the
+-- terms of the Apache License 2.0. For more information, see the files
+-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+
+module Ideas.Encoding.Request where
+
+import Control.Applicative
+import Data.Char
+import Data.List
+import Data.Maybe
+import Ideas.Common.Library hiding (exerciseId)
+import Ideas.Utils.Prelude
+
+data Request = Request
+   { serviceId      :: Maybe Id
+   , exerciseId     :: Maybe Id
+   , source         :: Maybe String
+   , feedbackScript :: Maybe String
+   , requestInfo    :: Maybe String
+   , cgiBinary      :: Maybe String
+   , logSchema      :: Maybe Schema
+   , randomSeed     :: Maybe Int
+   , dataformat     :: Maybe DataFormat -- default: XML
+   , encoding       :: [Encoding]
+   }
+
+instance Monoid Request where
+   mempty = Request Nothing Nothing Nothing Nothing
+                    Nothing Nothing Nothing Nothing Nothing []
+   mappend x y = Request
+      { serviceId      = make serviceId
+      , exerciseId     = make exerciseId
+      , source         = make source
+      , feedbackScript = make feedbackScript
+      , requestInfo    = make requestInfo
+      , cgiBinary      = make cgiBinary
+      , logSchema      = make logSchema
+      , randomSeed     = make randomSeed
+      , dataformat     = make dataformat
+      , encoding       = encoding x <> encoding y
+      }
+    where
+      make f = f x <|> f y
+
+data Schema = V1 | V2 | NoLogging deriving (Show, Eq)
+
+getSchema :: Request -> Schema
+getSchema = fromMaybe V1 . logSchema -- log schema V1 is the default
+
+readSchema :: Monad m => String -> m Schema
+readSchema s0
+   | s == "v1" = return V1
+   | s == "v2" = return V2
+   | s `elem` ["false", "no"] = return NoLogging
+   | otherwise = fail "Unknown schema"
+ where
+   s = map toLower (filter isAlphaNum s0)
+
+data DataFormat = XML | JSON
+   deriving Show -- needed for LoggingDatabase
+
+data Encoding = EncHTML      -- html page as output
+              | EncOpenMath  -- encode terms in OpenMath
+              | EncString    -- encode terms as strings
+              | EncCompact   -- compact ouput
+              | EncPretty    -- pretty output
+              | EncJSON      -- encode terms in JSON
+ deriving Eq
+
+instance Show Encoding where
+   showList xs rest = intercalate "+" (map show xs) ++ rest
+   show EncHTML     = "html"
+   show EncOpenMath = "openmath"
+   show EncString   = "string"
+   show EncCompact  = "compact"
+   show EncPretty   = "pretty"
+   show EncJSON     = "json"
+
+htmlOutput :: Request -> Bool
+htmlOutput = (EncHTML `elem`) . encoding
+
+compactOutput :: Request -> Bool
+compactOutput req =
+   case (EncCompact `elem` xs, EncPretty `elem` xs) of
+      (True, False) -> True
+      (False, True) -> False
+      _             -> isJust (cgiBinary req)
+ where
+   xs = encoding req
+
+useOpenMath :: Request -> Bool
+useOpenMath r =
+   case dataformat r of
+      Just JSON -> False
+      _ -> all (`notElem` encoding r) [EncString, EncHTML]
+
+useJSONTerm :: Request -> Bool
+useJSONTerm r =
+   case dataformat r of
+      Just JSON -> EncJSON `elem` encoding r
+      _ -> False
+
+useLogging :: Request -> Bool
+useLogging = (EncHTML `notElem`) . encoding
+
+discoverDataFormat :: Monad m => String -> m DataFormat
+discoverDataFormat xs =
+   case dropWhile isSpace xs of
+      '<':_ -> return XML
+      '{':_ -> return JSON
+      _     -> fail "Unknown data format"
+
+readEncoding :: Monad m => String -> m [Encoding]
+readEncoding = mapM (f . map toLower) . splitsWithElem '+'
+ where
+   f "html"     = return EncHTML
+   f "openmath" = return EncOpenMath
+   f "string"   = return EncString
+   f "compact"  = return EncCompact
+   f "pretty"   = return EncPretty
+   f "json"     = return EncJSON
+   f s          = fail $ "Invalid encoding: " ++ s

@@ -15,7 +15,6 @@ import Data.List
 import Data.Maybe
 import Ideas.Common.Library
-import Ideas.Common.Utils (Some(..))
 import Ideas.Text.HTML
 
 ruleToHTML :: Some Exercise -> Rule a -> HTMLBuilder

@@ -16,7 +16,6 @@ 
 import Data.Char
 import Ideas.Common.Library
-import Ideas.Common.Utils (Some(..))
 import Ideas.Encoding.OpenMathSupport (toOMOBJ)
 import Ideas.Text.OpenMath.FMP
 import Ideas.Text.OpenMath.Object

@@ -14,10 +14,10 @@ 
 module Ideas.Encoding.StrategyInfo (strategyToXML) where
 
-import Ideas.Common.CyclicTree
 import Ideas.Common.Id
 import Ideas.Common.Strategy.Abstract
 import Ideas.Common.Strategy.Configuration
+import Ideas.Common.Strategy.CyclicTree
 import Ideas.Common.Strategy.StrategyTree (StrategyTree)
 import Ideas.Text.XML
 

@@ -1,116 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2016, Ideas project team. This file is distributed under the
--- terms of the Apache License 2.0. For more information, see the files
--- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Ideas.Main.BlackBoxTests (blackBoxTests) where
-
-import Control.Monad
-import Data.Char
-import Data.List
-import Ideas.Common.Utils (snd3)
-import Ideas.Common.Utils.TestSuite
-import Ideas.Encoding.ModeJSON
-import Ideas.Encoding.ModeXML
-import Ideas.Main.Logging
-import Ideas.Service.DomainReasoner
-import Ideas.Service.Request
-import System.Directory
-import System.IO
-import qualified Data.Algorithm.Diff as Diff
-
--- Returns the number of tests performed
-blackBoxTests :: DomainReasoner -> String -> IO TestSuite
-blackBoxTests dr path = do
-   -- analyse content
-   xs0 <- getDirectoryContents path
-   let (xml,  xs1) = partition (".xml"  `isSuffixOf`) xs0
-       (json, xs2) = partition (".json" `isSuffixOf`) xs1
-       xs3         = map (path </>) (filter ((/= ".") . take 1) xs2)
-   -- recursively visit subdirectories
-   subs <- filterM doesDirectoryExist xs3
-   rest <- mapM (blackBoxTests dr) subs
-   return $ suite ("Directory " ++ simplerDirectory path) $
-      [ doBlackBoxTest dr JSON (path </> x)
-      | x <- json
-      ] ++
-      [ doBlackBoxTest dr XML (path </> x)
-      | x <- xml
-      ] ++
-      rest
-
-doBlackBoxTest :: DomainReasoner -> DataFormat -> FilePath -> TestSuite
-doBlackBoxTest dr format path =
-   assertMessageIO (stripDirectoryPart path) $ do
-      -- Comparing output with expected output
-      withFile path ReadMode $ \h1 -> do
-         hSetBinaryMode h1 True
-         txt <- hGetContents h1
-         out  <- case format of
-                    JSON -> liftM snd3 (processJSON Nothing Nothing dr noLogRef txt)
-                    XML  -> liftM snd3 (processXML  Nothing Nothing dr noLogRef txt)
-         withFile expPath ReadMode $ \h2 -> do
-            hSetBinaryMode h2 True
-            expt <- hGetContents h2
-            -- Force evaluation of the result, to make sure that
-            -- all file handles are closed afterwards.
-            let list1 = prepare expt
-                list2 = prepare out
-                msg   = unlines (path : diffs list1 list2)
-            if list1 == list2 then return mempty else do
-               force msg -- force evaluation of message before closing files
-               return (message msg)
- where
-   expPath = baseOf path ++ ".exp"
-   baseOf  = reverse . drop 1 . dropWhile (/= '.') . reverse
-
-force :: String -> IO ()
-force s | sum (map ord s) >= 0 = return ()
-        | otherwise = error "force"
-
-prepare :: String -> [String]
-prepare = filter (not . null) . lines . filter (/= '\r') . noVersion
- where
-   noVersion s | "version\": \"" `isPrefixOf` s =
-      "version\": \"X" ++ dropWhile (/='"') (drop 11 s)
-   noVersion s | "version=\"" `isPrefixOf` s =
-      "version=\"X" ++ dropWhile (/='"') (drop 9 s)
-   noVersion (x:xs) = x:noVersion xs
-   noVersion [] = []
-
-diffs :: [String] -> [String] -> [String]
-diffs xs ys = concatMap f $ Diff.getDiff xs ys
- where
-   f (Diff.First a)  = ["- " ++ a]
-   f (Diff.Second a) = ["+ " ++ a]
-   f _ = []
-
-simplerDirectory :: String -> String
-simplerDirectory s
-   | "../"   `isPrefixOf` s = simplerDirectory (drop 3 s)
-   | "test/" `isPrefixOf` s = simplerDirectory (drop 5 s)
-   | otherwise = s
-
-stripDirectoryPart :: String -> String
-stripDirectoryPart = reverse . takeWhile (/= '/') . reverse
-
-(</>) :: FilePath -> FilePath -> FilePath
-x </> y = x ++ "/" ++ y
-
-{-
-logicConfluence :: IO ()
-logicConfluence = reportTest "logic rules" (isConfluent f rs)
- where
-   f    = normalizeWith ops . normalFormWith ops rs
-   ops  = map makeCommutative Logic.logicOperators
-   rwrs = Logic.logicRules \\ [Logic.ruleOrOverAnd, Logic.ruleCommOr, Logic.ruleCommAnd]
-   rs   = [ r | RewriteRule r <- concatMap transformations rwrs ]
-   -- eqs  = bothWays [ r | RewriteRule r <- concatMap transformations Logic.logicRules ]
--}