packages feed

ideas 1.0 → 1.1

raw patch · 308 files changed

+16065/−30705 lines, 308 filesdep ~QuickChecknew-uploader

Dependency ranges changed: QuickCheck

Files

ideas.cabal view
@@ -1,5 +1,5 @@ name:                   ideas-version:                1.0+version:                1.1 synopsis:               Feedback services for intelligent tutoring systems homepage:               http://ideas.cs.uu.nl/www/ description:@@ -9,7 +9,7 @@   and Activemath.   category:               Education-copyright:              (c) 2011+copyright:              (c) 2013 license:                GPL license-file:           LICENSE.txt author:                 Bastiaan Heeren, Alex Gerdes, Johan Jeuring@@ -18,7 +18,7 @@ extra-source-files:     CREDITS.txt build-type:             Simple cabal-version:          >= 1.8.0.2-tested-with:            GHC == 6.10.1, GHC == 7.0.2+tested-with:            GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1  source-repository head   type:     svn@@ -26,222 +26,129 @@  -------------------------------------------------------------------------------- -Executable              ideas-  Main-is: Main.hs-  ghc-options: -Wall-  hs-source-dirs: src-  other-modules:-    Common.Algebra.Boolean-    Common.Algebra.CoBoolean-    Common.Algebra.CoField-    Common.Algebra.CoGroup-    Common.Algebra.Field-    Common.Algebra.Group-    Common.Algebra.Law-    Common.Algebra.SmartGroup-    Common.Classes-    Common.Context-    Common.Derivation-    Common.DerivationTree-    Common.Exercise-    Common.Id-    Common.Library-    Common.Navigator-    Common.Predicate-    Common.Rewriting-    Common.Rewriting.AC-    Common.Rewriting.Confluence-    Common.Rewriting.Difference-    Common.Rewriting.RewriteRule-    Common.Rewriting.Substitution-    Common.Rewriting.Term-    Common.Rewriting.Unification-    Common.Strategy-    Common.Strategy.Abstract-    Common.Strategy.Combinators-    Common.Strategy.Configuration-    Common.Strategy.Core-    Common.Strategy.Location-    Common.Strategy.Parsing-    Common.Strategy.Prefix-    Common.Strategy.Tests-    Common.Transformation-    Common.Utils-    Common.Utils.QuickCheck-    Common.Utils.StringRef-    Common.Utils.TestSuite-    Common.Utils.Uniplate-    Common.View-    Documentation.DefaultPage-    Documentation.ExampleFile-    Documentation.ExercisePage-    Documentation.Make-    Documentation.OpenMathDerivations-    Documentation.OverviewPages-    Documentation.RulePage-    Documentation.RulePresenter-    Documentation.SelfCheck-    Documentation.ServicePage-    Documentation.TestsPage-    Documentation.ViewPage-    Domain.LinearAlgebra-    Domain.LinearAlgebra.Checks-    Domain.LinearAlgebra.EquationsRules-    Domain.LinearAlgebra.Exercises-    Domain.LinearAlgebra.GramSchmidtRules-    Domain.LinearAlgebra.LinearSystem-    Domain.LinearAlgebra.LinearView-    Domain.LinearAlgebra.Matrix-    Domain.LinearAlgebra.MatrixRules-    Domain.LinearAlgebra.Parser-    Domain.LinearAlgebra.Strategies-    Domain.LinearAlgebra.Vector-    Domain.Logic-    Domain.Logic.BuggyRules-    Domain.Logic.Examples-    Domain.Logic.Exercises-    Domain.Logic.Formula-    Domain.Logic.GeneralizedRules-    Domain.Logic.Generator-    Domain.Logic.Parser-    Domain.Logic.Rules-    Domain.Logic.Strategies-    Domain.Logic.Views-    Domain.Math.Approximation-    Domain.Math.CleanUp-    Domain.Math.Data.DecimalFraction-    Domain.Math.Data.Interval-    Domain.Math.Data.MixedFraction-    Domain.Math.Data.OrList-    Domain.Math.Data.Polynomial-    Domain.Math.Data.PrimeFactors-    Domain.Math.Data.Relation-    Domain.Math.Data.SquareRoot-    Domain.Math.Data.WithBool-    Domain.Math.Derivative.Examples-    Domain.Math.Derivative.Exercises-    Domain.Math.Derivative.Rules-    Domain.Math.Derivative.Strategies-    Domain.Math.Equation.BalanceRules-    Domain.Math.Equation.CoverUpExercise-    Domain.Math.Equation.CoverUpRules-    Domain.Math.Equation.Examples-    Domain.Math.Equation.Views-    Domain.Math.ExerciseList-    Domain.Math.Expr-    Domain.Math.Expr.Clipboard-    Domain.Math.Expr.Data-    Domain.Math.Expr.Parser-    Domain.Math.Expr.Symbols-    Domain.Math.Expr.Views-    Domain.Math.Numeric.Exercises-    Domain.Math.Numeric.Generators-    Domain.Math.Numeric.Rules-    Domain.Math.Numeric.Strategies-    Domain.Math.Numeric.Tests-    Domain.Math.Numeric.Views-    Domain.Math.Polynomial.Balance-    Domain.Math.Polynomial.BalanceUtils-    Domain.Math.Polynomial.BuggyBalance-    Domain.Math.Polynomial.BuggyRules-    Domain.Math.Polynomial.Equivalence-    Domain.Math.Polynomial.Examples-    Domain.Math.Polynomial.Exercises-    Domain.Math.Polynomial.Generators-    Domain.Math.Polynomial.IneqExercises-    Domain.Math.Polynomial.LeastCommonMultiple-    Domain.Math.Polynomial.RationalExamples-    Domain.Math.Polynomial.RationalExercises-    Domain.Math.Polynomial.RationalRules-    Domain.Math.Polynomial.Rules-    Domain.Math.Polynomial.Strategies-    Domain.Math.Polynomial.Tests-    Domain.Math.Polynomial.Views-    Domain.Math.Power.Equation.Examples-    Domain.Math.Power.Equation.Exercises-    Domain.Math.Power.Equation.NormViews-    Domain.Math.Power.Equation.Rules-    Domain.Math.Power.Equation.Strategies-    Domain.Math.Power.Examples-    Domain.Math.Power.Exercises-    Domain.Math.Power.NormViews-    Domain.Math.Power.OldViews-    Domain.Math.Power.Rules-    Domain.Math.Power.Strategies-    Domain.Math.Power.Utils-    Domain.Math.Power.Views-    Domain.Math.Safe-    Domain.Math.Simplification-    Domain.Math.SquareRoot.Tests-    Domain.Math.SquareRoot.Views-    Domain.RelationAlgebra-    Domain.RelationAlgebra.Exercises-    Domain.RelationAlgebra.Formula-    Domain.RelationAlgebra.Generator-    Domain.RelationAlgebra.Parser-    Domain.RelationAlgebra.Rules-    Domain.RelationAlgebra.Strategies-    Main-    Main.IDEAS-    Main.LoggingDatabase-    Main.Options-    Main.Revision-    Service.BasicServices-    Service.Diagnose-    Service.DomainReasoner-    Service.Evaluator-    Service.FeedbackScript.Analysis-    Service.FeedbackScript.Parser-    Service.FeedbackScript.Run-    Service.FeedbackScript.Syntax-    Service.FeedbackText-    Service.ModeJSON-    Service.ModeXML-    Service.OpenMathSupport-    Service.ProblemDecomposition-    Service.Request-    Service.RulesInfo-    Service.ServiceList-    Service.State-    Service.StrategyInfo-    Service.Submit-    Service.TypedExample-    Service.Types-    Text.HTML-    Text.JSON-    Text.OpenMath.Dictionary.Arith1-    Text.OpenMath.Dictionary.Calculus1-    Text.OpenMath.Dictionary.Fns1-    Text.OpenMath.Dictionary.Linalg2-    Text.OpenMath.Dictionary.List1-    Text.OpenMath.Dictionary.Logic1-    Text.OpenMath.Dictionary.Nums1-    Text.OpenMath.Dictionary.Quant1-    Text.OpenMath.Dictionary.Relation1-    Text.OpenMath.Dictionary.Transc1-    Text.OpenMath.FMP-    Text.OpenMath.MakeSymbols-    Text.OpenMath.Object-    Text.OpenMath.Symbol-    Text.OpenMath.Tests-    Text.Parsing-    Text.UTF8-    Text.XML-    Text.XML.Document-    Text.XML.Interface-    Text.XML.Parser-    Text.XML.Unicode-  build-depends:        base >= 4.2 && < 5,-                        directory,-                        time,-                        mtl,-                        cgi,-                        containers,-                        QuickCheck >= 2.4.1,-                        random,-                        filepath,-                        parsec,-                        uniplate+Library+  ghc-options:       -Wall+  hs-source-dirs:    src+  Build-Depends:     base >= 4.2 && < 5, +                     QuickCheck >= 2.4.1, +                     containers, +                     random, +                     mtl, +                     uniplate, +                     time, +                     filepath, +                     directory, +                     cgi, +                     parsec++  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.Derivation+   Ideas.Common.DerivationTree+   Ideas.Common.Environment+   Ideas.Common.Exercise+   Ideas.Common.Id+   Ideas.Common.Library+   Ideas.Common.Predicate+   Ideas.Common.Rewriting+   Ideas.Common.Rewriting.AC+   Ideas.Common.Rewriting.Confluence+   Ideas.Common.Rewriting.Difference+   Ideas.Common.Rewriting.RewriteRule+   Ideas.Common.Rewriting.Substitution+   Ideas.Common.Rewriting.Term+   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+   Ideas.Common.Strategy+   Ideas.Common.Strategy.Abstract+   Ideas.Common.Strategy.Combinators+   Ideas.Common.Strategy.Configuration+   Ideas.Common.Strategy.Core+   Ideas.Common.Strategy.Location+   Ideas.Common.Strategy.Parsing+   Ideas.Common.Strategy.Prefix+   Ideas.Common.Strategy.Tests+   Ideas.Common.Strategy.Traversal+   Ideas.Common.Traversal.Iterator+   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+   Ideas.Encoding.EncoderHTML+   Ideas.Encoding.EncoderJSON+   Ideas.Encoding.EncoderXML+   Ideas.Encoding.Evaluator+   Ideas.Encoding.LinkManager+   Ideas.Encoding.ModeJSON+   Ideas.Encoding.ModeXML+   Ideas.Encoding.OpenMathSupport+   Ideas.Encoding.RulePresenter+   Ideas.Encoding.RulesInfo+   Ideas.Encoding.StrategyInfo+   Ideas.Main.BlackBoxTests+   Ideas.Main.Default+   Ideas.Main.Documentation+   Ideas.Main.LoggingDatabase+   Ideas.Main.Options+   Ideas.Main.Revision+   Ideas.Service.BasicServices+   Ideas.Service.Diagnose+   Ideas.Service.DomainReasoner+   Ideas.Service.FeedbackScript.Analysis+   Ideas.Service.FeedbackScript.Parser+   Ideas.Service.FeedbackScript.Run+   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.OpenMath.Dictionary.Arith1+   Ideas.Text.OpenMath.Dictionary.Calculus1+   Ideas.Text.OpenMath.Dictionary.Fns1+   Ideas.Text.OpenMath.Dictionary.Linalg2+   Ideas.Text.OpenMath.Dictionary.List1+   Ideas.Text.OpenMath.Dictionary.Logic1+   Ideas.Text.OpenMath.Dictionary.Nums1+   Ideas.Text.OpenMath.Dictionary.Quant1+   Ideas.Text.OpenMath.Dictionary.Relation1+   Ideas.Text.OpenMath.Dictionary.Transc1+   Ideas.Text.OpenMath.FMP+   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  --------------------------------------------------------------------------------
− src/Common/Algebra/Boolean.hs 
@@ -1,203 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Algebra.Boolean
-   ( -- * Boolean algebra
-     BoolValue(..), Boolean(..)
-   , ands, ors, implies, equivalent
-   , andOverOrLaws, orOverAndLaws
-   , complementAndLaws, complementOrLaws
-   , absorptionAndLaws, absorptionOrLaws
-   , deMorganAnd, deMorganOr
-   , doubleComplement, complementTrue, complementFalse
-   , booleanLaws
-     -- * Dual monoid
-   , DualMonoid(..)
-     -- * And monoid
-   , And(..), fromAndLaw
-     -- * Or monoid
-   , Or(..), fromOrLaw
-     -- * Properties
-   , propsBoolean
-   ) where
-
-import Common.Algebra.Group
-import Common.Algebra.Law
-import Control.Applicative
-import Test.QuickCheck hiding ((><))
-
---------------------------------------------------------
--- 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 Boolean Bool where
-   (<&&>)     = (&&)
-   (<||>)     = (||)
-   complement = not
-
-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)
-
-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 monoid for a monoid (and for or, and vice versa)
-
-class MonoidZero a => DualMonoid a where
-   (><)      :: a -> a -> a
-   dualCompl :: a -> a
-
-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 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
-
-fromAndLaw :: Law (And a) -> Law a
-fromAndLaw = mapLaw And fromAnd
-
---------------------------------------------------------
--- 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
-
-fromOrLaw :: Law (Or a) -> Law a
-fromOrLaw = mapLaw Or fromOr
-
---------------------------------------------------------
--- Tests for Bool instance
-
-propsBoolean :: [Property]
-propsBoolean = map property (booleanLaws :: [Law Bool])
− src/Common/Algebra/CoBoolean.hs 
@@ -1,70 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Algebra.CoBoolean
-   ( CoBoolean(..)
-   , conjunctions, disjunctions
-   , (.||.), (.&&.)
-   ) where
-
-import Common.Algebra.Boolean
-import Common.Algebra.CoGroup
-import Common.Algebra.Group
-import Common.Algebra.SmartGroup
-import Control.Arrow
-import Data.Maybe
-
-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 (And *** 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 (Or *** 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
-
-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
− src/Common/Algebra/CoField.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Algebra.CoField
-   ( CoSemiRing(..), CoRing(..), CoField(..)
-   , SmartField(..)
-   , (.+.), (.-.), neg, (.*.), (./.)
-   ) where
-
-import Common.Algebra.CoGroup
-import Common.Algebra.Field
-import Common.Algebra.Group
-import Common.Algebra.SmartGroup
-import Control.Arrow ((***))
-import Control.Monad
-import qualified Control.Applicative as 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 (Additive *** Additive) . isPlus . fromAdditive
-
-instance CoRing a => CoGroup (Additive a) where
-   isInverse   = fmap Additive . isNegate . fromAdditive
-   isAppendInv = fmap (Additive *** Additive) . isMinus . fromAdditive
-
-instance CoSemiRing a => CoMonoid (Multiplicative a) where
-   isEmpty  = isOne . fromMultiplicative
-   isAppend = fmap (Multiplicative *** Multiplicative) . isTimes . fromMultiplicative
-
-instance CoField a => CoGroup (Multiplicative a) where
-   isInverse   = fmap Multiplicative . isRecip . fromMultiplicative
-   isAppendInv = fmap (Multiplicative *** Multiplicative) . isDivision . fromMultiplicative
-
-instance CoSemiRing a => CoMonoidZero (Multiplicative a) where
-   isMonoidZero = isZero . fromMultiplicative
-
-------------------------------------------------------------------
-
-newtype SmartField a = SmartField {fromSmartField :: a}
-   deriving (CoSemiRing, CoRing, CoField)
-
-instance Functor SmartField where -- could be derived
-   fmap f = SmartField . f . fromSmartField
-
-instance A.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 = A.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 = A.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 = A.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
− src/Common/Algebra/CoGroup.hs 
@@ -1,148 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Algebra.CoGroup
-   ( CoMonoid(..), CoGroup(..), CoMonoidZero(..)
-   , associativeList
-   ) where
-
-import Common.Algebra.Group
-import Common.Classes
-import Control.Applicative
-import Control.Arrow
-import Data.Maybe
-import qualified Data.Set as S
---import qualified Data.Map as M
---import qualified Data.Sequence as Q
-
-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 (first 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 (pure *** pure) . isAppend
-
-instance CoMonoid a => CoMonoidZero (WithZero a) where
-   isMonoidZero = isNothing . fromWithZero
− src/Common/Algebra/Field.hs 
@@ -1,243 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Algebra.Field
-   ( -- * Semi-ring
-     SemiRing(..), leftDistributive, rightDistributive
-   , distributiveLaws, semiRingLaws
-     -- * Ring
-   , Ring(..), leftNegateTimes, rightNegateTimes
-   , negateTimesLaws, ringLaws, commutativeRingLaws
-   , distributiveSubtractionLaws
-     -- * Field
-   , Field(..), exchangeInverses, fieldLaws
-     -- * Additive monoid
-   , Additive(..), fromAdditiveLaw
-     -- * Multiplicative monoid
-   , Multiplicative(..), fromMultiplicativeLaw
-     -- * Datatype for safe numeric operators
-   , SafeNum, safeNum
-   , propsField
-   ) where
-
-import Common.Algebra.Group
-import Common.Algebra.Law
-import Control.Monad
-import Test.QuickCheck
-import qualified Control.Applicative as A
-
---------------------------------------------------------
--- Semi-ring
-
-infixl 6 <+>
-infixl 7 <*>
-
-class SemiRing a where
-   -- additive
-   (<+>) :: a -> a -> a
-   zero  :: a
-   -- multiplicative
-   (<*>) :: a -> a -> a
-   one   :: a
-
-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
-
-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
-
-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
-
-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
-
-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]
-
---------------------------------------------------------
--- 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 (<->)
-
-fromAdditiveLaw :: Law (Additive a) -> Law a
-fromAdditiveLaw = mapLaw Additive fromAdditive
-
---------------------------------------------------------
--- 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
-
-fromMultiplicativeLaw :: Law (Multiplicative a) -> Law a
-fromMultiplicativeLaw = mapLaw Multiplicative fromMultiplicative
-
---------------------------------------------------------
--- 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 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 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 Fractional a => Field (SafeNum a) where
-   timesInverse = recip
-   (</>)        = (/)
-
-safeDivisor :: Num a => SafeNum a -> SafeNum a
-safeDivisor m = m >>= \a ->
-   if a == 0 then fail "division by zero" else return a
-
-propsField :: [Property]
-propsField = map property (fieldLaws :: [Law (SafeNum Rational)])
− src/Common/Algebra/Group.hs 
@@ -1,186 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Algebra.Group
-   ( -- * Monoids
-     module Data.Monoid, (<>), associative, leftIdentity
-   , rightIdentity, identityLaws, monoidLaws, commutativeMonoidLaws
-   , idempotent
-     -- * Groups
-   , Group(..), (<>-), leftInverse, rightInverse, doubleInverse
-   , inverseIdentity, inverseDistrFlipped, inverseLaws, groupLaws
-   , appendInverseLaws
-     -- * Abelian groups
-   , commutative, inverseDistr, abelianGroupLaws
-     -- * Monoids with a zero element
-   , MonoidZero(..), leftZero, rightZero, zeroLaws, monoidZeroLaws
-   , WithZero, fromWithZero
-     -- * Generalized laws
-   , associativeFor, commutativeFor, idempotentFor
-   , leftDistributiveFor, rightDistributiveFor
-   ) where
-
-import Common.Algebra.Law
-import Control.Applicative (Applicative)
-import Control.Monad (liftM2)
-import Data.Foldable (Foldable)
-import Data.Monoid
-import Data.Traversable (Traversable)
-
---------------------------------------------------------
--- Monoids
-
-infixl 6 <>
-
-(<>) :: Monoid a => a -> a -> a
-(<>) = mappend
-
-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
-
--- | 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
-
-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
-
-class Monoid a => MonoidZero a where
-   mzero :: a
-
-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
-
--- Type that adds a zero element
-newtype WithZero a = WZ { fromWithZero :: Maybe a }
-   deriving (Eq, Ord, Functor, Foldable, Traversable, 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
-
---------------------------------------------------------
--- 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)
− src/Common/Algebra/Law.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Algebra.Law
-   ( Law, LawSpec((:==:)), law, mapLaw
-   , propertyLaw, rewriteLaw
-   ) where
-
-import 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 = Abs (a -> LawSpec a) | a :==: a
-
-law :: LawBuilder l a => String -> l -> Law a
-law s l = Law s (lawSpec l)
-
-class LawBuilder l a | l -> a where
-   lawSpec :: l -> LawSpec a
-
-instance LawBuilder (LawSpec a) a where
-   lawSpec = id
-
-instance LawBuilder b a => LawBuilder (a -> b) a where
-   lawSpec f = Abs (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 (Abs f)    = Abs (rec . f . to)
-   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 (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) = rewriteRule 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 (Abs f)    = buildRuleSpec i f
-   buildGenerator (a :==: b)  = buildGenerator (a :~> b)
-   buildGenerator (Abs f)     = buildGenerator f
-
-getLawSpec :: Law a -> LawSpec a
-getLawSpec (Law _ l) = l
− src/Common/Algebra/SmartGroup.hs 
@@ -1,95 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Algebra.SmartGroup where
-
-import Common.Algebra.CoGroup
-import Common.Algebra.Group
-import Control.Applicative
-import Control.Monad (mplus)
-import Data.Maybe
-
-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)
− src/Common/Classes.hs 
@@ -1,108 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Type classes and instances.
---
------------------------------------------------------------------------------
-module Common.Classes
-   ( -- * Type class Apply
-     Apply, apply, applyAll, applicable, applyD, applyM
-     -- * Type class Container
-   , Container, singleton, getSingleton
-     -- * Type class BiArrow
-   , BiArrow(..)
-     -- * Type class BiFunctor
-   , BiFunctor, biMap, mapFirst, mapSecond, mapBoth
-   ) where
-
-import Common.Utils (safeHead)
-import Control.Arrow
-import Data.Maybe
-
-import qualified Data.Set as S
-
------------------------------------------------------------
--- Type class Apply
-
--- | A type class for functors that can be applied to a value. Transformation,
--- Rule, and Strategy are all instances of this type class.
-class Apply t where
-   applyAll :: t a -> a -> [a]  -- ^ Returns zero or more results
-
--- | Returns zero or one results
-apply :: Apply t => t a -> a -> Maybe a
-apply ta = safeHead . applyAll ta
-
--- | Checks whether the functor is applicable (at least one result)
-applicable :: Apply t => t a -> a -> Bool
-applicable ta = isJust . apply ta
-
--- | If not applicable, return the current value (as default)
-applyD :: Apply t => t a -> a -> a
-applyD ta a = fromMaybe a (apply ta a)
-
--- | Same as apply, except that the result (at most one) is returned in some monad
-applyM :: (Apply t, Monad m) => t a -> a -> m a
-applyM ta = maybe (fail "applyM") return . apply ta
-
------------------------------------------------------------
--- Type class Container
-
--- | Instances should satisfy the following law: @getSingleton . singleton == Just@
-class Container f where
-   singleton    :: a   -> f a
-   getSingleton :: f a -> Maybe a
-
-instance Container [] where
-   singleton        = return
-   getSingleton [a] = Just a
-   getSingleton _   = Nothing
-
-instance Container S.Set where
-   singleton    = S.singleton
-   getSingleton = getSingleton . S.toList
-
------------------------------------------------------------
--- Type class BiArrow
-
-infix 1 <->
-
--- |Type class for bi-directional arrows. @<->@ should be used instead of
--- @arr@ from the arrow interface. Minimal complete definition: @<->@.
-class Arrow arr => BiArrow arr where
-   (<->) :: (a -> b) -> (b -> a) -> arr a b
-   (!->) :: (a -> b) -> arr a b
-   (<-!) :: (b -> a) -> arr a b
-   -- default definitions
-   (!->) f = f <-> errBiArrow
-   (<-!) f = errBiArrow <-> f
-
-errBiArrow :: a
-errBiArrow = error "BiArrow: not bi-directional"
-
------------------------------------------------------------
--- Type class BiFunctor
-
-class BiFunctor f where
-   biMap     :: (a -> c) -> (b -> d) -> f a b -> f c d
-   mapFirst  :: (a -> b) -> f a c -> f b c
-   mapSecond :: (b -> c) -> f a b -> f a c
-   -- default definitions
-   mapFirst  = flip biMap id
-   mapSecond = biMap id
-
-instance BiFunctor Either where
-   biMap f g = either (Left . f) (Right . g)
-
-instance BiFunctor (,) where
-  biMap f g (a, b) = (f a, g b)
-
-mapBoth :: BiFunctor f => (a -> b) -> f a a -> f b b
-mapBoth f = biMap f f
− src/Common/Context.hs 
@@ -1,261 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A context for a term that maintains an environment of
--- key-value pairs. A context is both showable and parsable.
---
------------------------------------------------------------------------------
-module Common.Context
-   ( -- * Abstract data type
-     Context, fromContext, fromContextWith, fromContextWith2
-   , newContext, getEnvironment, modifyEnvironment
-     -- * Key-value pair environment (abstract)
-   , Environment, emptyEnv, nullEnv, keysEnv, lookupEnv, storeEnv
-   , diffEnv, deleteEnv
-     -- * Variables
-   , Var, newVar, makeVar
-     -- * Lifting
-   , liftToContext, liftTransContext
-   , use, useC, termNavigator, applyTop
-     -- * Context Monad
-   , ContextMonad, readVar, writeVar, modifyVar
-   , maybeCM, withCM, evalCM
-   ) where
-
-import Common.Id
-import Common.Navigator
-import Common.Rewriting
-import Common.Transformation
-import Common.Utils (commaList, readM)
-import Common.View
-import Control.Monad
-import Data.Dynamic
-import Data.Maybe
-import qualified Data.Map as M
-
-----------------------------------------------------------
--- Abstract data type
-
--- | Abstract data type for a context: a context stores an envrionent
--- (key-value pairs) and a value
-data Context a = C
-   { getEnvironment :: Environment -- ^ Returns the environment
-   , getNavigator   :: Navigator a -- ^ Retrieve a value from its context
-   }
-
-fromContext :: Monad m => Context a -> m a
-fromContext = leave . getNavigator
-
-fromContextWith :: Monad m => (a -> b) -> Context a -> m b
-fromContextWith f = liftM f . fromContext
-
-fromContextWith2 :: Monad m => (a -> b -> c) -> Context a -> Context b -> m c
-fromContextWith2 f a b = liftM2 f (fromContext a) (fromContext b)
-
-instance Eq a => Eq (Context a) where
-   x == y = fromMaybe False $ liftM2 (==) (fromContext x) (fromContext y)
-
-instance Show a => Show (Context a) where
-   show (C env a) =
-      let rest | null (keysEnv env) = ""
-               | otherwise = "  {" ++ show env ++ "}"
-      in show a ++ rest
-
-instance IsNavigator Context where
-   up        (C env a) = liftM (C env) (up a)
-   allDowns  (C env a) = map (C env) (allDowns a)
-   current   (C _   a) = current a
-   location  (C _   a) = location a
-   changeM f (C env a) = liftM (C env) (changeM f a)
-
-instance TypedNavigator Context where
-   changeT f (C env a) = liftM (C env) (changeT f a)
-   currentT  (C _   a) = currentT a
-   leaveT    (C _   a) = leaveT a
-   castT v   (C env a) = liftM (C env) (castT v a)
-
--- | Construct a context
-newContext :: Environment -> Navigator a -> Context a
-newContext = C
-
-modifyEnvironment :: (Environment -> Environment) -> Context a -> Context a
-modifyEnvironment f c = c {getEnvironment = f (getEnvironment c)}
-
-----------------------------------------------------------
--- Key-value pair environment (abstract)
-
-newtype Environment = Env { envMap :: M.Map String (Maybe Dynamic, String) }
-
-instance Show Environment where
-   show =
-      let f (k, (_, v)) = k ++ "=" ++ v
-      in commaList . map f . M.toList . envMap
-
-emptyEnv :: Environment
-emptyEnv = Env M.empty
-
-nullEnv :: Environment -> Bool
-nullEnv = null . keysEnv
-
-keysEnv :: Environment -> [String]
-keysEnv = M.keys . envMap
-
-lookupEnv :: Typeable a => String -> Environment -> Maybe a
-lookupEnv s (Env m) = result
- where
-   result -- Special case for result type String
-    | typeOf result == typeOf (Just "") = do
-         (_, txt) <- M.lookup s m
-         cast txt
-    | otherwise = do
-         (md, _) <- M.lookup s m
-         d <- md
-         fromDynamic d
-
-storeEnv :: (Typeable a, Show a) => String -> a -> Environment -> Environment
-storeEnv = storeEnvWith show
-
--- Generalized helper-function
-storeEnvWith :: Typeable a => (a -> String) -> String -> a -> Environment -> Environment
-storeEnvWith f s a (Env m) = Env (M.insert s pair m)
- where -- Special case for type String
-   pair =
-      case cast a of
-         Just txt -> (Nothing, txt)
-         Nothing  -> (Just (toDyn a), f a)
-
-diffEnv :: Environment -> Environment -> Environment
-diffEnv (Env m1) (Env m2) = Env (M.filterWithKey p m1)
- where p k (_, s) = maybe True ((/=s) . snd) (M.lookup k m2)
-
-deleteEnv :: String -> Environment -> Environment
-deleteEnv s (Env m) = Env (M.delete s m)
-
-----------------------------------------------------------
--- Variables
-
--- | A variable has a name and a default value (for initializing). Each
--- stored value must be readable and showable.
-data Var a = V
-   { varName    :: String
-   , varInitial :: a
-   , varShow    :: a -> String
-   , varRead    :: String -> Maybe a
-   }
-
--- | Simple constructor function for creating a variable. Uses the
--- Show and Read type classes
-newVar :: (Show a, Read a) => String -> a -> Var a
-newVar = makeVar show readM
-
--- | Extended constructor function for creating a variable. The show
--- and read functions are supplied explicitly.
-makeVar :: (a -> String) -> (String -> Maybe a) -> String -> a -> Var a
-makeVar showF readF s a = V s a showF readF
-
-----------------------------------------------------------
--- Lifting rewrite rules
-
--- | Lift a rule to operate on a term in a context
-liftToContext :: Rule a -> Rule (Context a)
-liftToContext = liftRuleIn contextView
-
-liftTransContext :: Transformation a -> Transformation (Context a)
-liftTransContext = liftTransIn contextView
-
--- | Apply a function at top-level. Afterwards, try to return the focus
--- to the old position
-applyTop :: (a -> a) -> Context a -> Context a
-applyTop f c =
-   case top c of
-      Just ok -> navigateTowards (location c) (change f ok)
-      Nothing -> c
-
-termNavigator :: IsTerm a => a -> Navigator a
-termNavigator a = fromMaybe (noNavigator a) (make a)
- where
-   make = castT termView . viewNavigatorWith spineHoles . toTerm
-
-   spineHoles :: Term -> [(Term, Term -> Term)]
-   spineHoles term
-      | null xs   = []
-      | otherwise = (x, flip makeTerm xs) : zipWith f [0..] xs
-    where
-      (x, xs)    = getSpine term
-      f i y      = (y, makeTerm x . changeAt i)
-      changeAt i b =
-         case splitAt i xs of
-            (ys, _:zs) -> ys ++ b:zs
-            _          -> xs
-
-use :: (IsTerm a, IsTerm b) => Rule a -> Rule (Context b)
-use = useC . liftToContext
-
-useC :: (IsTerm a, IsTerm b) => Rule (Context a) -> Rule (Context b)
-useC = liftRule (makeView (castT termView) (fromJust . castT termView))
-
-contextView :: View (Context a) (a, Context a)
-contextView = "views.contextView" @> makeView f g
- where
-   f ctx = current ctx >>= \a -> Just (a, ctx)
-   g = uncurry replace
-
-----------------------------------------------------------
--- Context monad
-
-newtype ContextMonad a = CM { unCM :: Environment -> Maybe (a, Environment) }
-
-withCM :: (a -> ContextMonad a) -> Context a -> Maybe (Context a)
-withCM f c = do
-   a0       <- current c
-   (a, env) <- unCM (f a0) (getEnvironment c)
-   let nav = replace a (getNavigator c)
-   return (newContext env nav)
-
-evalCM :: (a -> ContextMonad b) -> Context a -> Maybe b
-evalCM f c = do
-   a0     <- current c
-   (b, _) <- unCM (f a0) (getEnvironment c)
-   return b
-
-instance Functor ContextMonad where
-   fmap = liftM
-
-instance Monad ContextMonad where
-   fail       = const mzero
-   return a   = CM (\env -> return (a, env))
-   CM m >>= f = CM (\env -> do (a, e) <- m env
-                               let CM g = f a
-                               g e)
-
-instance MonadPlus ContextMonad where
-   mzero = CM (const mzero)
-   mplus (CM f) (CM g) = CM (\env -> f env `mplus` g env)
-
-readVar :: Typeable a => Var a -> ContextMonad a
-readVar var = CM $ \env -> return $
-   let name = varName var
-       txt  = fromMaybe "" $ lookupEnv name env
-   in case (lookupEnv name env, varRead var txt) of
-         (Just a, _) -> (a, env)
-         (_, Just a) -> (a, storeEnvWith (varShow var) name a env)
-         _           -> (varInitial var, env)
-
-writeVar  :: Typeable a => Var a -> a -> ContextMonad ()
-writeVar var a =
-   let f = storeEnvWith (varShow var) (varName var) a
-   in CM $ \env -> return ((), f env)
-
-modifyVar :: Typeable a => Var a -> (a -> a) -> ContextMonad ()
-modifyVar var f = readVar var >>= (writeVar var  . f)
-
-maybeCM :: Maybe a -> ContextMonad a
-maybeCM = maybe mzero return
− src/Common/Derivation.hs 
@@ -1,105 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Datatype for representing a derivation (parameterized both in the terms
--- and the steps)
---
------------------------------------------------------------------------------
-module Common.Derivation
-   ( -- * Data type
-     Derivation
-     -- * Constructing a derivation
-   , emptyDerivation, prepend, extend
-     -- * Querying a derivation
-   , isEmpty, derivationLength, terms, steps, triples
-   , firstTerm, lastTerm, lastStep, withoutLast
-   , updateSteps, derivationM
-   ) where
-
-import Common.Classes
-import Common.Utils (safeHead)
-import qualified Data.Foldable as F
-import qualified Data.Sequence as S
-
------------------------------------------------------------------------------
--- Data type definition and instances
-
-data Derivation s a = D a (S.Seq (s, a))
-
-instance (Show s, Show a) => Show (Derivation s a) where
-   show (D a xs) = unlines $
-      show a : concatMap (\(r, b) -> ["   => " ++ show r, show b]) (F.toList xs)
-
-instance Functor (Derivation s) where
-   fmap = mapSecond
-
-instance BiFunctor Derivation where
-   biMap f g (D a xs) = D (g a) (fmap (biMap f g) xs)
-
------------------------------------------------------------------------------
--- Constructing a derivation
-
-emptyDerivation :: a -> Derivation s a
-emptyDerivation a = D a S.empty
-
-prepend :: (a, s) -> Derivation s a -> Derivation s a
-prepend (a, s) (D b xs) = D a ((s, b) S.<| xs)
-
-extend :: Derivation s a -> (s, a) -> Derivation s a
-extend (D a xs) p = D a (xs S.|> p)
-
------------------------------------------------------------------------------
--- Querying a derivation
-
--- | Tests whether the derivation is empty
-isEmpty :: Derivation s a -> Bool
-isEmpty (D _ xs) = S.null xs
-
--- | Returns the number of steps in a derivation
-derivationLength :: Derivation s a -> Int
-derivationLength (D _ xs) = S.length xs
-
--- | All terms in a derivation
-terms :: Derivation s a -> [a]
-terms (D a xs) = a:map snd (F.toList xs)
-
--- | All steps in a derivation
-steps :: Derivation s a -> [s]
-steps (D _ xs) = map fst (F.toList xs)
-
--- | The triples of a derivation, consisting of the before term, the
--- step, and the after term.
-triples :: Derivation s a -> [(a, s, a)]
-triples d = zip3 (terms d) (steps d) (tail (terms d))
-
-firstTerm :: Derivation s a -> a
-firstTerm = head . terms
-
-lastTerm :: Derivation s a -> a
-lastTerm = last . terms
-
-lastStep:: Derivation s a -> Maybe s
-lastStep = safeHead . reverse . steps
-
-withoutLast :: Derivation s a -> Derivation s a
-withoutLast d@(D a xs) =
-   case S.viewr xs of
-      S.EmptyR  -> d
-      ys S.:> _ -> D a ys
-
-updateSteps :: (a -> s -> a -> t) -> Derivation s a -> Derivation t a
-updateSteps f d =
-   let ts   = [ f a b c | (a, b, c) <- triples d ]
-       x:xs = terms d
-   in D x (S.fromList (zip ts xs))
-
--- | Apply a monadic function to each term, and to each step
-derivationM :: Monad m => (s -> m ()) -> (a -> m ()) -> Derivation s a -> m ()
-derivationM f g (D a xs) = g a >> mapM_ (\(s, b) -> f s >> g b) (F.toList xs)
− src/Common/DerivationTree.hs 
@@ -1,188 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Datatype for representing derivations as a tree. The datatype stores all
--- intermediate results as well as annotations for the steps.
---
------------------------------------------------------------------------------
-module Common.DerivationTree
-   ( -- * Data types
-     DerivationTree
-     -- * Constructors
-   , singleNode, addBranches, makeTree
-     -- * Query
-   , root, endpoint, branches, subtrees
-   , leafs, lengthMax
-     -- * Adapters
-   , restrictHeight, restrictWidth, updateAnnotations
-   , cutOnStep, mergeMaybeSteps, sortTree
-     -- * Conversions
-   , derivation, randomDerivation, derivations
-   ) where
-
-import Common.Classes
-import Common.Derivation
-import Common.Utils (safeHead)
-import Control.Monad
-import Data.List
-import Data.Maybe
-import System.Random
-
------------------------------------------------------------------------------
--- Data type definitions for derivation trees and derivation lists
-
-data DerivationTree s a = DT
-   { root     :: a                           -- ^ The root of the tree
-   , endpoint :: Bool                        -- ^ Is this node an endpoint?
-   , branches :: [(s, DerivationTree s a)]   -- ^ All branches
-   }
- deriving Show
-
-instance Functor (DerivationTree s) where
-   fmap = mapSecond
-
-instance BiFunctor DerivationTree where
-   biMap f g (DT a b xs) = DT (g a) b (map (biMap f (biMap f g)) xs)
-
------------------------------------------------------------------------------
--- Constructors for a derivation tree
-
--- | Constructs a node without branches; the boolean indicates whether the
--- node is an endpoint or not
-singleNode :: a -> Bool -> DerivationTree s a
-singleNode a b = DT a b []
-
--- | Branches are attached after the existing ones (order matters)
-addBranches :: [(s, DerivationTree s a)] -> DerivationTree s a -> DerivationTree s a
-addBranches new (DT a b xs) = DT a b (xs ++ new)
-
-makeTree :: (a -> (Bool, [(s, a)])) -> a -> DerivationTree s a
-makeTree f = rec
- where
-   rec a = let (b, xs) = f a
-           in addBranches (map (mapSecond rec) xs) (singleNode a b)
-
------------------------------------------------------------------------------
--- Inspecting a derivation tree
-
--- | Returns the annotations at a given node
-annotations :: DerivationTree s a -> [s]
-annotations = map fst . branches
-
--- | Returns all subtrees at a given node
-subtrees :: DerivationTree s a -> [DerivationTree s a]
-subtrees = map snd . branches
-
--- | Returns all leafs, i.e., final results in derivation. Be careful:
--- the returned list may be very long
-leafs :: DerivationTree s a -> [a]
-leafs t = [ root t | endpoint t ] ++ concatMap leafs (subtrees t)
-
--- | The argument supplied is the maximum number of steps; if more steps are
--- needed, Nothing is returned
-lengthMax :: Int -> DerivationTree s a -> Maybe Int
-lengthMax n = join . fmap (f . derivationLength) . derivation
-            . commit . restrictHeight (n+1)
- where
-    f i = if i<=n then Just i else Nothing
-
-updateAnnotations :: (a -> s -> a -> t) -> DerivationTree s a -> DerivationTree t a
-updateAnnotations f = rec
- where
-   rec (DT a b xs) =
-      let g (s, t) = (f a s (root t), rec t)
-      in DT a b (map g xs)
-
------------------------------------------------------------------------------
--- Changing a derivation tree
-
--- | Restrict the height of the tree (by cutting off branches at a certain depth).
--- Nodes at this particular depth are turned into endpoints
-restrictHeight :: Int -> DerivationTree s a -> DerivationTree s a
-restrictHeight n t
-   | n == 0    = singleNode (root t) True
-   | otherwise = t {branches = map f (branches t)}
- where
-   f = mapSecond (restrictHeight (n-1))
-
--- | Restrict the width of the tree (by cutting off branches).
-restrictWidth :: Int -> DerivationTree s a -> DerivationTree s a
-restrictWidth n = rec
- where
-   rec t = t {branches = map (mapSecond rec) (take n (branches t))}
-
--- | Commit to the left-most derivation (even if this path is unsuccessful)
-commit :: DerivationTree s a -> DerivationTree s a
-commit = restrictWidth 1
-
--- | Filter out intermediate steps, and merge its branches (and endpoints) with
--- the rest of the derivation tree
-mergeSteps :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a
-mergeSteps p = rec
- where
-   rec t = addBranches (concat list) (singleNode (root t) isEnd)
-    where
-      new = map rec (subtrees t)
-      (bools, list) = unzip (zipWith f (annotations t) new)
-      isEnd = endpoint t || or bools
-      f s st
-         | p s       = (False, [(s, st)])
-         | otherwise = (endpoint st, branches st)
-
-sortTree :: (l -> l -> Ordering) -> DerivationTree l a -> DerivationTree l a
-sortTree f t = t {branches = change (branches t) }
- where
-   change = map (mapSecond (sortTree f)) . sortBy cmp
-   cmp (l1, _) (l2, _) = f l1 l2
-
-mergeMaybeSteps :: DerivationTree (Maybe s) a -> DerivationTree s a
-mergeMaybeSteps = mapFirst fromJust . mergeSteps isJust
-
-cutOnStep :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a
-cutOnStep p = rec
- where
-   rec t = t {branches = map f (branches t)}
-   f (s, t)
-      | p s       = (s, singleNode (root t) True)
-      | otherwise = (s, rec t)
-
------------------------------------------------------------------------------
--- Conversions from a derivation tree
-
--- | All possible derivations (returned in a list)
-derivations :: DerivationTree s a -> [Derivation s a]
-derivations t =
-   [ emptyDerivation (root t) | endpoint t ] ++
-   [ (root t, r) `prepend` d | (r, st) <- branches t, d <- derivations st ]
-
--- | The first derivation (if any)
-derivation :: DerivationTree s a -> Maybe (Derivation s a)
-derivation = safeHead . derivations
-
--- | Return  a random derivation (if any exists at all)
-randomDerivation :: RandomGen g => g -> DerivationTree s a -> Maybe (Derivation s a)
-randomDerivation g t = msum xs
- where
-   (xs, g0) = shuffle g list
-   list     = [ Just (emptyDerivation (root t)) | endpoint t ] ++
-              map make (branches t)
-   make (r, st) = do
-      d <- randomDerivation g0 st
-      return ((root t, r) `prepend` d)
-
-shuffle :: RandomGen g => g -> [a] -> ([a], g)
-shuffle g0 xs = rec g0 [] (length xs) xs
- where
-   rec g acc n ys =
-      case splitAt i ys of
-         (as, b:bs) -> rec g1 (b:acc) (n-1) (as++bs)
-         _ -> (acc, g)
-    where
-      (i, g1) = randomR (0, n-1) g
− src/Common/Exercise.hs 
@@ -1,496 +0,0 @@-{-# LANGUAGE Rank2Types #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- This module defines the concept of an exercise
---
------------------------------------------------------------------------------
-module Common.Exercise
-   ( -- * Exercises
-     Exercise, makeExercise, emptyExercise
-   , exerciseId, status, parser, prettyPrinter
-   , equivalence, similarity, ready, suitable, isReady, isSuitable
-   , hasTermView
-   , strategy, navigation, canBeRestarted, extraRules, ruleOrdering
-   , difference, differenceEqual
-   , testGenerator, randomExercise, examples, getRule
-   , simpleGenerator, useGenerator
-   , randomTerm, randomTermWith, ruleset
-   , makeContext, inContext, recognizeRule
-   , ruleOrderingWith, ruleOrderingWithId
-   , Examples, mapExamples, Difficulty(..), readDifficulty, level
-   , hasTypeable, useTypeable, castFrom, castTo
-     -- * Exercise status
-   , Status(..), isPublic, isPrivate
-     -- * Miscellaneous
-   , withoutContext, simpleSimilarity, simpleEquivalence
-   , prettyPrinterContext, restrictGenerator
-   , showDerivation, printDerivation
-   , ExerciseDerivation, defaultDerivation
-   , derivationDiffEnv, derivationPrevious
-   , checkExercise, checkParserPretty
-   , checkExamples, exerciseTestSuite
-   ) where
-
-import Common.Classes
-import Common.Context
-import Common.Derivation
-import Common.DerivationTree
-import Common.Id
-import Common.Navigator
-import Common.Predicate
-import Common.Rewriting
-import Common.Strategy hiding (not, fail, repeat, replicate)
-import Common.Transformation
-import Common.Utils (ShowString(..), commaList)
-import Common.Utils.TestSuite
-import Common.View
-import Control.Monad.Error
-import Data.Char
-import Data.Function
-import Data.List
-import Data.Maybe
-import Data.Ord
-import Data.Typeable
-import System.Random
-import Test.QuickCheck hiding (label)
-import Test.QuickCheck.Gen
-import qualified Common.Rewriting.Difference as Diff
-import qualified Common.Strategy as S
-
-data Exercise a = Exercise
-   { -- identification and meta-information
-     exerciseId     :: Id -- identifier that uniquely determines the exercise
-   , status         :: Status
-     -- parsing and pretty-printing
-   , parser         :: String -> Either String a
-   , prettyPrinter  :: a -> String
-     -- syntactic and semantic checks
-   , equivalence    :: Context a -> Context a -> Bool
-   , similarity     :: Context a -> Context a -> Bool -- possibly more liberal than syntactic equality
-   , ready          :: Predicate a
-   , suitable       :: Predicate a
-   , hasTermView    :: Maybe (View Term a)
-   , hasTypeable    :: Maybe (IsTypeable a)
-     -- strategies and rules
-   , strategy       :: LabeledStrategy (Context a)
-   , navigation     :: a -> Navigator a
-   , canBeRestarted :: Bool                -- By default, assumed to be the case
-   , extraRules     :: [Rule (Context a)]  -- Extra rules (possibly buggy) not appearing in strategy
-   , ruleOrdering   :: Rule (Context a) -> Rule (Context a) -> Ordering -- Ordering on rules (for onefirst)
-     -- testing and exercise generation
-   , testGenerator  :: Maybe (Gen a)
-   , randomExercise :: Maybe (StdGen -> Difficulty -> a)
-   , examples       :: [(Difficulty, a)]
-   }
-
-instance Eq (Exercise a) where
-   e1 == e2 = getId e1 == getId e2
-
-instance Ord (Exercise a) where
-   compare = comparing getId
-
-instance Apply Exercise where
-   applyAll ex = concatMap fromContext . applyAll (strategy ex) . inContext ex
-
-instance HasId (Exercise a) where
-   getId = exerciseId
-   changeId f ex = ex { exerciseId = f (exerciseId ex) }
-
-makeExercise :: (Show a, Eq a, IsTerm a) => Exercise a
-makeExercise = emptyExercise
-   { prettyPrinter = show
-   , similarity    = (==)
-   , hasTermView   = Just termView
-   }
-
-emptyExercise :: Exercise a
-emptyExercise = Exercise
-   { -- identification and meta-information
-     exerciseId     = error "no exercise code"
-   , status         = Experimental
-     -- parsing and pretty-printing
-   , parser         = const (Left "<<no parser>>")
-   , prettyPrinter  = const "<<no pretty-printer>>"
-     -- syntactic and semantic checks
-   , equivalence    = \_ _ -> True
-   , similarity     = \_ _ -> True
-   , ready          = true
-   , suitable       = true
-   , hasTermView    = Nothing
-   , hasTypeable    = Nothing
-     -- strategies and rules
-   , strategy       = label "Fail" S.fail
-   , navigation     = noNavigator
-   , canBeRestarted = True
-   , extraRules     = []
-   , ruleOrdering   = compareId
-     -- testing and exercise generation
-   , testGenerator  = Nothing
-   , randomExercise = Nothing
-   , examples       = []
-   }
-
-makeContext :: Exercise a -> Environment -> a -> Context a
-makeContext ex env = newContext env . navigation ex
-
--- | Put a value into an empty environment
-inContext :: Exercise a -> a -> Context a
-inContext = flip makeContext emptyEnv
-
----------------------------------------------------------------
--- Difficulty levels
-
-type Examples a = [(Difficulty, a)]
-
-mapExamples :: (a -> b) -> Examples a -> Examples b
-mapExamples f = map (second f)
-
-data Difficulty = VeryEasy | Easy | Medium | Difficult | VeryDifficult
-   deriving (Eq, Ord, Enum)
-
-instance Show Difficulty where
-   show = (xs !!) . fromEnum
-    where
-      xs = ["very_easy", "easy", "medium", "difficult", "very_difficult"]
-
-readDifficulty :: String -> Maybe Difficulty
-readDifficulty s =
-   case filter p [VeryEasy .. VeryDifficult] of
-            [a] -> Just a
-            _   -> Nothing
- where
-   normal = filter isAlpha . map toLower
-   p = (== normal s) . normal . show
-
-level :: Difficulty -> [a] -> Examples a
-level = zip . repeat
-
----------------------------------------------------------------
--- Exercise generators
-
--- returns a sorted list of rules (no duplicates)
-ruleset :: Exercise a -> [Rule (Context a)]
-ruleset ex = nub (sortBy compareId list)
- where
-   list = extraRules ex ++ rulesInStrategy (strategy ex)
-
-simpleGenerator :: Gen a -> Maybe (StdGen -> Difficulty -> a)
-simpleGenerator = useGenerator (const True) . const
-
-useGenerator :: (a -> Bool) -> (Difficulty -> Gen a) -> Maybe (StdGen -> Difficulty -> a)
-useGenerator p makeGen = Just (\rng -> rec rng . makeGen)
- where
-   rec rng gen@(MkGen f)
-      | p a       = a
-      | otherwise = rec (snd (next rng)) gen
-    where
-      (size, r) = randomR (0, 100) rng
-      a         = f r size
-
-restrictGenerator :: (a -> Bool) -> Gen a -> Gen a
-restrictGenerator p g = do
-   a <- g
-   if p a then return a
-          else restrictGenerator p g
-
-randomTerm :: Difficulty -> Exercise a -> IO a
-randomTerm dif ex = do
-   rng <- newStdGen
-   return (randomTermWith rng dif ex)
-
-randomTermWith :: StdGen -> Difficulty -> Exercise a -> a
-randomTermWith rng dif ex =
-   case randomExercise ex of
-      Just f  -> f rng dif
-      Nothing
-         | null xs   -> error "randomTermWith: no generator"
-         | otherwise ->
-              snd (xs !! fst (randomR (0, length xs - 1) rng))
-       where xs = examples ex
-
-difference :: Exercise a -> a -> a -> Maybe (a, a)
-difference ex a b = do
-   v <- hasTermView ex
-   Diff.differenceWith v a b
-
-differenceEqual :: Exercise a -> a -> a -> Maybe (a, a)
-differenceEqual ex a b = do
-   v <- hasTermView ex
-   Diff.differenceEqualWith v (simpleEquivalence ex) a b
-
--- Recognize a rule at (possibly multiple) locations
-recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [(Location, ArgValues)]
-recognizeRule ex r ca cb = rec (fromMaybe ca (top ca))
- where
-   rec x =
-      let here = case ruleRecognizer (similarity ex) r x cb of
-                    Just as -> [(location x, as)]
-                    Nothing -> []
-      in here ++ concatMap rec (allDowns x)
-
-ruleOrderingWith :: [Rule a] -> Rule a -> Rule a -> Ordering
-ruleOrderingWith = ruleOrderingWithId . map getId
-
-ruleOrderingWithId :: HasId b => [b] -> Rule a -> Rule a -> Ordering
-ruleOrderingWithId bs r1 r2 =
-   let xs = map getId bs in
-   case (findIndex (==getId r1) xs, findIndex (==getId r2) xs) of
-      (Just i,  Just j ) -> i `compare` j
-      (Just _,  Nothing) -> LT
-      (Nothing, Just _ ) -> GT
-      (Nothing, Nothing) -> compareId r1 r2
-
----------------------------------------------------------------
--- Using type representations for casts
-
-data IsTypeable a = IT (forall b . Typeable b => a -> Maybe b)
-                       (forall b . Typeable b => b -> Maybe a)
-
-useTypeable :: Typeable a => Maybe (IsTypeable a)
-useTypeable = Just (IT cast cast)
-
-castFrom :: Typeable b => Exercise a -> a -> Maybe b
-castFrom ex a = do
-   IT f _ <- hasTypeable ex
-   f a
-
-castTo :: Typeable b => Exercise a -> b -> Maybe a
-castTo ex a = do
-   IT _ g <- hasTypeable ex
-   g a
-
----------------------------------------------------------------
--- Exercise status
-
-data Status
-   = Stable       -- ^ A released exercise that has undergone some thorough testing
-   | Provisional  -- ^ A released exercise, possibly with some deficiencies
-   | Alpha        -- ^ An exercise that is under development
-   | Experimental -- ^ An exercise for experimentation purposes only
-   deriving (Show, Eq)
-
--- | An exercise with the status @Stable@ or @Provisional@
-isPublic :: Exercise a -> Bool
-isPublic ex = status ex `elem` [Stable, Provisional]
-
--- | An exercise that is not public
-isPrivate :: Exercise a -> Bool
-isPrivate = not . isPublic
-
----------------------------------------------------------------
--- Rest
-
--- | Function for defining equivalence or similarity without taking
--- the context into account.
-withoutContext :: (a -> a -> Bool) -> Context a -> Context a -> Bool
-withoutContext f a b = fromMaybe False (fromContextWith2 f a b)
-
-isReady :: Exercise a -> a -> Bool
-isReady = evalPredicate . ready
-
-isSuitable :: Exercise a -> a -> Bool
-isSuitable = evalPredicate . suitable
-
--- | Similarity on terms without a context
-simpleSimilarity :: Exercise a -> a -> a -> Bool
-simpleSimilarity ex = similarity ex `on` inContext ex
-
--- | Equivalence on terms without a context
-simpleEquivalence :: Exercise a -> a -> a -> Bool
-simpleEquivalence ex = equivalence ex `on` inContext ex
-
-prettyPrinterContext :: Exercise a -> Context a -> String
-prettyPrinterContext ex =
-   maybe "<<invalid term>>" (prettyPrinter ex) . fromContext
-
-getRule :: Monad m => Exercise a -> Id -> m (Rule (Context a))
-getRule ex a =
-   case filter ((a ==) . getId) (ruleset ex) of
-      [hd] -> return hd
-      []   -> fail $ "Could not find ruleid " ++ showId a
-      _    -> fail $ "Ambiguous ruleid " ++ showId a
-
--- |Shows a derivation for a given start term. The specified rule ordering
--- is used for selection.
-showDerivation :: Exercise a -> a -> String
-showDerivation ex a = show (present der) ++ extra
- where
-   der   = derivationPrevious (derivationDiffEnv (defaultDerivation ex a))
-   extra =
-      case fromContext (lastTerm der) of
-         Nothing               -> "<<invalid term>>"
-         Just b | isReady ex b -> ""
-                | otherwise    -> "<<not ready>>"
-   present = biMap (ShowString . f) (ShowString . prettyPrinterContext ex)
-   f ((b, env), old) = showId b ++ part1 ++ part2
-    where
-      newl = "\n      "
-      g (ArgValue descr x) = labelArgument descr ++ "=" ++ showArgument descr x
-      part1 = case expectedArguments b old of
-                 Just xs -> newl ++ commaList (map g xs)
-                 Nothing -> ""
-      part2 | nullEnv env = ""
-            | otherwise   = newl ++ show env
-
-type ExerciseDerivation a = Derivation (Rule (Context a)) (Context a)
-
-defaultDerivation :: Exercise a -> a -> ExerciseDerivation a
-defaultDerivation ex a =
-   let ca     = inContext ex a
-       tree   = sortTree (ruleOrdering ex) (derivationTree (strategy ex) ca)
-       single = emptyDerivation ca
-   in fromMaybe single (derivation tree)
-
-derivationDiffEnv :: Derivation s (Context a) -> Derivation (s, Environment) (Context a)
-derivationDiffEnv = updateSteps $ \y b x ->
-   let env = diffEnv (getEnvironment x) (getEnvironment y)
-   in (b, deleteEnv "location" env)
-
--- helper, needed for showing arguments
-derivationPrevious :: Derivation s a -> Derivation (s, a) a
-derivationPrevious = updateSteps $ \a s _ -> (s, a)
-
-printDerivation :: Exercise a -> a -> IO ()
-printDerivation ex = putStrLn . showDerivation ex
-
----------------------------------------------------------------
--- Checks for an exercise
-
-checkExercise :: Exercise a -> IO ()
-checkExercise = runTestSuite . exerciseTestSuite
-
-exerciseTestSuite :: Exercise a -> TestSuite
-exerciseTestSuite ex = suite ("Exercise " ++ show (exerciseId ex)) $ do
-   -- get some exercises
-   xs <- if isJust (randomExercise ex)
-         then liftIO $ replicateM 10 (randomTerm Medium ex)
-         else return (map snd (examples ex))
-   -- do tests
-   assertTrue "Exercise terms defined" (not (null xs))
-   assertTrue "Equivalence implemented" $
-      let eq a b = equivalence ex (inContext ex a) (inContext ex b)
-      in length (nubBy eq xs) > 1
-   assertTrue "Similarity implemented" $
-      let sim a b = similarity ex (inContext ex a) (inContext ex b)
-      in length (nubBy sim xs) > 1
-   checkExamples ex
-   case testGenerator ex of
-      Nothing  -> return ()
-      Just gen -> do
-         let showAsGen = showAs (prettyPrinter ex) gen
-         addProperty "parser/pretty printer" $ forAll showAsGen $
-            checkParserPrettyEx ex . inContext ex . fromS
-
-         suite "Soundness non-buggy rules" $
-            forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r ->
-               let eq a b = equivalence ex (fromS a) (fromS b)
-                   myGen  = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen)
-                   myView = makeView (return . fromS) (S (prettyPrinterContext ex))
-                   args   = stdArgs {maxSize = 10, maxSuccess = 10, maxDiscard = 100}
-               in addPropertyWith (showId r) args $
-                     propRuleSmart eq (liftRule myView r) myGen
-
-         addProperty "soundness strategy/generator" $
-            forAll showAsGen $
-               maybe False (isReady ex) . fromContext
-               . applyD (strategy ex) . inContext ex . fromS
-
-data ShowAs a = S {showS :: a -> String, fromS :: a}
-
-instance Show (ShowAs a) where
-   show a = showS a (fromS a)
-
-showAs :: (a -> String) -> Gen a -> Gen (ShowAs a)
-showAs f = liftM (S f)
-
--- check combination of parser and pretty-printer
-checkParserPretty :: (a -> a -> Bool) -> (String -> Either String a) -> (a -> String) -> a -> Bool
-checkParserPretty eq p pretty a =
-   either (const False) (eq a) (p (pretty a))
-
-checkParserPrettyEx :: Exercise a -> Context a -> Bool
-checkParserPrettyEx ex ca =
-   let f    = mapSecond make . parser ex
-       make = newContext (getEnvironment ca) . navigation ex
-   in checkParserPretty (similarity ex) f (prettyPrinterContext ex) ca
-
-checkExamples :: Exercise a -> TestSuite
-checkExamples ex = do
-   let xs = map snd (examples ex)
-   unless (null xs) $ suite "Examples" $
-      mapM_ (checksForTerm True ex) xs
-
-checksForTerm :: Bool -> Exercise a -> a -> TestSuite
-checksForTerm leftMost ex a = do
-   let tree = derivationTree (strategy ex) (inContext ex a)
-   -- Left-most derivation
-   when leftMost $
-      case derivation tree of
-         Just d  -> checksForDerivation ex d
-         Nothing ->
-            fail $ "no derivation for " ++ prettyPrinter ex a
-   -- Random derivation
-   g <- liftIO getStdGen
-   case randomDerivation g tree of
-      Just d  -> checksForDerivation ex d
-      Nothing -> return ()
-
-checksForDerivation :: Exercise a -> Derivation (Rule (Context a)) (Context a) -> TestSuite
-checksForDerivation ex d = do
-   -- Conditions on starting term
-   let start = firstTerm d
-   assertTrue
-      ("start term not suitable: " ++ prettyPrinterContext ex start) $
-      maybe False (isSuitable ex) (fromContext start)
-
-   {-
-   b2 <- do let b = False -- maybe True (isReady ex) (fromContext start)
-            when b $ report $
-               "start term is ready: " ++ prettyPrinterContext ex start
-            return b-}
-   -- Conditions on final term
-   let final = lastTerm d
-   {-
-   b3 <- do let b = False -- maybe True (isSuitable ex) (fromContext final)
-            when b $ report $
-               "final term is suitable: " ++ prettyPrinterContext ex start
-               ++ "  =>  " ++ prettyPrinterContext ex final
-            return b -}
-   assertTrue
-      ("final term not ready: " ++ prettyPrinterContext ex start
-               ++ "  =>  " ++ prettyPrinterContext ex final) $
-      maybe False (isReady ex) (fromContext final)
-
-   -- Parser/pretty printer on terms
-   let ts  = terms d
-       p1  = not . checkParserPrettyEx ex
-   assertNull "parser/pretty-printer" $ take 1 $ flip map (filter p1 ts) $ \hd ->
-      let s = prettyPrinterContext ex hd
-      in "parse error for " ++ s ++ ": parsed as "
-         ++ either show (prettyPrinter ex) (parser ex s)
-
-   -- Equivalences between terms
-   let pairs    = [ (x, y) | x <- ts, y <- ts ]
-       p2 (x, y) = not (equivalence ex x y)
-   assertNull "equivalences" $ take 1 $ flip map (filter p2 pairs) $ \(x, y) ->
-      "not equivalent: " ++ prettyPrinterContext ex x
-      ++ "  with  " ++ prettyPrinterContext ex y
-
-   -- Similarity of terms
-   let p3 (x, r, y) = not (isFinalRule r) && similarity ex x y
-   assertNull  "similars" $ take 1 $ flip map (filter p3 (triples d)) $ \(x, r, y) ->
-      "similar subsequent terms: " ++ prettyPrinterContext ex x
-      ++ "  with  " ++ prettyPrinterContext ex y
-      ++ "  using  " ++ show r
-
-   let xs = [ x | x <- terms d, not (similarity ex x x) ]
-   assertNull "self similarity" $ take 1 $ flip map xs $ \hd ->
-      "term not similar to itself: " ++ prettyPrinterContext ex hd
− src/Common/Id.hs 
@@ -1,184 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Identification of entities
---
------------------------------------------------------------------------------
-module Common.Id
-   ( Id, IsId(..), HasId(..), Identify(..), ( # ), sameId
-   , unqualified, qualifiers, qualification
-   , describe, description, showId, compareId
-   , mempty, isEmptyId
-   ) where
-
-import Common.Classes
-import Common.Utils (splitsWithElem)
-import Common.Utils.StringRef
-import Control.Monad
-import Data.Char
-import Data.List
-import Data.Monoid
-import Data.Ord
-import Test.QuickCheck
-
----------------------------------------------------------------------
--- Abstract data type and its instances
-
-data Id = Id
-   { idList        :: [String]
-   , idDescription :: String
-   , idRef         :: !StringRef
-   }
-
-instance Show Id where
-   show = intercalate "." . idList
-
-instance Eq Id where
-   a == b = idRef a == idRef b
-
-instance Ord Id where
-   compare = comparing idRef
-
-instance Monoid Id where
-   mempty  = emptyId
-   mappend = ( # )
-
-instance Arbitrary Id where
-   arbitrary = frequency
-      [ (4, do n  <- choose (0, 8)
-               xs <- replicateM n (elements ['a' .. 'z'])
-               return $ newId xs)
-      , (1, liftM2 mappend arbitrary arbitrary)
-      ]
-
----------------------------------------------------------------------
--- Type class for constructing identifiers
-
-class IsId a where
-   newId    :: a   -> Id
-   concatId :: [a] -> Id -- for String instance
-   -- default definition
-   concatId = mconcat . map newId
-
-instance IsId Id where
-   newId = id
-
-instance IsId Char where
-   newId c  = stringId [c]
-   concatId = stringId
-
-instance IsId a => IsId [a] where
-   newId    = concatId
-   concatId = mconcat . map newId
-
-instance IsId () where
-   newId = const emptyId
-
-instance (IsId a, IsId b) => IsId (a, b) where
-   newId (a, b) = newId a # newId b
-
-instance (IsId a, IsId b, IsId c) => IsId (a, b, c) where
-   newId (a, b, c) = newId a # newId b # newId c
-
-instance IsId a => IsId (Maybe a) where
-   newId = maybe emptyId newId
-
-instance (IsId a, IsId b) => IsId (Either a b) where
-   newId = either newId newId
-
------------------------------------------------------
--- Type class for structures containing an identifier
-
-class HasId a where
-   getId    :: a -> Id
-   changeId :: (Id -> Id) -> a -> a
-
-instance HasId Id where
-   getId    = id
-   changeId = id
-
-instance (HasId a, HasId b) => HasId (Either a b) where
-   getId      = either getId getId
-   changeId f = biMap (changeId f) (changeId f)
-
-class HasId a => Identify a where
-   (@>) :: IsId n => n -> a -> a
-
----------------------------------------------------------------------
--- Private constructors
-
-appendId :: Id -> Id -> Id
-appendId a b
-   | null (idList a) = b
-   | null (idList b) = a
-   | otherwise       = Id (idList a ++ idList b) "" ref
- where
-   ref = stringRef (show a ++ "." ++ show b)
-
--- Only allow alphanum and '-' ('.' has a special meaning)
-stringId :: String -> Id
-stringId txt = Id (make s) "" (stringRef s)
- where
-   s    = norm txt
-   make = filter (not . null) . splitsWithElem '.'
-   norm = filter ok . map toLower
-   ok c = isAlphaNum c || c `elem` ".-_"
-
-emptyId :: Id
-emptyId = Id [] "" (stringRef "")
-
----------------------------------------------------------------------
--- Additional functionality (overloaded)
-
-infixr 8 #
-
-( # ) :: (IsId a, IsId b) => a -> b -> Id
-a # b = appendId (newId a) (newId b)
-
-sameId :: (IsId a, IsId b) => a -> b -> Bool
-sameId a b = newId a == newId b
-
-unqualified :: HasId a => a -> String
-unqualified a
-   | null xs   = ""
-   | otherwise = last xs
- where
-   xs = idList (getId a)
-
-qualifiers :: HasId a => a -> [String]
-qualifiers a
-   | null xs   = []
-   | otherwise = init xs
- where
-   xs = idList (getId a)
-
-qualification :: HasId a => a -> String
-qualification = intercalate "." . qualifiers
-
-description :: HasId a => a -> String
-description = idDescription . getId
-
-showId :: HasId a => a -> String
-showId = show . getId
-
-compareId :: HasId a => a -> a -> Ordering
-compareId = comparing showId
-
-isEmptyId :: Id -> Bool
-isEmptyId = (== emptyId)
-
-describe :: HasId a => String -> a -> a
-describe = changeId . describeId
- where
-   describeId s a
-      | null (idDescription a) =
-           a {idDescription = s}
-      | otherwise =
-           a {idDescription = s ++ " " ++ idDescription a}
− src/Common/Library.hs 
@@ -1,56 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Exports most from package Common
---
------------------------------------------------------------------------------
-module Common.Library
-   ( module Export
-   , failS, notS, repeatS, replicateS, sequenceS, untilS
-   ) where
-
-import Common.Classes as Export
-import Common.Context as Export
-import Common.Derivation as Export
-import Common.DerivationTree as Export
-import Common.Exercise as Export
-import Common.Id as Export
-import Common.Navigator as Export hiding (left, right)
-import Common.Predicate as Export
-import Common.Rewriting as Export
-import Common.Strategy as Export hiding (fail, not, repeat, replicate, sequence, until)
-import Common.Transformation as Export
-import Common.View as Export
-
-import qualified Common.Strategy as S
-
--- | Alias for strategy combinator @fail@
-failS :: Strategy a
-failS = S.fail
-
--- | Alias for strategy combinator @not@
-notS :: IsStrategy f => f a -> Strategy a
-notS = S.not
-
--- | Alias for strategy combinator @repeat@
-repeatS :: IsStrategy f => f a -> Strategy a
-repeatS = S.repeat
-
--- | Alias for strategy combinator @replicate@
-replicateS :: IsStrategy f => Int -> f a -> Strategy a
-replicateS = S.replicate
-
--- | Alias for strategy combinator @sequence@
-sequenceS :: IsStrategy f => [f a] -> Strategy a
-sequenceS = S.sequence
-
--- | Alias for strategy combinator @until@
-untilS :: IsStrategy f => (a -> Bool) -> f a -> Strategy a
-untilS = S.until
− src/Common/Navigator.hs 
@@ -1,272 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- This module defines a type class for navigating an expression.
---
------------------------------------------------------------------------------
-module Common.Navigator
-   ( -- * Type classes for navigating expressions
-     IsNavigator(..), TypedNavigator(..)
-     -- * Types and constructors
-   , Navigator, Location
-   , navigator, noNavigator, viewNavigator, viewNavigatorWith
-     -- * Derived navigations
-   , leave, replace, arity, isTop, isLeaf, ups, downs, navigateTo
-   , navigateTowards, top, downFirst, downLast, left, right
-   , replaceT
-   ) where
-
-import Common.Utils.Uniplate
-import Common.View hiding (left, right)
-import Control.Monad
-import Data.Maybe
-import Data.Typeable
-
----------------------------------------------------------------
--- Type class for navigating expressions
-
-type Location = [Int]
-
--- | For a minimal complete definition, provide an implemention for downs or
--- allDowns. All other functions need an implementation as well, except for
--- change. Note that a constructor (a -> f a) is not included in the type class
--- to allow additional type class constraints on type a.
-class IsNavigator f where
-   -- navigation
-   up       :: Monad m => f a -> m (f a)
-   down     :: Monad m => Int -> f a -> m (f a)
-   allDowns :: f a -> [f a]
-   -- inspection
-   current  :: Monad m => f a -> m a
-   location :: f a -> Location
-   -- adaption
-   change   :: (a -> a) -> f a -> f a
-   changeM  :: Monad m => (a -> m a) -> f a -> m (f a)
-   -- default definitions
-   down n a =
-      case drop n (allDowns a) of
-         []   -> fail ("down " ++ show n)
-         hd:_ -> return hd
-   allDowns a =
-      [ fa | i <- [0 .. arity a-1], fa <- down i a ]
-   change f a =
-      fromMaybe a (changeM (Just . f) a)
-
-class IsNavigator f => TypedNavigator f where
-   changeT  :: (Monad m, Typeable b) => (b -> m b) -> f a -> m (f a)
-   currentT :: (Monad m, Typeable b) => f a -> m b
-   leaveT   :: (Monad m, Typeable b) => f a -> m b
-   castT    :: (Monad m, Typeable e) => View e b -> f a -> m (f b)
-   -- By default, fail
-   changeT _ _ = fail "changeT: not defined"
-   currentT _  = fail "currentT: not defined"
-   leaveT _    = fail "leaveT: not defined"
-   castT _ _   = fail "castT: not defined"
-
----------------------------------------------------------------
--- Derived navigations
-
-leave  :: (IsNavigator f, Monad m) => f a -> m a
-leave a = maybe (current a) leave (up a)
-
-replace :: IsNavigator f => a -> f a -> f a
-replace = change . const
-
-arity :: IsNavigator f => f a -> Int
-arity  = length . allDowns
-
-isTop :: IsNavigator f => f a -> Bool
-isTop  = isNothing . up
-
-isLeaf :: IsNavigator f => f a -> Bool
-isLeaf = null . allDowns
-
-ups :: (IsNavigator f, Monad m) => Int -> f a -> m (f a)
-ups n a = foldM (const . up) a [1..n]
-
-downs :: (IsNavigator f, Monad m) => [Int] -> f a -> m (f a)
-downs is a = foldM (flip down) a is
-
-navigateTo :: (IsNavigator f, Monad m) => Location -> f a -> m (f a)
-navigateTo is a = ups (length js - n) a >>= downs (drop n is)
- where
-   js = location a
-   n  = length (takeWhile id (zipWith (==) is js))
-
-navigateTowards :: IsNavigator f => Location -> f a -> f a
-navigateTowards is a =
-   case ups (length js - n) a of
-      Just b  -> safeDowns (drop n is) b
-      Nothing -> a
- where
-   js = location a
-   n  = length (takeWhile id (zipWith (==) is js))
-
-   safeDowns []     b = b
-   safeDowns (m:ms) b = maybe b (safeDowns ms) (down m b)
-
-top :: (IsNavigator f, Monad m) => f a -> m (f a)
-top = navigateTo []
-
-downFirst :: (IsNavigator f, Monad m) => f a -> m (f a)
-downFirst = down 0
-
-downLast :: (IsNavigator f, Monad m) => f a -> m (f a)
-downLast a = down (arity a - 1) a
-
-left :: (IsNavigator f, Monad m) => f a -> m (f a)
-left a0 = rec a0
- where
-   rec a
-      | isTop a   = downFirst a0
-      | i == 0    = up a >>= rec
-      | otherwise = up a >>= down (i-1)
-    where
-      i = last (location a)
-
-right :: (IsNavigator f, Monad m) => f a -> m (f a)
-right a0 = rec a0
- where
-   rec a
-      | isTop a   = downLast a0
-      | otherwise = do
-           p <- up a
-           let n = arity p
-           if i >= n-1 then rec p else down (i+1) p
-    where
-      i = last (location a)
-
----------------------------------------------------------------
--- Instance based on Uniplate
-
--- The uniplate function is stored in the data type to get rid of the
--- Uniplate type class constraints in the member functions of the
--- Navigator type class.
-data UniplateNav a = UN (HolesType a) [(Int, a -> a)] a
-
-type HolesType a = a -> [(a, a -> a)]
-
-makeUN :: HolesType a -> a -> UniplateNav a
-makeUN f = UN f []
-
-instance Show a => Show (UniplateNav a) where
-   show = showNav
-
-instance IsNavigator UniplateNav where
-   up (UN _ [] _)            = fail "up"
-   up (UN uni ((_, f):xs) a) = return (UN uni xs (f a))
-
-   allDowns (UN uni xs a) =
-      let make i (b, f) = UN uni ((i, f):xs) b
-      in zipWith make [0..] (uni a)
-
-   location (UN _ xs _) = reverse (map fst xs)
-
-   changeM f (UN uni xs a) = liftM (UN uni xs) (f a)
-   current   (UN _ _    a) = return a
-
-showNav :: (IsNavigator f, Show a) => f a -> String
-showNav a = maybe "???" show (leave a) ++ "   { "
-            ++ maybe "???" show (current a)
-            ++ " @ " ++ show (location a) ++ " }"
-
----------------------------------------------------------------
--- Instance based on a View
-
-data ViewNav a b = VN (View a b) (UniplateNav a)
-
-instance Show a => Show (ViewNav a b) where
-   show (VN _ a) = show a
-
-instance IsNavigator (ViewNav a) where
-   up        (VN v a) = liftM (VN v) (up a)
-   allDowns  (VN v a) = liftM (VN v) (allDowns a)
-   location  (VN _ a) = location a
-   current   (VN v a) = current a >>= matchM v
-   changeM f (VN v a) =
-      let g b = matchM v b >>= (liftM (build v) . f)
-      in liftM (VN v) (changeM g a)
-
-instance Typeable a => TypedNavigator (ViewNav a) where
-   changeT f (VN v a) = do
-      new <- current a >>= castM >>= f >>= castM
-      return (VN v (replace new a))
-   currentT (VN _ a) =
-      current a >>= castM
-   leaveT (VN _ a) =
-      leave a >>= castM
-   castT v (VN v0 a)
-      | tp1 == tp2 = return (VN (castView v) a)
-      | otherwise  = fail $ "castT: " ++ show tp1 ++ " and " ++ show tp2
-    where
-      tp1 = typeOf (getTp v)
-      tp2 = typeOf (getTp v0)
-
-      getTp :: View a b -> a
-      getTp = error "castT: getTp"
-
-replaceT :: (Monad m, TypedNavigator f, Typeable b) =>  b -> f a -> m (f a)
-replaceT = changeT . const . return
-
-castM :: (Monad m, Typeable a, Typeable b) => a -> m b
-castM = maybe (fail "castM") return . cast
-
-castView :: (Typeable c, Typeable a) => View a b -> View c b
-castView v = makeView f g
- where
-   f e = castM e >>= matchM v
-   g   = fromMaybe (error "castT: build") . castM . build v
-
----------------------------------------------------------------
--- Uniform navigator type
-
-instance Show a => Show (Navigator a) where
-   show = showNav
-
-data Navigator a = forall f . TypedNavigator f => N (f a)
-data Simple    a = forall f . IsNavigator f    => S (f a)
-
-instance IsNavigator Navigator where
-   up        (N a) = liftM N (up a)
-   allDowns  (N a) = map N (allDowns a)
-   current   (N a) = current a
-   location  (N a) = location a
-   changeM f (N a) = liftM N (changeM f a)
-
-instance TypedNavigator Navigator where
-   changeT f (N a) = liftM N (changeT f a)
-   currentT  (N a) = currentT a
-   leaveT    (N a) = leaveT a
-   castT v   (N a) = liftM N (castT v a)
-
-instance IsNavigator Simple where
-   up        (S a) = liftM S (up a)
-   allDowns  (S a) = map S (allDowns a)
-   current   (S a) = current a
-   location  (S a) = location a
-   changeM f (S a) = liftM S (changeM f a)
-
-instance TypedNavigator Simple
-
----------------------------------------------------------------
--- Constructors
-
-navigator :: Uniplate a => a -> Navigator a
-navigator = N . S . makeUN holes
-
-noNavigator :: a -> Navigator a
-noNavigator = N . S . UN (const []) []
-
-viewNavigator :: (Uniplate a, Typeable a) => a -> Navigator a
-viewNavigator = viewNavigatorWith holes
-
-viewNavigatorWith :: Typeable a => HolesType a -> a -> Navigator a
-viewNavigatorWith f = N . VN identity . makeUN f
− src/Common/Predicate.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Representation for predicates
---
------------------------------------------------------------------------------
-module Common.Predicate
-   ( -- * Predicate representation
-     Predicate, predicate, predicateView
-   , evalPredicate
-     -- * Exports from Boolean algebra
-   , BoolValue(..), Boolean(..)
-   , ands, ors, implies, equivalent
-   ) where
-
-import Common.Algebra.Boolean
-import Common.Id
-import Common.View
-
-data Predicate a
-   = Const Bool
-   | Prim (a -> Bool)
-   | forall b . PView (View a b)
-   | Compl (Predicate a)
-   | Predicate a :&&: Predicate a
-   | Predicate a :||: Predicate a
-   | Id :@ Predicate a
-
-instance BoolValue (Predicate a) where
-   fromBool = Const
-   isTrue  (Const b) = b
-   isTrue  _         = False
-   isFalse (Const b) = not b
-   isFalse _         = False
-
-instance Boolean (Predicate a) where
-   Const b <&&> y       = if b then y else false
-   x       <&&> Const b = if b then x else false
-   x       <&&> y       = x :&&: y
-   Const b <||> y       = if b then true else y
-   x       <||> Const b = if b then true else x
-   x       <||> y       = x :||: y
-   complement (Const b) = Const (not b)
-   complement x         = Compl x
-
-instance HasId (Predicate a) where
-   getId (n :@ _)  = n
-   getId (PView v) = getId v
-   getId _         = mempty
-   changeId f (n :@ a) = f n :@ a
-   changeId f a        = f mempty :@ a
-
-instance Identify (Predicate a) where
-   n @> v | isEmptyId a = v
-          | otherwise   = a :@ v
-    where
-      a = newId n
-
-predicate :: (a -> Bool) -> Predicate a
-predicate = Prim
-
-predicateView :: View a b -> Predicate a
-predicateView = PView
-
-evalPredicate :: Predicate a -> a -> Bool
-evalPredicate p a = rec p
- where
-   rec (Const b)  = b
-   rec (Prim f)   = f a
-   rec (PView v)  = a `belongsTo` v
-   rec (Compl x)  = not (rec x)
-   rec (x :&&: y) = rec x && rec y
-   rec (x :||: y) = rec x || rec y
-   rec (_ :@ x)   = rec x
− src/Common/Rewriting.hs 
@@ -1,18 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Rewriting
-   ( module Common.Rewriting.Term
-   , module Common.Rewriting.RewriteRule
-   ) where
-
-import Common.Rewriting.RewriteRule
-import Common.Rewriting.Term
− src/Common/Rewriting/AC.hs 
@@ -1,116 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Rewriting.AC
-   ( -- * Types
-     Pairings, PairingsList, PairingsPair
---   , pairings, pairingsMatch
-     -- * Primitive pairings functions
-   , pairingsNone, pairingsA
-   , pairingsC, pairingsAC
-   ) where
-
-type Pairings     a   = a -> a -> [[(a, a)]]
-type PairingsList a b = [a] -> [b] -> [[([a], [b])]]
-type PairingsPair a b = (a, a) -> (b, b) -> [[(a, b)]]
-
------------------------------------------------------------
--- Pairing terms with an AC theory
--- matchMode: the left-hand sides cannot have the operator at top-level
-
-{-
-pairings, pairingsMatch :: IsMagma m => m a -> Pairings a
-pairings      = pairingsMode False
-pairingsMatch = pairingsMode True
-
-pairingsMode :: IsMagma m => Bool -> m a -> Pairings a
-pairingsMode matchMode op =
-   case (isAssociative op, isCommutative op) of
-      (True , True ) -> operatorPairings op (pairingsAC matchMode)
-      (True , False) -> operatorPairings op (pairingsA matchMode)
-      (False, True ) -> opPairings op pairingsC
-      (False, False) -> opPairings op pairingsNone
--}
-
--- non-associative, non-commutative pairings
-pairingsNone :: PairingsPair a b
-pairingsNone (a1, a2) (b1, b2) =
-   [[(a1, b1), (a2, b2)]]
-
--- commutative pairings
-pairingsC :: PairingsPair a b
-pairingsC (a1, a2) (b1, b2) =
-   [[(a1, b1), (a2, b2)], [(a1, b2), (a2, b1)]]
-
--- associative pairings
-pairingsA :: Bool -> PairingsList a b
-pairingsA matchMode = rec
- where
-   rec [] [] = [[]]
-   rec as bs =
-      [ (a1, b1):ps
-      | i <- if matchMode && not (null as) then [1] else [1 .. length as]
-      , j <- [1 .. length bs]
-      , i==1 || j==1
-      , let (as1, as2) = splitAt i as
-      , let (bs1, bs2) = splitAt j bs
-      , let a1 = as1
-      , let b1 = bs1
-      , ps <- rec as2 bs2
-      ]
-
--- associative/commutative pairings
-pairingsAC :: Bool -> PairingsList a b
-pairingsAC matchMode = rec
- where
-   rec [] [] = [[]]
-   rec [] _  = []
-   rec (a:as) bs =
-      [ (as1, bs1):ps
-      | (asr, as2) <- if matchMode then [([], as)] else splits as
-      , let as1 = a:asr
-      , (bs1, bs2) <- splits bs
-      , not (null bs1)
-      , length as1==1 || length bs1==1
-      , ps <- rec as2 bs2
-      ]
-
-----------------------------------------------------------
--- Helper functions
-{-
-opPairings :: IsMagma m => m a -> PairingsPair a a -> Pairings a
-opPairings op f a b = fromMaybe [] $
-   liftM2 f (match (magmaView op) a) (match (magmaView op) b)
-
-operatorPairings :: IsMagma m => m a -> PairingsList a a -> Pairings a
-operatorPairings op g = curry $
-   let f a = fromMaybe [a] $ match (magmaListView op) a
-       h = build (magmaListView op)
-   in map (map (onBoth h)) . uncurry g . onBoth f
--}
-splits :: [a] -> [([a], [a])]
-splits = foldr insert [([], [])]
- where
-   insert a ps =
-      let toLeft  (xs, ys) = (a:xs,   ys)
-          toRight (xs, ys) = (  xs, a:ys)
-      in map toLeft ps ++ map toRight ps
-
-{-
-onBoth :: (a -> b) -> (a, a) -> (b, b)
-onBoth f (x, y) = (f x, f y)
-
-permutations :: [a] -> [[a]]
-permutations = foldr (concatMap . insert) [[]]
- where
-   insert a []     = [[a]]
-   insert a (x:xs) = (a:x:xs) : map (x:) (insert a xs)
--}
− src/Common/Rewriting/Confluence.hs 
@@ -1,153 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Rewriting.Confluence
-   ( isConfluent, checkConfluence, checkConfluenceWith
-   , somewhereM
-   , Config, defaultConfig, showTerm, complexity, termEquality
-   ) where
-
-import Common.Id
-import Common.Navigator
-import Common.Rewriting.RewriteRule
-import Common.Rewriting.Substitution
-import Common.Rewriting.Term
-import Common.Rewriting.Unification
-import Common.Utils.Uniplate hiding (rewriteM)
-import Data.Maybe
-
-normalForm :: [RewriteRule a] -> Term -> Term
-normalForm rs = run []
- where
-   run hist a =
-      case [ b | r <- rs, b <- somewhereM (rewriteTerm r) a ] of
-         []   -> a
-         hd:_ -> if hd `elem` hist
-                 then error "cyclic"
-                 else run (a:hist) hd
-
-rewriteTerm :: RewriteRule a -> Term -> [Term]
-rewriteTerm r t = do
-   let lhs :~> rhs = ruleSpecTerm $
-          case metaVars t of
-             [] -> r
-             ns -> renumberRewriteRule (maximum ns+1) r
-   sub <- match lhs t
-   return (sub |-> rhs)
-
--- uniplate-like helper-functions
-somewhereM :: Uniplate a => (a -> [a]) -> a -> [a]
-somewhereM f = concatMap leave . rec . navigator
- where
-   rec ca = changeM f ca ++ concatMap rec (allDowns ca)
-
-----------------------------------------------------
-
-type Pair   a = (RewriteRule a, Term)
-type Triple a = (RewriteRule a, Term, Term)
-
-superImpose :: RewriteRule a -> RewriteRule a -> [Navigator Term]
-superImpose r1 r2 = rec (navigator lhs1)
- where
-    lhs1 :~> _ = ruleSpecTerm r1
-    lhs2 :~> _ = ruleSpecTerm (renumber r1 r2)
-
-    rec ca = case current ca of
-                Just (TMeta _) -> []
-                Just a -> maybe [] (return . (`subTop` ca)) (unify a lhs2) ++ concatMap rec (allDowns ca)
-                Nothing -> []
-
-    subTop s ca = fromMaybe ca $
-       fmap (change (s |->)) (top ca) >>= navigateTo (location ca)
-
-    renumber r = case metaInRewriteRule r of
-                    [] -> id
-                    xs -> renumberRewriteRule (maximum xs + 1)
-
-criticalPairs :: [RewriteRule a] -> [(Term, Pair a, Pair a)]
-criticalPairs rs =
-   [ (a, (r1, b1), (r2, b2))
-   | r1       <- rs
-   , r2       <- rs
-   , na <- superImpose r1 r2
-   , compareId r1 r2 == LT || not (null (location na))
-   , a  <- leave na
-   , b1 <- rewriteTerm r1 a
-   , b2 <- changeM (rewriteTerm r2) na >>= leave
-   ]
-
-noDiamondPairs :: Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)]
-noDiamondPairs cfg rs = noDiamondPairsWith (normalForm rs) cfg rs
-
-noDiamondPairsWith :: (Term -> Term) -> Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)]
-noDiamondPairsWith f cfg rs =
-   [ (a, (r1, e1, nf1), (r2, e2, nf2))
-   | (a, (r1, e1), (r2, e2)) <- criticalPairs rs
-   , let (nf1, nf2) = (f e1, f e2)
-   , not (termEquality cfg nf1 nf2)
-   ]
-
-reportPairs :: Config -> [(Term, Triple a, Triple a)] -> IO ()
-reportPairs cfg = putStrLn . unlines . zipWith report [1::Int ..]
- where
-   f = showTerm cfg
-   report i (a, (r1, e1, nf1), (r2, e2, nf2)) = unlines
-      [ show i ++ ") " ++ f a
-      , "  "   ++ showId r1
-      , "    " ++ f e1 ++ if e1==nf1 then "" else "   -->   " ++ f nf1
-      , "  "   ++ showId r2
-      , "    " ++ f e2 ++ if e2==nf2 then "" else "   -->   " ++ f nf2
-      ]
-
-----------------------------------------------------
-
-isConfluent :: [RewriteRule a] -> Bool
-isConfluent = null . noDiamondPairs defaultConfig
-
-checkConfluence :: [RewriteRule a] -> IO ()
-checkConfluence = checkConfluenceWith defaultConfig
-
-checkConfluenceWith :: Config -> [RewriteRule a] -> IO ()
-checkConfluenceWith cfg = reportPairs cfg . noDiamondPairs cfg
-
-data Config = Config
-   { showTerm     :: Term -> String
-   , complexity   :: Term -> Int
-   , termEquality :: Term -> Term -> Bool
-   }
-
-defaultConfig :: Config
-defaultConfig = Config show (const 0) (==)
-
-----------------------------------------------------
--- Example
-{-
-r1, r2, r3, r4, r5 :: RewriteRule SLogic
-r1 = rewriteRule "R1" $ \p q r -> p :||: (q :||: r) :~> (p :||: q) :||: r
-r2 = rewriteRule "R2" $ \p q   -> p :||: q :~> q :||: p
-r3 = rewriteRule "R3" $ \p     -> p :||: p :~> p
-r4 = rewriteRule "R4" $ \p     -> p :||: T :~> T
-r5 = rewriteRule "R5" $ \p     -> p :||: F :~> p
-
-this = [r1, r2, r3, r4, r5, r6]
-go = reportPairs $ noDiamondPairs this
-
-r6 :: RewriteRule SLogic
-r6 = rewriteRule "R6" $ \p -> p :||: T :~> F
-
-r1, r2, r3 :: RewriteRule Expr
-r1 = rewriteRule "a1" $ \a -> 0+a :~> a
-r2 = rewriteRule "a3" $ \a b c -> a+(b+c) :~> (a+b)+c
-r3 = rewriteRule "a2" $ \a -> a+0 :~> a
-
-go = do -- putStrLn $ unlines $ map show $ criticalPairs [r1,r2]
-        checkConfluence [r1,r2,r3]
--}
− src/Common/Rewriting/Difference.hs 
@@ -1,86 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Compute the difference of two terms generically, taking associativity
--- into account.
---
------------------------------------------------------------------------------
-module Common.Rewriting.Difference
-   ( difference, differenceEqual
-   , differenceWith, differenceEqualWith
-   ) where
-
-import Common.Rewriting.Term
-import Common.View
-import Control.Monad
-import Data.Function
-import Data.Maybe
-
-differenceWith :: View Term a -> a -> a -> Maybe (a, a)
-differenceWith = diff (\_ _ -> True)
-
-differenceEqualWith :: View Term a -> (a -> a -> Bool) -> a -> a -> Maybe (a, a)
-differenceEqualWith v eq p q = guard (eq p q) >> diff eq v p q
-
-difference :: IsTerm a => a -> a -> Maybe (a, a)
-difference = diff (\_ _ -> True) termView
-
--- | This function returns the difference, except that the
--- returned terms should be logically equivalent. Nothing can signal that
--- there is no difference, or that the terms to start with are not equivalent.
-differenceEqual :: IsTerm a => (a -> a -> Bool) -> a -> a -> Maybe (a, a)
-differenceEqual eq p q = do
-   guard (eq p q)
-   diff eq termView p q
-
-collectSym :: Symbol -> Term -> [Term]
-collectSym s a = maybe [a] (uncurry ((++) `on` collectSym s)) (isBinary s a)
-
--- local implementation function
-diff :: (a -> a -> Bool) -> View Term a -> a -> a -> Maybe (a, a)
-diff eq v a b = do
-   let eqT x y = fromMaybe False $ liftM2 eq (match v x) (match v y)
-   (t1, t2) <- diffTerm eqT (build v a) (build v b)
-   liftM2 (,) (match v t1) (match v t2)
-
-diffTerm :: (Term -> Term -> Bool) -> Term -> Term -> Maybe (Term, Term)
-diffTerm eq = rec
- where
-   rec p q =
-      case (getFunction p, getFunction q) of
-         (Just (s1, ps), Just (s2, qs))
-            | s1 /= s2         -> Just (p, q)
-            | isAssociative s1 -> (diffA s1 `on` collectSym s1) p q
-            | otherwise        -> diffList ps qs
-         _  | p == q           -> Nothing
-            | otherwise        -> Just (p, q)
-
-   diffList xs ys
-      | length xs /= length ys = Nothing
-      | otherwise =
-           case catMaybes (zipWith rec xs ys) of
-              [p] -> Just p
-              _   -> Nothing
-
-   diffA s = curry (make . rev . f . rev . f)
-    where
-      f (p:ps, q:qs) | not (null ps || null qs) &&
-                       isNothing (rec p q) &&
-                       equal ps qs =
-         f (ps, qs)
-      f pair = pair
-
-      equal     = eq `on` builder
-      rev       = reverse *** reverse
-      builder   = foldr1 (binary s)
-      make pair =
-         case pair of
-            ([p], [q]) -> rec p q
-            (ps, qs)   -> Just (builder ps, builder qs)
− src/Common/Rewriting/RewriteRule.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses,
-       FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Rewriting.RewriteRule
-   ( -- * Supporting type class
-     Different(..)
-     -- * Rewrite rules and specs
-   , RewriteRule, ruleSpecTerm, RuleSpec(..)
-     -- * Compiling rewrite rules
-   , rewriteRule, RuleBuilder(..)
-     -- * Using rewrite rules
-   , rewrite, rewriteM, showRewriteRule, smartGenerator
-   , metaInRewriteRule, renumberRewriteRule
-   ) where
-
-import Common.Classes
-import Common.Id
-import Common.Rewriting.Substitution
-import Common.Rewriting.Term
-import Common.Rewriting.Unification
-import Common.Utils.Uniplate (descend)
-import Common.View hiding (match)
-import Control.Monad
-import Test.QuickCheck
-import qualified Data.IntSet as IS
-
-------------------------------------------------------
--- Rewrite rules and specs
-
-infixl 1 :~>
-
-data RuleSpec a = a :~> a deriving Show
-
-instance Functor RuleSpec where
-   fmap f (a :~> b) = f a :~> f b
-
-data RewriteRule a = R
-   { ruleId         :: Id
-   , ruleSpecTerm   :: RuleSpec Term
-   , ruleShow       :: a -> String
-   , ruleTermView   :: View Term a
-   , smartGenerator :: Gen a
-   }
-
-instance Show (RewriteRule a) where
-   show = showId
-
-instance HasId (RewriteRule a) where
-   getId = ruleId
-   changeId f r = r {ruleId = f (ruleId r)}
-
-------------------------------------------------------
--- Compiling a rewrite rule
-
-class Different a where
-   different :: (a, a)
-
-instance Different a => Different [a] where
-   different = ([], [fst different])
-
-instance Different Char where
-   different = ('a', 'b')
-
-class (IsTerm a, Show a) => RuleBuilder t a | t -> a where
-   buildRuleSpec  :: Int -> t -> RuleSpec Term
-   buildGenerator :: t -> Gen a
-
-instance (IsTerm a, Show a) => RuleBuilder (RuleSpec a) a where
-   buildRuleSpec  = const $ fmap toTerm
-   buildGenerator (a :~> _) = return a
-
-instance (Arbitrary a, Different a, RuleBuilder t b) => RuleBuilder (a -> t) b where
-   buildRuleSpec i f = buildFunction i (buildRuleSpec (i+1) . f)
-   buildGenerator f  = liftM f arbitrary >>= buildGenerator
-
-buildFunction :: Different a => Int -> (a -> RuleSpec Term) -> RuleSpec Term
-buildFunction n f = fzip (fill n) ((f *** f) different)
- where
-   fzip g (a :~> b, c :~> d) = g a c :~> g b d
-
-fill :: Int -> Term -> Term -> Term
-fill i = rec
- where
-   rec (TApp f a) (TApp g b) = TApp (rec f g) (rec a b)
-   rec a b
-      | a == b    = a
-      | otherwise = TMeta i
-
-buildSpec :: RuleSpec Term -> Term -> [Term]
-buildSpec (lhs :~> rhs) a = do
-   s <- matchA lhs a
-   let (b1, b2) = (specialLeft `IS.member` dom s, specialRight `IS.member` dom s)
-       sym      = maybe (error "buildSpec") fst (getFunction lhs)
-       extLeft  x = if b1 then binary sym (TMeta specialLeft) x else x
-       extRight x = if b2 then binary sym x (TMeta specialRight) else x
-   return (s |-> extLeft (extRight rhs))
-
-rewriteRule :: (IsId n, RuleBuilder f a) => n -> f -> RewriteRule a
-rewriteRule s f = R (newId s) (buildRuleSpec 0 f) show termView (buildGenerator f)
-
-------------------------------------------------------
--- Using a rewrite rule
-
-instance Apply RewriteRule where
-   applyAll = rewrite
-
-rewrite :: RewriteRule a -> a -> [a]
-rewrite r a =
-   concatMap (fromTermRR r) $ buildSpec (ruleSpecTerm r) $ toTermRR r a
-
-rewriteM :: MonadPlus m => RewriteRule a -> a -> m a
-rewriteM r = msum . map return . rewrite r
-
------------------------------------------------------------
--- Pretty-print a rewriteRule
-
-showRewriteRule :: Bool -> RewriteRule a -> Maybe String
-showRewriteRule sound r = do
-   x <- fromTermRR r (sub |-> a)
-   y <- fromTermRR r (sub |-> b)
-   let op = if sound then "~>" else "/~>"
-   return (ruleShow r x ++ " " ++ op ++ " " ++ ruleShow r y)
- where
-   a :~> b = ruleSpecTerm r
-   vs  = IS.toList (metaVarSet a `IS.union` metaVarSet b)
-   sub = listToSubst $ zip vs [ TVar [c] | c <- ['a' ..] ]
-
-------------------------------------------------------
-
--- some helpers
-metaInRewriteRule :: RewriteRule a -> [Int]
-metaInRewriteRule r = metaVars a ++ metaVars b
- where a :~> b = ruleSpecTerm r
-
-renumberRewriteRule :: Int -> RewriteRule a -> RewriteRule a
-renumberRewriteRule n r = r {ruleSpecTerm = fmap f (ruleSpecTerm r)}
- where
-   f (TMeta i) = TMeta (i+n)
-   f term      = descend f term
-
-toTermRR :: RewriteRule a -> a -> Term
-toTermRR = build . ruleTermView
-
-fromTermRR :: Monad m => RewriteRule a -> Term -> m a
-fromTermRR = matchM . ruleTermView
− src/Common/Rewriting/Substitution.hs 
@@ -1,116 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Substitutions on terms. Substitutions are idempotent, and non-cyclic.
---
------------------------------------------------------------------------------
-module Common.Rewriting.Substitution
-   ( Substitution, emptySubst, singletonSubst, dom
-   , (@@), (|->), listToSubst, composable
-   , tests
-   ) where
-
-import Common.Rewriting.Term
-import Common.Utils.TestSuite
-import Common.Utils.Uniplate
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import Test.QuickCheck
-import qualified Data.IntMap as IM
-import qualified Data.IntSet as IS
-
------------------------------------------------------------
---- * Substitution
-
--- | Abstract data type for substitutions
-newtype Substitution = S { unS :: IM.IntMap Term }
-   deriving Eq
-
-instance Monoid Substitution where
-   mempty  = emptySubst
-   mappend = (@@)
-
-infixr 5 |->
-infixr 6 @@
-
-instance Show Substitution where
-   show = show . unS
-
--- | Returns the empty substitution
-emptySubst :: Substitution
-emptySubst = S IM.empty
-
--- | Returns a singleton substitution
-singletonSubst :: Int -> Term -> Substitution
-singletonSubst i a
-   | a == TMeta i        = emptySubst
-   | i `elem` metaVars a = error "Substitution: cyclic"
-   | otherwise           = S (IM.singleton i a)
-
--- | Turns a list into a substitution
-listToSubst :: [(Int, Term)] -> Substitution
-listToSubst = mconcat . map (uncurry singletonSubst)
-
--- | Combines two substitutions. The left-hand side substitution is first applied to
--- the co-domain of the right-hand side substitution
-(@@) :: Substitution -> Substitution -> Substitution
-s1 @@ s2
-   | composable s1 s2 = S $ IM.map (s1 |->) (unS s2) `IM.union` unS s1
-   | otherwise        = error "Substitution: cyclic"
-
-composable :: Substitution -> Substitution -> Bool
-composable s1 s2 =
-   let f = IS.unions . map metaVarSet . IM.elems . unS
-   in IS.null (IS.intersection (f s1) (dom s2))
-
--- | Lookups a variable in a substitution. Nothing indicates that the variable is
--- not in the domain of the substitution
-lookupVar :: Int -> Substitution -> Maybe Term
-lookupVar s = IM.lookup s . unS
-
--- | Returns the domain of a substitution (as a set)
-dom :: Substitution -> IS.IntSet
-dom = IM.keysSet . unS
-
--- | Apply the substitution
-(|->) :: Substitution -> Term -> Term
-s |-> term =
-   case term of
-      TMeta i -> fromMaybe term (lookupVar i s)
-      _       -> descend (s |->) term
-
------------------------------------------------------------
---- * Test substitution properties
-
-instance Arbitrary Substitution where
-   arbitrary = do
-      n  <- choose (1, 10)
-      ts <- vector n
-      let is = [0..] \\ concatMap metaVars ts
-      return (listToSubst (zip is ts))
-
-tests :: TestSuite
-tests = suite "Substitution" $ do
-   addProperty "left unit" $ \s ->
-      mempty @@ s == s
-   addProperty "right unit" $ \s ->
-      s @@ mempty == s
-   addProperty "associative" $ \s1 s2 s3 ->
-      composable s1 s2 && composable (s1 @@ s2) s3
-      && composable s2 s3 && composable s1 (s2 @@ s3)
-      ==> (s1 @@ s2) @@ s3 == s1 @@ (s2 @@ s3)
-   addProperty "idempotence" $ \s ->
-      s @@ s == s
-   addProperty "idempotence/application" $ \s a ->
-      s |-> a == s |-> (s |-> a)
-   addProperty "composition" $ \s1 s2 a ->
-      composable s1 s2
-      ==> s1 |-> (s2 |-> a) == (s1 @@ s2) |-> a
− src/Common/Rewriting/Term.hs 
@@ -1,267 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A simple data type for term rewriting
---
------------------------------------------------------------------------------
-module Common.Rewriting.Term
-   ( -- * Symbols
-     Symbol, newSymbol
-   , isAssociative, makeAssociative
-     -- * Terms
-   , Term(..), IsTerm(..), termView
-   , fromTermM, fromTermWith
-   , getSpine, makeTerm
-     -- * Functions and symbols
-   , WithFunctions(..), isSymbol, isFunction
-   , unary, binary, isUnary, isBinary
-     -- * Variables
-   , WithVars(..), isVariable
-   , vars, varSet, hasVar, withoutVar
-   , hasSomeVar, hasNoVar, variableView
-     -- * Meta variables
-   , WithMetaVars(..), isMetaVar
-   , metaVars, metaVarSet, hasMetaVar
-   ) where
-
-import Common.Id
-import Common.Utils (ShowString(..))
-import Common.Utils.QuickCheck
-import Common.Utils.Uniplate
-import Common.View
-import Control.Monad
-import Data.Function
-import Data.Maybe
-import Data.Typeable
-import qualified Data.IntSet as IS
-import qualified Data.Set as S
-
------------------------------------------------------------
--- Symbols
-
-data Symbol = S { isAssociative :: Bool, symbolId :: Id }
-
-instance Eq Symbol where
-   (==) = (==) `on` getId -- without associativity property
-
-instance Ord Symbol where
-   compare = compareId    -- without associativity property
-
-instance Show Symbol where
-   show = showId
-
-instance HasId Symbol where
-   getId = symbolId
-   changeId f (S b a) = S b (f a)
-
-newSymbol :: IsId a => a -> Symbol
-newSymbol = S False . newId
-
-makeAssociative :: Symbol -> Symbol
-makeAssociative (S _ a) = S True a
-
------------------------------------------------------------
--- * Data type for terms
-
-data Term = TVar   String
-          | TCon   Symbol
-          | TApp   Term Term
-          | TNum   Integer
-          | TFloat Double
-          | TMeta  Int
- deriving (Show, Eq, Ord, Typeable)
-
-instance Uniplate Term where
-   uniplate (TApp f a) = plate TApp |* f |* a
-   uniplate term       = plate term
-
------------------------------------------------------------
--- * Type class for conversion to/from terms
-
-class IsTerm a where
-   toTerm   :: a -> Term
-   fromTerm :: MonadPlus m => Term -> m a
-
-termView :: IsTerm a => View Term a
-termView = makeView fromTerm toTerm
-
-instance IsTerm Term where
-   toTerm   = id
-   fromTerm = return
-
-instance IsTerm ShowString where
-   toTerm = TVar . fromShowString
-   fromTerm (TVar s) = return (ShowString s)
-   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)
-
-instance IsTerm Int where
-   toTerm = TNum . fromIntegral
-   fromTerm = liftM fromInteger . fromTerm
-
-instance IsTerm Integer where
-   toTerm = TNum
-   fromTerm (TNum a) = return a
-   fromTerm _        = fail "fromTerm"
-
-instance IsTerm Double where
-   toTerm = TFloat
-   fromTerm (TFloat a) = return a
-   fromTerm _          = fail "fromTerm"
-
-fromTermM :: (Monad m, IsTerm a) => Term -> m a
-fromTermM = maybe (fail "fromTermM") return . fromTerm
-
-fromTermWith :: (Monad m, IsTerm a) => (Symbol -> [a] -> m a) -> Term -> m a
-fromTermWith f a = do
-   (s, xs) <- getFunction a
-   ys      <- mapM fromTermM xs
-   f s ys
-
------------------------------------------------------------
--- * Functions and symbols
-
-class WithFunctions a where
-   -- constructing
-   symbol   :: Symbol -> a
-   function :: Symbol -> [a] -> a
-   -- matching
-   getSymbol   :: Monad m => a -> m Symbol
-   getFunction :: Monad m => a -> m (Symbol, [a])
-   -- default definition
-   symbol s = function s []
-   getSymbol a =
-      case getFunction a of
-         Just (t, []) -> return t
-         _            -> fail "Common.Term.getSymbol"
-
-instance WithFunctions Term where
-   function = makeTerm . TCon
-   getFunction a =
-      case getSpine a of
-         (TCon s, xs) -> return (s, xs)
-         _            -> fail "Common.Rewriting.getFunction"
-
-isSymbol :: WithFunctions a => Symbol -> a -> Bool
-isSymbol s = maybe False (==s) . getSymbol
-
-isFunction :: (WithFunctions a, Monad m) => Symbol -> a -> m [a]
-isFunction s a =
-   case getFunction a of
-      Just (t, as) | s == t -> return as
-      _                     -> fail "Common.Term.isFunction"
-
-unary :: WithFunctions a => Symbol -> a -> a
-unary s a = function s [a]
-
-binary :: WithFunctions a => Symbol -> a -> a -> a
-binary s a b = function s [a, b]
-
-isUnary :: (WithFunctions a, Monad m) => Symbol -> a -> m a
-isUnary s a =
-   case isFunction s a of
-      Just [x] -> return x
-      _        -> fail "Common.Term.isUnary"
-
-isBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a)
-isBinary s a =
-   case isFunction s a of
-      Just [x, y] -> return (x, y)
-      _           -> fail "Common.Term.isBinary"
-
------------------------------------------------------------
--- * Variables
-
-class WithVars a where
-   variable     :: String -> a
-   getVariable  :: Monad m => a -> m String
-
-instance WithVars Term where
-   variable = TVar
-   getVariable (TVar s) = return s
-   getVariable _        = fail "Common.Rewriting.getVariable"
-
-isVariable :: WithVars a => a -> Bool
-isVariable = isJust . getVariable
-
-vars :: (Uniplate a, WithVars a) => a -> [String]
-vars = concatMap getVariable . universe
-
-varSet :: (Uniplate a, WithVars a) => a -> S.Set String
-varSet = S.fromList . vars
-
-hasVar :: (Uniplate a, WithVars a) => String -> a -> Bool
-hasVar i = (i `elem`) . vars
-
-withoutVar :: (Uniplate a, WithVars a) => String -> a -> Bool
-withoutVar i = not . hasVar i
-
-hasSomeVar :: (Uniplate a, WithVars a) => a -> Bool
-hasSomeVar = not . hasNoVar
-
-hasNoVar :: (Uniplate a, WithVars a) => a -> Bool
-hasNoVar = null . vars
-
-variableView :: WithVars a => View a String
-variableView = makeView getVariable variable
-
------------------------------------------------------------
--- * Meta variables
-
-class WithMetaVars a where
-   metaVar    :: Int -> a
-   getMetaVar :: Monad m => a -> m Int
-
-instance WithMetaVars Term where
-   metaVar = TMeta
-   getMetaVar (TMeta i) = return i
-   getMetaVar _         = fail "Common.Rewriting.getMetaVar"
-
-isMetaVar :: WithMetaVars a => a -> Bool
-isMetaVar = isJust . getMetaVar
-
-metaVars :: (Uniplate a, WithMetaVars a) => a -> [Int]
-metaVars = concatMap getMetaVar . universe
-
-metaVarSet :: (Uniplate a, WithMetaVars a) => a -> IS.IntSet
-metaVarSet = IS.fromList . metaVars
-
-hasMetaVar :: (Uniplate a, WithMetaVars a) => Int -> a -> Bool
-hasMetaVar i = (i `elem`) . metaVars
-
------------------------------------------------------------
--- * Utility functions
-
-getSpine :: Term -> (Term, [Term])
-getSpine = rec []
- where
-   rec xs (TApp f a) = rec (a:xs) f
-   rec xs a          = (a, xs)
-
-makeTerm :: Term -> [Term] -> Term
-makeTerm = foldl TApp
-
------------------------------------------------------------
--- * Arbitrary term generator
-
-instance Arbitrary Term where
-   arbitrary = generators
-      [ constGens $ map TVar ["x", "y", "z"]
-      , arbGen TNum, arbGen TFloat, arbGen TMeta
-      , constGens $ map (TCon . newSymbol) ["a", "b"]
-      , unaryGens $ map (unary . newSymbol) ["h", "k"]
-      , binaryGens $ map (binary . newSymbol) ["f", "g"]
-      ]
− src/Common/Rewriting/Unification.hs 
@@ -1,141 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Rewriting.Unification
-   ( unify, match, matchA, specialLeft, specialRight
-   , unificationTests
-   ) where
-
-import Common.Rewriting.AC (pairingsA)
-import Common.Rewriting.Substitution
-import Common.Rewriting.Term
-import Common.Utils.TestSuite
-import Control.Arrow
-import Control.Monad
-
------------------------------------------------------------
--- Unification (in both ways)
-
-unify :: Term -> Term -> Maybe Substitution
-unify term1 term2 =
-   case (term1, term2) of
-      (TMeta i, TMeta j) | i == j ->
-         return emptySubst
-      (TMeta i, _) | not (i `hasMetaVar` term2) ->
-         return (singletonSubst i term2)
-      (_, TMeta j) | not (j `hasMetaVar` term1) ->
-         return (singletonSubst j term1)
-      (TApp f a, TApp g b) -> do
-         s1 <- unify f g
-         s2 <- unify (s1 |-> a) (s1 |-> b)
-         return (s2 @@ s1)
-      _ | term1 == term2 ->
-         return emptySubst
-      _ -> Nothing
-
-match :: MonadPlus m => Term -> Term -> m Substitution
-match term1 term2 =
-   case (term1, term2) of
-      (TMeta i, TMeta j) | i == j ->
-         return emptySubst
-      (TMeta i, _) | not (i `hasMetaVar` term2) ->
-         return (singletonSubst i term2)
-      (_, TMeta _) ->
-         fail "unifyM: no unifier"
-      (TApp f a, TApp g b) -> do
-         s1 <- match f g
-         s2 <- match (s1 |-> a) b
-         guard (composable s1 s2)
-         return (s1 @@ s2)
-      _ | term1 == term2 ->
-         return emptySubst
-      _ -> fail "unifyM: no unifier"
-
------------------------------------------------------------
--- Matching (or: one-way unification)
-
--- second term should not have meta variables
-
-matchA :: Term -> Term -> [Substitution]
-matchA = rec True
- where
-   rec _ (TMeta i) y =
-      return (singletonSubst i y)
-
-   rec isTop x y =
-      case getSpine x of
-         (TCon s, [a1, a2]) | isAssociative s ->
-            concatMap (uncurry recList . unzip) (associativeMatch isTop s a1 a2 y)
-         (a, as) -> do
-            let (b, bs) = getSpine y
-            guard (a == b)
-            recList as bs
-
-   recList [] [] = return emptySubst
-   recList (x:xs) (y:ys) = do
-      s1 <- rec False x y
-      s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys)
-      return (s2 @@ s1)
-   recList _ _ = []
-
-associativeMatch :: Bool -> Symbol -> Term -> Term -> Term -> [[(Term, Term)]]
-associativeMatch isTop s1 a1 a2 (TApp (TApp (TCon s2) b1) b2)
-   | s1==s2 = map (map make) result
- where
-   as = collect a1 . collect a2 $ []
-   bs = collect b1 . collect b2 $ []
-   list | isTop     = map ($ as) [id, extLeft, extRight, extBoth]
-        | otherwise = [as]
-
-   extLeft  = (TMeta specialLeft:)
-   extRight = (++[TMeta specialRight])
-   extBoth  = extLeft . extRight
-
-   result = concatMap (\zs -> pairingsA True zs bs) list
-   make   = construct *** construct
-
-   collect term =
-      case getFunction term of
-         Just (t, [a, b]) | s1==t -> collect a . collect b
-         _ -> (term:)
-
-   construct xs
-      | null xs   = error "associativeMatcher: empty list"
-      | otherwise = foldr1 (binary s1) xs
-associativeMatch _ _ _ _ _ = []
-
-specialLeft, specialRight :: Int -- special meta variables for context extension
-specialLeft  = maxBound
-specialRight = pred specialLeft
-
------------------------------------------------------------
---- * Test unification properties
-
-unificationTests :: TestSuite
-unificationTests = suite "Unification" $ do
-   addProperty "unify" $ \a b ->
-      case unify a b of
-         Just s  -> (s |-> a) == (s |-> b)
-         Nothing -> True
-   addProperty "unify-succeed" $ \a s ->
-      let b = s |-> a in
-      case unify a b of
-         Just s2 -> (s2 |-> a) == (s2 |-> b)
-         Nothing -> False
-   addProperty "match" $ \a b ->
-      case match a b of
-         Just s  -> (s |-> a) == b
-         Nothing -> True
-   addProperty "match-succeed" $ \a s ->
-      let b = s |-> a in
-      case match a (s |-> a) of
-         Just s2 -> (s2 |-> a) == b
-         Nothing -> True
− src/Common/Strategy.hs 
@@ -1,54 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A strategy is a context-free grammar with rules as symbols. Strategies can be
--- labeled with strings. A type class is introduced to lift all the combinators
--- that work on strategies, only to prevent that you have to insert these lifting
--- functions yourself.
---
------------------------------------------------------------------------------
-module Common.Strategy
-   ( -- * Data types and type classes
-     Strategy, LabeledStrategy
-   , IsStrategy(..)
-     -- * Running strategies
-   , fullDerivationTree, derivationTree
-     -- * Strategy combinators
-     -- ** Basic combinators
-   , (<*>), (<|>), (<%>), succeed, fail, atomic, label
-   , sequence, alternatives, interleave, permute
-     -- ** EBNF combinators
-   , many, many1, replicate, option
-     -- ** Negation and greedy combinators
-   , check, not, repeat, repeat1, try, (|>), exhaustive
-   , while, until, multi
-     -- ** Traversal combinators
-   , fix, once, somewhere, topDown, bottomUp
-   , onceWith, somewhereWith
-     -- * Configuration combinators
-   , module Common.Strategy.Configuration
-     -- * Strategy locations
-   , strategyLocations, subStrategy
-   , subTaskLocation, nextTaskLocation
-     -- * Prefixes
-   , Prefix, emptyPrefix, makePrefix, prefixTree, Step(..)
-   , prefixToSteps, stepsToRules, lastStepInPrefix
-     -- * Misc
-   , cleanUpStrategy, cleanUpStrategyAfter
-   , rulesInStrategy, mapRules, mapRulesS
-   ) where
-
-import Common.Strategy.Abstract
-import Common.Strategy.Combinators
-import Common.Strategy.Configuration
-import Common.Strategy.Location
-import Common.Strategy.Parsing
-import Common.Strategy.Prefix
-import Prelude ()
− src/Common/Strategy/Abstract.hs 
@@ -1,236 +0,0 @@-{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Strategy.Abstract
-   ( Strategy, IsStrategy(..)
-   , LabeledStrategy, label, unlabel
-   , fullDerivationTree, derivationTree, rulesInStrategy
-   , mapRules, mapRulesS, mapRulesM, cleanUpStrategy, cleanUpStrategyAfter
-     -- Accessors to the underlying representation
-   , toCore, fromCore, liftCore, liftCore2, makeLabeledStrategy
-   , toLabeledStrategy
-   , LabelInfo, processLabelInfo, changeInfo, makeInfo
-   , removed, collapsed, hidden, IsLabeled(..), noInterleaving
-   ) where
-
-import Common.Classes
-import Common.DerivationTree
-import Common.Id
-import Common.Rewriting (RewriteRule)
-import Common.Strategy.Core
-import Common.Strategy.Parsing
-import Common.Transformation
-import Common.Utils (commaList)
-import Common.Utils.Uniplate hiding (rewriteM)
-import Control.Monad
-import Test.QuickCheck hiding (label)
-import qualified Data.Traversable as T
-
------------------------------------------------------------
---- Strategy data-type
-
--- | Abstract data type for strategies
-newtype Strategy a = S { toCore :: Core LabelInfo a }
-
-instance Show (Strategy a) where
-   show = show . toCore
-
-instance Apply Strategy where
-   applyAll = runCore . toCore
-
-instance (Arbitrary a, CoArbitrary a) => Arbitrary (Strategy a) where
-   arbitrary = liftM fromCore arbitrary
-
------------------------------------------------------------
---- The information used as label in a strategy
-
-data LabelInfo = Info
-   { labelId   :: Id
-   , removed   :: Bool
-   , collapsed :: Bool
-   , hidden    :: Bool
-   }
- deriving (Eq, Ord)
-
-instance Show LabelInfo where
-   show info =
-      let ps = ["removed"   | removed   info] ++
-               ["collapsed" | collapsed info] ++
-               ["hidden"    | hidden    info]
-          extra = " (" ++ commaList ps ++ ")"
-      in showId info ++ if null ps then "" else extra
-
-instance HasId LabelInfo where
-   getId = labelId
-   changeId f info = info { labelId = f (labelId info) }
-
-instance Arbitrary LabelInfo where
-   arbitrary = liftM (makeInfo :: Id -> LabelInfo) arbitrary
-
-makeInfo :: IsId a => a -> LabelInfo
-makeInfo s = Info (newId s) False False False
-
------------------------------------------------------------
---- Type class
-
--- | Type class to turn values into strategies
-class IsStrategy f where
-   toStrategy :: f a -> Strategy a
-
-instance IsStrategy Strategy where
-   toStrategy = id
-
-instance IsStrategy (LabeledStrategy) where
-  toStrategy (LS info (S core)) = S (Label info core)
-
-instance IsStrategy Rule where
-   toStrategy r
-      | isMajorRule r = toStrategy (toLabeled r)
-      | otherwise     = S (Rule r)
-
-instance IsStrategy RewriteRule where
-   toStrategy r =
-      toStrategy (makeRule (getId r) (makeRewriteTrans r))
-
------------------------------------------------------------
---- Labeled Strategy data-type
-
--- | A strategy which is labeled with a string
-data LabeledStrategy a = LS
-   { labelInfo :: LabelInfo  -- ^ Returns information associated with this label
-   , unlabel   :: Strategy a -- ^ Removes the label from a strategy
-   }
-
-makeLabeledStrategy :: IsStrategy f => LabelInfo -> f a -> LabeledStrategy a
-makeLabeledStrategy info = LS info . toStrategy
-
-toLabeledStrategy :: Monad m => Strategy a -> m (LabeledStrategy a)
-toLabeledStrategy s =
-   case toCore s of
-      Label l c -> return (makeLabeledStrategy l (fromCore c))
-      _         -> fail "Strategy without label"
-
-instance Show (LabeledStrategy a) where
-   show s = show (labelInfo s) ++ ": " ++ show (unlabel s)
-
-instance Apply LabeledStrategy where
-   applyAll = applyAll . toStrategy
-
-instance HasId (LabeledStrategy a) where
-   getId = getId . labelInfo
-   changeId = changeInfo . changeId
-
-class IsLabeled f where
-   toLabeled :: f a -> LabeledStrategy a
-
-instance IsLabeled LabeledStrategy where
-   toLabeled = id
-
-instance IsLabeled Rule where
-   toLabeled r = LS (makeInfo (getId r)) (S (Rule r))
-
-instance IsLabeled RewriteRule where
-   toLabeled r = toLabeled (makeRule (getId r) (makeRewriteTrans r))
-
--- | Labels a strategy with a string
-label :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a
-label l = LS (makeInfo l) . toStrategy
-
-changeInfo :: IsLabeled f => (LabelInfo -> LabelInfo) -> f a -> LabeledStrategy a
-changeInfo f a = LS (f info) s
- where LS info s = toLabeled a
-
------------------------------------------------------------
---- Process Label Information
-
-processLabelInfo :: (l -> LabelInfo) -> Core l a -> Core l a
-processLabelInfo getInfo = rec []
- where
-   rec env core =
-      case core of
-         Rec n a   -> Rec n (rec ((n, core):env) a)
-         Label l a -> forLabel env l (rec env a)
-         _ -> descend (rec env) core
-
-   forLabel env l c
-      | removed info   = Fail
-      | collapsed info = Label l (Rule asRule) -- !!
-      | otherwise      = new
-    where
-      new | hidden info = fmap minorRule (Label l c)
-          | otherwise   = Label l c
-      info   = getInfo l
-      asRule = makeSimpleRuleList (getId info) (runCore (subst new))
-      subst  = flip (foldl (flip (uncurry substCoreVar))) env
-
------------------------------------------------------------
---- Remaining functions
-
--- | Returns the derivation tree for a strategy and a term, including all
--- minor rules
-fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Step LabelInfo a) a
-fullDerivationTree = make . processLabelInfo id . toCore . toStrategy
- where
-   make core = fmap value . parseDerivationTree . makeState core
-
--- | Returns the derivation tree for a strategy and a term with only major rules
-derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a
-derivationTree s = mergeMaybeSteps . mapFirst f . fullDerivationTree s
- where
-   f (RuleStep r) | isMajorRule r = Just r
-   f _ = Nothing
-
--- | Returns a list of all major rules that are part of a labeled strategy
-rulesInStrategy :: IsStrategy f => f a -> [Rule a]
-rulesInStrategy f = [ r | Rule r <- universe (toCore (toStrategy f)), isMajorRule r ]
-
--- | Apply a function to all the rules that make up a labeled strategy
-mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b
-mapRules f (LS n s) = LS n (mapRulesS f s)
-
-mapRulesS :: (Rule a -> Rule b) -> Strategy a -> Strategy b
-mapRulesS f = S . fmap f . toCore
-
-mapRulesM :: Monad m => (Rule a -> m (Rule a)) -> Strategy a -> m (Strategy a)
-mapRulesM f = liftM S . T.mapM f . toCore
-
--- | Use a function as do-after hook for all rules in a labeled strategy, but
--- also use the function beforehand
-cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a
-cleanUpStrategy f (LS n s) = cleanUpStrategyAfter f (LS n (make s))
- where
-   make = liftCore2 (.*.) (doAfter f idRule)
-
--- | Use a function as do-after hook for all rules in a labeled strategy
-cleanUpStrategyAfter :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a
-cleanUpStrategyAfter f = mapRules $ \r ->
-   if isMajorRule r then doAfter f r else r
-
-noInterleaving :: IsStrategy f => f a -> Strategy a
-noInterleaving = liftCore $ transform f
-   where
-      f (a :%:  b) = a :*: b
-      f (a :!%: b) = a :*: b
-      f (Atomic a) = a
-      f s          = s
-
------------------------------------------------------------
---- Functions to lift the core combinators
-
-fromCore :: Core LabelInfo a -> Strategy a
-fromCore = S
-
-liftCore :: IsStrategy f => (Core LabelInfo a -> Core LabelInfo a) -> f a -> Strategy a
-liftCore f = fromCore . f . toCore . toStrategy
-
-liftCore2 :: (IsStrategy f, IsStrategy g) => (Core LabelInfo a -> Core LabelInfo a -> Core LabelInfo a) -> f a -> g a -> Strategy a
-liftCore2 f = liftCore . f . toCore . toStrategy
− src/Common/Strategy/Combinators.hs 
@@ -1,183 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A collection of strategy combinators: all lifted to work on different
--- data types
---
------------------------------------------------------------------------------
-module Common.Strategy.Combinators where
-
-import Common.Context
-import Common.Id
-import Common.Navigator
-import Common.Strategy.Abstract
-import Common.Strategy.Configuration
-import Common.Strategy.Core
-import Common.Transformation
-import Data.Maybe
-import Prelude hiding (not, repeat, fail, sequence)
-import qualified Prelude
-
------------------------------------------------------------
---- Strategy combinators
-
--- Basic combinators --------------------------------------
-
-infixr 2 <%>
-infixr 3 <|>
-infixr 4  |>
-infixr 5 <*>
-
--- | Put two strategies in sequence (first do this, then do that)
-(<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
-(<*>) = liftCore2 (.*.)
-
--- | Choose between the two strategies (either do this or do that)
-(<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
-(<|>) = liftCore2 (.|.)
-
--- | Interleave two strategies
-(<%>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
-(<%>) = liftCore2 (.%.)
-
--- | The strategy that always succeeds (without doing anything)
-succeed :: Strategy a
-succeed = fromCore Succeed
-
--- | The strategy that always fails
-fail :: Strategy a
-fail = fromCore Fail
-
--- | Makes a strategy atomic (w.r.t. parallel composition)
-atomic :: IsStrategy f => f a -> Strategy a
-atomic = liftCore Atomic
-
--- | Puts a list of strategies into a sequence
-sequence :: IsStrategy f => [f a] -> Strategy a
-sequence = foldr ((<*>) . toStrategy) succeed
-
--- | Combines a list of alternative strategies
-alternatives :: IsStrategy f => [f a] -> Strategy a
-alternatives = foldr ((<|>) . toStrategy) fail
-
--- | Merges a list of strategies (in parallel)
-interleave :: IsStrategy f => [f a] -> Strategy a
-interleave = foldr ((<%>) . toStrategy) succeed
-
--- | Allows all permutations of the list
-permute :: IsStrategy f => [f a] -> Strategy a
-permute = foldr ((<%>) . atomic) succeed
-
--- EBNF combinators --------------------------------------
-
--- | Repeat a strategy zero or more times (non-greedy)
-many :: IsStrategy f => f a -> Strategy a
-many = liftCore Many
-
--- | Apply a certain strategy at least once (non-greedy)
-many1 :: IsStrategy f => f a -> Strategy a
-many1 s = s <*> many s
-
--- | Apply a strategy a certain number of times
-replicate :: IsStrategy f => Int -> f a -> Strategy a
-replicate n = sequence . Prelude.replicate n
-
--- | Apply a certain strategy or do nothing (non-greedy)
-option :: IsStrategy f => f a -> Strategy a
-option s = s <|> succeed
-
--- Negation and greedy combinators ----------------------
-
--- | Checks whether a predicate holds for the current term. The
---   check is considered to be a minor step.
-check :: (a -> Bool) -> Strategy a
-check p = toStrategy (checkRule p)
-
--- | Check whether or not the argument strategy cannot be applied: the result
---   strategy only succeeds if this is not the case (otherwise it fails).
-not :: IsStrategy f => f a -> Strategy a
-not = liftCore (Not . noLabels)
-
--- | Repeat a strategy zero or more times (greedy version of 'many')
-repeat :: IsStrategy f => f a -> Strategy a
-repeat = liftCore Repeat
-
--- | Apply a certain strategy at least once (greedy version of 'many1')
-repeat1 :: IsStrategy f => f a -> Strategy a
-repeat1 s = s <*> repeat s
-
--- | Apply a certain strategy if this is possible (greedy version of 'option')
-try :: IsStrategy f => f a -> Strategy a
-try s = s |> succeed
-
--- | Left-biased choice: if the left-operand strategy can be applied, do so. Otherwise,
---   try the right-operand strategy
-(|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
-(|>) = liftCore2 (:|>:)
-
--- | Repeat the strategy as long as the predicate holds
-while :: IsStrategy f => (a -> Bool) -> f a -> Strategy a
-while p s = repeat (check p <*> s)
-
--- | Repeat the strategy until the predicate holds
-until :: IsStrategy f => (a -> Bool) -> f a -> Strategy a
-until p = while (Prelude.not . p)
-
--- | Apply a strategy at least once, but collapse into a single step
-multi :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a
-multi s = collapse . label s . repeat1
-
--- | Apply the strategies from the list exhaustively (until this is no longer possible)
-exhaustive :: IsStrategy f => [f a] -> Strategy a
-exhaustive = repeat . alternatives
-
--- Traversal combinators --------------------------------------------
-
--- | A fix-point combinator on strategies (to model recursion). Powerful
--- (but dangerous) combinator
-fix :: (Strategy a -> Strategy a) -> Strategy a
-fix f = fromCore (coreFix (toCore . f . fromCore))
-
--- | Apply a strategy on (exactly) one of the term's direct children. The
--- function selects which children are visited.
-onceWith :: IsStrategy f => String -> (Context a -> [Int]) -> f (Context a) -> Strategy (Context a)
-onceWith n f s = ruleMoveDown <*> s <*> ruleMoveUp
- where
-   ruleMoveDown = minorRule $ makeSimpleRuleList ("navigation.down." ++ n) $ \a ->
-      concatMap (`down` a) (f a)
-   ruleMoveUp = minorRule $ makeSimpleRule "navigation.up" $ \a ->
-      Just (fromMaybe a (up a))
-
--- | Apply a strategy somewhere in the term. The function selects which
--- children are visited
-somewhereWith :: IsStrategy f => String -> (Context a -> [Int]) -> f (Context a) -> Strategy (Context a)
-somewhereWith n f s = fix $ \this -> s <|> onceWith n f this
-
--- | Apply a strategy on (exactly) one of the term's direct children
-once :: IsStrategy f => f (Context a) -> Strategy (Context a)
-once = onceWith "all" visitAll
-
--- | Apply a strategy somewhere in the term
-somewhere :: IsStrategy f => f (Context a) -> Strategy (Context a)
-somewhere = somewhereWith "all" visitAll
-
--- local helper
-visitAll :: Context a -> [Int]
-visitAll a = [ 0 .. arity a-1 ]
-
--- | Search for a suitable location in the term to apply the strategy using a
--- top-down approach
-topDown :: IsStrategy f => f (Context a) -> Strategy (Context a)
-topDown s = fix $ \this -> s |> once this
-
--- | Search for a suitable location in the term to apply the strategy using a
--- bottom-up approach
-bottomUp :: IsStrategy f => f (Context a) -> Strategy (Context a)
-bottomUp s = fix $ \this -> once this |> s
− src/Common/Strategy/Configuration.hs 
@@ -1,109 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Common.Strategy.Configuration
-   ( -- Types and constructors
-     StrategyConfiguration, ConfigItem
-   , ConfigLocation, byName, byGroup
-   , ConfigAction(..), configActions
-     --  Configure
-  ,  configure, configureNow
-     -- Combinators
-   , remove, reinsert, collapse, expand, hide, reveal
-   ) where
-
-import Common.Classes
-import Common.Id
-import Common.Strategy.Abstract
-import Common.Strategy.Core
-import Data.Maybe
-
----------------------------------------------------------------------
--- Types and constructors
-
-type StrategyConfiguration = [ConfigItem]
-type ConfigItem = (ConfigLocation, ConfigAction)
-
-data ConfigLocation
-   = ByName  Id
-   | ByGroup Id
- deriving Show
-
-data ConfigAction = Remove | Reinsert | Collapse | Expand | Hide | Reveal
-   deriving (Show, Enum)
-
-configActions :: [ConfigAction]
-configActions = [Remove .. ]
-
-byName :: HasId a => a -> ConfigLocation
-byName = ByName . getId
-
-byGroup :: HasId a => a -> ConfigLocation
-byGroup = ByGroup . getId
-
----------------------------------------------------------------------
--- Configure
-
-configureNow :: LabeledStrategy a -> LabeledStrategy a
-configureNow =
-   let lsToCore = toCore . toStrategy
-       coreToLS = fromMaybe err . toLabeledStrategy . fromCore
-       err      = error "configureNow: label disappeared"
-   in coreToLS . processLabelInfo id . lsToCore
-
-configure :: StrategyConfiguration -> LabeledStrategy a -> LabeledStrategy a
-configure cfg ls =
-   label (getId ls) (fromCore (configureCore cfg (toCore (unlabel ls))))
-
-configureCore :: StrategyConfiguration -> Core LabelInfo a -> Core LabelInfo a
-configureCore cfg = mapFirst (change [])
- where
-   change groups info =
-      let actions = getActions info groups cfg
-      in foldr doAction info actions
-
-getActions :: LabelInfo -> [String]
-           -> StrategyConfiguration -> [ConfigAction]
-getActions info groups = map snd . filter (select . fst)
- where
-   select (ByName a)  = getId info == a
-   select (ByGroup s) = showId s `elem` groups
-
-doAction :: ConfigAction -> LabelInfo -> LabelInfo
-doAction action =
-   case action of
-      Remove   -> setRemoved True
-      Reinsert -> setRemoved False
-      Collapse -> setCollapsed True
-      Expand   -> setCollapsed False
-      Hide     -> setHidden True
-      Reveal   -> setHidden False
-
----------------------------------------------------------------------
--- Configuration combinators
-
-remove, reinsert :: IsLabeled f => f a -> LabeledStrategy a
-remove   = changeInfo (doAction Remove)
-reinsert = changeInfo (doAction Reinsert)
-
-collapse, expand :: IsLabeled f => f a -> LabeledStrategy a
-collapse = changeInfo (doAction Collapse)
-expand   = changeInfo (doAction Expand)
-
-hide, reveal :: IsLabeled f => f a -> LabeledStrategy a
-hide   = changeInfo (doAction Hide)
-reveal = changeInfo (doAction Reveal)
-
--- helpers
-setRemoved, setCollapsed, setHidden :: Bool -> LabelInfo -> LabelInfo
-setRemoved   b info = info {removed   = b}
-setCollapsed b info = info {collapsed = b}
-setHidden    b info = info {hidden    = b}
− src/Common/Strategy/Core.hs 
@@ -1,199 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- The core strategy combinators. This module defines the interal data
--- structure of a strategy, and some utility functions that operate
--- directly on it.
---
------------------------------------------------------------------------------
-module Common.Strategy.Core
-   ( GCore(..), Core
-   , (.|.), (.*.), (.%.)
-   , coreMany, coreRepeat, coreOrElse, coreFix
-   , noLabels, substCoreVar
-   ) where
-
-import Common.Classes
-import Common.Transformation
-import Common.Utils.QuickCheck
-import Common.Utils.Uniplate
-import Control.Applicative
-import qualified Data.Foldable as F
-import qualified Data.Traversable as T
-
------------------------------------------------------------------
--- Strategy (internal) data structure, containing a selection
--- of combinators
-
-infixr 2 :%:, :!%:, .%.
-infixr 3 :|:, :|>:, .|.
-infixr 5 :*:, .*.
-
--- | Core expression, with rules
-type Core l a = GCore l (Rule a)
-
--- | A generalized Core expression, not restricted to rules. This makes GCore
--- a (traversable and foldable) functor.
-data GCore l a
-   = GCore l a :*:  GCore l a
-   | GCore l a :|:  GCore l a
-   | GCore l a :|>: GCore l a
-   | GCore l a :%:  GCore l a -- interleave
-   | GCore l a :!%: GCore l a -- interleave-first-from-left
-   | Many    (GCore l a)
-   | Repeat  (GCore l a)
-   | Not     (GCore l a)
-   | Label l (GCore l a)
-   | Atomic  (GCore l a)
-   | Succeed
-   | Fail
-   | Rule a -- ^ Generalized constructor (not restricted to rules)
-   | Var Int
-   | Rec Int (GCore l a)
- deriving Show
-
------------------------------------------------------------------
--- Useful instances
-
-instance Functor (GCore l) where
-   fmap = mapSecond
-
-instance Uniplate (GCore l a) where
-   uniplate core =
-      case core of
-         a :*: b   -> plate (:*:)  |* a |* b
-         a :|: b   -> plate (:|:)  |* a |* b
-         a :|>: b  -> plate (:|>:) |* a |* b
-         a :%: b   -> plate (:%:)  |* a |* b
-         a :!%: b  -> plate (:!%:) |* a |* b
-         Many a    -> plate Many   |* a
-         Repeat a  -> plate Repeat |* a
-         Label l a -> plate Label  |- l |* a
-         Atomic a  -> plate Atomic |* a
-         Rec n a   -> plate Rec    |- n |* a
-         Not a     -> plate Not    |* a
-         _         -> plate core
-
-instance BiFunctor GCore where
-   biMap f g = rec
-    where
-      rec core =
-         case core of
-            a :*: b   -> rec a :*:  rec b
-            a :|: b   -> rec a :|:  rec b
-            a :|>: b  -> rec a :|>: rec b
-            a :%: b   -> rec a :%:  rec b
-            a :!%: b  -> rec a :!%: rec b
-            Many a    -> Many   (rec a)
-            Repeat a  -> Repeat (rec a)
-            Not a     -> Not    (rec a)
-            Atomic a  -> Atomic (rec a)
-            Rec n a   -> Rec n  (rec a)
-            Label l a -> Label (f l) (rec a)
-            Rule a    -> Rule (g a)
-            Var n     -> Var n
-            Succeed   -> Succeed
-            Fail      -> Fail
-
-instance T.Traversable (GCore l) where
-   traverse f core =
-      case core of
-         a :*: b   -> (:*:)   <$> T.traverse f a <*> T.traverse f b
-         a :|: b   -> (:|:)   <$> T.traverse f a <*> T.traverse f b
-         a :|>: b  -> (:|>:)  <$> T.traverse f a <*> T.traverse f b
-         a :%: b   -> (:%:)   <$> T.traverse f a <*> T.traverse f b
-         a :!%: b  -> (:!%:)  <$> T.traverse f a <*> T.traverse f b
-         Many a    -> Many    <$> T.traverse f a
-         Repeat a  -> Repeat  <$> T.traverse f a
-         Label l a -> Label l <$> T.traverse f a
-         Atomic a  -> Atomic  <$> T.traverse f a
-         Rec n a   -> Rec n   <$> T.traverse f a
-         Not a     -> Not     <$> T.traverse f a
-         Rule r    -> Rule    <$> f r
-         Succeed   -> pure Succeed
-         Fail      -> pure Fail
-         Var n     -> pure $ Var n
-
-instance F.Foldable (GCore l) where
-   foldMap = T.foldMapDefault
-
-instance (Arbitrary l, Arbitrary a) => Arbitrary (GCore l a) where
-   arbitrary = generators
-      [ constGens [Succeed, Fail]
-      , unaryGen Atomic, arbGen Rule, unaryArbGen Label
-      , binaryGens [(:*:), (:|:), (:%:)]
-      ]
-
------------------------------------------------------------------
--- Smart constructors
-
-(.|.) :: GCore l a -> GCore l a -> GCore l a
-Fail .|. b    = b
-a    .|. Fail = a
-a    .|. b    = a :|: b
-
-(.*.) :: GCore l a -> GCore l a -> GCore l a
-Fail    .*. _       = Fail
-Succeed .*. b       = b
-_       .*. Fail    = Fail
-a       .*. Succeed = a
-a       .*. b       = a :*: b
-
-(.%.) :: GCore l a -> GCore l a -> GCore l a
-Fail    .%. _       = Fail
-Succeed .%. b       = b
-_       .%. Fail    = Fail
-a       .%. Succeed = a
-a       .%. b       = a :%: b
-
------------------------------------------------------------------
--- Definitions
-
-coreMany :: GCore l a -> GCore l a
-coreMany a = Rec n (Succeed :|: (a :*: Var n))
- where n = nextVar a
-
-coreRepeat :: GCore l a -> GCore l a
-coreRepeat a = Many a :*: Not a
-
-coreOrElse :: GCore l a -> GCore l a -> GCore l a
-coreOrElse a b = a :|: (Not a :*: b)
-
-coreFix :: (GCore l a -> GCore l a) -> GCore l a
-coreFix f = -- disadvantage: function f is applied twice
-   let i = nextVar (f (Var (-1)))
-   in Rec i (f (Var i))
-
------------------------------------------------------------------
--- Utility functions
-
-substCoreVar :: Int -> GCore l a -> GCore l a -> GCore l a
-substCoreVar i a core =
-   case core of
-      Var j   | i==j -> a
-      Rec j _ | i==j -> core
-      _              -> descend (substCoreVar i a) core
-
-nextVar :: GCore l a -> Int
-nextVar p
-   | null xs   = 0
-   | otherwise = maximum xs + 1
- where xs = coreVars p
-
-coreVars :: GCore l a -> [Int]
-coreVars core =
-   case core of
-      Var n   -> [n]
-      Rec n a -> n : coreVars a
-      _       -> concatMap coreVars (children core)
-
-noLabels :: GCore l a -> GCore l a
-noLabels (Label _ a) = noLabels a
-noLabels core        = descend noLabels core
− src/Common/Strategy/Location.hs 
@@ -1,80 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Locations in a strategy
---
------------------------------------------------------------------------------
-module Common.Strategy.Location
-   ( subTaskLocation, nextTaskLocation
-   , strategyLocations, subStrategy
-   ) where
-
-import Common.Id
-import Common.Strategy.Abstract
-import Common.Strategy.Core
-import Common.Utils (safeHead)
-import Common.Utils.Uniplate
-import Data.Maybe
-
------------------------------------------------------------
---- Strategy locations
-
--- old (current) and actual (next major rule) location
-subTaskLocation :: LabeledStrategy a -> Id -> Id -> Id
-subTaskLocation s xs ys = g (rec (f xs) (f ys))
- where
-   f = fromMaybe [] . toLoc s
-   g = fromMaybe (getId s) . fromLoc s
-   rec (i:is) (j:js)
-      | i == j    = i : rec is js
-      | otherwise = []
-   rec _ (j:_)    = [j]
-   rec _ _        = []
-
--- old (current) and actual (next major rule) location
-nextTaskLocation :: LabeledStrategy a -> Id -> Id -> Id
-nextTaskLocation s xs ys = g (rec (f xs) (f ys))
- where
-   f = fromMaybe [] . toLoc s
-   g = fromMaybe (getId s) . fromLoc s
-   rec (i:is) (j:js)
-      | i == j    = i : rec is js
-      | otherwise = [j]
-   rec _ _        = []
-
--- | Returns a list of all strategy locations, paired with the labeled
--- substrategy at that location
-strategyLocations :: LabeledStrategy a -> [([Int], LabeledStrategy a)]
-strategyLocations s = ([], s) : rec [] (toCore (unlabel s))
- where
-   rec is = concat . zipWith make (map (:is) [0..]) . collect
-
-   make is (l, core) =
-      let ls  = makeLabeledStrategy l (fromCore core)
-      in (is, ls) : rec is core
-
-   collect core =
-      case core of
-         Label l t -> [(l, t)]
-         Not _     -> []
-         _         -> concatMap collect (children core)
-
--- | Returns the substrategy or rule at a strategy location. Nothing
--- indicates that the location is invalid
-subStrategy :: Id -> LabeledStrategy a -> Maybe (LabeledStrategy a)
-subStrategy loc =
-   fmap snd . safeHead . filter ((==loc) . getId . snd) . strategyLocations
-
-fromLoc :: LabeledStrategy a -> [Int] -> Maybe Id
-fromLoc s loc = fmap getId (lookup loc (strategyLocations s))
-
-toLoc :: LabeledStrategy a -> Id -> Maybe [Int]
-toLoc s i =
-   fmap fst (safeHead (filter ((==i) . getId . snd) (strategyLocations s)))
− src/Common/Strategy/Parsing.hs 
@@ -1,281 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Basic machinery for executing a core strategy expression.
---
------------------------------------------------------------------------------
-module Common.Strategy.Parsing
-   ( Step(..)
-   , State, makeState, stack, choices, trace, value
-   , parseDerivationTree, replay, runCore
-   , firsts, Result(..), isReady
-   ) where
-
-import Common.Classes
-import Common.DerivationTree
-import Common.Strategy.Core
-import Common.Transformation
-import Common.Utils.Uniplate
-import Control.Arrow
-import Control.Monad
-
-----------------------------------------------------------------------
--- Step data type
-
-data Step l a = Enter l | Exit l | RuleStep (Rule a)
-   deriving (Show, Eq, Ord)
-
--- A core expression where the symbols are steps instead of "only" rules
-type StepCore l a = GCore l (Step l a)
-
-instance Apply (Step l) where
-   applyAll (RuleStep r) = applyAll r
-   applyAll _            = return
-
-----------------------------------------------------------------------
--- State data type
-
-data State l a = S
-   { stack   :: Stack l a
-   , choices :: [Bool]
-   , trace   :: [Step l a]
-   , timeout :: !Int
-   , value   :: a
-   } deriving Show
-
-data Stack l a = Stack
-   { active    :: [StepCore l a] -- the active items, performed in sequence
-   , suspended :: [StepCore l a] -- suspended items, performed after a step from active
-   , remainder :: [StepCore l a] -- remaining items: must be empty if there are no suspended items
-   } deriving Show
-
-makeState :: Core l a -> a -> State l a
-makeState = newState . fmap RuleStep
-
-newState :: StepCore l a -> a -> State l a
-newState core a = push core (S emptyStack [] [] 0 a)
-
-----------------------------------------------------------------------
--- Parse derivation tree
-
-parseDerivationTree :: State l a -> DerivationTree (Step l a) (State l a)
-parseDerivationTree = makeTree $ \state ->
-   let xs = firsts state
-   in ( any (isReady . fst) xs
-      , [ (step, s) | (Result step, s) <- xs ]
-      )
-
-firsts :: State l a -> [(Result (Step l a), State l a)]
-firsts st =
-   case pop st of
-      Nothing        -> [(Ready, st)]
-      Just (core, s) -> firstsStep core s
- where
-   firstsStep core state =
-      case core of
-         a :*: b   -> firstsStep a (push b state)
-         a :|: b   -> chooseFor True a ++ chooseFor False b
-         a :%: b   -> firstsStep (coreInterleave a b) state
-         a :!%: b  -> firstsStep a (suspend b state)
-         Rec i a   -> incrTimer state >>= firstsStep (substCoreVar i core a)
-         Var _     -> freeCoreVar "firsts"
-         Rule r    -> hasStep r
-         Label l a -> firstsStep (coreLabel l a) state
-         Atomic a  -> firstsStep a (useAtomic state)
-         Not a     -> guard (checkNot a state) >> firsts state
-         a :|>: b  -> firstsStep (coreOrElse a b) state
-         Many a    -> firstsStep (coreMany a) state
-         Repeat a  -> firstsStep (coreRepeat a) state
-         Fail      -> []
-         Succeed   -> firsts state
-    where
-      chooseFor b  = flip firstsStep (makeChoice b state)
-      hasStep step = [ (Result step, s) | s <- useRule step (traceStep step state) ]
-
--- helper datatype
-data Result a = Result a | Ready deriving  Show
-
-instance Functor Result where
-   fmap f (Result a) = Result (f a)
-   fmap _ Ready      = Ready
-
-isReady :: Result a -> Bool
-isReady Ready = True
-isReady _     = False
-
-----------------------------------------------------------------------
--- Running the parser
-
-runCore :: Core l a -> a -> [a]
-runCore core = runState . makeState core
-
-runState :: State l a -> [a]
-runState st =
-   case pop st of
-      Nothing        -> [value st]
-      Just (core, s) -> runStep core s
- where
-   runStep core state =
-      case core of
-         a :*: b   -> runStep a (push b state)
-         a :|: b   -> runStep a state ++ runStep b state
-         a :%: b   -> runStep (coreInterleave a b) state
-         a :!%: b  -> runStep a (suspend b state)
-         Rec i a   -> incrTimer state >>= runStep (substCoreVar i core a)
-         Var _     -> freeCoreVar "runState"
-         Rule  r   -> concatMap runState (useRule r (interleave r state))
-         Label _ a -> runStep a state
-         Atomic a  -> runStep a (useAtomic state)
-         Not a     -> guard (checkNot a state) >> runState state
-         a :|>: b  -> let xs = runStep a state
-                      in if null xs then runStep b state else xs
-         Many a    -> runStep (coreMany a) state
-         Repeat a  -> runStep (coreRepeat a) state
-         Fail      -> []
-         Succeed   -> runState state
-
-----------------------------------------------------------------------
--- Replay a parse run
-
-replay :: Monad m => Int -> [Bool] -> Core l a -> m (State l a)
-replay n0 bs0 = replayState n0 bs0 . flip makeState noValue
- where
-   noValue = error "no value in replay"
-
-   replayState n bs state =
-      case pop state of
-         _ | n==0       -> return state
-         Nothing        -> return state
-         Just (core, s) -> replayStep n bs core s
-
-   replayStep n bs core state =
-      case core of
-         _ | n==0  -> return state
-         a :*: b   -> replayStep n bs a (push b state)
-         a :|: b   -> case bs of
-                        []   -> fail "replay failed"
-                        x:xs -> let new = if x then a else b
-                                in replayStep n xs new (makeChoice x state)
-         a :%: b   -> replayStep n bs (coreInterleave a b) state
-         a :!%: b  -> replayStep n bs a (suspend b state)
-         Rec i a   -> replayStep n bs (substCoreVar i core a) state
-         Var _     -> freeCoreVar "replay"
-         Rule r    -> replayState (n-1) bs (traceStep r state)
-         Label l a -> replayStep n bs (coreLabel l a) state
-         Atomic a  -> replayStep n bs a (useAtomic state)
-         Not _     -> replayState n bs state
-         a :|>: b  -> replayStep n bs (coreOrElse a b) state
-         Many a    -> replayStep n bs (coreMany a) state
-         Repeat a  -> replayStep n bs (coreRepeat a) state
-         Fail      -> fail "replay failed"
-         Succeed   -> replayState n bs state
-
-----------------------------------------------------------------------
--- Core translations
-
-coreLabel :: l -> StepCore l a -> StepCore l a
-coreLabel l a = Rule (Enter l) :*: a :*: Rule (Exit l)
-
-coreInterleave :: StepCore l a -> StepCore l a -> StepCore l a
-coreInterleave a b = (a :!%: b) :|: (b :!%: a) :|: emptyOnly (a :*: b)
- where
-   emptyOnly core =
-      case core of
-         Rule step | interleaveAfter step -> Fail
-         Not _    -> core
-         x :|>: y -> emptyOnly x .|. (Not x :*: emptyOnly y)
-         Repeat x -> emptyOnly (coreRepeat x)
-         x :|: y  -> emptyOnly x .|. emptyOnly y
-         x :*: y  -> emptyOnly x .*. emptyOnly y
-         x :%: y  -> emptyOnly x .*. emptyOnly y -- no more interleaving
-         x :!%: y -> emptyOnly x .*. emptyOnly y -- no more interleaving
-         _        -> descend emptyOnly core
-
-----------------------------------------------------------------------
--- State functions
-
-push :: StepCore l a -> State l a -> State l a
-push = changeStack . pushStack
-
-suspend :: StepCore l a -> State l a -> State l a
-suspend = changeStack . suspendStack
-
-useAtomic :: State l a -> State l a
-useAtomic = changeStack interleaveStack
-
-pop :: State l a -> Maybe (StepCore l a, State l a)
-pop s = fmap (second f) (popStack (stack s))
- where f new = s {stack = new}
-
-makeChoice :: Bool -> State l a -> State l a
-makeChoice b s = s {choices = b : choices s}
-
-checkNot :: StepCore l a -> State l a -> Bool
-checkNot core = null . runState . newState core . value
-
-useRule :: Step l a -> State l a -> [State l a]
-useRule step state =
-   [ resetTimer state {value = b} | b <- applyAll step (value state) ]
-
-traceStep :: Step l a -> State l a -> State l a
-traceStep step s = interleave step s {trace = step : trace s}
-
-freeCoreVar :: String -> a
-freeCoreVar caller = error $ "Free var in core expression: " ++ caller
-
-incrTimer :: Monad m => State l a -> m (State l a)
-incrTimer s
-   | timeout s >= 20 = fail "timeout after 20 fixpoints"
-   | otherwise       = return (s {timeout = timeout s + 1})
-
-resetTimer :: State l a -> State l a
-resetTimer s = s {timeout = 0}
-
-interleaveAfter :: Step l a -> Bool
-interleaveAfter (RuleStep _) = True
-interleaveAfter _            = False
-
-interleave :: Step l a -> State l a -> State l a
-interleave step = if interleaveAfter step then useAtomic else id
-
-changeStack :: (Stack l a -> Stack l a) -> State l a -> State l a
-changeStack f s = s {stack = f (stack s)}
-
-----------------------------------------------------------------------
--- Stack functions
-
-emptyStack :: Stack l a
-emptyStack = Stack [] [] []
-
-pushStack :: StepCore l a -> Stack l a -> Stack l a
-pushStack core s = s {active = core : active s}
-
-suspendStack :: StepCore l a -> Stack l a -> Stack l a
-suspendStack core s
-   | null (active s) = s {suspended = core : suspended s}
-   | otherwise = emptyStack {suspended = [core], remainder = combineStack s}
-
-popStack :: Stack l a -> Maybe (StepCore l a, Stack l a)
-popStack s =
-   case active s of
-      x:xs -> Just (x, s {active = xs})
-      [] | null (suspended s) -> Nothing
-         | otherwise          -> Just (Fail, s)
-
-interleaveStack :: Stack l a -> Stack l a
-interleaveStack s = emptyStack {active = combineStack s}
-
-combineStack :: Stack l a -> [StepCore l a]
-combineStack s
-   | null (suspended s) = active s
-   | otherwise = front : remainder s
- where
-   actives = foldr (.*.) Succeed (active s)
-   front   = foldr (.%.) Succeed (actives:suspended s)
− src/Common/Strategy/Prefix.hs 
@@ -1,78 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A prefix encodes a sequence of steps already performed (a so-called trace),
--- and allows to continue the derivation at that particular point.
---
------------------------------------------------------------------------------
-module Common.Strategy.Prefix
-   ( Prefix, emptyPrefix, makePrefix
-   , prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix
-   ) where
-
-import Common.DerivationTree
-import Common.Strategy.Abstract
-import Common.Strategy.Parsing
-import Common.Transformation
-import Common.Utils
-import Control.Monad
-import Data.Maybe
-
------------------------------------------------------------
---- Prefixes
-
--- | Abstract data type for a (labeled) strategy with a prefix (a sequence of
--- executed rules). A prefix is still "aware" of the labels that appear in the
--- strategy. A prefix is encoded as a list of integers (and can be reconstructed
--- from such a list: see @makePrefix@). The list is stored in reversed order.
-data Prefix a = P (State LabelInfo a)
-
-prefixPair :: Prefix a -> (Int, [Bool])
-prefixPair (P s) = (length (trace s), reverse (choices s))
-
-prefixIntList :: Prefix a -> [Int]
-prefixIntList = f . prefixPair
- where
-   f (0, []) = []
-   f (n, bs) = n : map (\b -> if b then 0 else 1) bs
-
-instance Show (Prefix a) where
-   show = show . prefixIntList
-
-instance Eq (Prefix a) where
-   a == b = prefixPair a == prefixPair b
-
--- | Construct the empty prefix for a labeled strategy
-emptyPrefix :: LabeledStrategy a -> Prefix a
-emptyPrefix = fromMaybe (error "emptyPrefix") . makePrefix []
-
--- | Construct a prefix for a given list of integers and a labeled strategy.
-makePrefix :: Monad m => [Int] -> LabeledStrategy a -> m (Prefix a)
-makePrefix []     ls = makePrefix [0] ls
-makePrefix (i:is) ls = liftM P $
-   replay i (map (==0) is) (mkCore ls)
- where
-   mkCore = processLabelInfo id . toCore . toStrategy
-
--- | Create a derivation tree with a "prefix" as annotation.
-prefixTree :: Prefix a -> a -> DerivationTree (Prefix a) a
-prefixTree (P s) a = fmap value $ updateAnnotations (\_ _ -> P) $
-   parseDerivationTree s {value = a}
-
-prefixToSteps :: Prefix a -> [Step LabelInfo a]
-prefixToSteps (P t) = reverse (trace t)
-
--- | Retrieves the rules from a list of steps
-stepsToRules :: [Step l a] -> [Rule a]
-stepsToRules xs = [ r | RuleStep r <- xs ]
-
--- | Returns the last rule of a prefix (if such a rule exists)
-lastStepInPrefix :: Prefix a -> Maybe (Step LabelInfo a)
-lastStepInPrefix (P t) = safeHead (trace t)
− src/Common/Strategy/Tests.hs 
@@ -1,175 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Testing strategy combinator properties
---
------------------------------------------------------------------------------
-module Common.Strategy.Tests (tests) where
-
-import Common.Algebra.Group
-import Common.Algebra.Law
-import Common.Classes
-import Common.Id
-import Common.Strategy
-import Common.Strategy.Abstract
-import Common.Strategy.Parsing
-import Common.Utils.QuickCheck hiding (label, Result)
-import Common.Utils.TestSuite
-import Data.Function
-import Data.List
-import Data.Ord
-import Prelude hiding (fail)
-import qualified Common.Algebra.Field as F
-
----------------------------------------------------------
--- Properties
-
-tests :: TestSuite
-tests = suite "Strategy combinator properties" $ do
-   -- monoids and semi-rings
-   fs (commutative : idempotent : monoidLaws :: [Law Choice])
-   fs (monoidZeroLaws :: [Law Sequence])
-   fs (commutative : monoidZeroLaws :: [Law Interleave])
-   fs (F.distributiveLaws :: [Law Sequence])
-   fs (F.distributiveLaws :: [Law Interleave])
-
-   -- properties of atomic
-   addProperty "atomic-twice" $ \a ->
-      atomic (atomic a) === atomic (idS a)
-   assertTrue  "atomic-succeed" $
-      atomic succeed === succeed
-   assertTrue  "atomic-fail" $
-      atomic fail === fail
-   addProperty "atomic-choice" $ \a b ->
-      atomic (idS a <|> idS b) === atomic a <|> atomic b
-
-   -- splits theorm parallel/atomic
-   addProperty "atomic-split"  $ \x y a b ->
-      (atomic x <*> a) <%> (atomic y <*> b)
-      ===
-      (idS x <*> (a <%> (atomic y <*> b)))
-        <|>
-      (idS y <*> ((atomic x <*> idS a) <%> idS b))
- where
-   fs :: (Arbitrary a, Show a, Eq a) => [Law a] -> TestSuite
-   fs = mapM_ (\p -> addProperty (show p) p)
-
----------------------------------------------------------
--- Algebraic instances
-
-newtype Choice     = Choice     (Strategy Int) deriving (Show, Arbitrary)
-newtype Sequence   = Sequence   (Strategy Int) deriving (Show, Arbitrary)
-newtype Interleave = Interleave (Strategy Int) deriving (Show, Arbitrary)
-
-instance Eq Choice     where     Choice a == Choice b     = a === b
-instance Eq Sequence   where   Sequence a == Sequence b   = a === b
-instance Eq Interleave where Interleave a == Interleave b = a === b
-
-instance Monoid Choice where
-   mempty = Choice fail
-   mappend (Choice a) (Choice b) = Choice (a <|> b)
-
-instance Monoid Sequence where
-   mempty = Sequence succeed
-   mappend (Sequence a) (Sequence b) = Sequence (a <*> b)
-
-instance MonoidZero Sequence where
-   mzero = Sequence fail
-
-instance Monoid Interleave where
-   mempty = Interleave succeed
-   mappend (Interleave a) (Interleave b) = Interleave (a <%> b)
-
-instance MonoidZero Interleave where
-   mzero = Interleave fail
-
-instance F.SemiRing Sequence where
-   Sequence a <+> Sequence b = Sequence (a <|> b)
-   zero  = Sequence fail
-   (<*>) = mappend
-   one   = mempty
-
-instance F.SemiRing Interleave where
-   Interleave a <+> Interleave b = Interleave (a <|> b)
-   zero  = Interleave fail
-   (<*>) = mappend
-   one   = mempty
-
----------------------------------------------------------
--- Helper functions for equality
-
-idS :: Strategy Int -> Strategy Int
-idS = id
-
-infix 1 ===
-
-(===) :: Strategy Int -> Strategy Int -> Bool
-s1 === s2 = rec 100 [(start s1, start s2)]
- where
-   start = return . flip makeState 0 . toCore
-
-   rec :: Int -> [([State LabelInfo Int], [State LabelInfo Int])] -> Bool
-   rec _ [] = True
-   rec n (pair:rest)
-      | n == 0    = True
-      | otherwise = testReady xs ys
-                 && testValue xs ys
-                 && testFirsts gxs gys
-                 && rec (n-1) (rest ++ new)
-
-    where
-      p@(xs, ys)    = mapBoth (concatMap myFirsts) pair
-      gp@(gxs, gys) = mapBoth f p
-      new           = uncurry zip (mapBoth (map snd) gp)
-
-      testReady  = (==) `on` any (isReady . fst)
-      testValue  = (==) `on` (nub . sort . map (value . snd))
-      testFirsts = (==) `on` map fst
-
-      f          = map merge . groupBy eqFst . sortBy cmpFst . results
-      merge   as = (fst (head as), map snd as)
-      results as = [ (a, b) | (Result a, b) <- as ]
-
-      cmpFst (x, _) (y, _) = x `compare` y
-      eqFst  (x, _) (y, _) = x == y
-
-myFirsts :: State l a -> [(Result (Step l a), State l a)]
-myFirsts = concatMap f . firsts
- where
-   f pair@(result, a) =
-      case result of
-         Result (Enter _) -> myFirsts a
-         Result (Exit _)  -> myFirsts a
-         _                -> [pair]
-
-{-
-debug :: Show a => Strategy a -> a -> IO ()
-debug s = rec . makeState (toCore s)
- where
-   rec st = do
-      print st
-      putStrLn $ "\nReady: " ++ show (any (isReady . fst) xs)
-      putStrLn $ unlines $
-         zipWith (\i y -> show i ++ ". " ++ show (fst y)) [1::Int ..] ys
-      if (null xs) then print "(no choices)" else do
-      n <- ask
-      rec (snd (ys !! n))
-    where
-      xs = firsts st
-      ys = [ (a, b) | (Result a, b) <- xs ]
-
-      ask = do
-         putStr "? "
-         input <- getLine
-         case readInt input of
-            Just n | n > 0 && n <= length ys ->
-               return (n-1)
-            _ -> if input == "q" then error "QUIT" else ask -}
− src/Common/Transformation.hs 
@@ -1,433 +0,0 @@-{-# LANGUAGE GADTs, ExistentialQuantification #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- This module defines transformations. Given a term, a transformation returns a list of
--- results (often a singleton list or the empty list). A transformation can be parameterized
--- with one or more arguments. A rule is in essence just a transformation with a name (which
--- should be unique). Both transformations and rules can be lifted to work on more complex domains.
---
------------------------------------------------------------------------------
-module Common.Transformation
-   ( -- * Transformations
-     Transformation, makeTrans, makeTransList, makeRewriteTrans
-     -- * Arguments
-   , ArgDescr(..), defaultArgDescr, Argument(..), ArgValue(..), ArgValues
-   , supply1, supply2, supply3
-   , hasArguments, expectedArguments, getDescriptors, useArguments
-     -- * Rules
-   , Rule, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule
-   , finalRule, isFinalRule, ruleSiblings, rule, ruleList
-   , makeRule, makeRuleList, makeSimpleRule, makeSimpleRuleList
-   , idRule, checkRule, emptyRule, minorRule, buggyRule, doAfter
-   , siblingOf, transformations, getRewriteRules
-   , ruleRecognizer, useRecognizer, useSimpleRecognizer
-     -- * Lifting
-   , liftRule, liftTrans, liftRuleIn, liftTransIn
-     -- * QuickCheck
-   , testRule, propRuleSmart
-   ) where
-
-import Common.Classes
-import Common.Id
-import Common.Rewriting
-import Common.Utils
-import Common.View
-import Control.Monad
-import Data.Function
-import Data.Maybe
-import Test.QuickCheck
-
------------------------------------------------------------
---- Transformations
-
--- | Abstract data type for representing transformations
-data Transformation a
-   = Function (a -> [a])
-   | RewriteRule (RewriteRule a) (a -> [a])
-   | forall b . Abstraction (ArgumentList b) (a -> Maybe b) (b -> Transformation a)
-   | forall b c . LiftView (View a (b, c)) (Transformation b)
-   | Recognizer (a -> a -> Maybe ArgValues) (Transformation a)
-
-instance Apply Transformation where
-   applyAll (Function f)        = f
-   applyAll (RewriteRule _ f)   = f
-   applyAll (Abstraction _ f g) = \a -> maybe [] (\b -> applyAll (g b) a) (f a)
-   applyAll (LiftView v t)      = \a -> [ build v (b, c) | (b0, c) <- matchM v a, b <- applyAll t b0  ]
-   applyAll (Recognizer _ t)    = applyAll t
-
--- | Turn a function (which returns its result in the Maybe monad) into a transformation
-makeTrans :: (a -> Maybe a) -> Transformation a
-makeTrans f = makeTransList (maybe [] return . f)
-
--- | Turn a function (which returns a list of results) into a transformation
-makeTransList :: (a -> [a]) -> Transformation a
-makeTransList = Function
-
--- | Turn a rewrite rule into a transformation
-makeRewriteTrans :: RewriteRule a -> Transformation a
-makeRewriteTrans r = RewriteRule r (rewriteM r)
-
------------------------------------------------------------
---- Arguments
-
--- | A data type for describing an argument of a parameterized transformation
-data ArgDescr a = ArgDescr
-   { labelArgument    :: String               -- ^ Label that is shown to the user when asked to supply the argument
-   , defaultArgument  :: Maybe a              -- ^ Default value that can be used
-   , parseArgument    :: String -> Maybe a    -- ^ A parser
-   , showArgument     :: a -> String          -- ^ A pretty-printer
-   , termViewArgument :: View Term a          -- ^ Conversion to/from term
-   , genArgument      :: Gen a                -- ^ An arbitrary argument generator
-   }
-
--- | An argument descriptor, paired with a value
-data ArgValue = forall a . ArgValue (ArgDescr a) a
-
--- | List of argument values
-type ArgValues = [ArgValue]
-
-instance Show ArgValue where
-   show (ArgValue descr a) = showArgument descr a
-
-instance Eq ArgValue where
-   ArgValue d1 a1 == ArgValue d2 a2 =
-      build (termViewArgument d1) a1 == build (termViewArgument d2) a2
-
--- | Constructor function for an argument descriptor that uses the Show and Read type classes
-defaultArgDescr :: (Show a, Read a, IsTerm a, Arbitrary a) => String -> ArgDescr a
-defaultArgDescr descr = ArgDescr descr Nothing readM show termView arbitrary
-
--- | A type class for types which have an argument descriptor
-class Arbitrary a => Argument a where
-   makeArgDescr :: String -> ArgDescr a   -- ^ The first argument is the label of the argument descriptor
-
-instance Argument Int where
-   makeArgDescr = defaultArgDescr
-
--- | Parameterization with one argument using the provided label
-supply1 :: Argument x
-                  => String -> (a -> Maybe x)
-                  -> (x -> Transformation a) -> Transformation a
-supply1 s f t =
-   let args = Single (makeArgDescr s)
-   in Abstraction args f t
-
--- | Parameterization with two arguments using the provided labels
-supply2 :: (Argument x, Argument y)
-                   => (String, String) -> (a -> Maybe (x, y))
-                   -> (x -> y -> Transformation a) -> Transformation a
-supply2 (s1, s2) f t =
-   let args = Pair (Single (makeArgDescr s1)) (Single (makeArgDescr s2))
-   in Abstraction args f (uncurry t)
-
--- | Parameterization with three arguments using the provided labels
-supply3 :: (Argument x, Argument y, Argument z)
-                  => (String, String, String) -> (a -> Maybe (x, y, z))
-                  -> (x -> y -> z -> Transformation a) -> Transformation a
-supply3 (s1, s2, s3) f t =
-   let args = Pair (Single (makeArgDescr s1))
-                   (Pair (Single (makeArgDescr s2)) (Single (makeArgDescr s3)))
-       nest (a, b, c) = (a, (b, c))
-   in Abstraction args (fmap nest . f) (\(a, (b, c)) -> t a b c)
-
--- | Checks whether a rule is parameterized
-hasArguments :: Rule a -> Bool
-hasArguments = not . null . getDescriptors
-
--- | Returns a list of argument descriptors
-getDescriptors :: Rule a -> [Some ArgDescr]
-getDescriptors r =
-   case transformations r of
-      [t] -> rec t
-      _   -> []
- where
-   rec :: Transformation a -> [Some ArgDescr]
-   rec trans =
-      case trans of
-         Abstraction args _ _ -> someArguments args
-         LiftView _ t   -> rec t
-         Recognizer _ t -> rec t
-         _ -> []
-
--- | Returns a list of pretty-printed expected arguments.
--- Nothing indicates that there are no such arguments (or the arguments
--- are not applicable for the current value)
-expectedArguments :: Rule a -> a -> Maybe ArgValues
-expectedArguments r =
-   case transformations r of
-      [t] -> rec t
-      _   -> const Nothing
- where
-    rec :: Transformation a -> a -> Maybe ArgValues
-    rec trans a =
-       case trans of
-          Abstraction args f _ ->
-             fmap (argumentValues args) (f a)
-          LiftView v t -> do
-             (b, _) <- match v a
-             rec t b
-          Recognizer _ t ->
-             rec t a
-          _ -> Nothing
-
--- | Transform a rule and use a list of pretty-printed arguments. Nothing indicates that the arguments are
--- invalid (not parsable), or that the wrong number of arguments was supplied
-useArguments :: [String] -> Rule a -> Maybe (Rule a)
-useArguments list r =
-   case transformations r of
-      [t] -> do new <- make t
-                return r {transformations = [new]}
-      _   -> Nothing
- where
-   make :: Transformation a -> Maybe (Transformation a)
-   make trans =
-      case trans of
-         Abstraction args _ g -> fmap g (parseArguments args list)
-         LiftView v t         -> fmap (LiftView v) (make t)
-         Recognizer f t       -> fmap (Recognizer f) (make t)
-         _                    -> Nothing
-
------------------------------------------------------------
---- Internal machinery for arguments
-
-data ArgumentList a where
-   Single :: ArgDescr a -> ArgumentList a
-   Pair   :: ArgumentList a -> ArgumentList b -> ArgumentList (a, b)
-
-parseArguments :: ArgumentList a -> [String] -> Maybe a
-parseArguments (Single a) [x] = parseArgument a x
-parseArguments (Pair a b) xs =
-   let (ys, zs) = splitAt (numberOfArguments a) xs
-   in liftM2 (,) (parseArguments a ys) (parseArguments b zs)
-parseArguments _ _ = Nothing
-
-someArguments :: ArgumentList a -> [Some ArgDescr]
-someArguments (Single a) = [Some a]
-someArguments (Pair a b) = someArguments a ++ someArguments b
-
-argumentValues :: ArgumentList a -> a -> ArgValues
-argumentValues (Single a) x      = [ArgValue a x]
-argumentValues (Pair a b) (x, y) = argumentValues a x ++ argumentValues b y
-
-numberOfArguments :: ArgumentList a -> Int
-numberOfArguments = length . someArguments
-
------------------------------------------------------------
---- Rules
-
--- | Abstract data type for representing rules
-data Rule a = Rule
-   { ruleId          :: Id  -- ^ Unique identifier of the rule
-   , transformations :: [Transformation a]
-   , afterwards      :: a -> a
-   , isBuggyRule     :: Bool -- ^ Inspect whether or not the rule is buggy (unsound)
-   , isMinorRule     :: Bool -- ^ Returns whether or not the rule is minor (i.e., an administrative step that is automatically performed by the system)
-   , isFinalRule     :: Bool -- ^ Final (clean-up) step in derivation
-   , ruleSiblings    :: [Id]
-   }
-
-instance Show (Rule a) where
-   show = showId
-
-instance Eq (Rule a) where
-   r1 == r2 = ruleId r1 == ruleId r2
-
-instance Ord (Rule a) where
-   compare = compareId
-
-instance Apply Rule where
-   applyAll r a = do
-      t <- transformations r
-      b <- applyAll t a
-      return (afterwards r b)
-
-instance HasId (Rule a) where
-   getId        = ruleId
-   changeId f r = r { ruleId = f (ruleId r) }
-
-instance (Arbitrary a, CoArbitrary a) => Arbitrary (Rule a) where
-   arbitrary = liftM3 make arbitrary arbitrary arbitrary
-    where
-      make minor n f
-         | minor     = minorRule $ makeSimpleRule n f
-         | otherwise = makeSimpleRule (n :: Id) f
-
--- | Returns whether or not the rule is major (i.e., not minor)
-isMajorRule :: Rule a -> Bool
-isMajorRule = not . isMinorRule
-
-isRewriteRule :: Rule a -> Bool
-isRewriteRule = not . null . getRewriteRules
-
-siblingOf :: HasId b => b -> Rule a -> Rule a
-siblingOf sib r = r { ruleSiblings = getId sib : ruleSiblings r }
-
-ruleList :: (IsId n, RuleBuilder f a) => n -> [f] -> Rule a
-ruleList n = makeRuleList a . map (makeRewriteTrans . rewriteRule a)
- where a = newId n
-
-rule :: (IsId n, RuleBuilder f a) => n -> f -> Rule a
-rule n = makeRule a . makeRewriteTrans . rewriteRule a
- where a = newId n
-
--- | Turn a transformation into a rule: the first argument is the rule's name
-makeRule :: IsId n => n -> Transformation a -> Rule a
-makeRule n = makeRuleList n . return
-
--- | Turn a list of transformations into a single rule: the first argument is the rule's name
-makeRuleList :: IsId n => n -> [Transformation a] -> Rule a
-makeRuleList n ts = Rule (newId n) ts id False False False []
-
--- | Turn a function (which returns its result in the Maybe monad) into a rule: the first argument is the rule's name
-makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a
-makeSimpleRule n = makeRule n . makeTrans
-
--- | Turn a function (which returns a list of results) into a rule: the first argument is the rule's name
-makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a
-makeSimpleRuleList n = makeRule n . makeTransList
-
--- | A special (minor) rule that always returns the identity
-idRule :: Rule a
-idRule = minorRule $ makeSimpleRule "Identity" return
-
--- | A special (minor) rule that checks a predicate (and returns the identity
--- if the predicate holds)
-checkRule :: (a -> Bool) -> Rule a
-checkRule p = minorRule $ makeSimpleRule "Check" $ \a ->
-   if p a then Just a else Nothing
-
--- | A special (minor) rule that is never applicable (i.e., this rule always fails)
-emptyRule :: Rule a
-emptyRule = minorRule $ makeSimpleRule "Empty" (const Nothing)
-
--- | Mark the rule as minor (by default, rules are not minor)
-minorRule :: Rule a -> Rule a
-minorRule r = r {isMinorRule = True}
-
--- | Mark the rule as buggy (by default, rules are supposed to be sound)
-buggyRule :: Rule a -> Rule a
-buggyRule r = r {isBuggyRule = True}
-
--- | Mark the rule as final (by default, false). Final rules are used as a
--- final step in the derivation, to get the term in the expected form
-finalRule :: Rule a -> Rule a
-finalRule r = r {isFinalRule = True}
-
--- | Perform the function after the rule has been fired
-doAfter :: (a -> a) -> Rule a -> Rule a
-doAfter f r = r {afterwards = f . afterwards r}
-
-getRewriteRules :: Rule a -> [(Some RewriteRule, Bool)]
-getRewriteRules r = concatMap f (transformations r)
- where
-   f :: Transformation a -> [(Some RewriteRule, Bool)]
-   f trans =
-      case trans of
-         RewriteRule rr _ -> [(Some rr, not $ isBuggyRule r)]
-         LiftView _ t     -> f t
-         _                -> []
-
-ruleRecognizer :: (a -> a -> Bool) -> Rule a -> a -> a -> Maybe ArgValues
-ruleRecognizer eq r a b = msum
-   [ transRecognizer eq t a b | t <- transformations r ]
-
-transRecognizer :: (a -> a -> Bool) -> Transformation a -> a -> a -> Maybe ArgValues
-transRecognizer eq trans a b =
-   case trans of
-      Recognizer f t -> f a b `mplus` transRecognizer eq t a b
-      LiftView v t   -> msum
-         [ transRecognizer (eq `on` f) t av bv
-         | (av, c) <- matchM v a
-         , (bv, _) <- matchM v b
-         , let f z = build v (z, c)
-         ]
-       `mplus`
-         noArg (any (`eq` b) (applyAll trans a)) -- is this really needed?
-      _ -> noArg $ any (`eq` b) (applyAll trans a)
- where
-   noArg c = if c then Just [] else Nothing
-
-useRecognizer :: (a -> a -> Maybe ArgValues) -> Transformation a -> Transformation a
-useRecognizer = Recognizer
-
-useSimpleRecognizer :: (a -> a -> Bool) -> Transformation a -> Transformation a
-useSimpleRecognizer p = useRecognizer $ \x y -> guard (p x y) >> return []
-
------------------------------------------------------------
---- Lifting
-
-liftTrans :: View a b -> Transformation b -> Transformation a
-liftTrans v = liftTransIn (v &&& identity)
-
-liftTransIn :: View a (b, c) -> Transformation b -> Transformation a
-liftTransIn = LiftView
-
-liftRule :: View a b -> Rule b -> Rule a
-liftRule v = liftRuleIn (v &&& identity)
-
-liftRuleIn :: View a (b, c) -> Rule b -> Rule a
-liftRuleIn v r = r
-   { transformations = map (liftTransIn v) (transformations r)
-   , afterwards      = simplifyWith (mapFirst (afterwards r)) v
-   }
-
------------------------------------------------------------
---- QuickCheck
-
--- | Check the soundness of a rule: the equality function is passed explicitly
-testRule :: (Arbitrary a, Show a) => (a -> a -> Bool) -> Rule a -> IO ()
-testRule eq r =
-   quickCheck (propRule eq r arbitrary)
-
--- | Check the soundness of a rule and use a "smart generator" for this. The smart generator
--- behaves differently on transformations constructed with a (|-), and for these transformations,
--- the left-hand side patterns are used (meta variables are instantiated with random terms)
-propRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property
-propRuleSmart eq r = propRule eq r . smartGen r
-
-propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property
-propRule eq r gen =
-   forAll gen $ \a ->
-   forAll (smartApplyRule r a) $ \ma ->
-      isJust ma ==> (a `eq` fromJust ma)
-
-smartGen :: Rule a -> Gen a -> Gen a
-smartGen r gen = frequency [(2, gen), (1, smart)]
- where
-   smart = gen >>= \a ->
-      oneof (gen : mapMaybe (smartGenTrans a) (transformations r))
-
-smartGenTrans :: a -> Transformation a -> Maybe (Gen a)
-smartGenTrans a trans =
-   case trans of
-      RewriteRule r _ -> return (smartGenerator r)
-      LiftView v t -> do
-         (b, c) <- matchM v a
-         gen    <- smartGenTrans b t
-         return $ liftM (\n -> build v (n, c)) gen
-      _ -> Nothing
-
-smartApplyRule :: Rule a -> a -> Gen (Maybe a)
-smartApplyRule r a = do
-   xss <- mapM (`smartApplyTrans` a) (transformations r)
-   case concat xss of
-      [] -> return Nothing
-      xs -> elements $ map Just xs
-
-smartApplyTrans :: Transformation a -> a -> Gen [a]
-smartApplyTrans trans a =
-   case trans of
-      Abstraction args _ g -> smartArgs args >>= \b -> smartApplyTrans (g b) a
-      _ -> return (applyAll trans a)
-
-smartArgs :: ArgumentList a -> Gen a
-smartArgs (Single a) = genArgument a
-smartArgs (Pair a b) = liftM2 (,) (smartArgs a) (smartArgs b)
− src/Common/Utils.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A collection of general utility functions
---
------------------------------------------------------------------------------
-module Common.Utils
-   ( Some(..), ShowString(..), readInt, readM
-   , subsets, isSubsetOf
-   , cartesian, distinct, allsame
-   , safeHead, fixpoint
-   , splitAtElem, splitsWithElem
-   , useFixedStdGen, fst3, snd3, thd3, commaList
-   ) where
-
-import Data.Char
-import Data.List
-import System.Random
-
-data Some f = forall a . Some (f a)
-
-data ShowString = ShowString { fromShowString :: String }
-   deriving (Eq, Ord)
-
-instance Show ShowString where
-   show = fromShowString
-
-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 list = list ++ map (a:) list
-
-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) = all (/=x) xs && distinct xs
-
-allsame :: Eq a => [a] -> Bool
-allsame []     = True
-allsame (x:xs) = all (==x) xs
-
-safeHead :: [a] -> Maybe a
-safeHead (x:_) = return x
-safeHead _     = Nothing
-
-fixpoint :: Eq a => (a -> a) -> a -> a
-fixpoint f = stop . iterate f
- where
-   stop []           = error "Common.Utils: empty list"
-   stop (x:xs)
-      | x == head xs = x
-      | otherwise    = stop 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]
-
--- | Use a fixed standard "random" number generator. This generator is
--- accessible by calling System.Random.getStdGen
-useFixedStdGen :: IO ()
-useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -}
-
-fst3 :: (a, b, c) -> a
-fst3 (x, _, _) = x
-
-snd3 :: (a, b, c) -> b
-snd3 (_, x, _) = x
-
-thd3 :: (a, b, c) -> c
-thd3 (_, _, x) = x
-
-commaList :: [String] -> String
-commaList = intercalate ", "
− src/Common/Utils/QuickCheck.hs 
@@ -1,102 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Extensions to the QuickCheck library
---
------------------------------------------------------------------------------
-module 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.Monoid
-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)
− src/Common/Utils/StringRef.hs 
@@ -1,133 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is 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 Common.Utils.StringRef
-   ( StringRef, stringRef, toString, tableStatus
-   ) where
-
-import Common.Utils (commaList)
-import Data.Bits
-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)
-
-----------------------------------------------------------------
--- Hash table
-
-type HashTable = IM.IntMap [String]
-
-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 (\_ -> combine) hash [s] m of
-      (Nothing, new) -> do
-         writeIORef tableRef new
-         return (S (encodeIndexZero hash))
-      (Just old, new) ->
-         case findIndex (==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 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 ++ ": " ++ commaList (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
− src/Common/Utils/TestSuite.hs 
@@ -1,293 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A lightweight wrapper around the QuickCheck library. 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 test suite has a monadic
--- interface.
---
------------------------------------------------------------------------------
-module Common.Utils.TestSuite
-   ( -- * Test Suite Monad
-     TestSuite, MonadIO(..)
-     -- * Test suite constructors
-   , suite, addProperty, addPropertyWith, warn
-   , assertTrue, assertNull, assertEquals, assertIO
-     -- * Running a test suite
-   , runTestSuite, runTestSuiteResult
-     -- * Test Suite Result
-   , TestSuiteResult, subResults, findSubResult
-   , messages, topMessages, numberOfTests
-   , makeSummary, printSummary
-     -- * Messages
-   , Message, newMessage
-   , isError, warning, messageLabel
-   ) where
-
-import Control.Monad.State
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import Data.Time
-import Test.QuickCheck
-import qualified Data.Foldable as F
-import qualified Data.Sequence as S
-
-----------------------------------------------------------------
--- Test Suite Monad
-
-newtype TestSuiteM a = TSM { unTSM :: StateT Content IO a }
-
-data Content = C
-   { column :: !Int -- Number of characters on the current line, for formatting
-   , result :: !TestSuiteResult
-   }
-
-type TestSuite = TestSuiteM ()
-
-instance Monad TestSuiteM where
-   return  = TSM . return
-   m >>= f = TSM (unTSM m >>= unTSM . f)
-   fail s  = do assertTrue s False
-                return (error "TestSuite.fail: do not bind result")
-
-instance MonadIO TestSuiteM where
-   liftIO =  TSM . liftIO
-
-instance Monoid a => Monoid (TestSuiteM a) where
-   mempty  = return mempty
-   mappend = (>>)
-
-----------------------------------------------------------------
--- Test suite constructors
-
--- | Construct a (named) test suite containing tests and other suites
-suite :: String -> TestSuite -> TestSuite
-suite s m = TSM $ do
-   newline
-   liftIO $ putStrLn s
-   reset
-   t <- updateDiffTime (withEmptyTree (unTSM m))
-   addResult (suiteResult s t)
-
--- | Add a QuickCheck property to the test suite. The first argument is
--- a label for the property
-addProperty :: Testable prop => String -> prop -> TestSuite
-addProperty = flip addPropertyWith stdArgs
-
--- | Add a QuickCheck property to the test suite, also providing a test
--- configuration (Args)
-addPropertyWith :: Testable prop => String -> Args -> prop -> TestSuite
-addPropertyWith s args p = TSM $ do
-   newlineIndent
-   r <- liftIO $ quickCheckWithResult args p
-   reset
-   let f = addResult . messageResult . setLabel s
-   maybe (addResult okResult) f (toTestResult r)
-
-assertTrue :: String -> Bool -> TestSuite
-assertTrue msg = assertIO msg . return
-
-assertNull :: Show a => String -> [a] -> TestSuite
-assertNull s xs = addAssertion (f xs) (return (null xs))
- where f = setLabel s . newMessage . intercalate "\n" . map show
-
-assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite
-assertEquals s x y = addAssertion (setLabel s msg) (return (x==y))
- where msg = newMessage ("Not equal: " ++ show x ++ " and " ++ show y)
-
-assertIO :: String -> IO Bool -> TestSuite
-assertIO s = addAssertion (setLabel s $ newMessage "Assertion failed")
-
-warn :: String -> TestSuite
-warn = (`addAssertion` return False) . warning . newMessage
-
--- local helpers
-addAssertion :: Message -> IO Bool -> TestSuite
-addAssertion msg io = TSM $ do
-   b <- liftIO (io `catch` \_ -> return False)
-   if b then do
-      dot
-      addResult okResult
-    else do
-      newlineIndent
-      liftIO (print msg)
-      reset
-      addResult (messageResult msg)
-
-withEmptyTree :: StateT Content IO () -> StateT Content IO TestSuiteResult
-withEmptyTree m = do
-   t0 <- gets result
-   modify $ \c -> c {result = mempty}
-   m
-   tr <- gets result
-   modify $ \c -> c {result = t0}
-   return tr
-
--- formatting helpers
-newline :: StateT Content IO ()
-newline = do
-   i <- gets column
-   when (i>0) (liftIO $ putChar '\n')
-   reset
-
-newlineIndent :: StateT Content IO ()
-newlineIndent = do
-   newline
-   liftIO $ putStr "   "
-   modify $ \c -> c {column = 3}
-
-dot :: StateT Content IO ()
-dot = do
-   i <- gets column
-   unless (i>0 && i<60) newlineIndent
-   liftIO $ putChar '.'
-   modify $ \c -> c {column = column c+1}
-
-addResult :: TestSuiteResult -> StateT Content IO ()
-addResult r = modify $ \c -> c {result = result c `mappend` r}
-
-reset :: StateT Content IO ()
-reset = modify $ \c -> c {column = 0}
-
-----------------------------------------------------------------
--- Running a test suite
-
-runTestSuite :: TestSuite -> IO ()
-runTestSuite s = runTestSuiteResult s >> return ()
-
-runTestSuiteResult :: TestSuite -> IO TestSuiteResult
-runTestSuiteResult s =
-   updateDiffTime $ liftM result $
-   execStateT (unTSM s >> newline) (C 0 mempty)
-
-----------------------------------------------------------------
--- Test Suite Result
-
-data TestSuiteResult = TSR
-   { messageSeq     :: S.Seq Message
-   , suiteSeq       :: S.Seq (String, TestSuiteResult)
-   , numberOfTests  :: !Int
-   , diffTime       :: !NominalDiffTime
-   }
-
-instance Monoid TestSuiteResult where
-   mempty = TSR mempty mempty 0 0
-   mappend x y = TSR
-      { messageSeq    = messageSeq x `mappend` messageSeq y
-      , suiteSeq      = suiteSeq x `mappend` suiteSeq y
-      , numberOfTests = numberOfTests x + numberOfTests y
-      , diffTime      = diffTime x + diffTime y
-      }
-
-okResult :: TestSuiteResult
-okResult = mempty {numberOfTests = 1}
-
-messageResult :: Message -> TestSuiteResult
-messageResult m = okResult {messageSeq = S.singleton m}
-
-suiteResult :: String -> TestSuiteResult -> TestSuiteResult
-suiteResult s a = mempty
-   { suiteSeq = S.singleton (s, a)
-   , numberOfTests = numberOfTests a
-   }
-
--- one-line summary
-instance Show TestSuiteResult where
-   show res =
-      let (xs, ys) = partition isError (messages res)
-      in "(tests: " ++ show (numberOfTests res) ++
-         ", errors: " ++ show (length xs) ++
-         ", warnings: " ++ show (length ys) ++
-         ", " ++ show (diffTime res) ++ ")"
-
-subResults :: TestSuiteResult -> [(String, TestSuiteResult)]
-subResults = F.toList . suiteSeq
-
-topMessages :: TestSuiteResult -> [Message]
-topMessages = F.toList . messageSeq
-
-messages :: TestSuiteResult -> [Message]
-messages res =
-   topMessages res ++ concatMap (messages . snd) (subResults res)
-
-data Message = Message
-   { message      :: String
-   , isError      :: Bool
-   , messageLabel :: Maybe String
-   }
-
-instance Show Message where
-   show a = (if null pre then "" else pre ++ ": ") ++ message a
-    where
-       parens s = "(" ++ s ++ ")"
-       pre = unwords $
-                [ "Warning" | not (isError a) ] ++
-                maybe [] (return . parens) (messageLabel a)
-
-newMessage :: String -> Message
-newMessage s = Message s True Nothing
-
-warning :: Message -> Message
-warning m = m {isError = False}
-
-setLabel :: String -> Message -> Message
-setLabel s m = m {messageLabel = Just s}
-
-findSubResult :: String -> TestSuiteResult -> Maybe TestSuiteResult
-findSubResult name = listToMaybe . recs
- where
-   recs = concatMap rec . subResults
-   rec (n, t)
-      | n == name = [t]
-      | otherwise = recs t
-
-printSummary :: TestSuiteResult -> IO ()
-printSummary = putStrLn . makeSummary
-
-makeSummary :: TestSuiteResult -> String
-makeSummary res = unlines $
-   [ line
-   , "Tests    : " ++ show (numberOfTests res)
-   , "Failures : " ++ show (length xs)
-   , "Warnings : " ++ show (length ys)
-   , "\nTime     : " ++ show (diffTime res)
-   , "\nSuites: "
-   ] ++ map f (subResults res)
-     ++ [line]
- where
-   line        = replicate 75 '-'
-   (xs, ys)    = partition isError (messages res)
-   f (name, r) = "   " ++ name ++ "   " ++ show r
-
------------------------------------------------------
--- Utility functions
-
-toTestResult :: Result -> Maybe Message
-toTestResult res =
-   let make = Just . newMessage
-   in case res of
-         Success _ _ _           -> Nothing
-         Failure _ _ _ _ msg _ _ -> make msg
-         NoExpectedFailure _ _ _ -> make "no expected failure"
-         GaveUp i _  _           -> fmap warning $ make $
-                                    "passed only " ++ show i ++ " tests"
-
-updateDiffTime :: MonadIO m => m TestSuiteResult -> m TestSuiteResult
-updateDiffTime m = do
-   (res, d) <- getDiffTime m
-   return res {diffTime = d}
-
-getDiffTime :: MonadIO m => m a -> m (a, NominalDiffTime)
-getDiffTime action = do
-   t0 <- liftIO getCurrentTime
-   a  <- action
-   t1 <- liftIO getCurrentTime
-   return (a, diffUTCTime t1 t0)
− src/Common/Utils/Uniplate.hs 
@@ -1,24 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is 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 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
− src/Common/View.hs 
@@ -1,282 +0,0 @@-{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- This module defines views on data-types, as described in "Canonical Forms
--- in Interactive Exercise Assistants"
---
------------------------------------------------------------------------------
-module Common.View
-   ( Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..)
-   , Control.Arrow.ArrowZero(..), Control.Arrow.ArrowPlus(..)
-   , (>>>), (<<<)
-     -- * @IsMatch@ type class
-   , IsMatch(..), matchM, belongsTo, viewEquivalent, viewEquivalentWith
-   , Match, makeMatch
-     -- * @IsView@ type class
-   , IsView(..), simplify, simplifyWith
-   , canonical, canonicalWith, canonicalWithM, isCanonical, isCanonicalWith
-     -- * Views
-   , View, identity, makeView, matcherView
-     -- * Isomorphisms
-   , Isomorphism, from, to
-     -- * Some combinators
-   , swapView, listView, traverseView, ($<)
-     -- * Packaging a view
-   , ViewPackage(..)
-     -- * Properties on views
-   , propIdempotence, propSoundness, propNormalForm
-   ) where
-
-import Common.Classes
-import Common.Id
-import Control.Arrow
-import Control.Monad
-import Data.Maybe
-import Test.QuickCheck
-import qualified Control.Category as C
-import qualified Data.Traversable as T
-
-----------------------------------------------------------------------------------
--- @IsMatch@ type class
-
-class IsMatch f where
-   match   :: f a b -> a -> Maybe b
-   matcher :: f a b -> Match a b
-   -- default definitions
-   match   = runKleisli . unM . matcher
-   matcher = makeMatch . match
-
--- |generalized monadic variant of @match@
-matchM :: (Monad m, IsMatch f) => f a b -> a -> m b
-matchM v = maybe (fail "no match") return . match v
-
-belongsTo :: IsMatch f => a -> f a b -> Bool
-belongsTo a view = isJust (match view a)
-
-viewEquivalent :: (IsMatch f, Eq b) => f a b -> a -> a -> Bool
-viewEquivalent = viewEquivalentWith (==)
-
-viewEquivalentWith :: IsMatch f => (b -> b -> Bool) -> f a b -> a -> a -> Bool
-viewEquivalentWith eq view x y =
-   case (match view x, match view y) of
-      (Just a, Just b) -> a `eq` b
-      _                -> False
-
-newtype Match a b = M { unM :: Kleisli Maybe a b }
-   deriving (C.Category, Arrow, ArrowZero, ArrowPlus, ArrowChoice)
-
-instance IsMatch Match where
-   matcher = id
-
-makeMatch :: (a -> Maybe b) -> Match a b
-makeMatch = M . Kleisli
-
-----------------------------------------------------------------------------------
--- @IsView@ type class
-
--- |Minimal complete definition: @toView@ or both @match@ and @build@.
-class IsMatch f => IsView f where
-   build  :: f a b -> b -> a
-   toView :: f a b -> View a b
-   -- default definitions
-   build  f = build (toView f)
-   toView f = makeView (match f) (build f)
-
-canonical :: IsView f => f a b -> a -> Maybe a
-canonical = canonicalWith id
-
-canonicalWith :: IsView f => (b -> b) -> f a b -> a -> Maybe a
-canonicalWith f = canonicalWithM (return . f)
-
-canonicalWithM :: IsView f => (b -> Maybe b) -> f a b -> a -> Maybe a
-canonicalWithM f view a =
-   match view a >>= liftM (build view) . f
-
-isCanonical :: (IsView f, Eq a) => f a b -> a -> Bool
-isCanonical = isCanonicalWith (==)
-
-isCanonicalWith :: IsView f => (a -> a -> Bool) -> f a b -> a -> Bool
-isCanonicalWith eq v a = maybe False (eq a) (canonical v a)
-
-simplify :: IsView f => f a b -> a -> a
-simplify = simplifyWith id
-
-simplifyWith :: IsView f => (b -> b) -> f a b -> a -> a
-simplifyWith f view a = fromMaybe a (canonicalWith f view a)
-
-----------------------------------------------------------------------------------
--- Views
-
-data View a b where
-   Prim    :: Match a b -> (b -> a) -> View a b
-   (:@)    :: Id -> View a b -> View a b
-   (:>>>:) :: View a b -> View b c -> View a c
-   (:***:) :: View a c -> View b d -> View (a, b) (c, d)
-   (:+++:) :: View a c -> View b d -> View (Either a b) (Either c d)
-   Traverse :: T.Traversable f => View a b -> View (f a) (f b)
-
-instance C.Category View where
-   id    = makeView return id
-   v . w = w :>>>: v
-
-instance Arrow View where
-   arr     = (!->)
-   first   = (*** identity)
-   second  = (identity ***)
-   (***)   = (:***:)
-   f &&& g = copy >>> (f *** g)
-
-instance BiArrow View where
-   (<->) f = makeView (return . f)
-
-instance ArrowChoice View where
-   left    = (+++ identity)
-   right   = (identity +++)
-   (+++)   = (:+++:)
-   f ||| g = (f +++ g) >>> merge
-
-instance IsMatch View where
-   matcher view =
-      case view of
-         Prim m _   -> m
-         _ :@ v     -> matcher v
-         v :>>>: w  -> matcher v >>> matcher w
-         v :***: w  -> matcher v *** matcher w
-         v :+++: w  -> matcher v +++ matcher w
-         Traverse v -> makeMatch $ T.mapM (match v)
-
-instance IsView View where
-   build view =
-      case view of
-         Prim _ f   -> f
-         _ :@ v     -> build v
-         v :>>>: w  -> build v <<< build w
-         v :***: w  -> build v *** build w
-         v :+++: w  -> biMap (build v) (build w)
-         Traverse v -> fmap (build v)
-
-   toView = id
-
-instance HasId (View a b) where
-   getId (n :@ _) = n
-   getId _        = mempty
-   changeId f (n :@ a) = f n :@ a
-   changeId f a        = f mempty :@ a
-
-instance Identify (View a b) where
-   n @> v | isEmptyId a = v
-          | otherwise   = a :@ v
-    where
-      a = newId n
-
-makeView :: (a -> Maybe b) -> (b -> a) -> View a b
-makeView = matcherView . makeMatch
-
-matcherView :: Match a b -> (b -> a) -> View a b
-matcherView = Prim
-
-identity :: C.Category f => f a a
-identity = C.id
-
-----------------------------------------------------------------------------------
--- Isomorphisms (embedding-projection pairs)
-
--- to ep . from ep == id
-data Isomorphism a b = EP { pid :: Id, from :: a -> b, to :: b -> a }
-
-instance C.Category Isomorphism where
-   id    = id <-> id
-   f . g = from f . from g <-> to g . to f
-
-instance Arrow Isomorphism where
-   arr     = (!->)
-   first   = (*** identity)
-   second  = (identity ***)
-   p *** q = from p *** from q <-> to p *** to q
-   f &&& g = copy >>> (f *** g)
-
-instance BiArrow Isomorphism where
-   (<->) = EP mempty
-
-instance ArrowChoice Isomorphism where
-   left    = (+++ identity)
-   right   = (identity +++)
-   p +++ q = from p +++ from q <-> to p +++ to q
-   f ||| g = (f +++ g) >>> merge
-
-instance IsMatch Isomorphism where
-   match p = Just . from p
-
-instance IsView Isomorphism where
-   toView p = getId p @> makeView (match p) (to p)
-
-instance HasId (Isomorphism a b) where
-   getId = pid
-   changeId f p = p { pid = f (pid p) }
-
-instance Identify (Isomorphism a b) where
-   (@>) = changeId . const . newId
-
-----------------------------------------------------------------------------------
--- Some combinators
-
-swapView :: Isomorphism (a, b) (b, a)
-swapView = "views.swap" @> swap
-
--- | Specialized version of traverseView
-listView :: View a b -> View [a] [b]
-listView = traverseView
-
--- or is liftView a better name?
-traverseView :: T.Traversable f => View a b -> View (f a) (f b)
-traverseView = Traverse
-
-($<) :: T.Traversable f => View a (f b) -> View b c -> View a (f c)
-a $< b = a >>> traverseView b
-
-swap :: BiArrow arr => arr (a, b) (b, a)
-swap = f <-> f
- where
-   f :: (a, b) -> (b, a)
-   f (a, b) = (b, a)
-
-copy :: BiArrow arr => arr a (a, a)
-copy = (\a -> (a, a)) <-> fst
-
-merge :: BiArrow arr => arr (Either a a) a
-merge = either id id <-> Left
-
-----------------------------------------------------------------------------------
--- Packaging a view for documentation purposes
-
-data ViewPackage where
-   ViewPackage ::
-      (Show a, Show b, Eq a) => (String -> Maybe a) -> View a b -> ViewPackage
-
-instance HasId ViewPackage where
-   getId      (ViewPackage _ a) = getId a
-   changeId f (ViewPackage p a) = ViewPackage p (changeId f a)
-
-----------------------------------------------------------------------------------
--- Properties on views
-
-propIdempotence :: (Show a, Eq a) => Gen a -> View a b -> Property
-propIdempotence g v = forAll g $ \a ->
-   let b = simplify v a
-   in b == simplify v b
-
-propSoundness :: Show a => (a -> a -> Bool) -> Gen a -> View a c -> Property
-propSoundness semEq g v = forAll g $ \a ->
-   let b = simplify v a
-   in semEq a b
-
-propNormalForm :: (Show a, Eq a) => Gen a -> View a b -> Property
-propNormalForm g v = forAll g $ \a -> a == simplify v a
− src/Documentation/DefaultPage.hs 
@@ -1,102 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.DefaultPage where
-
-import Common.Id
-import Control.Monad
-import Service.DomainReasoner
-import Service.Types
-import System.Directory
-import System.FilePath
-import Text.HTML
-import qualified Text.XML as XML
-
-generatePage :: String -> String -> HTMLBuilder -> DomainReasoner ()
-generatePage = generatePageAt 0
-
-generatePageAt :: Int -> String -> String -> HTMLBuilder -> DomainReasoner ()
-generatePageAt n dir txt body = do
-   version <- getFullVersion
-   let filename = dir ++ "/" ++ txt
-       dirpart  = takeDirectory filename
-       doc      = defaultPage version (findTitle body) n body
-   liftIO $ do
-      putStrLn $ "Generating " ++ filename
-      unless (null dirpart) (createDirectoryIfMissing True dirpart)
-      writeFile filename (showHTML doc)
-
-defaultPage :: String -> String -> Int -> HTMLBuilder -> HTML
-defaultPage version title level builder =
-   htmlPage title (Just (up level ++ "ideas.css")) $ do
-      header level
-      divClass "content" builder
-      footer version
-
-header :: Int -> HTMLBuilder
-header level = divClass "header" $ do
-   divClass "ideas-logo" $ image (up level ++ "ideas.png")
-   divClass "ounl-logo" $ image (up level ++ "ounl.png")
-   make exerciseOverviewPageFile  "Exercises"
-   make "services.html"           "Services"
-   make "tests.html"              "Tests"
-   make "coverage/hpc_index.html" "Coverage"
-   make "api/index.html"          "API"
- where
-   make target = spanClass "menuitem" . link (up level ++ target) . text
-
-footer :: String -> HTMLBuilder
-footer version = divClass "footer" $
-   text $ "Automatically generated from sources: " ++ version
-
-up :: Int -> String
-up = concat . flip replicate "../"
-
-findTitle :: HTMLBuilder -> String
-findTitle = maybe "" XML.getData . XML.findChild "h1" . XML.makeXML "page"
-
-filePathId :: HasId a => a -> FilePath
-filePathId a = foldr (\x y -> x ++ "/" ++ y) (unqualified a) (qualifiers a)
-
-------------------------------------------------------------
--- Paths and files
-
-exerciseOverviewPageFile, exerciseOverviewAllPageFile,
-   serviceOverviewPageFile, testsPageFile, viewsOverviewPageFile :: String
-
-exerciseOverviewPageFile    = "exercises.html"
-exerciseOverviewAllPageFile = "exercises-all.html"
-serviceOverviewPageFile     = "services.html"
-viewsOverviewPageFile       = "views.html"
-testsPageFile               = "tests.html"
-
-exercisePageFile, exerciseDerivationsFile, exerciseStrategyFile,
-   exerciseDiagnosisFile, ruleFile :: HasId a => a -> FilePath
-exercisePageFile        a = filePathId a ++ ".html"
-exerciseDerivationsFile a = filePathId a ++ "-derivations.html"
-exerciseStrategyFile    a = filePathId a ++ "-strategy.html"
-exerciseDiagnosisFile   a = filePathId a ++ "-diagnosis.html"
-ruleFile                a = filePathId ("rule" # getId a) ++ ".html"
-
-servicePageFile :: Service -> String
-servicePageFile srv = "services/" ++ filePathId srv ++ ".html"
-
-viewPageFile :: HasId a => a -> String
-viewPageFile a = "views/" ++ showId a ++ ".html"
-
-diagnosisExampleFile :: Id -> String
-diagnosisExampleFile a = "examples/" ++ showId a ++ ".xml"
-
-------------------------------------------------------------
--- Utility functions
-
-showBool :: Bool -> String
-showBool b = if b then "yes" else "no"
− src/Documentation/ExampleFile.hs 
@@ -1,80 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- An example file contains a collection of examples for a certain exercise id,
--- encoded in XML. The examples can be for the diagnose and ready services.
---
------------------------------------------------------------------------------
-module Documentation.ExampleFile
-   ( ExampleFile, items, Item(..)
-   , readExampleFile, writeExampleFile
-   ) where
-
-import Common.Id
-import Common.Utils (readM)
-import Control.Monad
-import Data.Maybe
-import Text.XML
-
-data ExampleFile = EF { fileId :: Id, items :: [Item] }
-
-instance Show ExampleFile where
-   show a = "Example file for " ++ showId a ++
-            " (" ++ show (length (items a)) ++ " items)"
-
-instance HasId ExampleFile where
-   getId = fileId
-   changeId f a = a { fileId = f (fileId a) }
-
-data Item = Diagnose String String String
-          | Ready String (Maybe Bool) String
-
-readExampleFile :: FilePath -> IO ExampleFile
-readExampleFile file = do
-   txt <- readFile file
-   xml <- either fail return (parseXML txt)
-   guard (name xml == "examples")
-   exid <- findAttribute "exerciseid" xml
-   xs   <- mapM getItem (children xml)
-   return $ EF (newId exid) xs
-
-getItem :: XML -> IO Item
-getItem xml = do
-   guard (name xml == "diagnose")
-   before <- findAttribute "before" xml
-   after  <- findAttribute "after"  xml
-   let descr = fromMaybe "" $ findAttribute "description" xml
-   return $ Diagnose before after descr
- `mplus` do
-   guard (name xml == "ready")
-   term <- findAttribute "term" xml
-   let expected = findAttribute "expected" xml >>= readM
-       descr = fromMaybe "" $ findAttribute "description" xml
-   return $ Ready term expected descr
-
-writeExampleFile :: FilePath -> ExampleFile -> IO ()
-writeExampleFile file ex = writeFile file $ showXML $
-   makeXML "examples" $ do
-      "exerciseid" .=. showId ex
-      mapM_ buildItem (items ex)
-
-buildItem :: Item -> XMLBuilder
-buildItem item =
-   case item of
-      Diagnose before after descr ->
-         element "diagnose" $ do
-            "before"      .=. before
-            "after"       .=. after
-            "description" .=. descr
-      Ready term expected descr ->
-         element "ready" $ do
-            "term"        .=. term
-            maybe (return ()) (("expected" .=.) . show) expected
-            "description" .=. descr
− src/Documentation/ExercisePage.hs 
@@ -1,220 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.ExercisePage (makeExercisePage, idboxHTML) where
-
-import Common.Library hiding (up)
-import Common.Utils (Some(..), commaList)
-import Control.Monad
-import Data.Maybe
-import Documentation.DefaultPage
-import Documentation.ExampleFile
-import Documentation.OpenMathDerivations
-import Documentation.RulePresenter
-import Service.BasicServices
-import Service.Diagnose
-import Service.DomainReasoner
-import Service.State
-import Service.StrategyInfo
-import System.Directory
-import System.Random
-import Text.HTML
-
-makeExercisePage :: String -> Exercise a -> DomainReasoner ()
-makeExercisePage dir ex = do
-   let make     = makeId ex
-       makeId a = generatePageAt (length (qualifiers a)) dir . ($ getId a)
-       exFile   = dir ++ "/" ++ diagnosisExampleFile (getId ex)
-
-   exampleFileExists <- liftIO (doesFileExist exFile)
-
-   make exercisePageFile     (exercisePage exampleFileExists ex)
-   make exerciseStrategyFile (strategyPage ex)
-   unless (null (examples ex)) $ do
-       make exerciseDerivationsFile (derivationsPage ex)
-       liftIO $ makeOpenMathDerivations dir ex
-   when exampleFileExists $ do
-      ef <- liftIO (readExampleFile exFile)
-      make exerciseDiagnosisFile (diagnosisPage ef ex)
-    `catchError` \_ -> return ()
-
-exercisePage :: Bool -> Exercise a -> HTMLBuilder
-exercisePage exampleFileExists ex = do
-   idboxHTML "exercise" exid
-
-   h2 "1. General information"
-
-   let bolds (x:xs) = bold x:xs
-       bolds []     = []
-
-   table False $ map bolds
-      [ [ text "Code",   ttText (showId ex)]
-      , [ text "Status", text (show $ status ex)]
-      , [ text "Strategy"
-        , link (up len ++ exerciseStrategyFile exid) $
-             text (showId $ strategy ex)
-        ]
-      , [ text "OpenMath support"
-        , text $ showBool $ isJust $ hasTermView ex
-        ]
-      {- , [ text "Textual feedback"
-        , text $ showBool $ isJust $ getScript ex
-        ] -}
-      , [ text "Restartable strategy"
-        , text $ showBool $ canBeRestarted ex
-        ]
-      , [ text "Exercise generator"
-        , text $ showBool $ isJust $ randomExercise ex
-        ]
-      , [ text "Examples"
-        , text $ show $ length $ examples ex
-        ]
-      ]
-
-   h2 "2. Rules"
-   let rs   = rulesInStrategy (strategy ex)
-       goUp = up (length (qualifiers ex))
-       f r  = [ link (goUp ++ ruleFile r) $ ttText (showId r)
-              , text $ showBool $ isBuggyRule r
-              , text $ showBool $ hasArguments r
-              , text $ showBool $ r `elem` rs
-              , when (isRewriteRule r) $
-                   ruleToHTML (Some ex) r
-              ]
-   table True
-      ( [ text "Rule name", text "Buggy", text "Args"
-        , text "Used", text "Rewrite rule"
-        ]
-      : map f (ruleset ex)
-      )
-   when exampleFileExists $
-      para $ link (up len ++ exerciseDiagnosisFile exid) $ do
-         br
-         text "See diagnosis examples"
-   -- preText $ show $ treesToInfo ex trees
-
-   h2 "3. Example"
-   let state = generate (mkStdGen 0) ex Medium
-   derivationHTML ex (stateTerm state)
-   para $ unless (null (examples ex)) $
-      link (up len ++ exerciseDerivationsFile exid) (text "More examples")
- where
-   exid  = getId ex
-   len   = length (qualifiers ex)
-   {-
-   trees = [ mapFirst getId (derivationTree (strategy ex) (inContext ex a))
-           | (_, a) <- examples ex
-           ] -}
-
-strategyPage :: Exercise a -> HTMLBuilder
-strategyPage ex = do
-   h1 title
-   h2 "1. Representation in XML"
-   highlightXML True (strategyToXML (strategy ex))
-   h2 "2. Locations"
-   let f (loc, a) =
-          [text (show loc), indent (length loc) >> text (showId a)]
-       indent n = text (replicate (3*n) '.')
-   table True
-      ( [text "Location", text "Label"]
-      : map f (strategyLocations (strategy ex))
-      )
- where
-   title = "Strategy for " ++ showId ex
-
-derivationsPage :: Exercise a -> HTMLBuilder
-derivationsPage ex = do
-   h1 "Examples"
-   forM_ (zip [1::Int ..] (examples ex)) $ \(i, (_, a)) -> do
-      h2 (show i ++ ".")
-      derivationHTML ex a
-
-derivationHTML :: Exercise a -> a -> HTMLBuilder
-derivationHTML ex a = divClass "derivation" $ do
-   when (isJust (hasTermView ex)) $
-      let file = up upn ++ "derivations/" ++ showId ex ++ ".xml"
-      in divClass "mathml" $ link file $ text "MathML"
-   pre $ derivationM (forStep upn) (forTerm ex) der
-   unless (ok der) $
-      divClass "error" $ text "<<not ready>>"
- where
-   upn = length (qualifiers ex)
-   der = derivationPrevious (derivationDiffEnv (defaultDerivation ex a))
-   ok  = maybe False (isReady ex) . fromContext . lastTerm
-
-idboxHTML :: String -> Id -> HTMLBuilder
-idboxHTML kind i = divClass "idbox" $ do
-   divClass  "id-type" $ text kind
-   spanClass "id-code" $ ttText (showId i)
-   divClass  "id-description" $ text $
-      if null (description i) then "no description" else description i
-
-diagnosisPage :: ExampleFile -> Exercise a -> HTMLBuilder
-diagnosisPage ef ex = do
-   h1 ("Diagnosis examples for " ++ showId ex)
-   let rs = [ (t, eb, descr) | Ready t eb descr <- items ef ]
-   unless (null rs) $ table True $
-      map text ["term", "ready", "description"] : map readyItem rs
-   let ts = [ (t0, t1, expl) | Diagnose t0 t1 expl <- items ef ]
-   zipWithM_ diagnoseItem [1::Int ..] ts
- where
-   readyItem (t, eb, descr) =
-      let mark = if ok then id else spanClass "error"
-          (ok, result) =
-             case parser ex t of
-                Left _  -> (False, "error")
-                Right a -> let b = isReady ex a
-                           in (maybe True (==b) eb, showBool b)
-      in map mark [ttText t, text result, text descr]
-
-   diagnoseItem i (t0, t1, expl) = do
-      h2 (show i ++ ".")
-      preText (t0 ++ "\n  =>\n" ++ t1)
-      unless (null expl) $ para $ do
-         bold $ text "Description:"
-         space
-         text expl
-         br
-         bold $ text "Diagnosis:"
-         space
-         text (getDiagnosis t0 t1)
-
-   getDiagnosis t0 t1 =
-      case (parser ex t0, parser ex t1) of
-         (Left msg, _) -> "parse error (before): " ++ msg
-         (_, Left msg) -> "parse error (after): "  ++ msg
-         (Right a, Right b) -> show (diagnose (emptyState ex a) b)
-
-forStep :: Int -> ((Rule (Context a), Environment), Context a) -> HTMLBuilder
-forStep n ((r, env), old) = do
-      spaces 3
-      text "=>"
-      space
-      let target = up n ++ ruleFile r
-          make | null (description r) = link target
-               | otherwise = titleA (description r) . link target
-      make (text (unqualified r))
-      let xs = fromMaybe [] (expectedArguments r old)
-          g (ArgValue descr x) = labelArgument descr ++ "=" ++ showArgument descr x
-      unless (null xs) $ do
-         br
-         spaces 6
-         text (commaList (map g xs))
-      unless (nullEnv env) $ do
-         br
-         spaces 6
-         text (show env)
-      br
-
-forTerm :: Exercise a -> Context a -> HTMLBuilder
-forTerm ex ca = do
-   text (prettyPrinterContext ex ca)
-   br
− src/Documentation/Make.hs 
@@ -1,69 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.Make (DocItem(..), makeDocumentation) where
-
-import Common.Utils (Some(..))
-import Common.Utils.TestSuite
-import Control.Monad
-import Data.Maybe
-import Documentation.ExercisePage
-import Documentation.OverviewPages
-import Documentation.RulePage
-import Documentation.SelfCheck
-import Documentation.ServicePage
-import Documentation.TestsPage
-import Documentation.ViewPage
-import Service.DomainReasoner
-
-data DocItem = Pages | SelfCheck | BlackBox (Maybe String)
-   deriving Eq
-
-makeDocumentation :: String -> String -> DocItem -> DomainReasoner ()
-makeDocumentation docDir testDir item =
-   case item of
-      Pages -> do
-         report "Generating overview pages"
-         makeOverviewExercises docDir
-         makeOverviewServices  docDir
-         report "Generating exercise pages"
-         exs <- getExercises
-         forM_ exs $ \(Some ex) ->
-            makeExercisePage docDir ex
-         report "Generating view pages"
-         makeViewPages docDir
-         report "Generating rule pages"
-         makeRulePages docDir
-         report "Generating service pages"
-         getServices >>= mapM_ (makeServicePage docDir)
-         report "Running tests"
-         makeTestsPage docDir testDir
-         {- report "Status hashtable"
-         let file = docDir ++ "/hashtable.out"
-         liftIO $ do
-            putStrLn $ "Generating " ++ show file
-            tableStatus >>= writeFile file -}
-      SelfCheck -> do
-         checks <- selfCheck testDir
-         result <- liftIO (runTestSuiteResult checks)
-         liftIO (printSummary result)
-      BlackBox mdir -> do
-         run    <- runWithCurrent
-         checks <- liftIO $ blackBoxTests run (fromMaybe testDir mdir)
-         result <- liftIO $ runTestSuiteResult checks
-         liftIO (printSummary result)
-
-report :: String -> DomainReasoner ()
-report s = liftIO $ do
-   let line = replicate 75 '-'
-   putStrLn line
-   putStrLn ("--- " ++ s)
-   putStrLn line
− src/Documentation/OpenMathDerivations.hs 
@@ -1,42 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.OpenMathDerivations (makeOpenMathDerivations) where
-
-import Common.Library
-import Control.Monad
-import Data.Maybe
-import Service.OpenMathSupport
-import Text.OpenMath.Object
-import Text.XML
-
-makeOpenMathDerivations :: String -> Exercise a -> IO ()
-makeOpenMathDerivations dir ex =
-   when (isJust $ hasTermView ex) $ do
-      let file = dir ++ "/derivations/" ++ showId ex ++ ".xml"
-      putStrLn $ "Generating " ++ file
-      writeFile file $
-         "<?xml-stylesheet href=\"xsl/ideas.xsl\" type=\"text/xsl\" ?>\n" ++
-         show (derivationsXML ex)
-
-derivationsXML :: Exercise a -> XML
-derivationsXML ex = makeXML "derivations" $ do
-   "title" .=. showId ex
-   forM_ (zip [1::Int ..] (examples ex)) $ \(i, (_, a)) ->
-      element "derivation" $ do
-         "title" .=. show i
-         let der = derivationPrevious (derivationDiffEnv (defaultDerivation ex a))
-         derivationM f g der
- where
-   f ((r, _), _) = element "step" $ text (showId r)
-   g a = case fromContext a >>= toOpenMath ex of
-            Just om -> builder (omobj2xml om)
-            Nothing -> return ()
− src/Documentation/OverviewPages.hs 
@@ -1,86 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.OverviewPages
-   ( makeOverviewExercises, makeOverviewServices
-   ) where
-
-import Common.Exercise
-import Common.Id
-import Common.Utils (Some(..), safeHead)
-import Control.Monad
-import Data.Char
-import Data.List
-import Data.Maybe
-import Documentation.DefaultPage
-import Service.DomainReasoner
-import Service.Types
-import Text.HTML
-
-makeOverviewExercises :: String -> DomainReasoner ()
-makeOverviewExercises dir = do
-   list <- getExercises
-   generatePage dir exerciseOverviewPageFile $
-      exerciseOverviewPage False list
-   generatePage dir exerciseOverviewAllPageFile $
-      exerciseOverviewPage True list
-
-makeOverviewServices :: String -> DomainReasoner ()
-makeOverviewServices dir = do
-   list <- getServices
-   generatePage dir serviceOverviewPageFile (serviceOverviewPage list)
-
-exerciseOverviewPage :: Bool -> [Some Exercise] -> HTMLBuilder
-exerciseOverviewPage showAll list = do
-   h1 title
-
-   forM_ (zip [1::Int ..] (grouping list)) $ \(i, (dom, xs)) -> do
-      h2 (show i ++ ". " ++ dom)
-      table False (map makeRow xs)
-
-   unless showAll $ para $ do
-      text "Show"
-      space
-      link exerciseOverviewAllPageFile $
-         text "all exercises"
-      text ", including the ones under development"
- where
-   title | showAll   = "All exercises"
-         | otherwise = "Exercises"
-
-   makeRow (Some ex) =
-      [ link (exercisePageFile code) $ ttText (show code)
-      , do spaces 10
-           f (status ex)
-           spaces 10
-      , text $ description ex
-      ]
-    where
-      code = getId ex
-      f st = italic $ text ("(" ++ map toLower (show st) ++ ")")
-
-   grouping = map g . groupBy eq . sortBy cmp . filter p
-    where
-      cmp (Some a) (Some b) = compareId (exerciseId a) (exerciseId b)
-      eq a b      = f a == f b
-      f (Some ex) = safeHead (qualifiers (exerciseId ex))
-      g xs        = (fromMaybe "" (f (head xs)), xs)
-      p (Some ex) = showAll || isPublic ex
-
-serviceOverviewPage :: [Service] -> HTMLBuilder
-serviceOverviewPage list = do
-   h1 "Services"
-   let (xs, ys) = partition serviceDeprecated (sortBy compareId list)
-       make s   = link (servicePageFile s) (ttText (showId s))
-   ul $ map make ys
-   unless (null xs) $ do
-      h2 "Deprecated"
-      ul $ map make xs
− src/Documentation/RulePage.hs 
@@ -1,110 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.RulePage (makeRulePages) where
-
-import Common.Library hiding (up)
-import Common.Utils (commaList, Some(..))
-import Control.Monad
-import Data.List
-import Documentation.DefaultPage
-import Documentation.ExercisePage (idboxHTML)
-import Documentation.RulePresenter
-import Service.DomainReasoner
-import Service.RulesInfo (rewriteRuleToFMP, collectExamples, ExampleMap)
-import Text.HTML
-import Text.OpenMath.FMP
-import Text.OpenMath.Object
-import qualified Data.Map as M
-import qualified Text.XML as XML
-
-data ExItem a = EI (Exercise a) (ExampleMap a)
-
-makeRulePages :: String -> DomainReasoner ()
-makeRulePages dir = do
-   exs <- getExercises
-   let exMap = M.fromList
-          [ (getId ex, Some (EI ex (collectExamples ex)))
-          | Some ex <- exs
-          ]
-       ruleMap = M.fromListWith (++)
-          [ (getId r, [Some ex])
-          | Some ex <- exs
-          , r <- ruleset ex
-          ]
-   forM_ (M.toList ruleMap) $ \(ruleId, list) ->
-      case list of
-         [] -> return ()
-         Some ex:_ ->
-            case M.findWithDefault noExamples (getId ex) exMap of
-               Some (EI ex1 e) ->
-                  forM_ (getRule ex1 ruleId) $ \r ->
-                     generatePageAt lev dir (ruleFile ruleId) $
-                        rulePage ex1 e usedIn r
-          where
-            noExamples = Some (EI ex M.empty)
-            lev        = length (qualifiers ruleId) + 1
-            usedIn     = sortBy compareId [ getId ex1 | Some ex1 <- list ]
-
-rulePage :: Exercise a -> ExampleMap a -> [Id] ->  Rule (Context a) -> HTMLBuilder
-rulePage ex exMap usedIn r = do
-   idboxHTML "rule" (getId r)
-   let idList = text . commaList . map showId
-   para $ table False
-      [ [bold $ text "Buggy", text $ showBool (isBuggyRule r)]
-      , [bold $ text "Rewrite rule", text $ showBool (isRewriteRule r)]
-      , [bold $ text "Siblings", idList $ ruleSiblings r]
-      ]
-   when (isRewriteRule r) $ para $
-      ruleToHTML (Some ex) r
-
-   h3 "Used in exercises"
-   let f a = link (up upn ++ exercisePageFile a) (tt $ text $ show a)
-       upn = length (qualifiers r) + 1
-   ul $ map f usedIn
-
-   -- Examples
-   let ys  = M.findWithDefault [] (getId r) exMap
-   unless (null ys) $ do
-      h3 "Examples"
-      forM_ (take 3 ys) $ \(a, b) -> para $ divClass "step" $ pre $ do
-         forTerm ex (inContext ex a)
-         forStep upn (getId r, emptyEnv)
-         forTerm ex (inContext ex b)
-
-   -- FMPS
-   let xs = getRewriteRules r
-   unless (null xs) $ do
-      h3 "Formal Mathematical Properties"
-      forM_ xs $ \(Some rr, b) -> para $ do
-         let fmp = rewriteRuleToFMP b rr
-         highlightXML False $ XML.makeXML "FMP" $
-            XML.builder (omobj2xml (toObject fmp))
-
-forStep :: Int -> (Id, Environment) -> HTMLBuilder
-forStep n (i, env) = do
-      spaces 3
-      text "=>"
-      space
-      let target = up n ++ ruleFile i
-          make | null (description i) = link target
-               | otherwise = titleA (description i) . link target
-      make (text (unqualified i))
-      br
-      unless (nullEnv env) $ do
-         spaces 6
-         text (show env)
-         br
-
-forTerm :: Exercise a -> Context a -> HTMLBuilder
-forTerm ex ca = do
-   text (prettyPrinterContext ex ca)
-   br
− src/Documentation/RulePresenter.hs 
@@ -1,111 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.RulePresenter (ruleToHTML) where
-
-import Common.Library
-import Common.Utils (Some(..), safeHead)
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Text.HTML
-
-ruleToHTML :: Some Exercise -> Rule a -> HTMLBuilder
-ruleToHTML ex r =
-   forM_ (getRewriteRules r) $ \(Some rr, b) ->
-      rewriteRuleToHTML b ex rr
-
-rewriteRuleToHTML :: Bool -> Some Exercise -> RewriteRule a -> HTMLBuilder
-rewriteRuleToHTML sound ex r = do
-   let lhs :~> rhs = ruleSpecTerm r
-   showTerm ex lhs
-   spaces 3
-   showLeadsTo sound
-   spaces 3
-   showTerm ex rhs
-   br
-
-showLeadsTo :: Bool -> HTMLBuilder
-showLeadsTo sound = text (if sound then "\x21D2" else "\x21CF")
-
-showTerm :: Some Exercise -> Term -> HTMLBuilder
-showTerm (Some ex) = text . rec
- where
-   rec term =
-      case term of
-         TVar s   -> s
-         TNum i   -> show i
-         TFloat a -> show a
-         TMeta n  -> showMeta ex n
-         _ -> concatMap (either id recp) $
-            case getSpine term of
-               (TCon s, xs) ->
-                  let txt = spaced (Left (show s) : map Right xs)
-                  in fromMaybe txt (specialSymbol s xs)
-               (x, xs) -> spaced (map Right (x:xs))
-
-   recp term = parIf (isApp term) (rec term)
-   spaced    = intersperse (Left " ")
-
-   isApp (TApp _ _) = True
-   isApp _          = False
-
-   parIf b s = if b then "(" ++ s ++ ")" else s
-
-specialSymbol :: Symbol -> [Term] -> Maybe [Either String Term]
--- constants
-specialSymbol s []
-   | sameSymbol s "logic1.true"     = con "T"
-   | sameSymbol s "logic1.false"    = con "F"
-   | sameSymbol s "relalg.universe" = con "V" -- universe
-   | sameSymbol s "relalg.ident"    = con "I" -- identity
- where
-   con x = return [Left x]
--- unary symbols
-specialSymbol s [a]
-   | sameSymbol s "logic1.not"         = pref "\172" -- "~"
-   | sameSymbol s "arith1.unary_minus" = pref "-"
-   | sameSymbol s "relalg.not"         = post "\x203E"
-   | sameSymbol s "relalg.inv"         = post "~"
- where
-   pref x  = return [Left x, Right a]
-   post x = return [Right a, Left x]
--- binary symbols
-specialSymbol s [a, b]
-   | sameSymbol s "logic1.or"         = bin " \8744 " -- "||"
-   | sameSymbol s "logic1.and"        = bin " \8743 " -- "&&"
-   | sameSymbol s "logic1.implies"    = bin " \8594 " -- "->"
-   | sameSymbol s "logic1.equivalent" = bin " \8596 " -- "<->"
-   | sameSymbol s "relation1.eq"      = bin " = "
-   | sameSymbol s "arith1.plus"       = bin "+"
-   | sameSymbol s "arith1.minus"      = bin "-"
-   | sameSymbol s "arith1.power"      = bin "^"
-   | sameSymbol s "arith1.times"      = bin "\x00B7" -- "*"
-   | sameSymbol s "arith1.divide"     = bin "/"
-   | sameSymbol s "relalg.conj"       = bin " \x2229 " -- intersect
-   | sameSymbol s "relalg.disj"       = bin " \x222A " -- union
-   | sameSymbol s "relalg.comp"       = bin " ; " -- composition
-   | sameSymbol s "relalg.add"        = bin " \x2020 " -- relative addition/dagger
- where
-   bin x = return [Right a, Left x, Right b]
-specialSymbol s1 [TApp (TApp (TCon s2) x) a]
-   | sameSymbol s1 "calculus1.diff" && sameSymbol s2 "fns1.lambda" =
-        return [Left "D(", Right x, Left ") ", Right a]
-specialSymbol _ _ = Nothing
-
-sameSymbol :: Symbol -> String -> Bool
-sameSymbol = (==) . show
-
-showMeta :: Exercise a -> Int -> String
-showMeta ex n
-   | safeHead (qualifiers ex) == Just "logic" = [ [c] | c <- ['p'..] ] !! n
-   | safeHead (qualifiers ex) == Just "relationalgebra" = [ [c] | c <- ['r'..] ] !! n
-   | otherwise = [ [c] | c <- ['a'..] ] !! n
− src/Documentation/SelfCheck.hs 
@@ -1,133 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.SelfCheck (selfCheck, blackBoxTests) where
-
-import Common.Exercise
-import Common.Utils (useFixedStdGen, Some(..), snd3)
-import Common.Utils.TestSuite
-import Control.Monad
-import Data.List
-import Service.DomainReasoner
-import Service.ModeJSON
-import Service.ModeXML
-import Service.Request
-import System.Directory
-import qualified Common.Algebra.Boolean as Algebra
-import qualified Common.Algebra.Field as Algebra
-import qualified Common.Rewriting.Substitution as Substitution
-import qualified Common.Rewriting.Unification as Unification
-import qualified Common.Strategy.Tests as Strategy
-import qualified Text.JSON as JSON
-import qualified Text.OpenMath.Tests as OpenMath
-import qualified Text.UTF8 as UTF8
-
-selfCheck :: String -> DomainReasoner TestSuite
-selfCheck dir = do
-   list        <- getExercises
-   domainSuite <- getTestSuite
-   run         <- runWithCurrent
-
-   return $ do
-      suite "Framework checks" $ do
-         suite "Text encodings" $ do
-            addProperty "UTF8 encoding" UTF8.propEncoding
-            addProperty "JSON encoding" JSON.propEncoding
-            addProperty "OpenMath encoding" OpenMath.propEncoding
-         Substitution.tests
-         Unification.unificationTests
-         Strategy.tests
-         suite "Field properties" $
-            mapM_ (addProperty "field") Algebra.propsField
-         suite "Boolean properties" $
-            mapM_ (addProperty "boolean") Algebra.propsBoolean
-
-      suite "Domain checks" domainSuite
-
-      suite "Exercise checks" $
-         forM_ list $ \(Some ex) ->
-            exerciseTestSuite ex
-
-      suite "Black box tests" $
-         join (liftIO (blackBoxTests run dir))
-
--- Returns the number of tests performed
-blackBoxTests :: (DomainReasoner Bool -> IO Bool) -> String -> IO TestSuite
-blackBoxTests run path = do
-   putStrLn ("Scanning " ++ path)
-   -- analyse content
-   xs0 <- getDirectoryContents path
-   let (xml,  xs1) = partition (".xml"  `isSuffixOf`) xs0
-       (json, xs2) = partition (".json" `isSuffixOf`) xs1
-   -- perform tests
-   ts1 <- forM json $ \x ->
-             doBlackBoxTest run JSON (path ++ "/" ++ x)
-   ts2 <- forM xml $ \x ->
-             doBlackBoxTest run XML (path ++ "/" ++ x)
-   -- recursively visit subdirectories
-   ts3 <- forM (filter ((/= ".") . take 1) xs2) $ \x -> do
-             let p = path ++ "/" ++ x
-             valid <- doesDirectoryExist p
-             if not valid
-                then return (return ())
-                else liftM (suite $ "Directory " ++ simplerDirectory p)
-                           (blackBoxTests run p)
-   return $
-      sequence_ (ts1 ++ ts2 ++ ts3)
-
-doBlackBoxTest :: (DomainReasoner Bool -> IO Bool) -> DataFormat -> FilePath -> IO TestSuite
-doBlackBoxTest run format path = do
-   b <- doesFileExist expPath
-   return $ if not b
-      then warn $ expPath ++ " does not exist"
-      else assertIO (stripDirectoryPart path) $ run $ do
-         -- Comparing output with expected output
-         (txt, expt) <- liftIO $ do
-            useFixedStdGen -- fix the random number generator
-            txt  <- readFile path
-            expt <- liftIO $ readFile expPath
-            return (txt, expt)
-         out  <- case format of
-                    JSON -> liftM snd3 (processJSON txt)
-                    XML  -> liftM snd3 (processXML txt)
-         -- Conditional forces evaluation of the result, to make sure that
-         -- all file handles are closed afterwards.
-         if out ~= expt then return True else return False
-       `catchError`
-         \_ -> return False
- where
-   expPath = baseOf path ++ ".exp"
-   baseOf  = reverse . drop 1 . dropWhile (/= '.') . reverse
-   x ~= y  = filterVersion x == filterVersion y -- compare line-based
-
-   filterVersion =
-      let p s = not (null s || "version" `isInfixOf` s)
-      in filter p . lines . filter (/= '\r')
-
-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
-
-{-
-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 ]
--}
− src/Documentation/ServicePage.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE RankNTypes #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.ServicePage (makeServicePage) where
-
-import Common.Exercise
-import Common.Id
-import Common.Utils (Some(..))
-import Control.Monad
-import Documentation.DefaultPage
-import Service.DomainReasoner
-import Service.State
-import Service.TypedExample
-import Service.Types
-import Text.HTML
-import Text.XML (XML)
-
-makeServicePage :: String -> Service -> DomainReasoner ()
-makeServicePage dir s = do
-   xs <- examplesFor (showId s)
-   generatePageAt 1 dir (servicePageFile s)  (servicePage xs s)
-
-servicePage :: [Example] -> Service -> HTMLBuilder
-servicePage xs s = do
-   h1 (showId s)
-
-   para $ do
-      bold $ text "Signature:"
-      space
-      case serviceFunction s of
-         _ ::: t -> ttText (show t)
-   para $ do
-      bold $ text "Description: "
-      br
-      text $ description s
-
-   when (serviceDeprecated s) $
-      para $ bold $ text "Warning: this service is deprecated!"
-
-   unless (null xs) $ do
-      h2 $ "XML examples (" ++ show (length xs) ++ ")"
-      forM_ (zip [1::Int ..] xs) $
-         \(i, (msg, (xmlRequest, xmlReply, xmlTest))) -> do
-            h2 $ show i ++ ". " ++ msg
-            bold $ text "Request:"
-            highlightXML True xmlRequest
-            bold $ text "Reply:"
-            highlightXML True xmlReply
-            unless xmlTest $
-               spanClass "error" $
-                  bold $ text "Error: invalid request/reply pair"
-
------------------------------------------------------------------------
--- Examples
-
-type Example = (String, (XML, XML, Bool))
-
-examplesFor :: String -> DomainReasoner [Example]
-examplesFor s = tryAll [ f t | (t, f) <- list, s == t ]
- where
-   list =
-      [ ("derivation",   makeExample "logic.dnf"  (noCfg +++ logic1))
-      , ("derivation",   makeExample "math.lineq" (noCfg +++ lineq1))
-      , ("allfirsts",    makeExample "logic.dnf"  logic2)
-      , ("allfirsts",    makeExample "math.lineq" lineq2)
-      , ("onefirst",     makeExample "logic.dnf"  logic2)
-      , ("onefirst",     makeExample "math.lineq" lineq2)
-      , ("rulesinfo",    makeExample "math.lineq" noArgs)
-      , ("rulelist",     makeExample "math.lineq" exArgs)
-      , ("strategyinfo", makeExample "math.lineq" exArgs)
-      , ("examples",     makeExample "math.lineq" exArgs)
-      ]
-
-   logic1, logic2 :: Args
-   logic1 ex = newState ex "~(p /\\ ~q)"
-   logic2 ex = newState ex "~~p /\\ T"
-
-   lineq1, lineq2 :: Args
-   lineq1 ex = newState ex "5*(x+1) == 11"
-   lineq2 ex = newState ex "5*(x+1) == (x-1)/2"
-
-   (f +++ g) ex = f ex ++ g ex
-
-   noCfg _   = [Nothing ::: maybeType StrategyCfg]
-   noArgs _  = []
-   exArgs ex = [ex ::: Exercise]
-
-tryAll :: [DomainReasoner a] -> DomainReasoner [a]
-tryAll xs =
-   let f m = liftM return m `catchError` const (return [])
-   in liftM concat (mapM f xs)
-
-newState :: Monad m => Exercise a -> String -> m (TypedValue a)
-newState ex s =
-   case parser ex s of
-      Left msg -> fail ("newState: " ++ msg)
-      Right a  -> return (emptyState ex a ::: stateType)
-
-type Args = forall a . Exercise a -> [TypedValue a]
-
-makeExample :: String -> Args -> String -> DomainReasoner Example
-makeExample exName f srvName = do
-   Some ex <- findExercise (newId exName)
-   srv     <- findService srvName
-   tr      <- typedExample ex srv (f ex)
-   return (showId ex, tr)
− src/Documentation/TestsPage.hs 
@@ -1,50 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.TestsPage (makeTestsPage) where
-
-import Common.Utils.TestSuite
-import Control.Monad
-import Documentation.DefaultPage
-import Documentation.SelfCheck
-import Service.DomainReasoner
-import Text.HTML
-
-makeTestsPage :: String -> String -> DomainReasoner ()
-makeTestsPage docDir testDir = do
-   checks <- selfCheck testDir
-   result <- liftIO (runTestSuiteResult checks)
-   generatePage docDir testsPageFile (testsPage result)
-
-testsPage :: TestSuiteResult -> HTMLBuilder
-testsPage result = do
-   h1 "Summary"
-   preText (makeSummary result)
-   h1 "Tests"
-   formatResult [] result
-
-formatResult :: [Int] -> TestSuiteResult -> HTMLBuilder
-formatResult loc result = do
-   ttText (show result)
-   br
-   forM_ (topMessages result) $ \m ->
-      spanClass (if isError m then "error" else "warning")
-      (ttText (show m) >> br)
-   let subs = zip [1::Int ..] (subResults result)
-   forM_ subs $ \(i, (s, a)) -> do
-      let newloc = loc ++ [i]
-      showHeader newloc s
-      formatResult newloc a
-
-showHeader :: [Int] -> String -> HTMLBuilder
-showHeader [a]   s = h2 (show a ++ ". " ++ s)
-showHeader [a,b] s = h3 (show a ++ "." ++ show b ++ ". " ++ s)
-showHeader _     s = para (bold (text s))
− src/Documentation/ViewPage.hs 
@@ -1,74 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Documentation.ViewPage (makeViewPages) where
-
-import Common.Id
-import Common.View
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Documentation.DefaultPage
-import Documentation.ExampleFile
-import Documentation.ExercisePage
-import Prelude hiding ((^))
-import Service.DomainReasoner
-import Text.HTML
-
-makeViewPages :: String -> DomainReasoner ()
-makeViewPages dir = do
-   views <- liftM (sortBy compareId) getViews
-   generatePage dir viewsOverviewPageFile (makeOverviewPage views)
-   forM_ views $ \v -> do
-      let exFile = dir ++ "/" ++ diagnosisExampleFile (getId v)
-      xs <- liftIO $ liftM items (readExampleFile exFile)
-               `catch` \_ -> return []
-      generatePageAt 1 dir (viewPageFile v) (viewPage xs v)
-
-makeOverviewPage :: HasId a => [a] -> HTMLBuilder
-makeOverviewPage xs = do
-   h1 "Views"
-   table True (top : map make xs)
- where
-   top = map text ["id", "description"]
-   make x = [link (viewPageFile x) (text (showId x)), text (description x)]
-
-viewPage :: [Item] -> ViewPackage -> HTMLBuilder
-viewPage list (ViewPackage f v) = do
-   idboxHTML "view" (getId v)
-   unless (null list) $ do
-      h2 "Examples"
-      table True (top : content)
- where
-   top = map text
-      ["term", "representation", "canonical", "description"]
-
-   content = map present . reorder . concatMap make $ list
-
-   make (Ready t _ descr) =
-      case f t of
-         Just a ->
-            [(True, t, match v a, canonical v a, descr)]
-         Nothing ->
-            [(False, t, Nothing, Nothing, descr)]
-   make _ = []
-
-   reorder [] = []
-   reorder (x:xs) = x : ys ++ reorder zs
-    where
-      (ys, zs) | isJust (g x) = partition p xs
-               | otherwise    = ([], xs)
-      p a = g a == g x
-      g (_, _, _, c, _) = c
-
-   present (ok, t, b, c, descr) =
-      let mark = if ok then id else spanClass "error"
-      in map (mark . text) [t, maybe "-" show b, maybe "-" show c, descr]
− src/Domain/LinearAlgebra.hs 
@@ -1,20 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra (module Export) where
-
-import Domain.LinearAlgebra.EquationsRules as Export hiding (changeCover, findIndexM)
-import Domain.LinearAlgebra.Exercises as Export
-import Domain.LinearAlgebra.LinearSystem as Export
-import Domain.LinearAlgebra.Matrix as Export
-import Domain.LinearAlgebra.MatrixRules as Export
-import Domain.LinearAlgebra.Parser as Export
-import Domain.LinearAlgebra.Strategies as Export
− src/Domain/LinearAlgebra/Checks.hs 
@@ -1,64 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.Checks (checks) where
-
-import Common.Classes
-import Common.Context
-import Common.Exercise
-import Common.Utils.TestSuite
-import Data.Maybe
-import Domain.LinearAlgebra hiding (getSolution)
-import Domain.Math.Expr
-import Domain.Math.Simplification (simplify)
-import Test.QuickCheck
-
------------------------------------------------------------
---- QuickCheck properties
-
-checks :: TestSuite
-checks = suite "Linear algebra" $ do
-   let thorough = stdArgs {maxSize = 500, maxSuccess = 500}
-   addPropertyWith "echelon"         thorough propEchelon
-   addPropertyWith "reduced echelon" thorough propReducedEchelon
-   addPropertyWith "sound"           thorough propSound
-   addPropertyWith "solution"        thorough propSolution
-
-propEchelon :: Matrix Rational -> Bool
-propEchelon =
-   fromMaybe False . fromContextWith inRowEchelonForm . applyD forwardPass . gaussContext
-
-propReducedEchelon :: Matrix Rational -> Bool
-propReducedEchelon =
-   fromMaybe False . fromContextWith inRowReducedEchelonForm . applyD gaussianElimStrategy . gaussContext
-
-propSound :: Matrix Rational -> Bool
-propSound m =
-   (fromContext . applyD gaussianElimStrategy . gaussContext) m
-   == Just (fmap fromRational (reduce m))
-
-propSolution :: Matrix Rational -> Property
-propSolution m1 =
-   forAll (arbSolution m1) $ \(solution, m2) ->
-      let m3  = (fromContext . applyD gaussianElimStrategy . gaussContext) m2
-          p r = simplify (sum (zipWith g (solution ++ [-1]) r)) == 0
-          g   = (*) . fromRational
-      in maybe False (all p . rows) m3
-
-arbSolution :: (Arbitrary a, Num a) => Matrix a -> Gen ([a], Matrix a)
-arbSolution m = do
-   solution <- vector (snd $ dimensions m)
-   let finalCol  = map (return . sum . zipWith (*) solution) (rows m)
-       newMatrix = makeMatrix $ zipWith (++) (rows m) finalCol
-   return (solution, newMatrix)
-
-gaussContext :: Matrix Rational -> Context (Matrix Expr)
-gaussContext = inContext gaussianElimExercise . fmap fromRational
− src/Domain/LinearAlgebra/EquationsRules.hs 
@@ -1,215 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.EquationsRules where
-
-import Common.Library hiding (simplify)
-import Common.Utils
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Domain.LinearAlgebra.LinearSystem
-import Domain.LinearAlgebra.LinearView
-import Domain.LinearAlgebra.MatrixRules (covered) -- for context
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Domain.Math.Simplification (simplify)
-import Prelude
-import Test.QuickCheck
-
-equationsRules :: [Rule (Context (LinearSystem Expr))]
-equationsRules =
-   [ ruleExchangeEquations, ruleEliminateVar, ruleDropEquation
-   , ruleInconsistentSystem
-   , ruleScaleEquation, ruleBackSubstitution, ruleIdentifyFreeVariables
-   , ruleCoverUpEquation, ruleUncoverEquation, ruleCoverAllEquations
-   ]
-
-ruleExchangeEquations :: Rule (Context (LinearSystem Expr))
-ruleExchangeEquations = describe "Exchange two equations" $
-   simplifySystem $ makeRule "linearalgebra.linsystem.exchange" $
-   supply2 descr args (\x y -> liftTransContext $ exchange x y)
- where
-   descr = ("equation 1", "equation 2")
-   args  = evalCM $ \ls -> do
-      mv  <- minvar ls
-      eqs <- remaining ls
-      i   <- findIndexM (elem mv . getVarsSystem . return) eqs
-      cov <- readVar covered
-      return (cov, cov + i)
-
-ruleEliminateVar :: Rule (Context (LinearSystem Expr))
-ruleEliminateVar = describe "Eliminate a variable (using addition)" $
-   simplifySystem $ makeRule "linearalgebra.linsystem.eliminate" $
-   supply3 descr args (\x y z -> liftTransContext $ addEquations x y z)
- where
-   descr = ("equation 1", "equation 2", "scale factor")
-   args  = evalCM $ \ls -> do
-      mv <- minvar ls
-      hd:rest <- remaining ls
-      let getCoef = coefficientOf mv . leftHandSide
-      (i, coef) <- maybeCM $ safeHead [ (i, c) | (i, eq) <- zip [0..] rest, let c = getCoef eq, c /= 0 ]
-      guard (getCoef hd /= 0)
-      let v = negate coef / getCoef hd
-      cov <- readVar covered
-      return (i + cov + 1, cov, v)
-
-ruleDropEquation :: Rule (Context (LinearSystem Expr))
-ruleDropEquation = describe "Drop trivial equations (such as 0=0)" $
-   simplifySystem $ makeSimpleRule "linearalgebra.linsystem.trivial" $ withCM $ \ls -> do
-      i   <- findIndexM (fromMaybe False . testConstants (==)) ls
-      modifyVar covered (\n -> if i < n then n-1 else n)
-      return (deleteIndex i ls)
-
-ruleInconsistentSystem :: Rule (Context (LinearSystem Expr))
-ruleInconsistentSystem = describe "Inconsistent system (0=1)" $
-   simplifySystem $ makeSimpleRule "linearalgebra.linsystem.inconsistent" $ withCM $ \ls -> do
-      let stop = [0 :==: 1]
-      guard (invalidSystem ls && ls /= stop)
-      writeVar covered 1
-      return stop
-
-ruleScaleEquation :: Rule (Context (LinearSystem Expr))
-ruleScaleEquation = describe "Scale equation to one" $
-   simplifySystem $ makeRule "linearalgebra.linsystem.scale" $
-   supply2 descr args (\x y -> liftTransContext $ scaleEquation x y)
- where
-   descr = ("equation", "scale factor")
-   args  = evalCM $ \ls -> do
-      cov <- readVar covered
-      eq  <- maybeCM $ safeHead $ drop cov ls
-      let expr = leftHandSide eq
-      mv <- minvar ls
-      guard (coefficientOf mv expr /= 0)
-      let coef = 1 / coefficientOf mv expr
-      return (cov, coef)
-
-ruleBackSubstitution :: Rule (Context (LinearSystem Expr))
-ruleBackSubstitution = describe "Back substitution" $
-   simplifySystem $ makeRule "linearalgebra.linsystem.subst" $
-   supply3 descr args (\x y z -> liftTransContext $ addEquations x y z)
- where
-   descr = ("equation 1", "equation 2", "scale factor")
-   args  = evalCM $ \ls -> do
-      cov <- readVar covered
-      eq  <- maybeCM $ safeHead $ drop cov ls
-      let expr = leftHandSide eq
-      mv <- maybeCM $ safeHead (vars expr)
-      i  <- findIndexM ((/= 0) . coefficientOf mv . leftHandSide) (take cov ls)
-      let coef = negate $ coefficientOf mv (leftHandSide (ls !! i))
-      return (i, cov, coef)
-
-ruleIdentifyFreeVariables :: IsLinear a => Rule (Context (LinearSystem a))
-ruleIdentifyFreeVariables = describe "Identify free variables" $
-   minorRule $ makeSimpleRule "linearalgebra.linsystem.freevars" $ withCM $ \ls ->
-   let vs = [ head ys | ys <- map (vars . leftHandSide) ls, not (null ys) ]
-       f eq =
-          let (e1, e2) = splitLinearExpr (`notElem` vs) (leftHandSide eq) -- constant ends up in e1
-          in e2 :==: rightHandSide eq - e1
-   in return (map f ls)
-
-ruleCoverUpEquation :: Rule (Context (LinearSystem a))
-ruleCoverUpEquation = describe "Cover up first equation" $
-   minorRule $ makeRule "linearalgebra.linsystem.coverup" $ changeCover succ
-
-ruleUncoverEquation :: Rule (Context (LinearSystem a))
-ruleUncoverEquation = describe "Uncover one equation" $
-   minorRule $ makeRule "linearalgebra.linsystem.uncover" $ changeCover pred
-
-ruleCoverAllEquations :: Rule (Context (LinearSystem a))
-ruleCoverAllEquations = describe "Cove all equations" $
-   minorRule $ makeSimpleRule "linearalgebra.linsystem.coverall" $ withCM $ \ls -> do
-      writeVar covered (length ls)
-      return ls
-
--- local helper functions
-deleteIndex :: Int -> [a] -> [a]
-deleteIndex i xs = ys ++ drop 1 zs
- where (ys, zs) = splitAt i xs
-
-testConstants :: IsLinear a => (a -> a -> Bool) -> Equation a -> Maybe Bool
-testConstants f (lhs :==: rhs)
-   | hasNoVar lhs && hasNoVar rhs = Just (f lhs rhs)
-   | otherwise = Nothing
-
--- simplify a linear system
-simplifySystem :: Rule (Context (LinearSystem Expr)) -> Rule (Context (LinearSystem Expr))
-simplifySystem = doAfter $ change (map (fmap f))
- where f = simplifyWith (fmap simplify) linearView
-
----------------------------------------------------------------------------------
--- Parameterized transformations
-
-exchange :: Int -> Int -> Transformation [a]
-exchange i j
-   | i >  j    = exchange j i
-   | otherwise = makeTrans $ \xs -> do
-        guard (i/=j && validEquation i xs && validEquation j xs)
-        let (begin, x:rest) = splitAt i xs
-            (middle, y:end) = splitAt (j-i-1) rest
-        return $ begin++[y]++middle++[x]++end
-
-scaleEquation :: IsLinear a => Int -> a -> Transformation (LinearSystem a)
-scaleEquation i a = makeTrans $ \xs -> do
-   guard (a `notElem` [0,1] && validEquation i xs)
-   let (begin, this:end) = splitAt i xs
-   return (begin ++ [fmap (a*) this] ++ end)
-
-addEquations :: IsLinear a => Int -> Int -> a -> Transformation (LinearSystem a)
-addEquations i j a = makeTrans $ \xs -> do
-   guard (i/=j && validEquation i xs && validEquation j xs)
-   let (begin, this:end) = splitAt i xs
-       exprj = xs!!j
-   return $ begin++[combineWith (+) this (fmap (a*) exprj)]++end
-
-changeCover :: (Int -> Int) -> Transformation (Context (LinearSystem a))
-changeCover f = makeTrans $ withCM $ \ls -> do
-   new <- liftM f (readVar covered)
-   guard (new >= 0 && new <= length ls)
-   writeVar covered new
-   return ls
-
--- local helper function
-combineWith :: (a -> a -> a) -> Equation a -> Equation a -> Equation a
-combineWith f (x1 :==: x2) (y1 :==: y2) = f x1 y1 :==: f x2 y2
-
-validEquation :: Int -> [a] -> Bool
-validEquation n xs = n >= 0 && n < length xs
-
---------------------
--- TEMP
-
--- | The equations that remain to be solved
-remaining :: LinearSystem a -> ContextMonad (Equations a)
-remaining ls = do
-   cov <- readVar covered
-   return (drop cov ls)
-
--- | The minimal variable in the remaining equations
-minvar :: IsLinear a => LinearSystem a -> ContextMonad String
-minvar ls = do
-   list <- liftM getVarsSystem (remaining ls)
-   guard (not $ null list)
-   return (minimum list)
-
-systemInNF :: (Arbitrary a, IsLinear a) => Gen (LinearSystem a)
-systemInNF = do
-   n <- arbitrary
-   replicateM n $ liftM2 (:==:) arbitrary arbitrary
-
-toIntegerSystem :: RealFrac a => LinearSystem a -> LinearSystem Integer
-toIntegerSystem = map (fmap round)
-
-fromIntegerSystem :: RealFrac a => LinearSystem Integer -> LinearSystem a
-fromIntegerSystem = map (fmap fromInteger)
-
-findIndexM :: MonadPlus m => (a -> Bool) -> [a] -> m Int
-findIndexM p = maybe mzero return . findIndex p
− src/Domain/LinearAlgebra/Exercises.hs 
@@ -1,141 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.Exercises
-   ( gramSchmidtExercise, linearSystemExercise
-   , gaussianElimExercise, systemWithMatrixExercise
-   ) where
-
-import Common.Library hiding (simplify)
-import Control.Monad
-import Data.Function
-import Domain.LinearAlgebra.EquationsRules
-import Domain.LinearAlgebra.GramSchmidtRules
-import Domain.LinearAlgebra.LinearSystem
-import Domain.LinearAlgebra.Matrix
-import Domain.LinearAlgebra.MatrixRules
-import Domain.LinearAlgebra.Parser
-import Domain.LinearAlgebra.Strategies
-import Domain.LinearAlgebra.Vector
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Domain.Math.Simplification
-import Test.QuickCheck
-
-gramSchmidtExercise :: Exercise (VectorSpace (Simplified Expr))
-gramSchmidtExercise = makeExercise
-   { exerciseId     = describe "Gram-Schmidt" $
-                         newId "linearalgebra.gramschmidt"
-   , status         = Alpha
-   , parser         = \s -> case parseVectorSpace s of
-                              Right a  -> Right (fmap simplified a)
-                              Left msg -> Left msg
-   , prettyPrinter  = unlines . map show . vectors
-   , equivalence    = withoutContext $
-                      \x y -> let f = length . filter (not . isZero) . vectors . gramSchmidt
-                              in f x == f y
-   , extraRules     = rulesGramSchmidt
-   , ready          = predicate (orthonormalList . filter (not . isZero) . vectors)
-   , strategy       = gramSchmidtStrategy
-   , randomExercise = let f = simplified . fromInteger . (`mod` 25)
-                      in simpleGenerator (liftM (fmap f) arbitrary)
-   }
-
-linearSystemExercise :: Exercise (Equations Expr)
-linearSystemExercise = makeExercise
-   { exerciseId     = describe "Solve Linear System" $
-                         newId "linearalgebra.linsystem"
-   , status         = Stable
-   , parser         = \s -> case parseSystem s of
-                               Right a  -> Right (simplify a)
-                               Left msg -> Left msg
-   , prettyPrinter  = unlines . map show
-   , equivalence    = withoutContext $
-                      \x y -> let f = fromContext . applyD linearSystemStrategy
-                                    . inContext linearSystemExercise . map toStandardForm
-                              in case (f x, f y) of
-                                    (Just a, Just b) -> getSolution a == getSolution b
-                                    _ -> False
-   , extraRules     = equationsRules
-   , ruleOrdering   = ruleOrderingWithId [getId ruleScaleEquation]
-   , ready          = predicate inSolvedForm
-   , strategy       = linearSystemStrategy
-   , randomExercise = simpleGenerator (fmap matrixToSystem arbMatrix)
-   }
-
-gaussianElimExercise :: Exercise (Matrix Expr)
-gaussianElimExercise = makeExercise
-   { exerciseId     = describe "Gaussian Elimination" $
-                         newId "linearalgebra.gaussianelim"
-   , status         = Stable
-   , parser         = \s -> case parseMatrix s of
-                               Right a  -> Right (simplify a)
-                               Left msg -> Left msg
-   , prettyPrinter  = ppMatrixWith show
-   , equivalence    = withoutContext (eqMatrix `on` fmap simplified)
-   , extraRules     = matrixRules
-   , ready          = predicate inRowReducedEchelonForm
-   , strategy       = gaussianElimStrategy
-   , randomExercise = simpleGenerator arbMatrix
-   , testGenerator  = Just arbMatrix
-   }
-
-systemWithMatrixExercise :: Exercise Expr
-systemWithMatrixExercise = makeExercise
-   { exerciseId     = describe "Solve Linear System with Matrix" $
-                         newId "linearalgebra.systemwithmatrix"
-   , status         = Provisional
-   , parser         = \s -> case (parser linearSystemExercise s, parser gaussianElimExercise s) of
-                               (Right ok, _) -> Right $ toExpr ok
-                               (_, Right ok) -> Right $ toExpr ok
-                               (Left _, Left _) -> Left "Syntax error"
-   , prettyPrinter  = \expr -> case (fromExpr expr, fromExpr expr) of
-                                  (Just ls, _) -> (unlines . map show) (ls :: Equations Expr)
-                                  (_, Just m)  -> ppMatrix (m :: Matrix Expr)
-                                  _            -> show expr
-   , equivalence    = withoutContext $
-                      \x y -> let f expr = case (fromExpr expr, fromExpr expr) of
-                                              (Just ls, _) -> Just (ls :: Equations Expr)
-                                              (_, Just m)  -> Just $ matrixToSystem (m :: Matrix Expr)
-                                              _            -> Nothing
-                              in case (f x, f y) of
-                                    (Just a, Just b) -> simpleEquivalence linearSystemExercise a b
-                                    _ -> False
-   , extraRules     = map useC equationsRules ++ map useC (matrixRules :: [Rule (Context (Matrix Expr))])
-   , ready          = predicate (inSolvedForm . (fromExpr :: Expr -> Equations Expr))
-   , strategy       = systemWithMatrixStrategy
-   , randomExercise = simpleGenerator (fmap (toExpr . matrixToSystem) (arbMatrix :: Gen (Matrix Expr)))
-   , testGenerator  = fmap (liftM toExpr) (testGenerator linearSystemExercise)
-   }
-
---------------------------------------------------------------
--- Other stuff (to be cleaned up)
-
-arbMatrix :: Num a => Gen (Matrix a)
-arbMatrix = fmap (fmap fromInteger) arbNiceMatrix
-
-arbUpperMatrix :: (Enum a, Num a) => Gen (Matrix a)
-arbUpperMatrix = threeNums $ \a b c ->
-   makeMatrix [[1, a, b], [0, 1, c], [0, 0, 1]]
-
-arbAugmentedMatrix :: (Enum a, Num a) => Gen (Matrix a)
-arbAugmentedMatrix = threeNums $ \a b c ->
-   makeMatrix [[1, 0, 0, 1], [a, 1, 0, 1], [b, c, 1, 1]]
-
-threeNums :: (Enum a, Num a) => (a -> a -> a -> b) -> Gen b
-threeNums f = let m = elements [-5 .. 5]
-              in liftM3 f m m m
-
-arbNiceMatrix :: (Enum a, Num a) => Gen (Matrix a)
-arbNiceMatrix = do
-   m1 <- arbUpperMatrix
-   m2 <- arbAugmentedMatrix
-   return (multiply m1 m2)
− src/Domain/LinearAlgebra/GramSchmidtRules.hs 
@@ -1,97 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.GramSchmidtRules where
-
-import Common.Context
-import Common.Navigator hiding (current)
-import Common.Transformation
-import Common.Utils
-import Control.Monad
-import Domain.LinearAlgebra.Vector
-
-varI, varJ :: Var Int
-varI = newVar "considered" 0
-varJ = newVar "j" 0
-
-rulesGramSchmidt :: Floating a => [Rule (Context (VectorSpace a))]
-rulesGramSchmidt = [ruleNormalize, ruleOrthogonal, ruleNext]
-
--- Make the current vector of length 1
--- (only applicable if this is not already the case)
-ruleNormalize :: Floating a => Rule (Context (VectorSpace a))
-ruleNormalize = makeSimpleRule "Turn into unit Vector" $ withCM $ \vs -> do
-   v <- current vs
-   guard (norm v `notElem` [0, 1])
-   setCurrent (toUnit v) vs
-
--- Make the current vector orthogonal with some other vector
--- that has already been considered
-ruleOrthogonal :: Floating a => Rule (Context (VectorSpace a))
-ruleOrthogonal = makeRule "Make orthogonal" $ supply2 descr args transOrthogonal
- where
-   descr = ("vector 1", "vector 2")
-   args  = evalCM $ \_ -> do
-              i <- liftM pred (readVar varI)
-              j <- liftM pred (readVar varJ)
-              guard (i>j)
-              return (j, i)
-
--- Variable "j" is for administrating which vectors are already orthogonal
-ruleNextOrthogonal :: Rule (Context (VectorSpace a))
-ruleNextOrthogonal = minorRule $ makeSimpleRule "Orthogonal to next" $ withCM $ \vs -> do
-   i <- readVar varI
-   j <- liftM succ (readVar varJ)
-   guard (j < i)
-   writeVar varJ j
-   return vs
-
--- Consider the next vector
--- This rule should fail if there are no vectors left
-ruleNext :: Rule (Context (VectorSpace a))
-ruleNext = minorRule $ makeSimpleRule "Consider next vector" $ withCM $ \vs -> do
-   i <- readVar varI
-   guard (i < length (vectors vs))
-   writeVar varI (i+1)
-   writeVar varJ 0
-   return vs
-
-current :: VectorSpace a -> ContextMonad (Vector a)
-current vs = do
-   i <- readVar varI
-   case drop (i-1) (vectors vs) of
-      v:_ -> return v
-      _   -> mzero
-
-setCurrent :: Vector a -> VectorSpace a -> ContextMonad (VectorSpace a)
-setCurrent v vs = do
-   i <- readVar varI
-   case splitAt (i-1) (vectors vs) of
-      (xs, _:ys) -> return $ makeVectorSpace (xs ++ v:ys)
-      _          -> mzero
-
--- Two indices, change the second vector and make it orthogonal
--- to the first
-transOrthogonal :: Floating a => Int -> Int -> Transformation (Context (VectorSpace a))
-transOrthogonal i j = contextTrans $ \xs ->
-   do guard (i /= j && i >=0 && j >= 0)
-      u <- safeHead $ drop i (vectors xs)
-      guard (isUnit u)
-      case splitAt j (vectors xs) of
-         (begin, v:end) -> Just $ makeVectorSpace $ begin ++ makeOrthogonal u v:end
-         _ -> Nothing
-
--- Find proper abstraction, and move this function to transformation module
-contextTrans :: (a -> Maybe a) -> Transformation (Context a)
-contextTrans f = makeTrans $ \c -> do
-   a   <- fromContext c
-   new <- f a
-   return (replace new c)
− src/Domain/LinearAlgebra/LinearSystem.hs 
@@ -1,91 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.LinearSystem where
-
-import Common.Rewriting
-import Common.Utils
-import Common.Utils.Uniplate
-import Control.Monad
-import Data.Foldable (toList)
-import Data.List
-import Data.Maybe
-import Domain.LinearAlgebra.LinearView
-import Domain.LinearAlgebra.Matrix (Matrix, makeMatrix, rows)
-import Domain.Math.Data.Relation
-import qualified Data.Set as S
-
-type LinearSystem a = Equations a
-
-getVarsSystem :: IsLinear a => LinearSystem a -> [String]
-getVarsSystem = S.toList . S.unions . map varSet . concatMap toList
-
-evalSystem :: (Uniplate a, IsLinear a) => (String -> a) -> LinearSystem a -> Bool
-evalSystem f =
-   let evalEq (x :==: y) = x==y
-   in all (evalEq . fmap (evalLinearExpr f))
-
-invalidSystem :: IsLinear a => LinearSystem a -> Bool
-invalidSystem = any invalidEquation
-
-invalidEquation :: IsLinear a => Equation a -> Bool
-invalidEquation (lhs :==: rhs) = hasNoVar lhs && hasNoVar rhs && getConstant lhs /= getConstant rhs
-
-getSolution :: IsLinear a => LinearSystem a -> Maybe [(String, a)]
-getSolution xs = do
-   guard (distinct vs)
-   guard (null (vs `intersect` frees))
-   mapM make xs
- where
-   vs    = concatMap (vars . leftHandSide) xs
-   frees = concatMap (vars . rightHandSide) xs
-   make (lhs :==: rhs) = do
-      v <- getVariable lhs
-      return (v, rhs)
-
--- No constant on the left, no variables on the right
-inStandardForm :: IsLinear a => Equation a -> Bool
-inStandardForm (lhs :==: rhs) = getConstant lhs == 0 && hasNoVar rhs
-
-toStandardForm :: IsLinear a => Equation a -> Equation a
-toStandardForm (lhs :==: rhs) =
-      let c = getConstant rhs - getConstant lhs
-      in (lhs - rhs + c) :==: c
-
-inSolvedForm :: IsLinear a => LinearSystem a -> Bool
-inSolvedForm xs = invalidSystem xs || isJust (getSolution xs)
-
-homogeneous :: IsLinear a => LinearSystem a -> Bool
-homogeneous = all ((== 0) . rightHandSide)
-
--- Conversions
-systemToMatrix :: IsLinear a => LinearSystem a -> (Matrix a, [String])
-systemToMatrix system = (makeMatrix $ map (makeRow . toStandardForm) system, vs)
- where
-   vs = getVarsSystem system
-   makeRow (lhs :==: rhs) =
-      map (`coefficientOf` lhs) vs ++ [getConstant rhs]
-
-matrixToSystem :: IsLinear a => Matrix a -> LinearSystem a
-matrixToSystem = matrixToSystemWith variables
-
-matrixToSystemWith :: IsLinear a => [String] -> Matrix a -> LinearSystem a
-matrixToSystemWith vs = map makeEquation . rows
- where
-   varList = vs ++ (variables \\ vs)
-   makeEquation [] = 0 :==: 0
-   makeEquation xs =
-      let lhs = sum (zipWith (\v a -> a * variable v) varList (init xs))
-          rhs = last xs
-      in lhs :==: rhs
-
-variables :: [String]
-variables = map (\n -> 'x' : [n]) $ ['1' .. '9'] ++ ['a' .. 'z'] -- should be sorted!!
− src/Domain/LinearAlgebra/LinearView.hs 
@@ -1,107 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.LinearView
-   ( IsLinear(..), LinearMap, renameVariables
-   , splitLinearExpr, evalLinearExpr, linearView
-   ) where
-
-import Common.Rewriting
-import Common.Utils.Uniplate
-import Common.View
-import Control.Monad
-import Data.List
-import Domain.Math.Expr
-import qualified Data.Map as M
-
-data LinearMap a = LM { lmMap :: M.Map String a, lmConstant :: a }
-
-instance Functor LinearMap where
-   fmap f (LM m c) = LM (M.map f m) (f c)
-
-linearView :: View Expr (LinearMap Expr)
-linearView = makeView f g
- where
-   -- compositional (sumView would be a more restrictive alternative)
-   f expr =
-      case expr of
-         Nat _    -> return $ LM M.empty expr
-         Var s    -> return $ LM (M.singleton s 1) 0
-         a :+: b  -> liftM2 plusLM  (f a) (f b)
-         a :-: b  -> liftM2 plusLM  (f a) (liftM negateLM (f b))
-         Negate a -> liftM negateLM (f a)
-         a :*: b  -> join $ liftM2 timesLM (f a) (f b)
-         a :/: b  -> join $ liftM2 divLM (f a) (f b)
-         Sqrt a   -> join $ liftM sqrtLM (f a)
-         Number _ -> return $ LM M.empty expr
-         Sym s as -> mapM f as >>= symLM s
-
-   g (LM m c) = build sumView (concatMap make (M.toList m) ++ [c | c /= 0])
-   make (s, e)
-      | e == 0    = []
-      | e == 1    = [variable s]
-      | e == -1   = [negate (variable s)]
-      | otherwise = [e*variable s]
-
-plusLM :: Num a => LinearMap a -> LinearMap a -> LinearMap a
-plusLM (LM m1 c1) (LM m2 c2) = LM (M.unionWith (+) m1 m2) (c1+c2)
-
-negateLM :: Num a => LinearMap a -> LinearMap a
-negateLM (LM m c) = LM (M.map negate m) (negate c)
-
-timesLM :: Num a => LinearMap a -> LinearMap a -> Maybe (LinearMap a)
-timesLM lm1@(LM m1 c1) lm2@(LM m2 c2)
-   | M.null m1 = return $ fmap (c1*) lm2
-   | M.null m2 = return $ fmap (*c2) lm1
-   | otherwise = Nothing
-
-divLM :: Fractional a => LinearMap a -> LinearMap a -> Maybe (LinearMap a)
-divLM lm (LM m2 c2) = do
-   guard (M.null m2 && c2 /= 0)
-   return $ fmap (/c2) lm
-
-sqrtLM :: Floating a => LinearMap a -> Maybe (LinearMap a)
-sqrtLM (LM m c) = do
-   guard (M.null m)
-   return $ LM M.empty (sqrt c)
-
-symLM :: WithFunctions a => Symbol -> [LinearMap a] -> Maybe (LinearMap a)
-symLM f ps = do
-   guard (all (M.null . lmMap) ps)
-   return $ LM M.empty (function f (map lmConstant ps))
-
-class (Fractional a, Uniplate a, WithVars a) => IsLinear a where
-   isLinear      :: a -> Bool
-   getConstant   :: a -> a
-   coefficientOf :: String -> a -> a
-
-instance IsLinear Expr where
-   isLinear        = (`belongsTo` linearView)
-   getConstant     = maybe 0 lmConstant . match linearView
-   coefficientOf s = maybe 0 (M.findWithDefault 0 s . lmMap) . match linearView
-
-splitLinearExpr :: IsLinear a => (String -> Bool) -> a -> (a, a)
-splitLinearExpr f a = (make (getConstant a) xs, make 0 ys)
- where
-   (xs, ys) = partition f (vars a)
-   make = foldr (\v r -> coefficientOf v a * variable v + r)
-
-evalLinearExpr :: IsLinear a => (String -> a) -> a -> a
-evalLinearExpr f a =
-   case getVariable a of
-      Just s  -> f s
-      Nothing -> descend (evalLinearExpr f) a
-
-renameVariables :: IsLinear a => (String -> String) -> a -> a
-renameVariables f a =
-   case getVariable a of
-      Just s  -> variable (f s)
-      Nothing -> descend (renameVariables f) a
− src/Domain/LinearAlgebra/Matrix.hs 
@@ -1,298 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.Matrix
-   ( Matrix, Row, Column, isRectangular, makeMatrix, identity, mapWithPos
-   , changeEntries, changeEntry, setEntries, setEntry
-   , rows, row, columns, column, dimensions, entry, isEmpty
-   , add, scale, multiply
-   , reduce, forward, backward, inverse, invertible, rank, nullity, eqMatrix
-   , switchRows, scaleRow, addRow
-   , inRowEchelonForm, inRowReducedEchelonForm
-   , nonZero, pivot, isPivotColumn
-   , isSquare, identityMatrix, isLowerTriangular, isUpperTriangular
-   ) where
-
-import Common.Rewriting
-import Control.Applicative
-import Control.Monad
-import Data.Foldable (Foldable, foldMap)
-import Data.List hiding (transpose)
-import Data.Maybe
-import Data.Monoid
-import Data.Traversable (Traversable, sequenceA)
-import Domain.Math.Simplification
-import Test.QuickCheck
-import qualified Data.List as L
-import qualified Data.Map as M
-import qualified Text.OpenMath.Dictionary.Linalg2 as OM
-
--- Invariant: a matrix is always rectangular
-newtype Matrix a = M [[a]]
-   deriving (Eq, Ord, Show)
-
-type Row    a = [a]
-type Column a = [a]
-
-instance Functor Matrix where
-   fmap f (M rs) = M (map (map f) rs)
-
-instance Foldable Matrix where
-   foldMap f (M xss) = foldMap (mconcat . map f) xss
-
-instance Traversable Matrix where
-   sequenceA (M xss) = M <$> sequenceA (map sequenceA xss)
-
-instance IsTerm a => IsTerm (Matrix a) where
-   toTerm =
-      let f = function matrixrowSymbol . map toTerm
-      in function matrixSymbol . map f . rows
-   fromTerm a = do
-      rs  <- isFunction matrixSymbol a
-      xss <- mapM (isFunction matrixrowSymbol) rs
-      yss <- mapM (mapM fromTerm) xss
-      guard (isRectangular yss)
-      return (makeMatrix yss)
-
-instance Arbitrary a => Arbitrary (Matrix a) where
-   arbitrary = do
-      (i, j) <- arbitrary
-      arbSizedMatrix (i `mod` 5, j `mod` 5)
-
-instance CoArbitrary a => CoArbitrary (Matrix a) where
-   coarbitrary = coarbitrary . rows
-
-arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a)
-arbSizedMatrix (i, j) =
-   do rs <- replicateM i (vector j)
-      return (makeMatrix rs)
-
-matrixSymbol, matrixrowSymbol :: Symbol
-matrixSymbol    = newSymbol OM.matrixSymbol
-matrixrowSymbol = newSymbol OM.matrixrowSymbol
-
-instance Simplify a => Simplify (Matrix a) where
-   simplifyWith opt = fmap (simplifyWith opt)
-
--- Check whether the table is rectangular
-isRectangular :: [[a]] -> Bool
-isRectangular xss =
-   case map length xss of
-      []   -> True
-      n:ns -> all (==n) ns
-
--- Constructor function that checks whether the table is rectangular
-makeMatrix :: [Row a] -> Matrix a
-makeMatrix rs
-   | null (concat rs) = M []
-   | isRectangular rs = M rs
-   | otherwise        = error "makeMatrix: not rectangular"
-
-identity :: Num a => Int -> Matrix a
-identity n = M $ map f [0..n-1]
- where f i = replicate i 0 ++ [1] ++ replicate (n-i-1) 0
-
-isEmpty :: Matrix a -> Bool
-isEmpty (M xs) = null xs
-
-rows :: Matrix a -> [Row a]
-rows (M rs) = rs
-
-row :: Int -> Matrix a -> Row a
-row n = (!!n) . rows
-
-columns :: Matrix a -> [Column a]
-columns = rows . transpose
-
-column :: Int -> Matrix a -> Column a
-column n = (!!n) . columns
-
-dimensions :: Matrix a -> (Int, Int)
-dimensions m = (length $ rows m, length $ columns m)
-
-entry :: (Int, Int) -> Matrix a -> a
-entry (i, j) m = row i m !! j
-
-mapWithPos :: ((Int, Int) -> a -> b) -> Matrix a -> Matrix b
-mapWithPos f (M rs) = M $ zipWith g [0..] rs
- where g y = zipWith (\x -> f (y, x)) [0..]
-
-changeEntries :: M.Map (Int, Int) (a -> a) -> Matrix a -> Matrix a
-changeEntries mp = mapWithPos (\pos -> M.findWithDefault id pos mp)
-
-changeEntry :: (Int, Int) -> (a -> a) -> Matrix a -> Matrix a
-changeEntry pos = changeEntries . M.singleton pos
-
-setEntries :: M.Map (Int, Int) a -> Matrix a -> Matrix a
-setEntries mp = mapWithPos (\pos a -> M.findWithDefault a pos mp)
-
-setEntry :: (Int, Int) -> a -> Matrix a -> Matrix a
-setEntry pos = setEntries . M.singleton pos
-
--------------------------------------------------------
-
-add :: Num a => Matrix a -> Matrix a -> Matrix a
-add a b
-   | dimensions a == dimensions b =
-        M $ zipWith (zipWith (+)) (rows a) (rows b)
-   | otherwise =
-        error "add: dimensions differ"
-
-scale :: Num a => a -> Matrix a -> Matrix a
-scale a = fmap (*a)
-
-multiply :: Num a => Matrix a -> Matrix a -> Matrix a
-multiply a b
-   | snd (dimensions a) == fst (dimensions b) =
-        M $ map (\r -> map (sum . zipWith (*) r) (columns b)) (rows a)
-   | otherwise =
-        error "multiply: incorrect dimensions"
-
--------------------------------------------------------
--- Gaussian Elimination
-
-reduce :: Fractional a => Matrix a -> Matrix a
-reduce = backward . forward
-
-forward :: Fractional a => Matrix a -> Matrix a
-forward m
-   | h==0 || w==0 = m
-   | all (==0) col = M $ zipWith (:) (repeat 0) $ rows $ forward $ M $ map tail $ rows m
-   | x == 0 = forward (switchRows 0 (fromJust $ findIndex (/= 0) col) m)
-   | x == 1 = let M (r:rs) = foldr (\k -> addRow k 0 (negate $ entry (k,0) m)) m [1..h-1]
-                  M ts = forward (M rs)
-              in M (r:ts)
-   | otherwise = forward (scaleRow 0 (1/x) m)
- where
-   (h, w) = dimensions m
-   x      = entry (0,0) m
-   col    = column 0 m
-
-backward :: Fractional a => Matrix a -> Matrix a
-backward m = foldr f m [1..h-1]
- where
-   (h, _) = dimensions m
-   f i    = let g j = case findIndex (/=0) (row i m) of
-                         Just k  -> addRow j i (negate (entry (j, k) m))
-                         Nothing -> id
-            in flip (foldr g) [0..i-1]
-
-rank :: Fractional a => Matrix a -> Int
-rank = length . filter (isJust . pivot) . rows . reduce
-
-nullity :: Fractional a => Matrix a -> Int
-nullity m = snd (dimensions m) - rank m
-
-inverse :: Fractional a => Matrix a -> Maybe (Matrix a)
-inverse m
-   | h /= w     = Nothing
-   | rank m < w = Nothing
-   | otherwise  = Just $ M $ map (drop h) $ rows $ reduce $ M $ zipWith (++) (rows m) $ rows $ identity h
- where
-   (h, w) = dimensions m
-
-invertible :: Fractional a => Matrix a -> Bool
-invertible = isJust . inverse
-
-eqMatrix :: Fractional a => Matrix a -> Matrix a -> Bool
-eqMatrix m1 m2 = reduce m1 == reduce m2
-
--- test = rank $ makeMatrix $ [[0 :: Rational ,1,1,1], [1,2,3,2], [3,1,1,3]]
-
--- t = inverse $ M [[1,0],[0,3]]
-
--------------------------------------------------------
-
-transpose :: Matrix a -> Matrix a
-transpose (M rs) = M (L.transpose rs)
-
--------------------------------------------------------
-
-isSquare :: Matrix a -> Bool
-isSquare m = i==j
- where (i, j) = dimensions m
-
-identityMatrix :: Num a => Int -> Matrix a
-identityMatrix n = M $ map (\y -> map (\x -> if x==y then 1 else 0) list) list
- where list = [0..n-1]
-
--------------------------------------------------------
--- Elementary row operations (preserve matrix equivalence)
-
-checkRow :: Int -> Matrix a -> Bool
-checkRow i m = i >= 0 && i < fst (dimensions m)
-
-switchRows :: Int -> Int -> Matrix a -> Matrix a
-switchRows i j m@(M rs)
-   | i == j = m
-   | i >  j = switchRows j i m
-   | checkRow i m && checkRow j m =
-        let (before, r1:rest)  = splitAt i       rs
-            (middle, r2:after) = splitAt (j-i-1) rest
-        in M $ before ++ [r2] ++ middle ++ [r1] ++ after
-   | otherwise =
-        error "switchRows: invalid rows"
-
-scaleRow :: Num a => Int -> a -> Matrix a -> Matrix a
-scaleRow i a m@(M rs)
-   | checkRow i m =
-        let f y = if y==i then map (*a) else id
-        in M $ zipWith f [0..] rs
-   | otherwise =
-        error "scaleRow: invalid row"
-
-addRow :: Num a => Int -> Int -> a -> Matrix a -> Matrix a
-addRow i j a m@(M rs)
-   | checkRow i m && checkRow j m =
-        let rj  = map (*a) (row j m)
-            f y = if y==i then zipWith (+) rj else id
-        in M $ zipWith f [0..] rs
-   | otherwise =
-        error "addRow: invalid row"
-
--------------------------------------------------------
-
-isLowerTriangular :: Num a => Matrix a -> Bool
-isLowerTriangular = and . zipWith check [1..] . rows
- where check n = all (==0) . drop n
-
-isUpperTriangular :: Num a => Matrix a -> Bool
-isUpperTriangular = and . zipWith check [0..] . rows
- where check n = all (==0) . take n
-
-inRowEchelonForm :: Num a => Matrix a -> Bool
-inRowEchelonForm (M rs) =
-   not (any nonZero (dropWhile nonZero rs)) &&
-   increasing (map (length . takeWhile (==0)) (filter nonZero rs))
- where
-   increasing (x:ys@(y:_)) = x < y && increasing ys
-   increasing _ = True
-
-nonZero :: Num a => [a] -> Bool
-nonZero = any (/=0)
-
--- or row canonical form
-inRowReducedEchelonForm :: Num a => Matrix a -> Bool
-inRowReducedEchelonForm m@(M rs) =
-   inRowEchelonForm m &&
-   all (==1) (mapMaybe pivot rs) &&
-   all (isPivotColumn . flip column m . length . takeWhile (==0)) (filter nonZero rs)
-
-pivot :: Num a => Row a -> Maybe a
-pivot r = case dropWhile (==0) r of
-             hd:_ -> Just hd
-             _    -> Nothing
-
-isPivotColumn :: Num a => Column a -> Bool
-isPivotColumn c =
-   case filter (/=0) c of
-      [1] -> True
-      _   -> False
− src/Domain/LinearAlgebra/MatrixRules.hs 
@@ -1,146 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.MatrixRules where
-
-import Common.Context
-import Common.Navigator
-import Common.Transformation
-import Control.Monad
-import Data.List
-import Domain.LinearAlgebra.Matrix
-import Domain.Math.Simplification
-
-matrixRules :: (Argument a, Fractional a) => [Rule (Context (Matrix a))]
-matrixRules =
-   let noArgs f = f (const Nothing)
-   in [ noArgs ruleScaleRow
-      , noArgs ruleExchangeRows
-      , noArgs ruleAddMultiple
-      ]
-
-ruleFindColumnJ :: Num a => Rule (Context (Matrix a))
-ruleFindColumnJ = minorRule $ makeSimpleRule "linearalgebra.gaussianelim.FindColumnJ" $ withCM $ \m -> do
-   cols <- liftM columns (subMatrix m)
-   i    <- findIndexM nonZero cols
-   writeVar columnJ i
-   return m
-
-ruleExchangeNonZero :: (Simplify a, Num a) => Rule (Context (Matrix a))
-ruleExchangeNonZero = simplify $ ruleExchangeRows $ evalCM $ \m -> do
-   nonEmpty m
-   j   <- readVar columnJ
-   col <- liftM (column j) (subMatrix m)
-   i   <- findIndexM (/= 0) col
-   cov <- readVar covered
-   return (cov, i + cov)
-
-ruleScaleToOne :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a))
-ruleScaleToOne = simplify $ ruleScaleRow $ evalCM $ \m -> do
-   nonEmpty m
-   j   <- readVar columnJ
-   pv  <- liftM (entry (0, j)) (subMatrix m)
-   guard (pv /= 0)
-   cov <- readVar covered
-   return (cov, 1 / pv)
-
-ruleZerosFP :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a))
-ruleZerosFP = simplify $ ruleAddMultiple $ evalCM $ \m -> do
-   nonEmpty m
-   j   <- readVar columnJ
-   col <- liftM (drop 1 . column j) (subMatrix m)
-   i   <- findIndexM (/= 0) col
-   cov <- readVar covered
-   let v = negate (col!!i)
-   return (i + cov + 1, cov, v)
-
-ruleZerosBP :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a))
-ruleZerosBP = simplify $ ruleAddMultiple $ evalCM $ \m -> do
-   nonEmpty m
-   ri <- liftM (row 0) (subMatrix m)
-   let j   = length $ takeWhile (==0) ri
-       col = column j m
-   guard (any (/= 0) ri)
-   k <- findIndexM (/= 0) col
-   let v = negate (col!!k)
-   cov <- readVar covered
-   return (k, cov, v)
-
-ruleCoverRow :: Rule (Context (Matrix a))
-ruleCoverRow = minorRule $ makeRule "linearalgebra.gaussianelim.CoverRow" $ changeCover succ
-
-ruleUncoverRow :: Rule (Context (Matrix a))
-ruleUncoverRow = minorRule $ makeRule "linearalgebra.gaussianelim.UncoverRow" $ changeCover pred
-
----------------------------------------------------------------------------------
--- Parameterized rules
-
-ruleScaleRow :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, a)) -> Rule (Context (Matrix a))
-ruleScaleRow f = makeRule "linearalgebra.gaussianelim.scale" (supply2 descr f rowScale)
- where descr  = ("row", "scale factor")
-
-ruleExchangeRows :: Num a => (Context (Matrix a) -> Maybe (Int, Int)) -> Rule (Context (Matrix a))
-ruleExchangeRows f = makeRule "linearalgebra.gaussianelim.exchange" (supply2 descr f rowExchange)
- where descr = ("row 1", "row 2")
-
-ruleAddMultiple :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, Int, a)) -> Rule (Context (Matrix a))
-ruleAddMultiple f = makeRule "linearalgebra.gaussianelim.add" (supply3 descr f  rowAdd)
- where descr  = ("row 1", "row2", "scale factor")
-
----------------------------------------------------------------------------------
--- Parameterized transformations
-
-rowExchange :: Int -> Int -> Transformation (Context (Matrix a))
-rowExchange i j = matrixTrans $ \m -> do
-   guard (i /= j && validRow i m && validRow j m)
-   return (switchRows i j m)
-
-rowScale :: Num a => Int -> a -> Transformation (Context (Matrix a))
-rowScale i k = matrixTrans $ \m -> do
-   guard (k `notElem` [0, 1] && validRow i m)
-   return (scaleRow i k m)
-
-rowAdd :: Num a => Int -> Int -> a -> Transformation (Context (Matrix a))
-rowAdd i j k = matrixTrans $ \m -> do
-   guard (k /= 0 && i /= j && validRow i m && validRow j m)
-   return (addRow i j k m)
-
-changeCover :: (Int -> Int) -> Transformation (Context (Matrix a))
-changeCover f = makeTrans $ withCM $ \m -> do
-   new <- liftM f (readVar covered)
-   guard (new >= 0 && new <= fst (dimensions m))
-   writeVar covered new
-   return m
-
-matrixTrans ::  (Matrix a -> Maybe (Matrix a)) -> Transformation (Context (Matrix a))
-matrixTrans f = makeTrans $ \c -> do
-   a   <- fromContext c
-   new <- f a
-   return (replace new c)
-
--- local helper function
-validRow :: Int -> Matrix a -> Bool
-validRow i m = i >= 0 && i < fst (dimensions m)
-
-nonEmpty :: Matrix a -> ContextMonad ()
-nonEmpty m = subMatrix m >>= guard . not . isEmpty
-
-covered, columnJ :: Var Int
-covered = newVar "covered" 0
-columnJ = newVar "columnJ" 0
-
-subMatrix :: Matrix a -> ContextMonad (Matrix a)
-subMatrix m = do
-   cov <- readVar covered
-   return $ makeMatrix $ drop cov $ rows m
-
-findIndexM :: MonadPlus m => (a -> Bool) -> [a] -> m Int
-findIndexM p = maybe mzero return . findIndex p
− src/Domain/LinearAlgebra/Parser.hs 
@@ -1,82 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.Parser
-   ( parseMatrix, parseVectorSpace, parseSystem
-   , ppMatrix, ppMatrixWith
-   ) where
-
-import Data.Char
-import Data.Either
-import Data.List
-import Domain.LinearAlgebra.LinearSystem
-import Domain.LinearAlgebra.LinearView (isLinear)
-import Domain.LinearAlgebra.Matrix
-import Domain.LinearAlgebra.Vector
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-
-parseSystem :: String -> Either String (LinearSystem Expr)
-parseSystem input =
-   case foreachLine parseEqExpr input of
-      Left msg -> Left msg
-      Right eqs
-         | all f eqs -> Right eqs
-         | otherwise -> Left "System is not linear"
-        where
-          f (a :==: b) = isLinear a && isLinear b
-
------------------------------------------------------------
---- Parser
-
-parseMatrix :: String -> Either String (Matrix Expr)
-parseMatrix input =
-   case foreachLine parseExprTuple input of
-      Left msg -> Left msg
-      Right xss
-         | isRectangular xss -> Right (makeMatrix xss)
-         | otherwise         -> Left "Matrix is not rectangular"
-
-parseVectorSpace :: String -> Either String (VectorSpace Expr)
-parseVectorSpace input =
-   case foreachLine parseExprTuple input of
-      Left msg -> Left msg
-      Right xss
-         | sameDimension vs -> Right (makeVectorSpace vs)
-         | otherwise        -> Left "Vectors have different dimensions"
-       where
-         vs = map fromList xss
-
-nonEmptyLines :: String -> [String]
-nonEmptyLines = filter (not . all isSpace) . lines
-
-foreachLine :: (String -> Either String a) -> String -> Either String [a]
-foreachLine p input =
-   case (partitionEithers . map p . nonEmptyLines) input of
-      (msg:_, _) -> Left msg
-      ([],   as) -> Right as
-
------------------------------------------------------------
---- Pretty-Printer
-
-ppMatrix :: Show a => Matrix a -> String
-ppMatrix = ppMatrixWith show
-
-ppMatrixWith :: (a -> String) -> Matrix a -> String
-ppMatrixWith f = ppStringMatrix . fmap f
-
-ppStringMatrix :: Matrix String -> String
-ppStringMatrix = format . rows
- where
-   format m = let ws = foldr (zipWith max . map length) (repeat 0) m
-                  align i s = take i (s ++ repeat ' ')
-                  par s = "(" ++ s ++ ")"
-              in unlines $ map (par . intercalate ", " . zipWith align ws) m
− src/Domain/LinearAlgebra/Strategies.hs 
@@ -1,124 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.Strategies
-   ( gaussianElimStrategy, linearSystemStrategy
-   , gramSchmidtStrategy, systemWithMatrixStrategy
-   , forwardPass
-   ) where
-
-import Common.Context
-import Common.Id
-import Common.Strategy hiding (not)
-import Common.Transformation
-import Domain.LinearAlgebra.EquationsRules
-import Domain.LinearAlgebra.GramSchmidtRules
-import Domain.LinearAlgebra.LinearSystem
-import Domain.LinearAlgebra.Matrix
-import Domain.LinearAlgebra.MatrixRules
-import Domain.LinearAlgebra.Vector
-import Domain.Math.Expr
-import Domain.Math.Simplification
-import Prelude hiding (repeat)
-
-gaussianElimStrategy :: LabeledStrategy (Context (Matrix Expr))
-gaussianElimStrategy = label "Gaussian elimination" $
-   forwardPass <*> backwardPass
-
-forwardPass :: LabeledStrategy (Context (Matrix Expr))
-forwardPass = label "Forward pass" $
-   simplifyRule <*>
-   repeat   (   label "Find j-th column"      ruleFindColumnJ
-           <*>  label "Exchange rows"         (try ruleExchangeNonZero)
-           <*>  label "Scale row"             (try ruleScaleToOne)
-           <*>  label "Zeros in j-th column"  (repeat ruleZerosFP)
-           <*>  label "Cover up top row"      ruleCoverRow
-            )
-
-backwardPass :: LabeledStrategy (Context (Matrix Expr))
-backwardPass = label "Backward pass" $
-   simplifyRule <*>
-   repeat   (   label "Uncover row"  ruleUncoverRow
-           <*>  label "Sweep"        (repeat ruleZerosBP)
-            )
-
-backSubstitutionSimple :: LabeledStrategy (Context (LinearSystem Expr))
-backSubstitutionSimple =
-   label "Back substitution with equally many variables and equations" $
-       simplifyFirst
-   <*> label "Cover all equations" ruleCoverAllEquations
-   <*> repeat (   label "Uncover one equation"  ruleUncoverEquation
-              <*> label "Scale equation to one" (try ruleScaleEquation)
-              <*> label "Back Substitution"     (repeat ruleBackSubstitution)
-              )
-
-backSubstitution :: LabeledStrategy (Context (LinearSystem Expr))
-backSubstitution = label "Back substitution" $
-   ruleIdentifyFreeVariables <*> backSubstitutionSimple
-
-systemToEchelonWithEEO :: LabeledStrategy (Context (LinearSystem Expr))
-systemToEchelonWithEEO =
-   label "System to Echelon Form (EEO)" $
-   simplifyFirst <*>
-   repeat  (  dropEquation
-          <|> check (maybe False (not . null) . evalCM remaining)
-          <*> label "Exchange equations"        (try ruleExchangeEquations)
-          <*> label "Scale equation to one"     (option ruleScaleEquation)
-          <*> label "Eliminate variable"        (repeat ruleEliminateVar)
-          <*> label "Cover up first equation"   ruleCoverUpEquation
-           )
-
-dropEquation :: LabeledStrategy (Context (LinearSystem Expr))
-dropEquation =
-   label "Drop equations" $
-          label "Inconsistent system (0=1)" ruleInconsistentSystem
-      <|> label "Drop (0=0) equation"       ruleDropEquation
-
-linearSystemStrategy :: LabeledStrategy (Context (LinearSystem Expr))
-linearSystemStrategy = label "General solution to a linear system" $
-   systemToEchelonWithEEO <*> backSubstitution
-
-systemWithMatrixStrategy :: LabeledStrategy (Context Expr)
-systemWithMatrixStrategy = label "General solution to a linear system (matrix approach)" $
-       repeat (mapRules useC dropEquation)
-   <*> conv1
-   <*> mapRules useC gaussianElimStrategy
-   <*> conv2
-   <*> repeat (mapRules useC dropEquation)
-
-gramSchmidtStrategy :: LabeledStrategy (Context (VectorSpace (Simplified Expr)))
-gramSchmidtStrategy =
-   label "Gram-Schmidt" $ repeat $ label "Iteration" $
-       label "Consider next vector"   ruleNext
-   <*> label "Make vector orthogonal" (repeat (ruleNextOrthogonal <*> try ruleOrthogonal))
-   <*> label "Normalize"              (try ruleNormalize)
-
-varVars :: Var [String]
-varVars = newVar "variables" []
-
-simplifyFirst :: Rule (Context (LinearSystem Expr))
-simplifyFirst = simplifySystem idRule
-
-conv1 :: Rule (Context Expr)
-conv1 = describe "Convert linear system to matrix" $
-   makeSimpleRule "linearalgebra.linsystem.tomatrix" $ withCM $ \expr -> do
-      ls <- fromExpr expr
-      let (m, vs) = systemToMatrix ls
-      writeVar varVars vs
-      return (toExpr (simplify (m :: Matrix Expr)))
-
-conv2 :: Rule (Context Expr)
-conv2 = describe "Convert matrix to linear system" $
-   makeSimpleRule "linearalgebra.linsystem.frommatrix" $ withCM $ \expr -> do
-      vs <- readVar varVars
-      m  <- fromExpr expr
-      let linsys = matrixToSystemWith vs (m :: Matrix Expr)
-      return $ simplify $ toExpr linsys
− src/Domain/LinearAlgebra/Vector.hs 
@@ -1,189 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.LinearAlgebra.Vector
-   ( Vector, VectorSpace
-   , makeVectorSpace, vectors, sameDimension, gramSchmidt
-   , fromList, toList, liftV, liftV2, showVectorWith
-   , toUnit, isUnit, isZero, makeOrthogonal, orthogonal, orthonormalList
-   , scale, norm, distance, vectorSum, innerProduct, dimension
-   ) where
-
-import Common.Rewriting
-import Control.Applicative
-import Control.Monad
-import Data.Foldable (Foldable, foldMap)
-import Data.List
-import Data.Traversable (Traversable, sequenceA)
-import Domain.Math.Simplification
-import Test.QuickCheck
-import qualified Text.OpenMath.Dictionary.Linalg2 as OM
-
--------------------------------------------------------------------------------
--- Data types
-
-newtype Vector a = V [a]
-   deriving (Eq, Ord)
-
-newtype VectorSpace a = VS [Vector a]
-   deriving (Eq, Ord)
-
--------------------------------------------------------------------------------
--- Instances
-
-instance Functor Vector where
-   fmap f (V xs) = V (map f xs)
-
-instance Foldable Vector where
-   foldMap f (V xs) = foldMap f xs
-
-instance Traversable Vector where
-   sequenceA (V xs) = V <$> sequenceA xs
-
-instance Show a => Show (Vector a) where
-   show = showVectorWith show
-
-instance Num a => Num (Vector a) where
-   (+) = liftV2 (+)
-   (*) = liftV2 (*)
-   (-) = liftV2 (-)
-   negate = liftV negate
-   abs    = liftV abs
-   signum = liftV signum
-   fromInteger = fromList . return . fromInteger
-
-instance IsTerm a => IsTerm (Vector a) where
-   toTerm = function vectorSymbol . map toTerm . toList
-   fromTerm a = do
-      xs <- isFunction vectorSymbol a
-      ys <- mapM fromTerm xs
-      return (fromList ys)
-
-instance Arbitrary a => Arbitrary (Vector a) where
-   arbitrary   = liftM fromList $ oneof $ map vector [0..2]
-
-instance CoArbitrary a => CoArbitrary (Vector a) where
-   coarbitrary = coarbitrary . toList
-
-vectorSymbol :: Symbol
-vectorSymbol = newSymbol OM.vectorSymbol
-
-instance Simplify a => Simplify (Vector a) where
-   simplifyWith opt = fmap (simplifyWith opt)
-
-instance Functor VectorSpace where
-   fmap f (VS xs) = VS (map (fmap f) xs)
-
-instance Show a => Show (VectorSpace a) where
-   show = show . vectors
-
-instance IsTerm a => IsTerm (VectorSpace a) where
-   toTerm = toTerm . vectors
-   fromTerm a = do
-      xs <- fromTerm a
-      guard (sameDimension xs)
-      return (makeVectorSpace xs)
-
-instance Simplify a => Simplify (VectorSpace a) where
-   simplifyWith opt = fmap (simplifyWith opt)
-
-instance Arbitrary a => Arbitrary (VectorSpace a) where
-   arbitrary = do
-      i <- choose (0, 3) -- too many vectors "disables" prime factorization
-      j <- choose (0, 10 `div` i)
-      xs <- replicateM i (liftM fromList $ replicateM j arbitrary)
-      return $ makeVectorSpace xs
-
-instance CoArbitrary a => CoArbitrary (VectorSpace a) where
-   coarbitrary = coarbitrary . vectors
-
--------------------------------------------------------------------------------
--- Vector Space operations
-
--- Check whether all vectors have same dimension
-sameDimension :: [Vector a] -> Bool
-sameDimension xs =
-   case map dimension xs of
-      []   -> True
-      n:ns -> all (==n) ns
-
--- | Checks that all vectors in vector space have same dimension
-makeVectorSpace :: [Vector a] -> VectorSpace a
-makeVectorSpace xs
-   | sameDimension xs = VS xs
-   | otherwise        = error "makeVectorSpace: different dimensions"
-
-vectors :: VectorSpace a -> [Vector a]
-vectors (VS xs) = xs
-
-gramSchmidt :: Floating a => VectorSpace a -> VectorSpace a
-gramSchmidt (VS xs) = VS (reverse (foldr op [] xs))
- where
-   op a as = toUnit (foldr makeOrthogonal a as):as
-
--------------------------------------------------------------------------------
--- Vector operations
-
-showVectorWith :: (a -> String) -> Vector a -> String
-showVectorWith f (V xs) = "(" ++ intercalate "," (map f xs) ++ ")"
-
-toList :: Vector a -> [a]
-toList (V xs) = xs
-
-fromList :: [a] -> Vector a
-fromList = V
-
--- local helper function
-liftV :: (a -> b) -> Vector a -> Vector b
-liftV op = fromList . map op . toList
-
--- local helper function
-liftV2 :: (a -> b -> c) -> Vector a -> Vector b -> Vector c
-liftV2 op v1 v2 = fromList $ zipWith op (toList v1) (toList v2)
-
-toUnit :: Floating a => Vector a -> Vector a
-toUnit v = scale (1 / norm v) v
-
-isUnit :: Floating a => Vector a -> Bool
-isUnit v = norm v == 1
-
-isZero :: Num a => Vector a -> Bool
-isZero = all (==0) . toList
-
-makeOrthogonal :: Num a => Vector a -> Vector a -> Vector a
-makeOrthogonal v1 v2 = v2 - scale (innerProduct v1 v2) v1
-
-orthogonal :: Num a => Vector a -> Vector a -> Bool
-orthogonal v1 v2 = innerProduct v1 v2 == 0
-
-scale :: Num a => a -> Vector a -> Vector a
-scale a = liftV (*a)
-
-orthonormalList :: Floating a => [Vector a] -> Bool
-orthonormalList xs = all isUnit xs && all (uncurry orthogonal) pairs
- where
-   pairs = [ (a, b) | (i, a) <- zip [0::Int ..] xs, (j, b) <- zip [0..] xs, i < j ]
-
--- length of the vector (also called norm)
-norm :: Floating a => Vector a -> a
-norm v = sqrt $ innerProduct v v
-
-distance :: Floating a => Vector a -> Vector a -> a
-distance v1 v2 = norm (v1 - v2)
-
-vectorSum :: Num a => Vector a -> a
-vectorSum = sum . toList
-
-innerProduct :: Num a => Vector a -> Vector a -> a
-innerProduct v1 v2 = vectorSum (v1 * v2)
-
-dimension :: Vector a -> Int
-dimension = length . toList
− src/Domain/Logic.hs 
@@ -1,21 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Logic (module Export) where
-
-import Domain.Logic.BuggyRules as Export
-import Domain.Logic.Exercises as Export
-import Domain.Logic.Formula as Export
-import Domain.Logic.GeneralizedRules as Export
-import Domain.Logic.Generator as Export
-import Domain.Logic.Parser as Export
-import Domain.Logic.Rules as Export
-import Domain.Logic.Strategies as Export
− src/Domain/Logic/BuggyRules.hs 
@@ -1,228 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Buggy rules in the logic domain, expressing common misconceptions
---
------------------------------------------------------------------------------
-module Domain.Logic.BuggyRules (buggyRules) where
-
-import Common.Id
-import Common.Rewriting
-import Common.Transformation (Rule, buggyRule)
-import Domain.Logic.Formula
-import Domain.Logic.Generator()
-import qualified Common.Transformation as Rule
-
--- Collection of all known buggy rules
-buggyRules :: [Rule SLogic]
-buggyRules =
-   [ buggyRuleCommImp, buggyRuleAssImp, buggyRuleIdemImp, buggyRuleIdemEqui
-   , buggyRuleEquivElim1, buggyRuleImplElim2, buggyRuleEquivElim2, buggyRuleEquivElim3
-   , buggyRuleImplElim, buggyRuleImplElim1, buggyRuleDeMorgan1, buggyRuleDeMorgan2, buggyRuleDeMorgan3
-   , buggyRuleDeMorgan4, buggyRuleDeMorgan5, buggyRuleNotOverImpl, buggyRuleParenth1, buggyRuleParenth2
-   , buggyRuleParenth3, buggyRuleAssoc, buggyRuleAbsor
-   , buggyRuleAndSame, buggyRuleAndCompl, buggyRuleOrSame, buggyRuleOrCompl
-   , buggyRuleTrueProp, buggyRuleFalseProp, buggyRuleDistr, buggyRuleDistrNot
-   ]
-
-rule :: RuleBuilder f a => String -> f -> Rule a
-rule = Rule.rule . ( "logic.propositional.buggy" # )
-
-ruleList :: RuleBuilder f a => String -> [f] -> Rule a
-ruleList = Rule.ruleList . ( "logic.propositional.buggy" # )
-
------------------------------------------------------------------------------
--- Buggy rules
-
-buggyRuleAndSame :: Rule SLogic
-buggyRuleAndSame = buggyRule $ rule "AndSame" $
-   \x -> x :&&: x  :~>  T
-
-buggyRuleAndCompl :: Rule SLogic
-buggyRuleAndCompl = buggyRule $ ruleList "AndCompl"
-   [ \x -> x :&&: Not x  :~>  T
-   , \x -> Not x :&&: x  :~>  T
-   , \x -> x :&&: Not x  :~>  x
-   , \x -> Not x :&&: x  :~>  x
-   ]
-
-buggyRuleOrSame :: Rule SLogic
-buggyRuleOrSame = buggyRule $ rule "OrSame" $
-   \x -> x :||: x  :~>  T
-
-buggyRuleOrCompl :: Rule SLogic
-buggyRuleOrCompl = buggyRule $ ruleList "OrCompl"
-   [ \x -> x :||: Not x  :~>  F
-   , \x -> Not x :||:  x :~>  F
-   , \x -> x :||: Not x  :~>  x
-   , \x -> Not x :||:  x :~>  x
-   ]
-
-buggyRuleTrueProp :: Rule SLogic
-buggyRuleTrueProp = buggyRule $ ruleList "TrueProp"
-   [ \x -> x :||: T  :~>  x
-   , \x -> T :||: x  :~>  x
-   , \x -> x :&&: T  :~>  T
-   , \x -> T :&&: x  :~>  T
-   ]
-
-buggyRuleFalseProp :: Rule SLogic
-buggyRuleFalseProp = buggyRule $ ruleList "FalseProp"
-   [ \x -> x :||: F  :~>  F
-   , \x -> F :||: x  :~>  F
-   , \x -> x :&&: F  :~>  x
-   , \x -> F :&&: x  :~>  x
-   ]
-
-buggyRuleCommImp :: Rule SLogic
-buggyRuleCommImp = buggyRule $ rule "CommImp" $
-   \x y -> x :->: y  :~>  y :->: x --this does not hold: T->T => T->x
-
-buggyRuleAssImp :: Rule SLogic
-buggyRuleAssImp = buggyRule $ ruleList "AssImp"
-   [ \x y z -> x :->: (y :->: z)  :~>  (x :->: y) :->: z
-   , \x y z -> (x :->: y) :->: z  :~>  x :->: (y :->: z)
-   ]
-
-buggyRuleIdemImp :: Rule SLogic
-buggyRuleIdemImp = buggyRule $ rule "IdemImp" $
-   \x -> x :->: x  :~>  x
-
-buggyRuleIdemEqui :: Rule SLogic
-buggyRuleIdemEqui = buggyRule $ rule "IdemEqui" $
-   \x -> x :<->: x  :~>  x
-
-buggyRuleEquivElim1 :: Rule SLogic
-buggyRuleEquivElim1 = buggyRule $ ruleList "EquivElim1"
-    [ \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :&&: y)
-    , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :&&:  y)
-    , \x y -> x :<->: y :~> (x :&&: y) :||: ( x :&&: Not y)
-    , \x y -> x :<->: y :~> (x :&&: y) :||: (x :&&: y)
-    , \x y -> x :<->: y :~> (x :&&: y) :||: Not (x :||: Not y)
-    ]
-
-buggyRuleEquivElim2 :: Rule SLogic
-buggyRuleEquivElim2 = buggyRule $ ruleList "EquivElim2"
-    [ \x y -> x :<->: y :~> (x :||: y) :&&: (Not x :||: Not y)
-    , \x y -> x :<->: y :~> (x :&&: y) :&&: (Not x :&&: Not y)
-    , \x y -> x :<->: y :~> (x :&&: y) :||: (Not x :||: Not y)
-    ]
-
-buggyRuleEquivElim3 :: Rule SLogic
-buggyRuleEquivElim3 = buggyRule $ rule "EquivElim3"  $
-     \x y -> x :<->: y :~> Not x :||: y
-
-buggyRuleImplElim :: Rule SLogic
-buggyRuleImplElim = buggyRule $ ruleList "ImplElim"
-   [\x y -> x :->: y :~> Not (x :||: y)
-   ,\x y -> x :->: y :~> (x :||: y)
-   ,\x y -> x :->: y :~> Not (x :&&: y)
-   ]
-
-buggyRuleImplElim1 :: Rule SLogic
-buggyRuleImplElim1 = buggyRule $ rule "ImplElim1"  $
-     \x y -> x :->: y :~> Not x :&&: y
-
-buggyRuleImplElim2 :: Rule SLogic
-buggyRuleImplElim2 = buggyRule $ rule "ImplElim2" $
-     \x y -> x :->: y :~>  (x :&&: y) :||: (Not x :&&: Not y)
-
-buggyRuleDeMorgan1 :: Rule SLogic
-buggyRuleDeMorgan1 = buggyRule $ ruleList "DeMorgan1"
-    [ \x y -> Not (x :&&: y) :~>  Not x :||: y
-    , \x y -> Not (x :&&: y) :~>  x :||: Not y
-    , \x y -> Not (x :&&: y) :~>  x :||: y
-    , \x y -> Not (x :||: y) :~>  Not x :&&: y
-    , \x y -> Not (x :||: y) :~>  x :&&: Not y
-    , \x y -> Not (x :||: y) :~>  x :&&: y
-    ]
-
-buggyRuleDeMorgan2 :: Rule SLogic
-buggyRuleDeMorgan2 = buggyRule $ ruleList "DeMorgan2"
-    [ \x y -> Not (x :&&: y) :~>  Not (Not x :||: Not y)
-    , \x y -> Not (x :||: y) :~>  Not (Not x :&&: Not y) --note the firstNot in both formulas!
-    ]
-buggyRuleDeMorgan3 :: Rule SLogic
-buggyRuleDeMorgan3 = buggyRule $  rule "DeMorgan3" $
-    \x y -> Not (x :&&: y) :~>  Not x :&&: Not y
-
-buggyRuleDeMorgan4 :: Rule SLogic
-buggyRuleDeMorgan4 = buggyRule $  rule "DeMorgan4" $
-     \x y -> Not (x :||: y) :~>  Not x :||: Not y
-
-buggyRuleDeMorgan5 :: Rule SLogic
-buggyRuleDeMorgan5 = buggyRule $ ruleList "DeMorgan5"
-    [ \x y z -> Not (Not (x :&&: y) :||: z) :~>  Not (Not x :||: Not y):||: z
-    , \x y z -> Not (Not (x :&&: y) :&&: z) :~>  Not (Not x :||: Not y):&&: z
-    , \x y z -> Not (Not (x :||: y) :||: z) :~>  Not (Not x :&&: Not y):||: z
-    , \x y z -> Not (Not (x :||: y) :&&: z) :~>  Not (Not x :&&: Not y):&&: z
-    ]
-
-buggyRuleNotOverImpl :: Rule SLogic
-buggyRuleNotOverImpl = buggyRule $ rule "NotOverImpl" $
-    \x y -> Not (x :->: y) :~> Not x :->: Not y
-
-buggyRuleParenth1 :: Rule SLogic
-buggyRuleParenth1 = buggyRule $ ruleList "Parenth1"
-    [ \x y -> Not (x :&&: y)     :~> Not x :&&: y
-    , \x y -> Not (x :||: y)     :~> Not x :||: y
-    ]
-
-buggyRuleParenth2 :: Rule SLogic
-buggyRuleParenth2 = buggyRule $ rule "Parenth2" $
-    \x y -> Not (x :<->: y) :~> Not(x :&&: y) :||: (Not x :&&: Not y)
-
-buggyRuleParenth3 :: Rule SLogic
-buggyRuleParenth3 = buggyRule $ ruleList "Parenth3"
-    [ \x y -> Not (Not x :&&: y)  :~> x :&&: y
-    , \x y -> Not (Not x :||: y)  :~> x :||: y
-    , \x y -> Not (Not x :->: y)  :~> x :->: y
-    , \x y -> Not (Not x :<->: y) :~> x :<->: y
-    ]
-
-buggyRuleAssoc :: Rule SLogic
-buggyRuleAssoc = buggyRule $ ruleList "Assoc"
-    [ \x y z -> x :||: (y :&&: z) :~> (x :||: y) :&&: z
-    , \x y z -> (x :||: y) :&&: z :~> x :||: (y :&&: z)
-    , \x y z -> (x :&&: y) :||: z :~> x :&&: (y :||: z)
-    , \x y z -> x :&&: (y :||: z) :~> (x :&&: y) :||: z
-    ]
-
-buggyRuleAbsor :: Rule SLogic
-buggyRuleAbsor = buggyRule $ ruleList "Absor"
-    [ \x y z -> (x :||: y) :||: ((x :&&: y) :&&: z) :~> (x :||: y)
-    , \x y z -> (x :&&: y) :||: ((x :||: y) :&&: z) :~> (x :&&: y)
-    , \x y z -> (x :||: y) :&&: ((x :&&: y) :||: z) :~> (x :||: y)
-    , \x y z -> (x :&&: y) :&&: ((x :||: y) :||: z) :~> (x :&&: y)
-    ]
-
-buggyRuleDistr :: Rule SLogic
-buggyRuleDistr = buggyRule $ ruleList "Distr"
-   [ \x y z -> x :&&: (y :||: z)  :~>  (x :&&: y) :&&: (x :&&: z)
-   , \x y z -> (x :||: y) :&&: z  :~>  (x :&&: z) :&&: (y :&&: z)
-   , \x y z -> x :&&: (y :||: z)  :~>  (x :||: y) :&&: (x :||: z)
-   , \x y z -> (x :||: y) :&&: z  :~>  (x :||: z) :&&: (y :||: z)
-   , \x y z -> x :||: (y :&&: z)  :~>  (x :||: y) :||: (x :||: z)
-   , \x y z -> (x :&&: y) :||: z  :~>  (x :||: z) :||: (y :||: z)
-   , \x y z -> x :||: (y :&&: z)  :~>  (x :&&: y) :||: (x :&&: z)
-   , \x y z -> (x :&&: y) :||: z  :~>  (x :&&: z) :||: (y :&&: z)
-   ]
-
-buggyRuleDistrNot :: Rule SLogic
-buggyRuleDistrNot = buggyRule $ ruleList "DistrNot"
-   [ \x y z -> Not x :&&: (y :||: z)  :~>  (Not x :&&: y) :||: (x :&&: z)
-   , \x y z -> Not x :&&: (y :||: z)  :~>  (x :&&: y) :||: (Not x :&&: z)
-   , \x y z -> (x :||: y) :&&: Not z  :~>  (x :&&: Not z) :||: (y :&&: z)
-   , \x y z -> (x :||: y) :&&: Not z  :~>  (x :&&: z) :||: (y :&&: Not z)
-   , \x y z -> Not x :||: (y :&&: z)  :~>  (Not x :||: y) :&&: (x :||: z)
-   , \x y z -> Not x :||: (y :&&: z)  :~>  (x :||: y) :&&: (Not x :||: z)
-   , \x y z -> (x :&&: y) :||: Not z  :~>  (x :||: Not z) :&&: (y :||: z)
-   , \x y z -> (x :&&: y) :||: Not z  :~>  (x :||: z) :&&: (y :||: Not z)
-   ]
− src/Domain/Logic/Examples.hs 
@@ -1,41 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  josje.lodder@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A set of example proofs
---
------------------------------------------------------------------------------
-module Domain.Logic.Examples
-   ( exampleProofs
-   ) where
-
-import Common.Utils (ShowString(..))
-import Domain.Logic.Formula
-
-exampleProofs :: [(SLogic, SLogic)]
-exampleProofs = [(Not(p :||: (Not p :&&: q)), Not(p :||: q)),
-                ((p :->:q):||: Not p, (p :->: q) :||: q),
-                ((p :&&: Not q):||:(q :&&: Not p), (p :||:q):&&:Not(p :&&: q)),
-                (Not(p :||: Not(p :||: Not q)), Not(p :||: q)),
-                (p :<->: q, (p :->: q) :&&: (q :->: p)),
-                ((p :&&: q) :->: p, T),
-                ((p :->: q) :||: (q :->: p), T),
-                ((q :->: (Not p :->: q)) :->: p, Not p :->: (q :&&: ((p :&&: q) :&&: q))),
-                ((p :->: Not q):->:q, (s :||:(s :->:(q :||: p))) :&&: q),
-                (p :->: (q :->: r), (p :->: q) :->: (p :->:r)),
-                (Not((p :->: q) :->: Not(q :->: p)), p :<->: q),
-                 ((p :->: q):->: (p :->: s), (Not q :->: Not p) :->: (Not s :->: Not p)),
-                (Not((p :->:q) :->: (p:&&:q)), (p :->: q) :&&: (Not p :||: Not q)),
-                (Not((p :<->: q) :->: (p :||: (p :<->: q))), F)]
-
- where
-   p = Var (ShowString "p")
-   q = Var (ShowString "q")
-   s = Var (ShowString "s")
-   r = Var (ShowString "r")
− src/Domain/Logic/Exercises.hs 
@@ -1,87 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Exercise for the logic domain, used for the OUNL course
--- "Discrete Wiskunde A (DWA)"
---
------------------------------------------------------------------------------
-module Domain.Logic.Exercises
-   ( dnfExercise, dnfUnicodeExercise
-   ) where
-
-import Common.Library
-import Data.Maybe
-import Domain.Logic.BuggyRules
-import Domain.Logic.Formula
-import Domain.Logic.Generator
-import Domain.Logic.Parser
-import Domain.Logic.Rules
-import Domain.Logic.Strategies
-import Test.QuickCheck
-
--- Currently, we use the DWA strategy
-dnfExercise :: Exercise SLogic
-dnfExercise = makeExercise
-   { exerciseId     = describe "Proposition to DNF" $
-                         newId "logic.propositional.dnf"
-   , status         = Stable
-   , parser         = parseLogicPars
-   , prettyPrinter  = ppLogicPars
-   , equivalence    = withoutContext eqLogic
-   , similarity     = withoutContext equalLogicA
-   , ready          = predicate isDNF
-   , suitable       = predicate mySuitable
-   , extraRules     = map liftToContext (extraLogicRules ++ buggyRules)
-   , strategy       = dnfStrategyDWA
-   , navigation     = navigator
-   , testGenerator  = Just (restrictGenerator mySuitable arbitrary)
-   , randomExercise = useGenerator (const True) logicExercise
-   }
-
--- Direct support for unicode characters
-dnfUnicodeExercise :: Exercise SLogic
-dnfUnicodeExercise = dnfExercise
-   { exerciseId    = describe "Proposition to DNF (unicode support)" $
-                        newId "logic.propositional.dnf.unicode"
-   , parser        = parseLogicUnicodePars
-   , prettyPrinter = ppLogicUnicodePars
-   }
-
-logicExercise :: Difficulty -> Gen SLogic
-logicExercise dif =
-   let (gen, (minStep, maxStep)) = generateLevel dif
-       ok p = let i = fromMaybe maxBound (stepsRemaining maxStep p)
-              in countEquivalences p <= 2 && i >= minStep && i <= maxStep
-   in restrictGenerator ok gen
-
-mySuitable :: SLogic -> Bool
-mySuitable = (<=2) . countEquivalences
-
-stepsRemaining :: Int -> SLogic -> Maybe Int
-stepsRemaining i =
-   lengthMax i . derivationTree dnfStrategyDWA . inContext dnfExercise
-
--- QuickCheck property to monitor the number of steps needed
--- to normalize a random proposition (30-40% is ok)
-{-
-testGen :: Property
-testGen = forAll generateLogic $ \p ->
-   let n = steps p
-   in countEquivalences p <= 2 ==> label (show (n >= 4 && n <= 12)) True
-
-testme :: IO ()
-testme = quickCheck testGen
-
-start = ((r :<->: p) :||: (q :->: s)) :&&: (Not s :<->: (p :||: r))
- where
-  (p, q, r, s) = (Var "p", Var "q", Var "r", Var "s")
-
-go = derivation . emptyState dnfExercise
--}
− src/Domain/Logic/Formula.hs 
@@ -1,208 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Logic.Formula
-   ( module Domain.Logic.Formula
-   , conjunctions, disjunctions, ors, ands
-   ) where
-
-import Common.Algebra.Boolean
-import Common.Algebra.CoBoolean
-import Common.Classes
-import Common.Rewriting
-import Common.Utils (ShowString, subsets)
-import Common.Utils.Uniplate
-import Control.Applicative
-import Control.Monad
-import Data.Foldable (Foldable, foldMap, toList)
-import Data.List
-import qualified Data.Traversable as T
-import qualified Text.OpenMath.Dictionary.Logic1 as OM
-
-infixr 2 :<->:
-infixr 3 :->:
-infixr 4 :||:
-infixr 5 :&&:
-
--- | The data type Logic is the abstract syntax for the domain
--- | of logic expressions.
-data Logic a = Var a
-             | Logic a :->:  Logic a            -- implication
-             | Logic a :<->: Logic a            -- equivalence
-             | Logic a :&&:  Logic a            -- and (conjunction)
-             | Logic a :||:  Logic a            -- or (disjunction)
-             | Not (Logic a)                    -- not
-             | T                                -- true
-             | F                                -- false
- deriving (Eq, Ord)
-
--- | For simple use, we assume the variables to be strings
-type SLogic = Logic ShowString
-
-instance Show a => Show (Logic a) where
-   show = ppLogic
-
-instance Functor Logic where
-   fmap = T.fmapDefault
-
-instance Foldable Logic where
-   foldMap = T.foldMapDefault
-
-instance T.Traversable Logic where
-   traverse f = foldLogic
-      ( fmap Var . f, liftA2 (:->:), liftA2 (:<->:), liftA2 (:&&:)
-      , liftA2 (:||:), liftA Not, pure T, pure F
-      )
-
-instance BoolValue (Logic a) where
-   fromBool b = if b then T else F
-   isTrue T  = True
-   isTrue _  = False
-   isFalse F = True
-   isFalse _ = False
-
-instance Boolean (Logic a) where
-   (<&&>)     = (:&&:)
-   (<||>)     = (:||:)
-   complement = Not
-
-instance CoBoolean (Logic a) where
-   isAnd (p :&&: q)     = Just (p, q)
-   isAnd _              = Nothing
-   isOr  (p :||: q)     = Just (p, q)
-   isOr  _              = Nothing
-   isComplement (Not p) = Just p
-   isComplement _       = Nothing
-
-instance Container Logic where
-   singleton            = Var
-   getSingleton (Var a) = Just a
-   getSingleton _       = Nothing
-
--- | The type LogicAlg is the algebra for the data type Logic
--- | Used in the fold for Logic.
-type LogicAlg b a = (b -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a, a, a)
-
--- | foldLogic is the standard fold for Logic.
-foldLogic :: LogicAlg b a -> Logic b -> a
-foldLogic (var, impl, equiv, conj, disj, neg, tr, fl) = rec
- where
-   rec logic =
-      case logic of
-         Var x     -> var x
-         p :->: q  -> rec p `impl`  rec q
-         p :<->: q -> rec p `equiv` rec q
-         p :&&: q  -> rec p `conj`  rec q
-         p :||: q  -> rec p `disj`  rec q
-         Not p     -> neg (rec p)
-         T         -> tr
-         F         -> fl
-
--- | Pretty-printer for propositions
-ppLogic :: Show a => Logic a -> String
-ppLogic = ppLogicPrio 0
-
-ppLogicPrio :: Show a => Int -> Logic a -> String
-ppLogicPrio = (\f s -> f s "") . flip (foldLogic alg)
- where
-   alg = ( pp . show, binop 3 "->", binop 0 "<->", binop 2 "/\\"
-         , binop 1 "||", nott, pp "T", pp "F")
-   binop prio op p q n = parIf (n > prio) (p (prio+1) . ((" "++op++" ")++) . q prio)
-   pp s      = const (s++)
-   nott p _  = ("~"++) . p 4
-   parIf b f = if b then ("("++) . f . (")"++) else f
-
--- | The monadic join for logic
-catLogic :: Logic (Logic a) -> Logic a
-catLogic = foldLogic (id, (:->:), (:<->:), (:&&:), (:||:), Not, T, F)
-
--- | evalLogic takes a function that gives a logic value to a variable,
--- | and a Logic expression, and evaluates the boolean expression.
-evalLogic :: (a -> Bool) -> Logic a -> Bool
-evalLogic env = foldLogic (env, impl, (==), (&&), (||), not, True, False)
- where
-   impl p q = not p || q
-
--- | eqLogic determines whether or not two Logic expression are logically
--- | equal, by evaluating the logic expressions on all valuations.
-eqLogic :: Eq a => Logic a -> Logic a -> Bool
-eqLogic p q = all (\f -> evalLogic f p == evalLogic f q) fs
- where
-   xs = varsLogic p `union` varsLogic q
-   fs = map (flip elem) (subsets xs)
-
--- | A Logic expression is atomic if it is a variable or a constant True or False.
-isAtomic :: Logic a -> Bool
-isAtomic logic =
-   case logic of
-      Not (Var _) -> True
-      _           -> null (children logic)
-
--- | Functions isDNF, and isCNF determine whether or not a Logix expression
--- | is in disjunctive normal form, or conjunctive normal form, respectively.
-isDNF, isCNF :: Logic a -> Bool
-isDNF = all isAtomic . concatMap conjunctions . disjunctions
-isCNF = all isAtomic . concatMap disjunctions . conjunctions
-
--- | Count the number of equivalences
-countEquivalences :: Logic a -> Int
-countEquivalences p = length [ () | _ :<->: _ <- universe p ]
-
--- | Function varsLogic returns the variables that appear in a Logic expression.
-varsLogic :: Eq a => Logic a -> [a]
-varsLogic = nub . toList
-
-instance Uniplate (Logic a) where
-   uniplate this =
-      case this of
-         p :->: q  -> plate (:->:)  |* p |* q
-         p :<->: q -> plate (:<->:) |* p |* q
-         p :&&: q  -> plate (:&&:)  |* p |* q
-         p :||: q  -> plate (:||:)  |* p |* q
-         Not p     -> plate Not     |* p
-         _         -> plate this
-
-instance Different (Logic a) where
-   different = (T, F)
-
-instance IsTerm a => IsTerm (Logic a) where
-   toTerm = foldLogic
-      ( toTerm, binary impliesSymbol, binary equivalentSymbol
-      , binary andSymbol, binary orSymbol, unary notSymbol
-      , symbol trueSymbol, symbol falseSymbol
-      )
-
-   fromTerm a =
-      fromTermWith f a `mplus` liftM Var (fromTerm a)
-    where
-      f s []
-         | s == trueSymbol       = return T
-         | s == falseSymbol      = return F
-      f s [x]
-         | s == notSymbol        = return (Not x)
-      f s [x, y]
-         | s == impliesSymbol    = return (x :->: y)
-         | s == equivalentSymbol = return (x :<->: y)
-      f s xs
-         | s == andSymbol        = return (ands xs)
-         | s == orSymbol         = return (ors xs)
-      f _ _ = fail "fromTerm"
-
-trueSymbol, falseSymbol, notSymbol, impliesSymbol, equivalentSymbol,
-   andSymbol, orSymbol :: Symbol
-
-trueSymbol       = newSymbol OM.trueSymbol
-falseSymbol      = newSymbol OM.falseSymbol
-notSymbol        = newSymbol OM.notSymbol
-impliesSymbol    = newSymbol OM.impliesSymbol
-equivalentSymbol = newSymbol OM.equivalentSymbol
-andSymbol        = makeAssociative $ newSymbol OM.andSymbol
-orSymbol         = makeAssociative $ newSymbol OM.orSymbol
− src/Domain/Logic/GeneralizedRules.hs 
@@ -1,143 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Generalized rules, and inverse rules, for De Morgan and distributivity
---
------------------------------------------------------------------------------
-module Domain.Logic.GeneralizedRules
-   ( generalRuleDeMorganOr, generalRuleDeMorganAnd
-   , generalRuleAndOverOr, generalRuleOrOverAnd
-   , inverseDeMorganOr, inverseDeMorganAnd
-   , inverseAndOverOr, inverseOrOverAnd
-   ) where
-
--- Note: the generalized rules do not take AC-unification into account,
--- and perhaps they should.
-import Common.Algebra.Boolean
-import Common.Transformation (Rule)
-import Control.Monad
-import Domain.Logic.Formula
-import qualified Common.Transformation as Rule
-
-makeSimpleRule :: String -> (a -> Maybe a) -> Rule a
-makeSimpleRule s = Rule.makeSimpleRule ("logic.propositional." ++ s)
-
------------------------------------------------------------------------------
--- Inverse rules
-
--- generalized (works for multiple terms)
-inverseDeMorganOr :: Rule SLogic
-inverseDeMorganOr = makeSimpleRule "InvDeMorganOr" $ \p -> do
-   let xs = conjunctions p
-   guard (length xs > 1)
-   ys <- mapM isNot xs
-   return (Not $ ors ys)
-
--- generalized (works for multiple terms)
-inverseDeMorganAnd :: Rule SLogic
-inverseDeMorganAnd = makeSimpleRule "InvDeMorganAnd" $ \p -> do
-   let xs = disjunctions p
-   guard (length xs > 1)
-   ys <- mapM isNot xs
-   return (Not $ ands ys)
-
-inverseAndOverOr :: Rule SLogic
-inverseAndOverOr = makeSimpleRule "InvAndOverOr" $ \p -> do
-   let xs = disjunctions p
-   guard (length xs > 1)
-   do pairs <- mapM isAndHead xs
-      let (as, ys) = unzip pairs
-      guard (allSame as)
-      return (head as :&&: ors ys)
-    `mplus` do
-      pairs <- mapM isAndLast xs
-      let (ys, as) = unzip pairs
-      guard (allSame as)
-      return (ors ys :&&: head as)
-
-inverseOrOverAnd :: Rule SLogic
-inverseOrOverAnd = makeSimpleRule "InvOrOverAnd" $ \p -> do
-   let xs = conjunctions p
-   guard (length xs > 1)
-   do pairs <- mapM isOrHead xs
-      let (as, ys) = unzip pairs
-      guard (allSame as)
-      return (head as :||: ands ys)
-    `mplus` do
-      pairs <- mapM isOrLast xs
-      let (ys, as) = unzip pairs
-      guard (allSame as)
-      return (ands ys :||: head as)
-
-isNot :: SLogic -> Maybe SLogic
-isNot (Not p) = Just p
-isNot _       = Nothing
-
-isAndHead, isAndLast, isOrHead, isOrLast :: SLogic -> Maybe (SLogic, SLogic)
-isAndHead = useHead (:&&:) . conjunctions
-isAndLast = useLast (:&&:) . conjunctions
-isOrHead  = useHead (:||:) . disjunctions
-isOrLast  = useLast (:||:) . disjunctions
-
-useHead, useLast :: (a -> a -> a) -> [a] -> Maybe (a, a)
-useHead op (x:xs) | not (null xs) =
-   Just (x, foldr1 op xs)
-useHead _ _ = Nothing
-
-useLast op = fmap (\(x, y) -> (y, x)) . useHead (flip op) . reverse
-
-allSame :: Eq a => [a] -> Bool
-allSame []     = True
-allSame (x:xs) = all (==x) xs
-
------------------------------------------------------------------------------
--- Generalized rules
-
-generalRuleDeMorganOr :: Rule SLogic
-generalRuleDeMorganOr = makeSimpleRule "GenDeMorganOr" f
- where
-   f (Not e) = do
-      let xs = disjunctions e
-      guard (length xs > 2)
-      return (ands (map Not xs))
-   f _ = Nothing
-
-generalRuleDeMorganAnd :: Rule SLogic
-generalRuleDeMorganAnd = makeSimpleRule "GenDeMorganAnd" f
- where
-   f (Not e) = do
-      let xs = conjunctions e
-      guard (length xs > 2)
-      return (ors (map Not xs))
-   f _ = Nothing
-
-generalRuleAndOverOr :: Rule SLogic
-generalRuleAndOverOr = makeSimpleRule "GenAndOverOr" f
- where
-   f (x :&&: y) =
-      case (disjunctions x, disjunctions y) of
-         (xs, _) | length xs > 2 ->
-            return (ors (map (:&&: y) xs))
-         (_, ys) | length ys > 2 ->
-            return (ors (map (x :&&:) ys))
-         _ -> Nothing
-   f _ = Nothing
-
-generalRuleOrOverAnd :: Rule SLogic
-generalRuleOrOverAnd = makeSimpleRule "GenOrOverAnd" f
- where
-   f (x :||: y) =
-      case (conjunctions x, conjunctions y) of
-         (xs, _) | length xs > 2 ->
-            return (ands (map (:||: y) xs))
-         (_, ys) | length ys > 2 ->
-            return (ands (map (x :||:) ys))
-         _ -> Nothing
-   f _ = Nothing
− src/Domain/Logic/Generator.hs 
@@ -1,146 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Logic.Generator
-   ( generateLogic, generateLevel, equalLogicA, equalLogicACI
-   ) where
-
-import Common.Algebra.Boolean
-import Common.Exercise
-import Common.Utils (ShowString(..))
-import Common.Utils.Uniplate
-import Control.Monad
-import Data.Char
-import Data.List
-import Domain.Logic.Formula
-import Test.QuickCheck
-
--------------------------------------------------------------
--- Code that doesn't belong here
-
--- | Equality modulo associativity of operators
-equalLogicA :: Eq a => Logic a -> Logic a -> Bool
-equalLogicA p q = rec p == rec q
- where
-   rec a = case a of
-              _ :&&: _ -> ands (map rec (conjunctions a))
-              _ :||: _ -> ors  (map rec (disjunctions a))
-              _        -> descend rec a
-
--- | Equality modulo associativity/commutativity/idempotency of operators,
---   and there units/absorbing elements
-equalLogicACI :: Ord a => Logic a -> Logic a -> Bool
-equalLogicACI p q = rec p == rec q
- where
-   rec a@(_ :&&: _) =
-      let xs = filter (/=T) $ nub $ sort $ conjunctions a
-      in if F `elem` xs then F else ands (map rec xs)
-   rec a@(_ :||: _) =
-      let xs = filter (/=F) $ nub $ sort $ disjunctions a
-      in if T `elem` xs then T else ors (map rec xs)
-   rec a = descend rec a
-
------------------------------------------------------------
--- Logic generator
-
-generateLogic :: Gen SLogic
-generateLogic = normalGenerator
-
-generateLevel :: Difficulty -> (Gen SLogic, (Int, Int))
-generateLevel dif
-   | dif <= Easy      = (easyGenerator,      (3, 6))
-   | dif >= Difficult = (difficultGenerator, (7, 18))
-   | otherwise        = (normalGenerator,    (4, 12))
-
--- Use the propositions with 3-6 steps
-easyGenerator :: Gen SLogic
-easyGenerator = do
-   n  <- elements [2, 4] -- , return 8]
-   sizedGen True varGen n
-
--- Use the propositions with 4-12 steps
-normalGenerator :: Gen SLogic
-normalGenerator = do
-   p0 <- sizedGen False varGen 4
-   p1 <- preventSameVar varList p0
-   return (removePartsInDNF p1)
-
--- Use the propositions with 7-18 steps
-difficultGenerator :: Gen SLogic
-difficultGenerator = do
-   let vs = ShowString "s" : varList
-   p0 <- sizedGen False (elements vs) 4
-   p1 <- preventSameVar vs p0
-   return (removePartsInDNF p1)
-
-varList :: [ShowString]
-varList = map ShowString ["p", "q", "r"]
-
-varGen :: Gen ShowString
-varGen = elements varList
-
-sizedGen :: Bool -> Gen a -> Int -> Gen (Logic a)
-sizedGen constants gen = go
- where
-   go n
-      | n > 0 =
-           let rec   = go (n `div` 2)
-               op2 f = liftM2 f rec rec
-           in frequency
-                 [ (2, go 0)
-                 , (2, op2 (:->:))
-                 , (1, op2 (:<->:))
-                 , (3, op2 (:&&:))
-                 , (3, op2 (:||:))
-                 , (3, liftM Not rec)
-                 ]
-      | constants = frequency
-           [(5, liftM Var gen), (1, return T), (1, return F)]
-      | otherwise = liftM Var gen
-
------------------------------------------------------------------
--- Simple tricks for creating for "nice" logic propositions
-
-preventSameVar :: Eq a => [a] -> Logic a -> Gen (Logic a)
-preventSameVar xs = rec
- where
-   rec p = case holes p of
-              [(Var a, _), (Var b, update)] | a==b -> do
-                 c <- elements $ filter (/=a) xs
-                 return $ update (Var c)
-              _ -> descendM rec p
-
-removePartsInDNF :: SLogic -> SLogic
-removePartsInDNF = buildOr . filter (not . simple) . disjunctions
- where
-   buildOr [] = T
-   buildOr xs = foldl1 (:||:) xs
-
-   simple = all f . conjunctions
-    where
-      f (Not p) = null (children p)
-      f p       = null (children p)
-
------------------------------------------------------------
---- QuickCheck generator
-
-instance Arbitrary SLogic where
-   arbitrary = sized (\i -> sizedGen True varGen (i `min` 4))
-
-instance CoArbitrary SLogic where
-   coarbitrary = foldLogic
-      (var, bin 1, bin 2, bin 3, bin 4, un 5, con 6, con 7)
-    where
-      con       = variant :: Int -> Gen a -> Gen a
-      var       = un 0 . coarbitrary . map ord . fromShowString
-      un  n a   = con n . a
-      bin n a b = con n . a . b
− src/Domain/Logic/Parser.hs 
@@ -1,163 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Logic.Parser
-   ( parseLogic, parseLogicPars, parseLogicUnicodePars -- , parseLogicProof
-   , ppLogicPars, ppLogicUnicodePars
-   ) where
-
-import Common.Algebra.Boolean
-import Common.Utils (ShowString(..))
-import Domain.Logic.Formula
-import Text.Parsing
-import qualified Text.ParserCombinators.Parsec.Token as P
-
------------------------------------------------------------
---- Parser
-
-parseLogic :: String -> Either String SLogic
-parseLogic = parseBalanced (parserSLogic False False)
-
-parseLogicUnicode :: String -> Either String SLogic
-parseLogicUnicode = parseBalanced (parserSLogic True False)
-
-parseLogicPars :: String -> Either String SLogic
-parseLogicPars input =
-     either (Left . ambiguousOperators parseLogic input) suspiciousVariable
-   $ parseBalanced (parserSLogic False True) input
-
-parseLogicUnicodePars :: String -> Either String SLogic
-parseLogicUnicodePars input =
-   either (Left . ambiguousOperators parseLogicUnicode input) suspiciousVariable
-   $ parseBalanced (parserSLogic True True) input
-
-parseBalanced :: Parser a -> String -> Either String a
-parseBalanced p input =
-   maybe (parseSimple p input) (Left . show) (balanced [('(', ')')] input)
-
--- generalized parser
-parserSLogic :: Bool -> Bool -> Parser SLogic
-parserSLogic unicode extraPars = pLogic
- where
-   pLogic
-      | extraPars = atom <**> option id composed
-      | otherwise = buildExpressionParser table atom
-
-   composed = choice
-      [ flip (:->:)  <$ reservedOp implSym  <*> atom
-      , flip (:<->:) <$ reservedOp equivSym <*> atom
-      , (\xs x -> ors (x:xs))  <$> many1 (reservedOp disjSym >> atom)
-      , (\xs x -> ands (x:xs)) <$> many1 (reservedOp conjSym >> atom)
-      ]
-
-   atom = choice
-      [ T <$ P.reserved lexer trSym
-      , F <$ P.reserved lexer flSym
-      , Var . ShowString <$> P.identifier lexer
-      , P.parens lexer pLogic
-      , Not <$ reservedOp negSym <*> atom
-      ]
-
-   table =
-      [ [Infix ((:->:)  <$ reservedOp implSym)  AssocRight ]
-      , [Infix ((:&&:)  <$ reservedOp conjSym)  AssocRight ]
-      , [Infix ((:||:)  <$ reservedOp disjSym)  AssocRight ]
-      , [Infix ((:<->:) <$ reservedOp equivSym) AssocRight ]
-      ]
-
-   (implSym, equivSym, conjSym, disjSym, negSym, trSym, flSym)
-      | unicode   = unicodeTuple
-      | otherwise = asciiTuple
-
-lexer :: P.TokenParser a
-lexer = P.makeTokenParser $ emptyDef
-   { reservedNames   = ["T", "F"]
-   , reservedOpNames = ["~", "<->", "->", "||", "/\\"]
-   , identStart      = lower
-   , identLetter     = lower
-   , opStart         = fail ""
-   , opLetter        = fail ""
-   }
-
-reservedOp :: String -> Parser ()
-reservedOp = P.reservedOp lexer
-
------------------------------------------------------------
---- Helper-functions for syntax warnings
-
-ambiguousOperators :: (String -> Either a b) -> String -> String -> String
-ambiguousOperators p s err =
-   let msg = "Syntax error: ambiguous use of operators (write parentheses)"
-   in either (const err) (const msg) (p s)
-
--- Report variables
-suspiciousVariable :: SLogic -> Either String SLogic
-suspiciousVariable r =
-   case filter p (map fromShowString (varsLogic r)) of
-      v:_ -> Left $ "Unexpected variable " ++ v
-                 ++ ". Did you forget an operator?"
-      _   -> Right r
- where
-   p xs = length xs > 1 && all (`elem` "pqrst") xs
-
------------------------------------------------------------
---- Pretty-Printer
-
--- | Pretty printer that produces extra parentheses: also see parseLogicPars
-ppLogicPars :: SLogic -> String
-ppLogicPars = ppLogicParsGen asciiTuple
-
--- | Pretty printer with unicode characters
-ppLogicUnicodePars :: SLogic -> String
-ppLogicUnicodePars = ppLogicParsGen unicodeTuple
-
-ppLogicParsGen :: SymbolTuple -> SLogic -> String
-ppLogicParsGen (impl, equiv, conj, disj, neg, tr, fl) =
-   (\f -> f 0 "") . foldLogic alg
- where
-   alg = ( pp . fromShowString, binop 3 impl, binop 3 equiv, binop 1 conj
-         , binop 2 disj, nott, pp tr, pp fl
-         )
-   binop :: Int -> String -> (Int -> String -> String) -> (Int -> String -> String) -> Int -> String -> String
-   binop prio op p q n =
-      parIf (n/=0 && (n==3 || prio/=n))
-            (p prio . ((" "++op++" ")++) . q prio)
-   pp s = const (s++)
-   nott  p _ = (neg++) . p 3
-   parIf b f = if b then ("("++) . f . (")"++) else f
-
------------------------------------------------------------
---- Ascii symbols
-
-type SymbolTuple = (String, String, String, String, String, String, String)
-
-asciiTuple :: SymbolTuple
-asciiTuple = (implASym, equivASym, andASym, orASym, notASym, "T", "F")
-
-implASym, equivASym, andASym, orASym, notASym :: String
-implASym  = "->"
-equivASym = "<->"
-andASym   = "/\\"
-orASym    = "||"
-notASym   = "~"
-
------------------------------------------------------------
---- Unicode symbols
-
-unicodeTuple :: SymbolTuple
-unicodeTuple = (implUSym, equivUSym, andUSym, orUSym, notUSym, "T", "F")
-
-implUSym, equivUSym, andUSym, orUSym, notUSym :: String
-implUSym  = "\8594"
-equivUSym = "\8596"
-andUSym   = "\8743"
-orUSym    = "\8744"
-notUSym   = "\172"
− src/Domain/Logic/Rules.hs 
@@ -1,238 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Rewrite rules in the logic domain (including all the rules from the
--- DWA course)
---
------------------------------------------------------------------------------
-module Domain.Logic.Rules
-   ( extraLogicRules, ruleAbsorpAnd, ruleAbsorpOr, ruleAndOverOr
-   , ruleComplAnd, ruleComplOr, ruleDeMorganAnd, ruleDeMorganOr
-   , ruleDefEquiv, ruleDefImpl, ruleFalseInEquiv, ruleFalseInImpl
-   , ruleFalseZeroAnd, ruleFalseZeroOr, ruleIdempAnd, ruleIdempOr
-   , ruleNotFalse, ruleNotNot, ruleNotTrue, ruleTrueInEquiv
-   , ruleTrueInImpl, ruleTrueZeroAnd, ruleTrueZeroOr
-   ) where
-
-import Common.Id
-import Common.Rewriting
-import Common.Transformation (Rule, minorRule)
-import Domain.Logic.Formula
-import Domain.Logic.GeneralizedRules
-import Domain.Logic.Generator()
-import qualified Common.Transformation as Rule
-
-extraLogicRules :: [Rule SLogic]
-extraLogicRules =
-   [ ruleCommOr, ruleCommAnd, ruleAssocOr, ruleAssocAnd
-   , ruleFalseInEquiv, ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl
-   , ruleCommEquiv, ruleDefEquivImpls, ruleEquivSame, ruleImplSame
-   , generalRuleOrOverAnd, ruleOrOverAnd
-   , inverseDeMorganOr, inverseDeMorganAnd
-   , inverseAndOverOr, inverseOrOverAnd
-   ]
-
-logic :: IsId a => a -> Id
-logic = ( # ) "logic.propositional"
-
-rule :: RuleBuilder f a => String -> f -> Rule a
-rule = Rule.rule . logic
-
-ruleList :: RuleBuilder f a => String -> [f] -> Rule a
-ruleList = Rule.ruleList . logic
-
------------------------------------------------------------------------------
--- Commutativity
-
-ruleCommOr :: Rule SLogic
-ruleCommOr = rule "CommOr" $
-   \x y -> x :||: y  :~>  y :||: x
-
-ruleCommAnd :: Rule SLogic
-ruleCommAnd = rule "CommAnd" $
-   \x y -> x :&&: y  :~>  y :&&: x
-
------------------------------------------------------------------------------
--- Associativity (implicit)
-
-ruleAssocOr :: Rule SLogic
-ruleAssocOr = minorRule $ rule "AssocOr" $
-   \x y z -> (x :||: y) :||: z  :~>  x :||: (y :||: z)
-
-ruleAssocAnd :: Rule SLogic
-ruleAssocAnd = minorRule $ rule "AssocAnd" $
-   \x y z -> (x :&&: y) :&&: z  :~>  x :&&: (y :&&: z)
-
------------------------------------------------------------------------------
--- Distributivity
-
-ruleAndOverOr :: Rule SLogic
-
-ruleAndOverOr = ruleList "AndOverOr"
-   [ \x y z -> x :&&: (y :||: z)  :~>  (x :&&: y) :||: (x :&&: z)
-   , \x y z -> (x :||: y) :&&: z  :~>  (x :&&: z) :||: (y :&&: z)
-   ]
-
-ruleOrOverAnd :: Rule SLogic
-ruleOrOverAnd = ruleList "OrOverAnd"
-   [ \x y z -> x :||: (y :&&: z)  :~>  (x :||: y) :&&: (x :||: z)
-   , \x y z -> (x :&&: y) :||: z  :~>  (x :||: z) :&&: (y :||: z)
-   ]
-
------------------------------------------------------------------------------
--- Idempotency
-
-ruleIdempOr, ruleIdempAnd :: Rule SLogic
-
-ruleIdempOr = rule "IdempOr" $
-   \x -> x :||: x  :~>  x
-
-ruleIdempAnd = rule "IdempAnd" $
-   \x -> x :&&: x  :~>  x
-
------------------------------------------------------------------------------
--- Absorption
-
-ruleAbsorpOr, ruleAbsorpAnd :: Rule SLogic
-
-ruleAbsorpOr = ruleList "AbsorpOr"
-   [ \x y -> x :||: (x :&&: y)  :~>  x
-   , \x y -> x :||: (y :&&: x)  :~>  x
-   , \x y -> (x :&&: y) :||: x  :~>  x
-   , \x y -> (y :&&: x) :||: x  :~>  x
-   ]
-
-ruleAbsorpAnd = ruleList "AbsorpAnd"
-   [ \x y -> x :&&: (x :||: y)  :~>  x
-   , \x y -> x :&&: (y :||: x)  :~>  x
-   , \x y -> (x :||: y) :&&: x  :~>  x
-   , \x y -> (y :||: x) :&&: x  :~>  x
-   ]
-
------------------------------------------------------------------------------
--- True-properties
-
-ruleTrueZeroOr, ruleTrueZeroAnd, ruleComplOr, ruleNotTrue :: Rule SLogic
-
-ruleTrueZeroOr = ruleList "TrueZeroOr"
-   [ \x -> T :||: x  :~>  T
-   , \x -> x :||: T  :~>  T
-   ]
-
-ruleTrueZeroAnd = ruleList "TrueZeroAnd"
-   [ \x -> T :&&: x  :~>  x
-   , \x -> x :&&: T  :~>  x
-   ]
-
-ruleComplOr = ruleList "ComplOr"
-   [ \x -> x :||: Not x  :~>  T
-   , \x -> Not x :||: x  :~>  T
-   ]
-
-ruleNotTrue = rule "NotTrue" $
-   Not T  :~>  F
-
------------------------------------------------------------------------------
--- False-properties
-
-ruleFalseZeroOr, ruleFalseZeroAnd, ruleComplAnd, ruleNotFalse :: Rule SLogic
-
-ruleFalseZeroOr = ruleList "FalseZeroOr"
-   [ \x -> F :||: x  :~>  x
-   , \x -> x :||: F  :~>  x
-   ]
-
-ruleFalseZeroAnd = ruleList "FalseZeroAnd"
-   [ \x -> F :&&: x  :~>  F
-   , \x -> x :&&: F  :~>  F
-   ]
-
-ruleComplAnd = ruleList "ComplAnd"
-   [ \x -> x :&&: Not x  :~>  F
-   , \x -> Not x :&&: x  :~>  F
-   ]
-
-ruleNotFalse = rule "NotFalse" $
-   Not F  :~>  T
-
------------------------------------------------------------------------------
--- Double negation
-
-ruleNotNot :: Rule SLogic
-ruleNotNot = rule "NotNot" $
-   \x -> Not (Not x)  :~>  x
-
------------------------------------------------------------------------------
--- De Morgan
-
-ruleDeMorganOr :: Rule SLogic
-ruleDeMorganOr = rule "DeMorganOr" $
-   \x y -> Not (x :||: y)  :~>  Not x :&&: Not y
-
-ruleDeMorganAnd :: Rule SLogic
-ruleDeMorganAnd = rule "DeMorganAnd" $
-   \x y -> Not (x :&&: y)  :~>  Not x :||: Not y
-
------------------------------------------------------------------------------
--- Implication elimination
-
-ruleDefImpl :: Rule SLogic
-ruleDefImpl = rule "DefImpl" $
-   \x y -> x :->: y  :~>  Not x :||: y
-
------------------------------------------------------------------------------
--- Equivalence elimination
-
-ruleDefEquiv :: Rule SLogic
-ruleDefEquiv = rule "DefEquiv" $
-   \x y -> x :<->: y  :~>  (x :&&: y) :||: (Not x :&&: Not y)
-
------------------------------------------------------------------------------
--- Additional rules, not in the DWA course
-
-ruleFalseInEquiv :: Rule SLogic
-ruleFalseInEquiv = ruleList "FalseInEquiv"
-   [ \x -> F :<->: x  :~>  Not x
-   , \x -> x :<->: F  :~>  Not x
-   ]
-
-ruleTrueInEquiv :: Rule SLogic
-ruleTrueInEquiv = ruleList "TrueInEquiv"
-   [ \x -> T :<->: x  :~>  x
-   , \x -> x :<->: T  :~>  x
-   ]
-
-ruleFalseInImpl :: Rule SLogic
-ruleFalseInImpl = ruleList "FalseInImpl"
-   [ \x -> F :->: x  :~>  T
-   , \x -> x :->: F  :~> Not x
-   ]
-
-ruleTrueInImpl :: Rule SLogic
-ruleTrueInImpl = ruleList "TrueInImpl"
-   [ \x -> T :->: x  :~>  x
-   , \x -> x :->: T  :~>  T
-   ]
-
-ruleCommEquiv :: Rule SLogic
-ruleCommEquiv = rule "CommEquiv" $
-   \x y -> x :<->: y  :~>  y :<->: x
-
-ruleDefEquivImpls :: Rule SLogic
-ruleDefEquivImpls = rule "DefEquivImpls" $
-   \x y -> x :<->: y  :~>  (x :->: y) :&&: (y :->: x)
-
-ruleEquivSame :: Rule SLogic
-ruleEquivSame = rule "EquivSame" $
-   \x -> x :<->: x  :~>  T
-
-ruleImplSame :: Rule SLogic
-ruleImplSame = rule "ImplSame" $
-   \x -> x :->: (x::SLogic)  :~>  T
− src/Domain/Logic/Strategies.hs 
@@ -1,98 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Logic.Strategies
-   ( dnfStrategy, dnfStrategyDWA, somewhereOr
-   ) where
-
-import Common.Library
-import Domain.Logic.Formula
-import Domain.Logic.GeneralizedRules
-import Domain.Logic.Rules
-
------------------------------------------------------------------------------
--- To DNF, with priorities (the "DWA" approach)
-
-dnfStrategyDWA :: LabeledStrategy (Context SLogic)
-dnfStrategyDWA =  label "Bring to dnf (DWA)" $
-   repeatS $ toplevel <|> somewhereOr
-      (  label "Simplify"                            simpl
-      |> label "Eliminate implications/equivalences" eliminateImplEquiv
-      |> label "Eliminate nots"                      eliminateNots
-      |> label "Move ors to top"                     orToTop
-      )
- where
-    toplevel = useRules
-       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr
-       , ruleAbsorpOr, ruleComplOr
-       ]
-    simpl = somewhere $ useRules
-       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd
-       , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse
-       , ruleNotNot, ruleIdempOr, ruleIdempAnd, ruleAbsorpOr, ruleAbsorpAnd
-       , ruleComplOr, ruleComplAnd
-       ]
-    eliminateImplEquiv = somewhere $ useRules
-       [ ruleDefImpl, ruleDefEquiv
-       ]
-    eliminateNots = somewhere $ useRules
-       [ generalRuleDeMorganAnd, generalRuleDeMorganOr
-       , ruleDeMorganAnd, ruleDeMorganOr
-       ]
-    orToTop = somewhere $ useRules
-       [ generalRuleAndOverOr, ruleAndOverOr ]
-
--- A specialized variant of the somewhere traversal combinator. Apply
--- the strategy only at (top-level) disjuncts
-somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic)
-somewhereOr s =
-   let isOr a = case current a of
-                   Just (_ :||: _) -> True
-                   _               -> False
-   in fix $ \this -> check (Prelude.not . isOr) <*> s
-                 <|> check isOr <*> once this
-
---check1, check2 :: (a -> Bool) -> Rule a
---check1 p = minorRule $ makeSimpleRule "check1" $ \a -> if p a then Just a else Nothing
---check2 p = minorRule $ makeSimpleRule "check2" $ \a -> if p a then Just a else Nothing
-
------------------------------------------------------------------------------
--- To DNF, in four steps
-
-dnfStrategy :: LabeledStrategy (Context SLogic)
-dnfStrategy =  label "Bring to dnf"
-      $  label "Eliminate constants"                 eliminateConstants
-     <*> label "Eliminate implications/equivalences" eliminateImplEquiv
-     <*> label "Eliminate nots"                      eliminateNots
-     <*> label "Move ors to top"                     orToTop
- where
-   eliminateConstants = repeatS $ topDown $ useRules
-      [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd
-      , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse, ruleFalseInEquiv
-      , ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl
-      ]
-   eliminateImplEquiv = repeatS $ bottomUp $ useRules
-      [ ruleDefImpl, ruleDefEquiv
-      ]
-   eliminateNots = repeatS $ topDown $
-      useRules
-         [ generalRuleDeMorganAnd, generalRuleDeMorganOr ]
-      |> useRules
-         [ ruleDeMorganAnd, ruleDeMorganOr
-         , ruleNotNot
-         ]
-   orToTop = repeatS $ somewhere $
-      liftToContext generalRuleAndOverOr |>
-      liftToContext ruleAndOverOr
-
--- local helper function
-useRules :: [Rule SLogic] -> Strategy (Context SLogic)
-useRules = alternatives . map liftToContext
− src/Domain/Logic/Views.hs 
@@ -1,100 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Logic.Views
-   ( (.<->.), (.->.), (.&&.), (.||.)
-   , simplify, pushNot, pushNotWith
-   , orView, andView
-   ) where
-
-import Common.Algebra.CoBoolean
-import Common.Id
-import Common.View hiding (simplify)
-import Domain.Logic.Formula
-
-------------------------------------------------------------
--- Smart constructors
-
-infixr 2 .<->.
-infixr 3 .->.
-
-(.<->.) :: Logic a -> Logic a -> Logic a
-T .<->. q = q
-F .<->. q = nott q
-p .<->. T = p
-p .<->. F = nott p
-p .<->. q = p :<->: q
-
-(.->.) :: Logic a -> Logic a -> Logic a
-T .->. q = q
-F .->. _ = T
-_ .->. T = T
-p .->. F = nott p
-p .->. q = p :->: q
-
-{- (.||.) :: Logic a -> Logic a -> Logic a
-T .||. _ = T
-F .||. q = q
-_ .||. T = T
-p .||. F = p
-p .||. q = p :||: q
-
-(.&&.) :: Logic a -> Logic a -> Logic a
-T .&&. q = q
-F .&&. _ = F
-p .&&. T = p
-_ .&&. F = F
-p .&&. q = p :&&: q -}
-
-nott :: Logic a -> Logic a
-nott (Not p) = p
-nott p       = Not p
-
--------------------------------------------------
--- Views and transformations
-
-simplify :: Logic a -> Logic a
-simplify = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), nott, T, F)
-
-pushNotWith :: (a -> Logic a) -> Logic a -> Logic a
-pushNotWith f = foldLogic (Var, (.->.), (.<->.), (.&&.), (.||.), rec, T, F)
- where
-   rec logic =
-      case logic of
-         Not p :<->: q -> p     .<->. q
-         p :<->: Not q -> p     .<->. q
-         p :<->: q     -> rec p .<->. q
-         p :->:  q     -> p     .&&.  rec q
-         p :||:  q     -> rec p .&&.  rec q
-         p :&&:  q     -> rec p .||.  rec q
-         Not p         -> p
-         T             -> F
-         F             -> T
-         Var a         -> f a
-
-pushNot :: Logic a -> Logic a
-pushNot = pushNotWith (nott . Var)
-
-orView :: View (Logic a) [a]
-orView = "logic.orView" @> makeView (($ []) . f) (foldr ((.||.) . Var) F)
- where
-   f (p :||: q) = (>>= f p) .  f q
-   f (Var a)    = return . (a:)
-   f F          = return
-   f _          = const Nothing
-
-andView :: View (Logic a) [a]
-andView = "logic.andView" @> makeView (($ []) . f) (foldr ((.&&.) . Var) T)
- where
-   f (p :&&: q) = (>>= f p) .  f q
-   f (Var a)    = return . (a:)
-   f T          = return
-   f _          = const Nothing
− src/Domain/Math/Approximation.hs 
@@ -1,84 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Selection of numerical algorithms for approximations
---
------------------------------------------------------------------------------
-module Domain.Math.Approximation where
-
-import Data.List
-
-type Function = Double -> Double
-
-type Approximation = [Double]
-
-------------------------------------------------------------
--- Precision of a floating-point number
-
-precision :: Int -> Double -> Double
-precision n = (/a) . fromInteger . round . (*a)
- where a = 10 Prelude.^ max 0 n
-
-------------------------------------------------------------
--- Stop criteria
-
-within :: Double -> Approximation -> Double
-within _ []  = error "within []"
-within _ [x] = x
-within d (x:xs@(y:_))
-   | abs (x-y) <= d = x
-   | otherwise      = within d xs
-
-relative :: Double -> Approximation -> Double
-relative _ []  = error "relative []"
-relative _ [x] = x
-relative d (x:xs@(y:_))
-   | abs (x-y) <= d*abs y = x
-   | otherwise            = relative d xs
-
-------------------------------------------------------------
--- Root-finding algorithms
-
--- http://en.wikipedia.org/wiki/Bisection_method
-bisection :: Function -> [Double] -> Approximation
-bisection f ds =
-   case partition ((<= 0) . f) ds of
-      (lo:_, hi:_) -> run hi lo
-      _            -> []
- where
-   run hi lo
-      | fm <= 0   = mid : run hi mid
-      | otherwise = mid : run mid lo
-    where
-      mid = (hi+lo) / 2
-      fm  = f mid
-
--- http://en.wikipedia.org/wiki/Newton's_method
-newton :: Function -> Function -> Double -> Approximation
-newton f df x0 = iterate next x0
- where
-    next a
-       | dfa == 0  = a
-       | otherwise = a - f a / dfa
-     where
-       dfa = df a
-
-------------------------------------------------------------
--- Finding the derivative of a function
-
-derivative :: Double -> Function -> Function
-derivative delta f x = (f (x+delta) - f (x-delta)) / (2*delta)
-
--- Test code
-{-
-same f g = sum [ abs (f x - g x) | x <- [0,0.01..6] ]
-
-test1 = same (derivative 0.01 sin) cos
-test2 = same (derivative 0.01 cos) (negate . sin) -}
− src/Domain/Math/CleanUp.hs 
@@ -1,173 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.CleanUp
-   ( cleanUpRelations, cleanUpRelation, cleanUpExpr
-   , cleanUpSimple, cleanUpView, cleanUpACView
-   , assocExpr, acExpr, smart, assocPlus, assocTimes
-   ) where
-
-import Common.Classes
-import Common.Utils (fixpoint)
-import Common.Utils.Uniplate
-import Common.View
-import Control.Monad
-import Data.Foldable (foldMap)
-import Data.List
-import Data.Maybe
-import Data.Ord
-import Data.Ratio
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Data.SquareRoot (fromSquareRoot)
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views (rationalView, integerView)
-import Domain.Math.Power.OldViews (powerFactorViewWith)
-import Domain.Math.SquareRoot.Views (squareRootViewWith)
-import Prelude hiding ((^), recip)
-import qualified Prelude
-
-----------------------------------------------------------------------
--- Root simplification
-
-simplerRoot :: Rational -> Integer -> Expr
-simplerRoot a b
-   | b < 0          = 1 ./. simplerRoot a (abs b)
-   | a < 0 && odd b = neg (simplerRoot (abs a) b)
-   | otherwise      = f (numerator a) b ./. f (denominator a) b
- where
-   f x y
-      | x == 0              = 0
-      | y == 0 || x <= 0    = root (fromIntegral x) (fromIntegral y)
-      | e Prelude.^ y == x  = fromIntegral e
-      | otherwise           = root (fromIntegral x) (fromIntegral y)
-    where
-      e = round ((fromIntegral x :: Double) ** (1 / fromIntegral y))
-
-------------------------------------------------------------
--- Cleaning up
-
-cleanUpSimple :: Expr -> Expr
-cleanUpSimple = fixpoint (transform (smart . f))
- where
-   f = simplifyWith (assocPlus rationalView) sumView
-
-cleanUpRelations :: OrList (Relation Expr) -> OrList (Relation Expr)
-cleanUpRelations = noDuplicates . foldMap cleanUpRelation
-
-cleanUpRelation :: Relation Expr -> OrList (Relation Expr)
-cleanUpRelation = f . fmap cleanUpBU
- where
-   f rel
-      | any falsity (universe a ++ universe b) = false
-      | a == b    = fromBool (relationType rel `elem` equals)
-      | otherwise =
-           case (match rationalView a, match rationalView b) of
-              (Just r, Just s) -> fromBool (eval (relationType rel) r s)
-              _                -> singleton rel
-    where
-      (a, b) = (leftHandSide rel, rightHandSide rel)
-
-   equals =
-      [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo, Approximately]
-
-   falsity :: Expr -> Bool
-   falsity (Sqrt e)  = maybe False (<0)  (match rationalView e)
-   falsity (_ :/: e) = maybe False (==0) (match rationalView e)
-   falsity _         = False
-
--- also simplify square roots
-cleanUpExpr :: Expr -> Expr
-cleanUpExpr = fixpoint $
-   cleanUpBU . transform (simplify (squareRootViewWith rationalView))
-
-cleanUpView, cleanUpACView :: View Expr Expr
-cleanUpView   = makeView (return . cleanUpExpr) id
-cleanUpACView = makeView (return . acExpr . cleanUpExpr) id
-
--- normalize expr with associativity and commutative rules for + and *
-assocExpr, acExpr :: Expr -> Expr
-assocExpr = normExpr id
-acExpr    = normExpr sort
-
-normExpr :: ([Expr] -> [Expr]) -> Expr -> Expr
-normExpr f = rec
- where
-   rec expr =
-      case (from sumView expr, from productView expr) of
-         (xs, _) | length xs > 1 ->
-            to sumView $ f $ map rec xs
-         (_, (b, xs)) | length xs > 1 ->
-            to productView (b, f $ map rec xs)
-         _ ->
-            descend rec expr
-
-------------------------------------------------------------
--- Associativity
-
-assocPlus, assocTimes :: View Expr a -> [Expr] -> [Expr]
-assocPlus  = assocOp (+)
-assocTimes = assocOp (*)
-
-assocOp :: (Expr -> Expr -> Expr) -> View Expr a -> [Expr] -> [Expr]
-assocOp op v = rec . map (simplify v)
- where
-   rec (x:y:zs) =
-      case canonical v (op x y) of
-         Just a  -> rec (a:zs)
-         Nothing -> x:rec (y:zs)
-   rec xs = xs
-
-------------------------------------------------------------
--- Fixpoint of a bottom-up traversal
-
-cleanUpBU :: Expr -> Expr
-cleanUpBU = {- fixpoint $ -} transform $ \e ->
-   simplify myView $
-   fromMaybe (smart e) $
-      canonical rationalView e
-    `mplus`
-      liftM (transform smart) (canonical specialSqrtOrder e)
-      -- Just simplify order of terms with square roots for now
-    `mplus` do
-      let f xs | length xs > 1 = return (assocPlus rationalView xs)
-          f _ = Nothing
-      canonicalWithM f sumView e
-    `mplus`
-      canonical myView e
-    `mplus` do
-      let f (b, xs) | length xs > 1 = return (b, assocTimes rationalView xs)
-          f _ = Nothing
-      canonicalWithM f simpleProductView e
- where
-   myView = powerFactorViewWith rationalView
-
-specialSqrtOrder :: View Expr [Expr]
-specialSqrtOrder = toView sumView >>> makeView f id
- where
-   make = match (squareRootViewWith rationalView)
-   g    = isNothing . fromSquareRoot . snd
-   f xs = do
-      ys <- mapM make xs
-      return $ map fst $ sortBy (comparing g) $ zip xs ys
-
-smart :: Expr -> Expr
-smart (a :*: b) = a .*. b
-smart (a :/: b) = a ./. b
-smart expr@(Sym s [x, y])
-   | isPowerSymbol s = x .^. y
-   | isRootSymbol  s = fromMaybe expr $
-        liftM2 simplerRoot (match rationalView x) (match integerView y)
-smart (Negate a) = neg a
-smart (a :+: b) = a .+. b
-smart (a :-: b) = a .-. b
-smart (Sqrt (Nat n)) = simplerRoot (fromIntegral n) 2
-smart e = e
− src/Domain/Math/Data/DecimalFraction.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Decimal fractions: the denominator of such a fraction must a power of 10.
--- Division in the Fractional type class is not safe.
---
------------------------------------------------------------------------------
-module Domain.Math.Data.DecimalFraction
-   ( DecimalFraction, fromDouble, validDivisor, digits
-   ) where
-
-import Control.Monad
-import Data.Maybe
-import Data.Ratio
-import Domain.Math.Safe
-
--- |Data type for decimal fractions
-newtype DecimalFraction = DF Rational -- Invariant: denominator is valid
-   deriving (Eq, Ord, Num, Real)
-
-instance Show DecimalFraction where
-   show d@(DF r) = show x ++ "." ++ replicate extra '0' ++ show y
-    where
-      digs   = digits d
-      base   = 10^digs
-      n      = numerator (r * fromInteger base)
-      (x, y) = n `divMod` base
-      extra  = digs - length (show y)
-
-instance Fractional DecimalFraction where
-   a/b = fromMaybe (error "invalid divisor") (safeDiv a b)
-   fromRational r = fromInteger (numerator r) / fromInteger (denominator r)
-
-instance SafeDiv DecimalFraction where
-   safeDiv (DF a) (DF b) = do
-      guard (validDivisor (DF b))
-      liftM DF (a `safeDiv` b)
-
-instance SafePower DecimalFraction where
-   safePower x (DF r)
-      | denominator r /= 1 = Nothing
-      | y >= 0             = Just a
-      | otherwise          = safeDiv 1 a
-    where
-      y = numerator r
-      a = x Prelude.^ abs y
-   safeRoot x y = safeRecip y >>= safePower x
-
--- | Approximation of a double, with a precision of 8 digits
-fromDouble :: Double -> DecimalFraction
-fromDouble d = DF (fromInteger base / 10^digs)
- where
-   digs = 8 :: Int -- maximum number of digits
-   base = round (d * 10^digs) :: Integer
-
--- |Tests whether it is safe to divide by this fraction: it is safe to divide
--- if its numerator(!) is a product of two's and five's.
-validDivisor :: DecimalFraction -> Bool
-validDivisor (DF a) = validDenominator (abs (numerator a))
-
--- |number of decimal digits
-digits :: DecimalFraction -> Int
-digits (DF r) = head $ filter p [0..]
- where
-   p i = 10^i `mod` denominator r == 0
-
--- local helper
-validDenominator :: Integer -> Bool
-validDenominator n
-   | n == 0         = False
-   | even n         = validDenominator (n `div` 2)
-   | n `mod` 5 == 0 = validDenominator (n `div` 5)
-   | otherwise      = n == 1
− src/Domain/Math/Data/Interval.hs 
@@ -1,309 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Support for mathematical intervals (open, closed, unbounded). @Interval@
--- is a normalized (and sorted) list of intervals that supports testing for
--- equality (provided that there is a valid ordering on the elements).
---
------------------------------------------------------------------------------
-module Domain.Math.Data.Interval
-   ( -- * Data types
-     Interval, Endpoint(..)
-     -- * Interval constructors
-   , empty, point, unbounded, open, closed
-   , leftOpen, rightOpen, greaterThan, greaterThanOrEqualTo
-   , lessThan, lessThanOrEqualTo, true, false
-     -- * Interval combinators
-   , except, union, intersect, complement
-     -- * Inspecing an interval
-   , segments, isIn
-     -- * QuickChecks
-   , testMe
-   ) where
-
-import Common.Algebra.Boolean
-import Common.Algebra.Law
-import Common.Utils (commaList)
-import Common.Utils.TestSuite
-import Control.Monad
-import Data.Maybe
-import Test.QuickCheck
-
---------------------------------------------------------------------
--- Data declarations
-
-newtype Interval a = I [Segment a]
-   deriving Eq
-
-data Segment a = S (Endpoint a) (Endpoint a)
-   deriving Eq
-
-data Endpoint a = Excluding a | Including a | Unbounded
-   deriving Eq
-
-instance Ord a => BoolValue (Interval a) where
-   fromBool b = if b then unbounded else empty
-   isTrue   = (==true)
-   isFalse  = (==false)
-
-instance Ord a => Boolean (Interval a) where
-   (<&&>)     = intersect
-   (<||>)     = union
-   complement = complementIntervals
-
-instance Show a => Show (Interval a) where
-   show (I xs) = "{ " ++ commaList (map show xs) ++ " }"
-
-instance Show a => Show (Segment a) where
-   show (S a b) = showLeft a ++ "," ++ showRight b
-
-instance Functor Endpoint where
-   fmap f (Excluding a) = Excluding (f a)
-   fmap f (Including a) = Including (f a)
-   fmap _ Unbounded     = Unbounded
-
-showLeft, showRight :: Show a => Endpoint a -> String
-showLeft  (Excluding a) = '(' : show a
-showLeft  (Including a) = '[' : show a
-showLeft  Unbounded     = "(-inf"
-showRight (Excluding a) = show a ++ ")"
-showRight (Including a) = show a ++ "]"
-showRight Unbounded     = "inf)"
-
---------------------------------------------------------------------
--- Interval constructors
-
-empty :: Interval a
-empty = I []
-
-point :: a -> Interval a
-point a = I [S (Including a) (Including a)]
-
-unbounded :: Ord a => Interval a
-unbounded = makeInterval Unbounded Unbounded
-
-open :: Ord a => a -> a -> Interval a
-open a b = makeInterval (Excluding a) (Excluding b)
-
-closed :: Ord a => a -> a -> Interval a
-closed a b = makeInterval (Including a) (Including b)
-
-leftOpen :: Ord a => a -> a -> Interval a
-leftOpen a b = makeInterval (Excluding a) (Including b)
-
-rightOpen :: Ord a => a -> a -> Interval a
-rightOpen a b = makeInterval (Including a) (Excluding b)
-
-greaterThan :: Ord a => a -> Interval a
-greaterThan a = makeInterval (Excluding a) Unbounded
-
-greaterThanOrEqualTo :: Ord a => a -> Interval a
-greaterThanOrEqualTo a = makeInterval (Including a) Unbounded
-
-lessThan :: Ord a => a -> Interval a
-lessThan a = makeInterval Unbounded (Excluding a)
-
-lessThanOrEqualTo :: Ord a => a -> Interval a
-lessThanOrEqualTo a = makeInterval Unbounded (Including a)
-
--- local constructor
-makeInterval :: Ord a => Endpoint a -> Endpoint a -> Interval a
-makeInterval pl pr = maybe empty (I . return) (makeSegment pl pr)
-
-makeSegment :: Ord a => Endpoint a -> Endpoint a -> Maybe (Segment a)
-makeSegment pl pr =
-   case liftM2 compare (getPoint pl) (getPoint pr) of
-      Just EQ
-         | isExcluding pl -> Nothing
-         | isExcluding pr -> Nothing
-      Just GT             -> Nothing
-      _ -> Just (S pl pr)
-
-isIncluding :: Endpoint a -> Bool
-isIncluding (Including _) = True
-isIncluding _             = False
-
-isExcluding :: Endpoint a -> Bool
-isExcluding (Excluding _) = True
-isExcluding _             = False
-
---------------------------------------------------------------------
--- Inspecting an interval
-
-segments :: Interval a -> [(Endpoint a, Endpoint a)]
-segments (I xs) = [ (a, b) | S a b <- xs ]
-
---------------------------------------------------------------------
--- Combining multiple intervals
-
-except :: Ord a => a -> Interval a
-except a = lessThan a <||> greaterThan a
-
-insert :: Ord a => Segment a -> Interval a -> Interval a
-insert ia (I xs) = I (rec ia xs)
- where
-   rec iv [] = [iv]
-   rec iv@(S a _) (hd@(S b _):rest) =
-      case merge iv hd of
-         Just new -> rec new rest
-         Nothing
-            | minPointLeft b a == b -> hd:rec iv rest
-            | otherwise             -> iv:hd:rest
-
-union :: Ord a => Interval a -> Interval a -> Interval a
-union xs (I ys) = foldr insert xs ys
-
-intersect :: Ord a => Interval a -> Interval a -> Interval a
-intersect (I xs) (I ys) = I (f xs ys)
- where
-   f (a@(S _ ar):as) (b@(S _ br):bs) =
-      let cond = maxPointRight ar br == ar
-          rest | cond      = f (a:as) bs
-               | otherwise = f as (b:bs)
-      in maybe id (:) (inBoth a b) rest
-   f _ _ = []
-
-complementIntervals :: Ord a => Interval a -> Interval a
-complementIntervals (I xs)
-   | null xs   = unbounded
-   | otherwise = I $ catMaybes $
-        left (head xs) : zipWith f xs (drop 1 xs) ++ [right (last xs)]
- where
-   f (S _ a) (S b _) = liftM2 S (g a) (g b)
-
-   g (Including a) = Just (Excluding a)
-   g (Excluding a) = Just (Including a)
-   g Unbounded     = Nothing
-
-   left  (S al _) = fmap (S Unbounded) (g al)
-   right (S _ ar) = fmap (flip S Unbounded) (g ar)
-
-isIn :: Ord a => a -> Interval a -> Bool
-isIn a (I xs) = any p xs
- where
-   p (S x y) = f GT x && f LT y
-   f value b =
-      let g c = (c==EQ && isIncluding b) || c==value
-      in maybe True (g . compare a) (getPoint b)
-
----------------------------------------------------------------------
--- Local helper functions
-
-getPoint :: Endpoint a -> Maybe a
-getPoint (Including a) = Just a
-getPoint (Excluding a) = Just a
-getPoint Unbounded     = Nothing
-
-merge :: Ord a => Segment a -> Segment a -> Maybe (Segment a)
-merge ia@(S al ar) ib@(S bl br)
-   | minPointLeft al bl /= al = merge ib ia
-   | otherwise =
-        case liftM2 compare (getPoint ar) (getPoint bl) of
-           Just LT -> Nothing
-           Just EQ | isExcluding ar && isExcluding bl -> Nothing
-           _ -> Just (S al (maxPointRight ar br))
-
-inBoth :: Ord a => Segment a -> Segment a -> Maybe (Segment a)
-inBoth (S al ar) (S bl br) =
-   makeSegment (maxPointLeft al bl) (minPointRight ar br)
-
-minPointLeft, minPointRight, maxPointLeft, maxPointRight
-   :: Ord a => Endpoint a -> Endpoint a -> Endpoint a
-minPointLeft  = compareEndpoint True  True
-minPointRight = compareEndpoint True  False
-maxPointLeft  = compareEndpoint False False
-maxPointRight = compareEndpoint False True
-
-compareEndpoint :: Ord a => Bool -> Bool -> Endpoint a -> Endpoint a -> Endpoint a
-compareEndpoint b1 b2 a b =
-   case liftM2 compare (getPoint a) (getPoint b) of
-      Just LT                -> x
-      Just EQ | p a          -> x
-              | otherwise    -> y
-      Just GT                -> y
-      Nothing | b2           -> Unbounded
-              | x==Unbounded -> y
-              | otherwise    -> x
- where
-   p = if b1==b2 then isIncluding else isExcluding
-   (x, y) = if b1 then (a, b) else (b, a)
-
----------------------------------------------------------------------
--- QuickCheck
-
-instance (Arbitrary a, Ord a) => Arbitrary (Endpoint a) where
-   arbitrary = frequency
-      [ (2, liftM Excluding arbitrary)
-      , (2, liftM Including arbitrary)
-      , (1, return Unbounded)
-      ]
-instance (CoArbitrary a, Ord a) => CoArbitrary (Endpoint a) where
-   coarbitrary (Excluding a) = variant (0 :: Int) . coarbitrary a
-   coarbitrary (Including a) = variant (1 :: Int) . coarbitrary a
-   coarbitrary Unbounded     = variant (2 :: Int)
-
-instance (Arbitrary a, Ord a) => Arbitrary (Interval a) where
-   arbitrary = do
-      n  <- choose (0, 100)
-      xs <- replicateM n (liftM2 makeInterval arbitrary arbitrary)
-      return (ors xs)
-
-instance (CoArbitrary a, Ord a) => CoArbitrary (Segment a) where
-   coarbitrary (S a b) = coarbitrary a . coarbitrary b
-
-instance (CoArbitrary a, Ord a) => CoArbitrary (Interval a) where
-   coarbitrary (I xs) = coarbitrary xs
-
-testMe :: TestSuite
-testMe = suite "Intervals" $ do
-
-   suite "Constructor functions" $ do
-     addProperty "empty"     $ op0 empty     (const False)
-     addProperty "unbounded" $ op0 unbounded (const True)
-
-     addProperty "greater than"             $ op1 greaterThan (>)
-     addProperty "greater than or equal to" $ op1 greaterThanOrEqualTo (>=)
-     addProperty "less than"                $ op1 lessThan (<)
-     addProperty "less than or equal to"    $ op1 lessThanOrEqualTo (<=)
-     addProperty "point    "                $ op1 point (==)
-
-     addProperty "open"       $ op2 open      (<)  (<)
-     addProperty "closed"     $ op2 closed    (<=) (<=)
-     addProperty "left open"  $ op2 leftOpen  (<)  (<=)
-     addProperty "right open" $ op2 rightOpen (<=) (<)
-
-   suite "Combinators" $ do
-      addProperty "except"     defExcept
-      addProperty "union"      defUnion
-      addProperty "intersect"  defIntersect
-      addProperty "complement" defComplement
-
-   suite "Boolean algebra" $
-      forM_ (booleanLaws :: [Law (Interval Int)]) $ \p ->
-         addProperty (show p) p
-
-defExcept :: Int -> Int -> Bool
-defExcept a b = isIn a (except b) == (a/=b)
-
-defUnion, defIntersect :: Int -> Interval Int -> Interval Int -> Bool
-defUnion     a b c = isIn a (b `union` c) == (isIn a b || isIn a c)
-defIntersect a b c = isIn a (b `intersect` c) == (isIn a b && isIn a c)
-
-defComplement :: Int -> Interval Int -> Bool
-defComplement a b = isIn a (complement b) == not (isIn a b)
-
-op0 :: Interval Int -> (Int -> Bool) -> Int -> Bool
-op0 g p a = isIn a g == p a
-
-op1 :: (Int -> Interval Int) -> (Int -> Int -> Bool) -> Int -> Int -> Bool
-op1 g op a b = isIn a (g b) == (a `op` b)
-
-op2 :: (Int -> Int -> Interval Int) -> (Int -> Int -> Bool) -> (Int -> Int -> Bool) -> Int -> Int -> Int -> Bool
-op2 g opl opr a b c = isIn a (g b c) == (b `opl` a && a `opr` c)
− src/Domain/Math/Data/MixedFraction.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Signed mixed fractions (also known as mixed numbers):
--- for example, 5[1/4] or -3[2/5]
---
------------------------------------------------------------------------------
-module Domain.Math.Data.MixedFraction
-   ( MixedFraction, wholeNumber, fractionPart, numerator, denominator
-   ) where
-
-import qualified Data.Ratio as R
-
-newtype MixedFraction = MF { unMF :: Rational }
-   deriving (Eq, Ord, Num, Fractional, Real, RealFrac)
-
-instance Show MixedFraction where
-   show mf
-      | b == 0    = sign ++ show a
-      | a == 0    = sign ++ show b ++ "/" ++ show c
-      | otherwise = sign ++ show a ++ "[" ++ show b ++ "/" ++ show c ++ "]"
-    where
-      (a, b, c) = (wholeNumber mf, numerator mf, denominator mf)
-      sign = if mf < 0 then "-" else ""
-
--- | Always positive
-wholeNumber :: MixedFraction -> Integer
-wholeNumber = fst . properMF
-
--- | Always positive
-fractionPart :: MixedFraction -> Rational
-fractionPart = snd . properMF
-
--- | Always positive
-numerator :: MixedFraction -> Integer
-numerator = R.numerator . fractionPart
-
--- | Always positive
-denominator :: MixedFraction -> Integer
-denominator = R.denominator . fractionPart
-
--- local helper
-properMF :: MixedFraction -> (Integer, Rational)
-properMF = properFraction . abs . unMF
− src/Domain/Math/Data/OrList.hs 
@@ -1,146 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Data.OrList
-   ( OrList, OrSet, true, false, (<>)
-   , isTrue, isFalse, fromBool, toOrList
-   , noDuplicates, catOrList
-   , oneDisjunct, orListView, orSetView
-   ) where
-
-import Common.Algebra.Boolean
-import Common.Algebra.CoGroup
-import Common.Algebra.Group
-import Common.Classes
-import Common.Rewriting
-import Common.View
-import Control.Applicative
-import Control.Monad (liftM2)
-import Data.Foldable (Foldable, foldMap, toList)
-import Data.List
-import Data.Traversable (Traversable, traverse)
-import Domain.Logic.Formula (Logic((:||:)))
-import Test.QuickCheck
-import qualified Data.Set as S
-import qualified Domain.Logic.Formula as Logic
-
-instance Functor OrList where
-   fmap f (OrList a) = OrList (fmap (map f) a)
-
-instance Foldable OrList where
-   foldMap f (OrList a) = maybe mempty (foldMap f) (fromWithZero a)
-
-instance Traversable OrList where
-   traverse f (OrList a) =
-      maybe (pure mzero) (liftA toOrList . traverse f) (fromWithZero a)
-
-------------------------------------------------------------
--- OrList data type
-
-newtype OrList a = OrList (WithZero [a]) deriving
-   (Eq, Ord, Monoid, MonoidZero, CoMonoid, CoMonoidZero)
-
-instance BoolValue (OrList a) where
-   fromBool b = if b then mzero else mempty
-   isTrue  = isMonoidZero
-   isFalse = isEmpty
-
-instance Container OrList where
-   singleton = OrList . pure . singleton
-   getSingleton (OrList a) = fromWithZero a >>= getSingleton
-
-instance IsTerm a => IsTerm (OrList a) where
-   toTerm = toTerm . build orListView
-   fromTerm expr = fromTerm expr >>= matchM orListView
-
-instance Arbitrary a => Arbitrary (OrList a) where
-   arbitrary = do
-      n  <- choose (1, 3)
-      xs <- vector n
-      return (toOrList xs)
-
-instance Show a => Show (OrList a) where
-   show xs | isTrue  xs = "true"
-           | isFalse xs = "false"
-           | otherwise  = f xs
-    where
-      f = unwords . intersperse "or" . map show . toList
-
-------------------------------------------------------------
--- Functions
-
--- | Remove duplicates
-noDuplicates :: Eq a => OrList a -> OrList a
-noDuplicates (OrList a) = OrList (fmap nub a)
-
-oneDisjunct :: Monad m => (a -> m (OrList a)) -> OrList a -> m (OrList a)
-oneDisjunct f (OrList a) =
-   case fromWithZero a of
-      Just [x] -> f x
-      _ -> fail "oneDisjunct"
-
-------------------------------------------------------------
--- OrSet data type
-
-newtype OrSet a = OrSet (WithZero (S.Set a)) deriving
-   (Eq, Ord, Monoid, MonoidZero, CoMonoid, CoMonoidZero)
-
-instance (Show a, Ord a) => Show (OrSet a) where
-   show = show . build orSetView
-
-instance Ord a => BoolValue (OrSet a) where
-   fromBool b = if b then mzero else mempty
-   isTrue  = isMonoidZero
-   isFalse = isEmpty
-
-instance Container OrSet where
-   singleton = OrSet . pure . singleton
-   getSingleton (OrSet a) = fromWithZero a >>= getSingleton
-
-------------------------------------------------------------
--- View to the logic data type
-
-toOrList :: [a] -> OrList a
-toOrList = mconcat . map singleton
-
-orListView :: View (Logic a) (OrList a)
-orListView = makeView f g
- where
-   f p  = case p of
-             Logic.Var a -> return (singleton a)
-             Logic.T     -> return true
-             Logic.F     -> return false
-             a :||: b    -> liftM2 mappend (f a) (f b)
-             _           -> Nothing
-   g = fromOr . foldOrListWith (Or . Logic.Var)
-
-orSetView :: Ord a => View (OrList a) (OrSet a)
-orSetView = makeView (Just . f) g
- where
-   f (OrList xs) = OrSet  (fmap S.fromList xs)
-   g (OrSet  xs) = OrList (fmap S.toList xs)
-
-foldOrList :: MonoidZero a => OrList a -> a
-foldOrList xs
-   | isTrue xs  = mzero
-   | isFalse xs = mempty
-   | otherwise  = foldr1 (<>) (toList xs)
-
-foldOrListWith :: MonoidZero b => (a -> b) -> OrList a -> b
-foldOrListWith f = foldOrList . fmap f
-
-{-
-foldOrListF :: (MonoidZero (f a), Container f) => OrList a -> f a
-foldOrListF = foldOrListWith to -}
-
-catOrList :: OrList (OrList a) -> OrList a
-catOrList = foldOrList
− src/Domain/Math/Data/Polynomial.hs 
@@ -1,253 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Data.Polynomial
-   ( Polynomial, var, con, raise
-   , degree, lowestDegree, coefficient, terms
-   , isMonic, toMonic, isRoot, positiveRoots, negativeRoots
-   , derivative, eval, longDivision, polynomialGCD
-   , factorize
-   ) where
-
-import Common.Classes
-import Control.Applicative (Applicative, (<$>), liftA)
-import Control.Monad
-import Data.Char
-import Data.Foldable (Foldable, foldMap)
-import Data.List (nub)
-import Data.Ratio (approxRational)
-import Data.Traversable (Traversable, sequenceA)
-import Domain.Math.Approximation (newton, within)
-import Domain.Math.Safe
-import Test.QuickCheck hiding (within)
-import qualified Data.IntMap as IM
-import qualified Data.IntSet as IS
-
-------------------------------------------------------------------
--- Data type:
---   Invariant: all keys are non-negative, all values are non-zero
---   (note that the second part of the invariant (zero values)
---    can be violated using the functor instance)
-
-newtype Polynomial a = P { unsafeP :: IM.IntMap a }
-
-invariant :: Num a => IM.IntMap a -> IM.IntMap a
-invariant = IM.filterWithKey (\n a -> n >= 0 && a /= 0)
-
-makeP :: Num a => IM.IntMap a -> Polynomial a
-makeP = P . invariant
-
-unP :: Num a => Polynomial a -> IM.IntMap a
-unP = invariant . unsafeP
-
--------------------------------------------------------------------
--- Instances
-
-instance Num a => Eq (Polynomial a) where
-   p1 == p2 = unP p1 == unP p2
-
-instance Num a => Show (Polynomial a) where
-   show p
-      | p ==0     = "f(x) = 0"
-      | otherwise = "f(x) = " ++ fix (concatMap f (reverse (IM.toList (unP p))))
-    where
-      f (n, a) = sign (one (show a ++ g n))
-      g n = concat $ [ "x" | n > 0 ] ++ [ '^' : show n | n > 1 ]
-      one ('1':xs@('x':_))     = xs
-      one ('-':'1':xs@('x':_)) = xs
-      one xs                   = xs
-      sign ('-':xs) = " - " ++ xs
-      sign xs       = " + " ++ xs
-      fix xs = case dropWhile isSpace xs of
-                  '+':ys -> dropWhile isSpace ys
-                  '-':ys -> '-':dropWhile isSpace ys
-                  ys     -> ys
-
-instance Fractional a => SafeDiv (Polynomial a) where
-   -- polynomial division, no remainder
-   safeDiv p1 p2
-      | p2==0     = Nothing
-      | degree p1 < degree p2 = Nothing
-      | b==0      = return a
-      | otherwise = Nothing
-    where
-      (a, b) = longDivision p1 p2
-
--- the Functor instance does not maintain the invariant
-instance Functor Polynomial where
-   fmap f = P . IM.map f . unsafeP
-
-instance Foldable Polynomial where
-   foldMap f = foldMap f . unsafeP
-
-instance Traversable Polynomial where
-   sequenceA = liftA P . sequenceIntMap . unsafeP
-
-instance Num a => Num (Polynomial a) where
-   p1 + p2 = makeP $ IM.unionWith (+) (unP p1) (unP p2)
-   p1 * p2 = makeP $ foldr (uncurry op) IM.empty list
-    where
-      op   = IM.insertWith (+)
-      list = [ (i+j, a*b) | (a, i) <- terms p1, (b, j) <- terms p2 ]
-   negate      = fmap negate
-   fromInteger = makeP . IM.singleton 0 . fromInteger
-   -- not defined for polynomials
-   abs    = error "abs not defined for polynomials"
-   signum = error "signum not defined for polynomials"
-
-instance (Arbitrary a, Num a) => Arbitrary (Polynomial a) where
-   arbitrary = do
-      d <- choose (0, 5)
-      let f n x = con x * var ^ n
-      liftM (sum . zipWith f [0::Int ..]) (vector (d+1))
-
--------------------------------------------------------------------
--- Functions on polynomials
-
--- a single variable (such as "x")
-var :: Num a => Polynomial a
-var = makeP (IM.singleton 1 1)
-
-con :: Num a => a -> Polynomial a
-con = makeP . IM.singleton 0
-
--- | Raise all powers by a constant (discarding negative exponents)
-raise :: Num a => Int -> Polynomial a -> Polynomial a
-raise i = makeP . IM.fromAscList . map (mapFirst (+i)) . IM.toList . unP
-
-------------------------------------------------
-
-degree :: Num a => Polynomial a -> Int
-degree p
-   | IS.null is = 0
-   | otherwise  = IS.findMax is
- where is = IM.keysSet (unP p)
-
-lowestDegree :: Num a => Polynomial a -> Int
-lowestDegree p
-   | IS.null is = 0
-   | otherwise  = IS.findMin is
- where is = IM.keysSet (unP p)
-
-coefficient :: Num a => Int -> Polynomial a -> a
-coefficient n = IM.findWithDefault 0 n . unP
-
-terms :: Num a => Polynomial a -> [(a, Int)]
-terms p = [ (a, n) | (n, a) <- IM.toList (unP p) ]
-
-isMonic :: Num a => Polynomial a -> Bool
-isMonic p = coefficient (degree p) p == 1
-
-toMonic :: Fractional a => Polynomial a -> Polynomial a
-toMonic p = con (recip a) * p
- where a = coefficient (degree p) p
-
-isRoot :: Num a => Polynomial a -> a -> Bool
-isRoot p a = eval p a == 0
-
--- Returns the maximal number of positive roots (Descartes theorem)
--- Multiple roots are counted separately
-positiveRoots :: Num a => Polynomial a -> Int
-positiveRoots = signChanges . IM.elems . unP
-
--- Returns the maximal number of negative roots (Descartes theorem)
--- Multiple roots are counted separately
-negativeRoots :: Num a => Polynomial a -> Int
-negativeRoots = signChanges . flipOdd . IM.elems . unP
- where
-   flipOdd (x:y:zs) = x:negate y:flipOdd zs
-   flipOdd xs = xs
-
-signChanges :: Num a => [a] -> Int
-signChanges = f . map signum
- where
-   f (x:xs@(hd:_)) = if x==hd then f xs else 1 + f xs
-   f _ = 0
-
-------------------------------------------------
-
-derivative :: Num a => Polynomial a -> Polynomial a
-derivative p = makeP $ IM.fromAscList
-   [ (n-1, fromIntegral n*a) | (n, a) <- IM.toList (unP p) ]
-
-eval :: Num a => Polynomial a -> a -> a
-eval p x = sum [ a * x^n | (n, a) <- IM.toList (unP p) ]
-
--- polynomial long division
-longDivision :: Fractional a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a)
-longDivision p1 p2 = monicLongDivision (f p1) (f p2)
- where
-   f p = con (recip a) * p
-   a   = coefficient (degree p2) p2
-
--- polynomial long division, where p2 is monic
-monicLongDivision :: Num a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a)
-monicLongDivision p1 p2
-   | d1 >= d2 && isMonic p2 = (toP quotient, toP remainder)
-   | otherwise = error $ "invalid monic division" ++ show (p1, p2)
- where
-   d1 = degree p1
-   d2 = degree p2
-   xs = map (`coefficient` p1) [d1, d1-1 .. 0]
-   ys = drop 1 $ map (negate . (`coefficient` p2)) [d2, d2-1 .. 0]
-
-   (quotient, remainder) = rec [] xs
-   toP = makeP . IM.fromAscList . zip [0..]
-
-   rec acc (a:as) | length as >= length ys =
-      rec (a:acc) (zipWith (+) (map (*a) ys ++ repeat 0) as)
-   rec acc as = (acc, reverse as)
-
--- use polynomial long division to compute the greatest common factor
--- of the polynomials
-polynomialGCD :: Fractional a => Polynomial a -> Polynomial a -> Polynomial a
-polynomialGCD x y
-   | degree y > degree x = rec y x
-   | otherwise           = rec x y
- where
-   rec a b
-      | b == 0    = a
-      | otherwise = rec b (snd (longDivision a b))
-
-------------------------
-
-factorize :: Polynomial Rational -> [Polynomial Rational]
-factorize p
-   | degree p <= 1 = [p]
-   | l > 0         = var ^ l : factorize (raise (-l) p)
-   | otherwise     =
-        case pairs of
-           (p1,p2):_ -> factorize p1 ++ factorize p2
-           []        -> [p]
- where
-   l     = snd (head (terms p))
-   pairs = [ (p1, p2)
-           | a <- candidateRoots p
-           , isRoot p a
-           , let p1 = var - con a
-           , Just p2 <- [safeDiv p p1]
-           ]
-
-candidateRoots :: Polynomial Rational -> [Rational]
-candidateRoots p = nub (map (`approxRational` 0.0001) xs)
- where
-    f  = eval (fmap fromRational p)
-    df = eval (fmap fromRational (derivative p))
-    xs = nub (map (within 0.0001 . take 10 . newton f df) startList)
-    startList = [0, 3, -3, 10, -10, 100, -100]
-
--- TODO: replace me by sequenceA
--- This definition is for backwards compatibility. In older versions of IntMap,
--- the instance for Traversable is lacking.
-sequenceIntMap :: Applicative m => IM.IntMap (m a) -> m (IM.IntMap a)
-sequenceIntMap m = IM.fromDistinctAscList <$> zip ks <$> sequenceA as
- where
-   (ks, as) = unzip (IM.toList m)
− src/Domain/Math/Data/PrimeFactors.hs 
@@ -1,173 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Data.PrimeFactors
-   ( PrimeFactors
-   , factors, multiplicity, coprime
-   , square, power, splitPower
-   , primes, greatestPower, allPowers
-   ) where
-
-import Data.Maybe
-import qualified Data.IntMap as IM
-
--------------------------------------------------------------
--- Representation
-
--- Invariants:
--- * Keys in map are prime numbers only (exception: representation of 0)
--- * Elements in map are positive (non-zero)
--- * Zero is represented by [(0,1)] (since 0^1 equals 0)
--- * The number can be negative, in which case we use the factors of
---   its absolute value
-data PrimeFactors = PF Integer Factors
-
-type Factors = IM.IntMap Int
-
--------------------------------------------------------------
--- Conversion to and from factors
-
-toFactors :: Integer -> Factors
-toFactors a
-   | a > 0     = rec primes a
-   | a < 0     = rec primes (-a)
-   | otherwise = IM.singleton 0 1
- where
-   rec [] n       = IM.singleton (fromIntegral n) 1
-   rec (p:ps) n
-      | n <= 1    = IM.empty
-      | otherwise = f 0 n
-    where
-      p2 = fromIntegral p
-      f i m
-         | r == 0    = f (i+1) q
-         | i >  0    = IM.insert p i (rec ps m)
-         | otherwise = rec ps m
-       where
-         (q, r) = quotRem m p2
-
-fromFactors :: Factors -> Integer
-fromFactors = product . map f . IM.toList
- where f (a, i) = toInteger a ^ toInteger i
-
--- For practical reasons, the list of prime numbers is cut-off after
--- 1000 elements (last primes gives 7919).
-primes :: [Int]
-primes = take 1000 $ rec [2..]
- where
-   rec (x:xs) = x : rec (filter (\y -> y `mod` x /= 0) xs)
-   rec []     = error "PrimeFactors: empty list"
-
--------------------------------------------------------------
--- Type class instances
-
-instance Show PrimeFactors where
-   show (PF a m) = show a ++ " (factors = " ++ show (IM.toList m) ++ ")"
-
-instance Eq PrimeFactors where
-    PF a _ == PF b _ = a==b
-
-instance Ord PrimeFactors where
-   PF a _ `compare` PF b _ = a `compare` b
-
-instance Num PrimeFactors where
-   PF a m1 + PF b m2
-      | a==0         = PF b m2 -- prevent recomputing prime factors
-      | b==0         = PF a m1
-      | otherwise    = fromInteger (a+b)
-   PF a m1 * PF b m2
-      | a==0 || b==0 = 0
-      | otherwise    = PF (a*b) (IM.unionWith (+) m1 m2)
-   negate (PF a m)   = PF (negate a) m
-   abs    (PF a m)   = PF (abs a) m
-   signum (PF a _)   = fromInteger (signum a)
-   fromInteger n     = PF n (toFactors n)
-
-instance Enum PrimeFactors where
-   toEnum   = fromIntegral
-   fromEnum = fromIntegral . toInteger
-
-instance Real PrimeFactors where
-   toRational = toRational . toInteger
-
-instance Integral PrimeFactors where
-   toInteger (PF a _) = a
-   quotRem = quotRemPF
-
--------------------------------------------------------------
--- Utility functions
-
-factors :: PrimeFactors -> [(Int, Int)]
-factors (PF _ m) = IM.toList m
-
-multiplicity :: Int -> PrimeFactors -> Int
-multiplicity i (PF _ m) = IM.findWithDefault 0 i m
-
--- no prime in common
-coprime :: PrimeFactors -> PrimeFactors -> Bool
-coprime (PF _ m1) (PF _ m2) = IM.null (IM.intersection m1 m2)
-
-square :: PrimeFactors -> PrimeFactors
-square = (`power` 2)
-
-power :: PrimeFactors -> Int -> PrimeFactors
-power (PF a m) i = PF (a^i) (IM.map (*i) m)
-
--- brute force, ugly
-greatestPower :: Integer -> Maybe (Integer, Integer)
-greatestPower n = f 2 1
-  where
-    f b e | n == b ^ e = Just (b, e)
-          | b > n      = Nothing
-          | b ^ e > n  = f (b + 1) 1
-          | otherwise  = f b (e + 1)
-
--- -- n == a^x with (a,x) == greatestPower n
--- prop_greatestPower n = traceShow n $
---    maybe True (\(a,x) -> fromIntegral a ^ fromIntegral x == n) $ greatestPower n
-
-allPowers :: Integer -> [(Integer, Integer)]
-allPowers n = do
-  (b, e) <- maybeToList $ greatestPower n
-  let f i = let (a, r) = e `divMod` i
-            in if a > 1 && r == 0 then Just (b^i, a) else Nothing
-  mapMaybe f [1..e]
-
--- prop_allPowers n = traceShow n $
---   and (map (\(a,x) -> fromIntegral a ^ fromIntegral x == n) (allPowers n))
-
--- splitPower i a = (b,c)
---  => b^i * c = a
-splitPower :: Int -> PrimeFactors -> (PrimeFactors, PrimeFactors)
-splitPower i (PF a m) = (PF b p1, PF c p2)
- where
-   pairs = IM.map (`quotRem` i) m
-   p1    = IM.filter (>0) (fmap fst pairs)
-   p2    = IM.filter (>0) (fmap snd pairs)
-   b     = fromFactors p1
-   c     = a `div` (b^i)
-
-quotRemPF :: PrimeFactors -> PrimeFactors -> (PrimeFactors, PrimeFactors)
-quotRemPF (PF a m1) (PF b m2)
-   | b==0 = error "PrimeFactors: division by zero"
-   | a==0 = (0,0)
-   | otherwise = sign $
-        case (IM.null up, IM.null dn) of
-           (True,  True)  -> (1, 0)
-           (False, True)  -> (PF (fromFactors up) up, 0)
-           (True,  False) -> (0, PF a m1)
-           _              -> (fromInteger qn, fromInteger rn)
- where
-   (up, dn) = IM.partition (>0) $ IM.filter (/=0) $ IM.unionWith (+) m1 (IM.map negate m2)
-   (qn, rn) = fromFactors up `quotRem` fromFactors (IM.map negate dn)
-   sign (q, r) = ( fromInteger (signum a*signum b) * q
-                 , fromInteger (signum a) * r
-                 )
− src/Domain/Math/Data/Relation.hs 
@@ -1,282 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Mathematical relations
---
------------------------------------------------------------------------------
-module Domain.Math.Data.Relation
-   ( -- * Type class
-     Relational(..)
-     -- * Relation data type
-   , Relation, relationType, RelationType(..), relationSymbols
-   , notRelation, eval
-     -- * Constructor functions
-   , makeType, (.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.)
-     -- * Equation (or equality)
-   , Equations, Equation(..), equationView
-     -- * Inequality
-   , Inequality(..), inequalityView
-   ) where
-
-import Common.Rewriting
-import Common.View
-import Control.Applicative
-import Control.Monad
-import Data.Foldable (Foldable, foldMap, toList)
-import Data.Maybe
-import Data.Monoid
-import Data.Traversable (Traversable, sequenceA)
-import Test.QuickCheck
-import Text.OpenMath.Dictionary.Relation1
-
------------------------------------------------------------------------------
--- Type class for relations
-
-class Functor f => Relational f where
-   leftHandSide  :: f a -> a
-   rightHandSide :: f a -> a
-   flipSides     :: f a -> f a -- possibly also flips operator
-   constructor   :: f a -> b -> b -> f b
-   isSymmetric   :: f a -> Bool
-   -- default definitions
-   isSymmetric _ = False
-
------------------------------------------------------------------------------
--- Relation data type
-
-data Relation a = R { lhs :: a, relationType :: RelationType, rhs :: a }
-   deriving (Eq, Ord)
-
--- Corresponds exactly to the symbols in the relation1 OpenMath dictionary
-data RelationType = EqualTo | NotEqualTo | LessThan | GreaterThan
-                  | LessThanOrEqualTo | GreaterThanOrEqualTo | Approximately
-   deriving (Show, Eq, Ord, Enum)
-
-instance Show a => Show (Relation a) where
-   show r = unwords [show (lhs r), showRelType (relationType r), show (rhs r)]
-
-instance Functor Relation where
-   fmap f (R x rt y) = R (f x) rt (f y)
-
-instance Foldable Relation where
-   foldMap = foldMapRelation
-
-instance Traversable Relation where
-   sequenceA = sequenceRelation
-
-instance Relational Relation where
-   leftHandSide  = lhs
-   rightHandSide = rhs
-   flipSides (R x rt y) = R y (flipRelType rt) x
-   constructor (R _ rt _) = flip R rt
-   isSymmetric = (`elem` [EqualTo, NotEqualTo, Approximately]) . relationType
-
-instance IsTerm a => IsTerm (Relation a) where
-   toTerm p =
-      let op  = relationType p
-          sym = maybe (newSymbol (show op)) snd (lookup op relationSymbols)
-      in binary sym (toTerm (leftHandSide p)) (toTerm (rightHandSide p))
-   fromTerm term =
-      case getFunction term of
-         Just (s, [a, b]) ->
-            case [ rt | (rt, (_, t)) <- relationSymbols, s==t ] of
-               [rt] -> liftM2 (makeType rt) (fromTerm a) (fromTerm b)
-               _    -> fail "fromTerm: relation"
-         _ -> fail "fromTerm: relation"
-
-relationSymbols :: [(RelationType, (String, Symbol))]
-relationSymbols =
-   [ (EqualTo,              ("==", newSymbol eqSymbol))
-   , (NotEqualTo,           ("/=", newSymbol neqSymbol))
-   , (LessThan,             ("<",  newSymbol ltSymbol))
-   , (GreaterThan,          (">",  newSymbol gtSymbol))
-   , (LessThanOrEqualTo,    ("<=", newSymbol leqSymbol))
-   , (GreaterThanOrEqualTo, (">=", newSymbol geqSymbol))
-   , (Approximately,        ("~=", newSymbol approxSymbol))
-   ]
-
-notRelation :: Relation a -> Relation a
-notRelation r = r { relationType = relationType r ? table }
- where
-   table = xs ++ map swap xs ++ [(Approximately, Approximately)]
-   swap (x, y) = (y, x)
-   xs = [ (EqualTo, NotEqualTo)
-        , (LessThan, GreaterThanOrEqualTo)
-        , (LessThanOrEqualTo, GreaterThan)
-        ]
-
-eval :: (Ord a, Num a) => RelationType -> a -> a -> Bool
-eval relType =
-   case relType of
-      EqualTo              -> (==)
-      NotEqualTo           -> (/=)
-      LessThan             -> (<)
-      GreaterThan          -> (>)
-      LessThanOrEqualTo    -> (<=)
-      GreaterThanOrEqualTo -> (>=)
-      Approximately        -> \a b -> 1000 * abs (a-b) < 1
-
--- helpers
-showRelType :: RelationType -> String
-showRelType = fst . (? relationSymbols)
-
-flipRelType :: RelationType -> RelationType
-flipRelType relType = fromMaybe relType (lookup relType table)
- where
-   table = pairs ++ map (\(a,b) -> (b,a)) pairs
-   pairs = [(LessThan, GreaterThan), (LessThanOrEqualTo, GreaterThanOrEqualTo)]
-
-(?) :: Eq a => a -> [(a, b)] -> b
-a ? xs = fromMaybe (error "Relation: Error in lookup") (lookup a xs)
-
-foldMapRelation :: (Relational f, Monoid m) => (a -> m) -> f a -> m
-foldMapRelation f p = f (leftHandSide p) `mappend` f (rightHandSide p)
-
-sequenceRelation :: (Relational g, Applicative f) => g (f a) -> f (g a)
-sequenceRelation p = constructor p <$> leftHandSide p <*> rightHandSide p
-
------------------------------------------------------------------------------
--- QuickCheck generators
-
-instance Arbitrary a => Arbitrary (Relation a) where
-   arbitrary = liftM3 R arbitrary arbitrary arbitrary
-
-instance CoArbitrary a => CoArbitrary (Relation a) where
-   coarbitrary p = coarbitrary (relationType p) . coarbitrary (toList p)
-
-instance Arbitrary RelationType where
-   arbitrary = elements [EqualTo .. Approximately]
-
-instance CoArbitrary RelationType where
-   coarbitrary op = variant (fromEnum op)
-
------------------------------------------------------------------------------
--- Constructor functions
-
-infix 1 .==., ./=., .<., .>., .<=., .>=., .~=.
-
-(.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.) :: a -> a -> Relation a
-(.==.) = makeType EqualTo
-(./=.) = makeType NotEqualTo
-(.<.)  = makeType LessThan
-(.>.)  = makeType GreaterThan
-(.<=.) = makeType LessThanOrEqualTo
-(.>=.) = makeType GreaterThanOrEqualTo
-(.~=.) = makeType Approximately
-
-makeType :: RelationType -> a -> a -> Relation a
-makeType = flip R
-
------------------------------------------------------------------------------
--- Equation data type (view on Relation)
-
-infix 1 :==:
-
-type Equations a = [Equation a]
-
-data Equation  a = a :==: a
-   deriving (Eq, Ord)
-
-instance Show a => Show (Equation a) where
-   show = show . build equationView
-
-instance Functor Equation where
-   fmap f (x :==: y) = f x :==: f y
-
-instance Foldable Equation where
-   foldMap = foldMapRelation
-
-instance Traversable Equation where
-   sequenceA = sequenceRelation
-
-instance Relational Equation where
-   leftHandSide  = leftHandSide  . build equationView
-   rightHandSide = rightHandSide . build equationView
-   flipSides (x :==: y) = y :==: x
-   constructor   = const (:==:)
-   isSymmetric   = const True
-
-instance Arbitrary a => Arbitrary (Equation a) where
-   arbitrary   = liftM2 (:==:) arbitrary arbitrary
-
-instance CoArbitrary a => CoArbitrary (Equation a) where
-   coarbitrary = coarbitrary . build equationView
-
-instance IsTerm a => IsTerm (Equation a) where
-   toTerm = toTerm . build equationView
-   fromTerm a = fromTerm a >>= matchM equationView
-
-equationView :: View (Relation a) (Equation a)
-equationView = makeView f g
- where
-   f (R x op y)
-      | op == EqualTo = return (x :==: y)
-      | otherwise     = Nothing
-   g (x :==: y) = x .==. y
-
------------------------------------------------------------------------------
--- Inequality (view on Relation)
-
-infix 1 :<:, :>:, :<=:, :>=:
-
-data Inequality a = a :<: a | a :>: a | a :<=: a | a :>=: a
-
-instance Show a => Show (Inequality a) where
-   show = show . build inequalityView
-
-instance Functor Inequality where
-   fmap f ineq =
-      let a = leftHandSide ineq
-          b = rightHandSide ineq
-      in constructor ineq (f a) (f b)
-
-instance Foldable Inequality where
-   foldMap = foldMapRelation
-
-instance Traversable Inequality where
-   sequenceA = sequenceRelation
-
-instance Relational Inequality where
-   leftHandSide  = leftHandSide  . build inequalityView
-   rightHandSide = rightHandSide . build inequalityView
-   flipSides = fromMaybe (error "inequality: flipSides") . matchM inequalityView
-             . flipSides . build inequalityView
-   constructor ineq =
-      let relType = relationType (build inequalityView ineq)
-      in fst (relType ? inequalityTable)
-
-instance Arbitrary a => Arbitrary (Inequality a) where
-   arbitrary = do
-      op <- elements $ map (fst . snd) inequalityTable
-      liftM2 op arbitrary arbitrary
-
-instance CoArbitrary a => CoArbitrary (Inequality a) where
-   coarbitrary = coarbitrary . build inequalityView
-
-instance IsTerm a => IsTerm (Inequality a) where
-   toTerm = toTerm . build inequalityView
-   fromTerm a = fromTerm a >>= matchM inequalityView
-
-inequalityView :: View (Relation a) (Inequality a)
-inequalityView = makeView f g
- where
-   f (R x op y) = fmap (\pair -> fst pair x y) (lookup op inequalityTable)
-   g ineq =
-      case ineq of
-         x :<:  y -> x .<.  y
-         x :>:  y -> x .>.  y
-         x :<=: y -> x .<=. y
-         x :>=: y -> x .>=. y
-
-inequalityTable :: [(RelationType, (a -> a -> Inequality a, a -> a -> Relation a))]
-inequalityTable =
-   [ (LessThan, ((:<:), (.<.))), (LessThanOrEqualTo, ((:<=:), (.<=.)))
-   , (GreaterThan, ((:>:), (.>.))), (GreaterThanOrEqualTo, ((:>=:), (.>=.)))
-   ]
− src/Domain/Math/Data/SquareRoot.hs 
@@ -1,190 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Data.SquareRoot
-   ( SquareRoot
-   , imaginary, imaginaryUnit
-   , con, toList, scale, fromSquareRoot
-   , sqrt, sqrtRational, isqrt, eval
-   ) where
-
-import Control.Monad
-import Data.Ratio
-import Domain.Math.Safe
-import Prelude hiding (sqrt)
-import Test.QuickCheck
-import qualified Data.Map as M
-import qualified Domain.Math.Data.PrimeFactors as P
-import qualified Prelude
-
--------------------------------------------------------------
--- Representation
-
--- Sum of square roots (possibly imaginary) that are normalized
---
--- Invariants:
--- * all keys are normalized (sqrt 8 -> 2*(sqrt 2))
--- * all values are non-zero
--- * We maintain the "imaginary" property since sqrt(-1)*sqrt(-1) may or may not
---   be equal to sqrt(1)
---
--- Note on the Ord instance: comparison does not follow the value (semantic
--- interpretation); it can be used though for sorting and storing in maps
-
-data SquareRoot a = S
-   { imaginary     :: Bool
-   , squareRootMap :: SqMap a
-   } deriving (Eq, Ord)
-
-type SqMap a = M.Map P.PrimeFactors a
-
--------------------------------------------------------------
--- Primitive operations on maps
-
--- re-establish invariants
-makeMap :: Num a => SqMap a -> SqMap a
-makeMap = M.filter (/=0) . M.foldWithKey f M.empty
- where
-   f k a m
-      | a == 0    = m
-      | otherwise = M.unionWith (+) (fmap (*a) (sqrtPF k)) m
-
-plusSqMap :: Num a => SqMap a -> SqMap a -> SqMap a
-plusSqMap m1 m2 = M.filter (/=0) (M.unionWith (+) m1 m2)
-
-minusSqMap :: Num a => SqMap a -> SqMap a -> SqMap a
-minusSqMap m1 m2 = m1 `plusSqMap` negateSqMap m2
-
-negateSqMap :: Num a => SqMap a -> SqMap a
-negateSqMap = fmap negate
-
-timesSqMap :: Num a => SqMap a -> SqMap a -> SqMap a
-timesSqMap m1 m2 =
-   case (M.toList m1, M.toList m2) of
-      ([], _) -> M.empty
-      (_, []) -> M.empty
-      ([(n, a)], _) | n==1 -> if a==0 then M.empty else fmap (*a) m2
-      (_, [(n, a)]) | n==1 -> if a==0 then M.empty else fmap (*a) m1
-      _ ->
-         let op n a = M.unionWith (+) (f n (fmap (a *) m1))
-             f i    = M.mapKeys (*i)
-         in makeMap (M.foldWithKey op M.empty m2)
-
-recipSqMap :: Fractional a => SqMap a -> SqMap a
-recipSqMap m =
-   case M.toList m of
-      []       -> error "SquareRoot: division by zero"
-      [(n, x)] -> M.singleton n (recip (x * fromIntegral n))
-      _        -> (a .-. b) .*. recipSqMap (makeMap ((a .*. a) .-. (b .*. b)))
- where
-   (ys, zs) = splitAt (length xs `div` 2) xs
-   (a, b)   = (M.fromList ys, M.fromList zs)
-   xs  = M.toList m
-   (.*.) = timesSqMap
-   (.-.) = minusSqMap
-
-sqrtPF :: Num a => P.PrimeFactors -> SqMap a
-sqrtPF n
-   | n == 0    = M.empty
-   | otherwise = M.singleton b (fromIntegral a)
- where
-   (a, b) = P.splitPower 2 n
-
--------------------------------------------------------------
--- Type class instances
-
-instance Num a => Show (SquareRoot a) where
-   show (S isNeg m) = g (map f (M.toList m)) ++ imPart
-    where
-      f (n, a) = ( signum a == -1
-                 , times (guard (abs a /= 1) >> Just (show (abs a)))
-                         (guard (n /= 1)     >> Just ("sqrt(" ++ show (toInteger n) ++ ")"))
-                 )
-      imPart = if isNeg then " (imaginary number)" else ""
-      g []         = "0"
-      g ((b,x):xs) = (if b then "-" else "") ++ x ++ concatMap h xs
-      h (b, x)     = (if b then " - " else " + ") ++ x
-
-      times (Just a) (Just b) = a ++ "*" ++ b
-      times (Just a) Nothing  = a
-      times Nothing  (Just b) = b
-      times Nothing  Nothing  = "1"
-
--- the Functor instance does not maintain the invariant (non-zero)
-instance Functor SquareRoot where
-   fmap f (S b m) = S b (M.map f m)
-
-instance Num a => Num (SquareRoot a) where
-   S b1 m1 + S b2 m2 = S (b1 || b2) (plusSqMap  m1 m2)
-   S b1 m1 - S b2 m2 = S (b1 || b2) (minusSqMap m1 m2)
-   S b1 m1 * S b2 m2 = S (b1 || b2) (timesSqMap m1 m2)
-   negate (S b m)    = S b (negateSqMap m)
-   fromInteger       = con . fromInteger
-
-   -- not defined for square roots
-   abs    = error "abs not defined for square roots"
-   signum = error "signum not defined for square roots"
-
-instance Fractional a => SafeDiv (SquareRoot a) where
-   safeDiv x y
-      | y == 0    = Nothing
-      | otherwise = Just (x/y)
-
-instance Fractional a => Fractional (SquareRoot a) where
-   recip (S b m) = S b (recipSqMap m)
-   fromRational  = con . fromRational
-
-instance Fractional a => Arbitrary (SquareRoot a) where
-   arbitrary = do
-      n <- choose (0, 10)
-      let f (a, b) = fromRational a * sqrtRational (fromRational (abs b))
-      liftM (sum . map f) (vector n)
-
--------------------------------------------------------------
--- Utility functions
-
-imaginaryUnit :: Num a => SquareRoot a
-imaginaryUnit = S True (M.singleton (-1) 1)
-
-toList :: SquareRoot a -> [(a, Integer)]
-toList = map (\(k, r) -> (r, toInteger k)) . M.toList . squareRootMap
-
-fromSquareRoot :: Num a => SquareRoot a -> Maybe a
-fromSquareRoot a =
-   case toList a of
-      [(b, n)] | n==1 -> Just b
-      []              -> Just 0
-      _ -> Nothing
-
-con :: Num a => a -> SquareRoot a
-con a = S False (if a==0 then M.empty else M.singleton 1 a)
-
-sqrt :: Num a => Integer -> SquareRoot a
-sqrt n
-   | n < 0     = S True (M.mapKeys negate m)
-   | otherwise = S False m
- where
-   m = sqrtPF (fromIntegral (abs n))
-
-scale :: Num a => a -> SquareRoot a -> SquareRoot a
-scale a sr = if a==0 then 0 else fmap (*a) sr
-
-isqrt :: Integer -> Integer
-isqrt = (floor :: Double -> Integer) . Prelude.sqrt . fromInteger
-
-sqrtRational :: Fractional a => Rational -> SquareRoot a
-sqrtRational r = scale (1/fromIntegral b) (sqrt (a*b))
- where
-   (a, b) = (numerator r, denominator r)
-
-eval :: Floating a => SquareRoot a -> a
-eval (S _ m) = M.foldWithKey f 0 m
- where f n a b = a * Prelude.sqrt (fromIntegral n) + b
− src/Domain/Math/Data/WithBool.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Values extended with boolean constants
---
------------------------------------------------------------------------------
-module Domain.Math.Data.WithBool
-   ( WithBool, fromWithBool, join
-   ) where
-
-import Common.Algebra.Boolean
-import Common.Classes
-import Common.Rewriting
-import Control.Applicative
-import Control.Monad
-import Data.Char (toLower)
-import Data.Foldable
-import Data.Traversable
-import Domain.Logic.Formula
-
--------------------------------------------------------------------
--- Abstract data type and instances
-
-newtype WithBool a = WB { fromWithBool :: Either Bool a }
-   deriving (Eq, Ord, Functor)
-
-instance Show a => Show (WithBool a) where
-   show = either (map toLower . show) show . fromWithBool
-
-instance BoolValue (WithBool a) where
-   fromBool = WB . Left
-   isTrue   = either id  (const False) . fromWithBool
-   isFalse  = either not (const False) . fromWithBool
-
-instance Container WithBool where
-   singleton    = WB . Right
-   getSingleton = either (const Nothing) Just . fromWithBool
-
-instance Monad WithBool where
-   return  = singleton
-   m >>= f = either fromBool f (fromWithBool m)
-
-instance Foldable WithBool where
-   foldMap = foldMapDefault
-
-instance Traversable WithBool where
-   traverse _ (WB (Left b))  = pure (WB (Left b))
-   traverse f (WB (Right a)) = (WB . Right) <$> f a
-
-instance IsTerm a => IsTerm (WithBool a) where
-   toTerm = either f toTerm . fromWithBool
-    where
-      f True  = symbol trueSymbol
-      f False = symbol falseSymbol
-   fromTerm term
-      | isSymbol trueSymbol  term = return true
-      | isSymbol falseSymbol term = return false
-      | otherwise                 = liftM singleton (fromTerm term)
− src/Domain/Math/Derivative/Examples.hs 
@@ -1,168 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Example exercises from the Digital Mathematics Environment (DWO),
--- see: http://www.fi.uu.nl/dwo/gr/frameset.html.
---
------------------------------------------------------------------------------
-module Domain.Math.Derivative.Examples
-   ( diffSet1, diffSet2, diffSet3, diffSet4
-   , diffSet5, diffSet6, diffSet7, diffSet8
-   ) where
-
-import Common.Rewriting
-import Data.Maybe
-import Domain.Math.Expr
-import Prelude hiding ((^))
-
-differentiateLists :: [[Expr]] -> [[Expr]]
-differentiateLists = map (map differentiate)
-
-differentiate :: Expr -> Expr
-differentiate a =
-   let x = fromMaybe "x" (selectVar a)
-   in unary diffSymbol $ binary lambdaSymbol (Var x) a
-
-----------------------------------------------------------
--- HAVO B applets
-
--- Hoofdstuk 6, differentieer
--- Bereken de afgeleide
-diffSet1 :: [[Expr]]
-diffSet1 = differentiateLists $
-   let x = Var "x" in
-   let p = Var "p" in
-   let q = Var "q" in
-   let r = Var "r" in
-   [ [ 3*x^4 - 7*x^2, -x^3-5*x, 1/2*x^6-5*x^2+4, -1/3*x^3+(3/2)*x^2-x+1]
-   , [ -x^5+5*x+23, -2*p^4+5*p-12, 3/5*q^5-q^3+4*q, -2/3*r^6+1/4*r^4-3*r+7]
-   , -- werk eerst de haakjes weg
-     [ (x-2)^2, -(1-3*x)^2, (x-1)*(2*x+5), -(1-3*x)*(2*x+7)]
-     -- differentieer
-   , [x^3-x*(x+5), -2*(p+1)*(p-12), q*(q^5-q^3)+3*q^2+4, -3*r*(r-1)*(r+2)]
-   ]
-
-----------------------------------------------------------
--- VWO A/C applets
-
--- Hoofdstuk 7, differentieer
-diffSet2 :: [[Expr]]
-diffSet2 = differentiateLists $
-   let x = Var "x" in
-   [ [ 5*x^2, -4*x^2, 10*x^2-8, -8*x^2+7]
-   , [ 3*x^2+4*x, -0.5*x^2-2*x, -8*x^2+7*x-3, -0.25*x^2+x-1]
-   , [ (x+2)^2, (5*x+7)*(4-3*x), (3*x+6)^2-8*x
-     , 5*(x-3)^2+5*x, 5*(x-3)^2+5*(2*x-1), -3*(x-1)*(5-9*x)-8*(x-7) ]
-   ]
-
--- Hoofdstuk 7, bereken de afgeleide: zelfde als Havo B applet
-
-----------------------------------------------------------
--- VWO B applets
-
--- Hoofdstuk 3, differentieren: zelfde als Havo B applet
-
--- Hoofdstuk 7
--- Gebruik de productregel
-diffSet3 :: [[Expr]]
-diffSet3 = differentiateLists $
-   let x = Var "x" in
-   [ [ (x^2+2*x)*(3*x+5), (2*x^2-3*x)*(4*x+1), (3*x^3+4*x)*(x^2-2)
-     , (4*x^3-x)*(3*x^2+7*x), (x^2+2*x)*(x^3-4*x^2+3), (5*x-7)*(2*x^3-3*x+1)
-     , (3*x^2+2)*(5*x^3+4*x^2-7*x), (4*x+1)*(3*x^3-x^2+2*x)
-     ]
-   , [ (3*x+1)^2, (5*x-2)^2, (2*x+7)^2, (4*x-3)^2
-     , (2*x^2-3*x)^2, (3*x^2+2)^2, 2*x^3-3*x^2, (5*x^3+7*x)^2
-     ]
-   ]
-
--- Gebruik de quotientregel
-diffSet4 :: [[Expr]]
-diffSet4 = differentiateLists $
-   let x = Var "x" in
-   [ [ 5/(x-1), 3/(x+2), (-2)/(x-3), (-3)/(x+4), 3/(2*x-1)
-     , 2/(3*x+4), (-4)/(3*x-1), (-2)/(4*x+3)
-     ]
-   , [ (x+1)/(x-2), (x-3)/(x+4), (x+5)/(x-1), (x-2)/(x+1)
-     , (2*x+3)/(4*x-1), (3*x-1)/(2*x+1), (4*x+3)/(3*x-2), (5*x-2)/(3*x+4)
-     ]
-   , [ (3*x^2)/(2*x^3+4), (2*x^3)/(3*x^2-1), (x^2)/(4*x^3-2)
-     , (3*x^3)/(5*x^2+7), (1-x^3)/(x+4), (x+3)/(2-x^2)
-     , (1-2*x^3)/(x+1), (x+5)/(2-3*x^2)
-     ]
-   , [ (2-x)/(x^2+1)+2*x^3, (x^3-3)/(4-x)+x^2
-     , (3-2*x)/(2*x^2-3)+x^3, (2*x^3-4)/(6-5*x)+4*x^2
-     ]
-   ]
-
--- differentieer x^n (n geheel), noteer zonder negatieve exponent
-diffSet5 :: [[Expr]]
-diffSet5 = differentiateLists $
-   let x = Var "x" in
-   [ [ 4/x^2, 5/x^3, 2/x^4, 3/x^5, 1/9*x^2, 1/7*x^3, 1/5*x^4, 1/8*x^5 ]
-   , [ 3*x^2-4/(x^2), 7*x^3-2/(x^3), 2*x^4-5/(x^4), 2*x^5-6/(x^5)
-     , (3*x+2)/(x^3), (2*x^2-4)/x^5, (4*x-3)/x^2, (6*x^2+5)/x^4
-     ]
-   , -- herleid de afgeleide tot 1 breuk
-     [ (2*x^4+3)/x^2, (2*x^5-5)/x^3, (4*x^5-1)/x^2, (4*x^4+3)/x^3
-     , (3*x-1)/(7*x^2), (2*x^3+1)/(3*x^4), (x^2-2)/(3*x^3), (x+5)/(6*x^3)
-     ]
-   ]
-
--- differentieer x^r (r uit R), noteer zonder negatieve en gebroken exponent
-diffSet6 :: [[Expr]]
-diffSet6 = differentiateLists $
-   let x = Var "x" in
-   [ [ x*root x 3, x^3*sqrt x, x*root x 5, x^4*sqrt x, 1/(x*root x 3)
-     , 1/(x^3*sqrt x), 1/(x*root x 5), 1/(x^4*sqrt x)
-     ]
-   , [ x^2*root (x^2) 3, x*root (x^3) 4, x^3*root (x^2) 5, x^2*root (x^3) 5
-     , (x^3+1)*(2+sqrt x), (3+x^2)*(1+root x 3), (x^2+1)*(root x 3+2)
-     , (3+x^3)*(sqrt x+1)
-     ]
-   , [ (sqrt x + 1)^2, (x*sqrt x-3)^2, (sqrt x-2)^2, (x*sqrt x+1)^2
-     , (x+2)/sqrt x, (x-3)/sqrt x, (x-4)/sqrt x, (x+5)/sqrt x
-     ]
-   , [ (x-2)/(x*sqrt x), (x+3)/(x*sqrt x), (x+4)/(x*sqrt x), (x-5)/(x*sqrt x)
-     , (x^2+2)/(3*sqrt x), (x^2-3)/(4*sqrt x)
-     , (x^2+4)/(2*sqrt x), (x^2-6)/(3*sqrt x)
-     ]
-   , [ (x+3)/(x^2*sqrt x), (x-1)/(x^3*sqrt x), (x-2)/(x^2*sqrt x)
-     , (x+4)/(x^3*sqrt x), (sqrt x-2)/x^2, (2*sqrt x+1)/x^2
-     , (1-sqrt x)/x, (3*sqrt x+2)/x
-     ]
-   ]
-
--- differentieren met de kettingregel
-diffSet7 :: [[Expr]]
-diffSet7 = differentiateLists $
-   let x = Var "x" in
-   [ [ 2*(x^2+3*x)^5, 3*(x^3-4*x)^6, -6*(x^2+2*x)^4, -5*(x^3-3*x^2)^3]
-   , [ -(2/(x^2+3*x)^5),-(3/(x^3-4*x)^6), 6/(x^2+2*x)^4, 5/(x^3-3*x^2)^3]
-   , [ sqrt (3*x^4-x), sqrt (x^3+5*x^2), sqrt (6*x^2+x), sqrt (7*x^3-3*x^2)]
-   , [ 1/sqrt (3*x-2), 1/sqrt (8*x+5), 1/sqrt (3*x-4), 1/sqrt (5*x-2)]
-   , [ (2*x-1)^2*sqrt (2*x-1), (3*x^2+2)*sqrt (3*x^2+2)
-     , (3*x+5)^3*sqrt (3*x+5), (4*x^3-7)*sqrt (4*x^3-7)
-     ]
-   ]
-
--- differentieren met de kettingregel gecombineerd
-diffSet8 :: [[Expr]]
-diffSet8 = differentiateLists $
-   let x = Var "x" in
-   [ [ 2*x*sqrt (4*x+3), 3*x*sqrt (2*x-5), 4*x*sqrt (3*x+2), 2*x*sqrt (5*x-3)]
-   , [ x^2*(4*x^2-2)^3, x^3*(3*x-4)^3, x^4*(3*x^2+1)^5, x^5*(4*x+3)^4]
-   , [ (x+3)/sqrt (2*x-1), (x+7)/sqrt (4*x+3)
-     , (x-2)/sqrt (3*x+1), (x-7)/sqrt (5*x-4)
-     ]
-   , [ sqrt (2*x^2-1)/(x+3), sqrt (4*x^2+3)/(x+7)
-     , sqrt (3*x^2+1)/(x-2), sqrt (5*x^2-4)/(x-7)
-     ]
-   ]
− src/Domain/Math/Derivative/Exercises.hs 
@@ -1,180 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Derivative.Exercises
-   ( derivativeExercise, derivativePolyExercise
-   , derivativeProductExercise, derivativeQuotientExercise
-   , derivativePowerExercise
-   ) where
-
-import Common.Library
-import Common.Utils.Uniplate
-import Control.Monad
-import Data.Function
-import Data.List
-import Data.Maybe
-import Data.Ord
-import Domain.Math.CleanUp
-import Domain.Math.Derivative.Examples
-import Domain.Math.Derivative.Rules
-import Domain.Math.Derivative.Strategies
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Generators
-import Domain.Math.Polynomial.RationalExercises
-import Domain.Math.Polynomial.Views
-import Prelude hiding (repeat, (^))
-import Test.QuickCheck
-
-derivativePolyExercise :: Exercise Expr
-derivativePolyExercise = describe
-   "Find the derivative of a polynomial. First normalize the polynomial \
-   \(e.g., with distribution). Don't make use of the product-rule, or \
-   \other chain rules." $ makeExercise
-   { exerciseId    = diffId # "polynomial"
-   , status        = Provisional
-   , parser        = parseExpr
-   , ready         = predicateView (polyNormalForm rationalView)
-   , suitable      = predicate isPolyDiff
-   , equivalence   = withoutContext eqPolyDiff
-   , similarity    = withoutContext (viewEquivalent cleanUpACView)
-   , strategy      = derivativePolyStrategy
-   , navigation    = navigator
-   , examples      = level Medium $ concat (diffSet1 ++ diffSet2 ++ diffSet3)
-   , testGenerator = Just $ liftM (diff . lambda "x") $
-                        sized quadraticGen
-   }
-
-derivativeProductExercise :: Exercise Expr
-derivativeProductExercise = describe
-   "Use the product-rule to find the derivative of a polynomial. Keep \
-   \the parentheses in your answer." $
-   derivativePolyExercise
-   { exerciseId    = diffId # "product"
-   , ready         = predicate noDiff
-   , strategy      = derivativeProductStrategy
-   , examples      = level Medium $ concat diffSet3
-   }
-
-derivativeQuotientExercise :: Exercise Expr
-derivativeQuotientExercise = describe
-   "Use the quotient-rule to find the derivative of a polynomial. Only \
-   \remove parentheses in the numerator." $
-   derivativePolyExercise
-   { exerciseId    = diffId # "quotient"
-   , ready         = predicate readyQuotientDiff
-   , suitable      = predicate isQuotientDiff
-   , equivalence   = withoutContext eqQuotientDiff
-   , strategy      = derivativeQuotientStrategy
-   , ruleOrdering  = ruleOrderingWithId [ruleDerivQuotient]
-   , examples      = level Medium $ concat diffSet4
-   , testGenerator = Nothing
-   }
-
-derivativePowerExercise :: Exercise Expr
-derivativePowerExercise = describe
-   "First write as a power, then find the derivative. Rewrite negative or \
-   \rational exponents." $
-   derivativePolyExercise
-   { exerciseId    = diffId # "power"
-   , status        = Experimental
-   , ready         = predicate noDiff <&&> predicate onlyNatPower
-   -- , isSuitable    = const True
-   , equivalence   = \_ _ -> True -- \x y -> eqApprox (evalDiff x) (evalDiff y)
-   , strategy      = derivativePowerStrategy
-   , examples      = level Medium $ concat (diffSet5 ++ diffSet6)
-   , testGenerator = Nothing
-   }
-
-derivativeExercise :: Exercise Expr
-derivativeExercise = makeExercise
-   { exerciseId   = describe "Derivative" diffId
-   , status       = Provisional
-   , parser       = parseExpr
-   , ready        = predicate noDiff
-   , strategy     = derivativeStrategy
-   , ruleOrdering = derivativeOrdering
-   , equivalence   = withoutContext eqQuotientDiff
-   , navigation   = navigator
-   , examples     = level Medium $ concat $ diffSet3++diffSet4++diffSet5
-                            {- diffSet6 -- ++diffSet7++diffSet8 -}
-   }
-
-derivativeOrdering :: Rule a -> Rule a -> Ordering
-derivativeOrdering = comparing f
- where
-   f a = (getId a /= j, getId a == i, showId a)
-   i = getId ruleDefRoot
-   j = getId ruleDerivPolynomial
-
-isPolyDiff :: Expr -> Bool
-isPolyDiff = maybe False (`belongsTo` polyViewWith rationalView) . getDiffExpr
-
-isQuotientDiff :: Expr -> Bool
-isQuotientDiff de = fromMaybe False $ do
-   expr <- getDiffExpr de
-   xs   <- match sumView expr
-   let f a = maybe [a] (\(x, y) -> [x, y]) (match divView a)
-       ys  = concatMap f xs
-       isp = (`belongsTo` polyViewWith rationalView)
-   return (all isp ys)
-
-eqPolyDiff :: Expr -> Expr -> Bool
-eqPolyDiff = viewEquivalent (polyViewWith rationalView) `on` evalDiff
-
-eqQuotientDiff :: Expr -> Expr -> Bool
-eqQuotientDiff = eqSimplifyRational `on` (cleanUpExpr . evalDiff)
-
-readyQuotientDiff :: Expr -> Bool
-readyQuotientDiff expr = fromMaybe False $ do
-   xs <- match sumView expr
-   let f a      = fromMaybe (a, 1) (match divView a)
-       (ys, zs) = unzip (map f xs)
-       isp = (`belongsTo` polyViewWith rationalView)
-       nfp = (`belongsTo` polyNormalForm rationalView)
-   return (all nfp ys && all isp zs)
-
-noDiff :: Expr -> Bool
-noDiff e = all (not . isDiffSymbol) [ s | Sym s _ <- universe e]
-
-onlyNatPower :: Expr -> Bool
-onlyNatPower e = all isNat [ a | Sym s [_, a] <- universe e, isPowerSymbol s ]
- where
-   isNat (Nat _) = True
-   isNat _       = False
-
-evalDiff :: Expr -> Expr
-evalDiff da =
-   case da of
-      Sym d [Sym l [Var x, expr]] | isDiffSymbol d && isLambdaSymbol l ->
-         cleanUpExpr (rec x expr)
-      _ -> descend evalDiff da
- where
-   rec x expr =
-      case expr of
-         _ | withoutVar x expr -> 0
-         Var y | x==y -> 1
-         a :+: b  -> rec x a + rec x b
-         a :-: b  -> rec x a - rec x b
-         Negate a -> -rec x a
-         a :*: b  -> rec x a*b + a*rec x b
-         a :/: b  -> (b*rec x a - a*rec x b) / b^2
-         Sqrt a   -> rec x (a^(1/2))
-         Sym s [a, b]
-            | isPowerSymbol s ->
-                 case match rationalView b of
-                    Just n  -> fromRational n * a^fromRational (n-1) * rec x a
-                    Nothing -> diffExpr
-            | isRootSymbol s ->
-                 rec x (a^(1/b))
-         _ -> diffExpr
-    where
-      diffExpr = diff (lambda x expr)
− src/Domain/Math/Derivative/Rules.hs 
@@ -1,202 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Derivative.Rules where
-
-import Common.Library hiding (root)
-import Control.Monad
-import Data.Maybe
-import Domain.Math.Data.Polynomial
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Views
-import Domain.Math.Power.Views
-import Prelude hiding ((^))
-
-derivativeRules :: [Rule Expr]
-derivativeRules =
-   [ ruleDerivCon, ruleDerivPlus, ruleDerivMin, ruleDerivNegate
-   , ruleDerivMultiple, ruleDerivPower, ruleDerivVar
-   , ruleDerivProduct, ruleDerivQuotient, ruleDerivPowerChain
-   , ruleSine, ruleLog, ruleDerivSqrt, ruleDerivSqrtChain
-   ]
-
-diff :: Expr -> Expr
-diff = unary diffSymbol
-
-ln :: Expr -> Expr
-ln = unary lnSymbol
-
-lambda :: String -> Expr -> Expr
-lambda = binary lambdaSymbol . Var
-
-diffId :: Id
-diffId = newId "calculus.differentiation"
-
-isDiffSymbol, isLambdaSymbol :: Symbol -> Bool
-isDiffSymbol   = (== diffSymbol)
-isLambdaSymbol = (== lambdaSymbol)
-
------------------------------------------------------------------
--- Rules for Diffs
-
-ruleSine :: Rule Expr
-ruleSine = rule (diffId, "sine") $
-   \x -> diff (lambda x (sin (Var x)))  :~>  cos (Var x)
-
-ruleLog :: Rule Expr
-ruleLog = rule (diffId, "logarithmic") $
-   \x -> diff (lambda x (ln (Var x)))  :~>  1 / Var x
-
-ruleDerivPlus :: Rule Expr
-ruleDerivPlus = rule (diffId, "plus") $
-   \x f g -> diff (lambda x (f + g))  :~>  diff (lambda x f) + diff (lambda x g)
-
-ruleDerivMin :: Rule Expr
-ruleDerivMin = rule (diffId, "min") $
-   \x f g -> diff (lambda x (f - g))  :~>  diff (lambda x f) - diff (lambda x g)
-
-ruleDerivNegate :: Rule Expr
-ruleDerivNegate = rule (diffId, "negate") $
-   \x f -> diff (lambda x (-f))  :~>  -diff (lambda x f)
-
-ruleDerivVar :: Rule Expr
-ruleDerivVar = rule (diffId, "var") $
-   \x -> diff (lambda x (Var x))  :~>  1
-
-ruleDerivProduct :: Rule Expr
-ruleDerivProduct = rule (diffId, "product") $
-   \x f g -> diff (lambda x (f * g))  :~>  diff (lambda x f)*g + f*diff (lambda x g)
-
--- The second rewrite rule should not have been necessary, except that cleaning
--- up an expression will typically put the negate in front of the division: this
--- makes sure the rule is triggered anyway.
-ruleDerivQuotient :: Rule Expr
-ruleDerivQuotient = ruleList (diffId, "quotient")
-   [ \x f g -> diff (lambda x (f/g))  :~>  (g*diff (lambda x f) - f*diff (lambda x g)) / (g^2)
-   , \x f g -> diff (lambda x (-f/g))  :~>  (g*diff (lambda x (-f)) - (-f)*diff (lambda x g)) / (g^2)
-   ]
-
-ruleDerivPolynomial :: Rule Expr
-ruleDerivPolynomial = describe "This rule returns the derivative for all \
-   \expressions that can be turned into a polynomial (of rational numbers). \
-   \The polynomial does not have to be in standard form." $
-   makeSimpleRule (diffId, "deriv-of-poly") f
- where
-   f (Sym d [Sym l [Var v, expr]]) | isDiffSymbol d && isLambdaSymbol l = do
-      let myView = polyViewWith rationalView
-      (s, p) <- match myView expr
-      guard (s==v)
-      return (build myView (s, derivative p))
-   f _ = Nothing
-
------------------------------------
--- Special rules (not defined with unification)
-
-ruleDerivCon :: Rule Expr
-ruleDerivCon = makeSimpleRule (diffId, "constant") f
- where
-   f (Sym d [Sym l [Var x, e]])
-      | isDiffSymbol d && isLambdaSymbol l && withoutVar x e = return 0
-   f _ = Nothing
-
-ruleDerivMultiple :: Rule Expr
-ruleDerivMultiple = makeSimpleRule (diffId, "constant-multiple") f
- where
-    f (Sym d [Sym l [Var x, n :*: e]])
-       | isDiffSymbol d && isLambdaSymbol l && withoutVar x n =
-       return $ n * diff (lambda x e)
-    f (Sym d [Sym l [Var x, e :*: n]])
-       | isDiffSymbol d && isLambdaSymbol l && withoutVar x n =
-       return $ n * diff (lambda x e)
-    f _ = Nothing
-
-ruleDerivPower :: Rule Expr
-ruleDerivPower = makeSimpleRule (diffId, "power") f
- where
-   f (Sym d [Sym l [Var x, Sym p [x1, n]]])
-      | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && Var x==x1 && withoutVar x n =
-      return $ n * (Var x ^ (n-1))
-   f _ = Nothing
-
-ruleDerivPowerChain :: Rule Expr
-ruleDerivPowerChain = makeSimpleRule (diffId, "chain-power") f
- where
-   f (Sym d [Sym l [Var x, Sym p [a, n]]])
-      | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && withoutVar x n =
-      return $ n * (a ^ (n-1)) * diff (lambda x a)
-   f _ = Nothing
-
-ruleDerivSqrt :: Rule Expr
-ruleDerivSqrt = makeSimpleRule (diffId, "sqrt") f
- where
-   f (Sym d [Sym l [Var x, Sqrt x1]])
-      | isDiffSymbol d && isLambdaSymbol l && Var x==x1 =
-      return $ 1 / (2 * sqrt (Var x))
-   f _ = Nothing
-
-ruleDerivSqrtChain :: Rule Expr
-ruleDerivSqrtChain = makeSimpleRule (diffId, "chain-sqrt") f
- where
-   f (Sym d [Sym l [Var x, Sqrt a]])
-      | isDiffSymbol d && isLambdaSymbol l =
-      return $ (1 / (2 * sqrt a)) * diff (lambda x a)
-   f _ = Nothing
-
-ruleDefRoot :: Rule Expr
-ruleDefRoot = rule (diffId, "def-root") $
-   \a b -> root a b :~> a ^ (1/b)
-
-ruleDerivRoot :: Rule Expr
-ruleDerivRoot = rule (diffId, "def-root") $
-   \a b x -> diff (lambda x (root a b)) :~> diff (lambda x (a ^ (1/b)))
-
-ruleDerivPowerFactor :: Rule Expr
-ruleDerivPowerFactor = makeSimpleRule (diffId, "power-factor") $ \de -> do
-   expr <- getDiffExpr de
-   (a, x, r) <- match myPowerView expr
-   return $ build myPowerView (a*fromRational r, x, r-1)
-
--- (a+b)/c  ~>  a/c + b/c
-ruleSplitRational :: Rule Expr
-ruleSplitRational = makeSimpleRule (diffId, "split-rational") $ \expr -> do
-   (upper, c) <- match divView expr
-   (a, b)     <- match plusView upper
-   return (a/c + b/c)
-
-myPowerView :: View Expr (Expr, String, Rational)
-myPowerView = makeView f g
- where
-   f expr = case match timesView expr of
-               Just (a, b) -> do
-                  guard (hasNoVar a)
-                  (x, r) <- match powView b
-                  return (a, x, r)
-                `mplus` do
-                  guard (hasNoVar b)
-                  (x, r) <- match powView a
-                  return (b, x, r)
-               Nothing -> do
-                  (x, r) <- match powView expr
-                  return (1, x, r)
-   g (a, x, r) = a .*. (Var x .^. fromRational r)
-
-   powView = (matcher powerView <+> matcher noPowerView)
-             >>> matcher (variableView *** rationalView)
-   noPowerView = makeView (\expr -> Just (expr, 1)) (build powerView)
-
-isDiff :: Expr -> Bool
-isDiff = isJust . getDiffExpr
-
-getDiffExpr :: Expr -> Maybe Expr
-getDiffExpr (Sym d [Sym l [Var _, expr]]) |
-   isDiffSymbol d && isLambdaSymbol l = Just expr
-getDiffExpr _ = Nothing
− src/Domain/Math/Derivative/Strategies.hs 
@@ -1,104 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Derivative.Strategies
-   ( derivativeStrategy, derivativePolyStrategy
-   , derivativeProductStrategy, derivativeQuotientStrategy
-   , derivativePowerStrategy, getDiffExpr
-   ) where
-
-import Common.Library
-import Data.Maybe
-import Domain.Math.CleanUp
-import Domain.Math.Derivative.Rules
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Rules
-import Domain.Math.Polynomial.Views
-import Domain.Math.Power.Rules
-import Domain.Math.Power.Strategies
-
-import Prelude hiding ((^))
-
-derivativeStrategy :: LabeledStrategy (Context Expr)
-derivativeStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
-   label "Derivative" $ repeatS $ somewhere $
-      alternatives (map liftToContext derivativeRules)
-      <|> derivativePolyStepStrategy
-      <|> check isDiffC <*> once (once (liftToContext ruleDefRoot))
- where
-   isDiffC = maybe False isDiff . current
-
-derivativePolyStrategy :: LabeledStrategy (Context Expr)
-derivativePolyStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
-   label "derivative-polynomial" $
-      repeatS (somewhere (alternatives rulesPolyNF))
-      <*> derivativePolyStepStrategy
-
-rulesPolyNF :: [Rule (Context Expr)]
-rulesPolyNF =
-   distributeDivisionMulti :
-   map liftToContext
-   [ distributionSquare, distributeTimes, merge
-   , noDivisionConstant
-   ]
-
-derivativeProductStrategy :: LabeledStrategy (Context Expr)
-derivativeProductStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
-   label "derivative-product" $
-      repeatS (somewhere (derivativePolyStepStrategy |> alternatives list))
- where
-   list = distributeDivisionMulti : map liftToContext
-      [ noDivisionConstant
-      , ruleDerivProduct, defPowerNat
-      , ruleDerivNegate, ruleDerivPlus, ruleDerivMin
-      ]
-
-derivativeQuotientStrategy :: LabeledStrategy (Context Expr)
-derivativeQuotientStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
-   label "derivative-quotient" $
-   repeatS (somewhere (derivativePolyStepStrategy |> alternatives list))
-   <*> repeatS (exceptLowerDiv (alternatives rulesPolyNF))
- where
-   list = map liftToContext
-      [ ruleDerivQuotient, ruleDerivPlus, ruleDerivMin, ruleDerivNegate ]
-
-derivativePowerStrategy :: LabeledStrategy (Context Expr)
-derivativePowerStrategy = label "derivative-power" $
-   cleanUpStrategyAfter (applyTop cleanUpExpr) (label "split-rational"
-      (repeatS (somewhere (liftToContext ruleSplitRational)))) <*>
-   configure mycfg simplifyPowerStrategy <*>
-   repeatS (distr <*> configure mycfg simplifyPowerStrategy) <*>
-   cleanUpStrategyAfter (applyTop cleanUpExpr) (label "use-derivative-rules"
-      (repeatS (somewhere (alternatives list)))) <*>
-   configure mycfg nonNegBrokenExpStrategy
- where
-   list = map liftToContext
-      [ ruleDerivPlus, ruleDerivMin, ruleDerivNegate, ruleDerivPowerFactor
-      , ruleDerivCon ]
-   mycfg = [(byName myFractionTimes, Remove)]
-   distr = cleanUpStrategyAfter (applyTop cleanUpExpr) $
-      label "distr" (somewhere (alternatives rulesPolyNF))
-
-derivativePolyStepStrategy :: LabeledStrategy (Context Expr)
-derivativePolyStepStrategy = label "derivative-poly-step" $
-   check polyDiff <*> liftToContext ruleDerivPolynomial
- where
-   polyDiff = maybe False nfPoly . (>>= getDiffExpr) . current
-   nfPoly   = (`belongsTo` polyNormalForm rationalView)
-
-exceptLowerDiv :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr)
-exceptLowerDiv = somewhereWith "except-lower-div" $ \a ->
-   if isDivC a then [0] else [0 .. arity a-1]
- where
-   isDivC = maybe False isDiv . current
-   isDiv (_ :/: _) = True
-   isDiv _         = False
− src/Domain/Math/Equation/BalanceRules.hs 
@@ -1,37 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Equation.BalanceRules
-   ( plusT, minusT, timesT, divisionT
-   ) where
-
-import Common.Transformation
-import Common.View
-import Control.Monad
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-
-plusT, minusT :: Functor f => Expr -> Transformation (f Expr)
-plusT  e = makeTrans $ return . fmap (:+: e)
-minusT e = makeTrans $ return . fmap (:-: e)
-
-timesT :: Functor f => Expr -> Transformation (f Expr)
-timesT e = makeTrans $ unlessZero e . fmap (e :*:)
-
-divisionT :: Expr -> Transformation (Equation Expr)
-divisionT e = makeTrans $ unlessZero e . fmap (:/: e)
-
-unlessZero :: MonadPlus m => Expr -> a -> m a
-unlessZero e a = do
-   r <- matchM rationalView e
-   guard (r /= 0)
-   return a
− src/Domain/Math/Equation/CoverUpExercise.hs 
@@ -1,59 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Equation.CoverUpExercise
-   ( coverUpExercise, coverUpStrategy
-   ) where
-
-import Common.Library
-import Data.Maybe
-import Domain.Math.CleanUp (cleanUpExpr, cleanUpView)
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules
-import Domain.Math.Equation.Examples
-import Domain.Math.Equation.Views
-import Domain.Math.Expr
-
-------------------------------------------------------------
--- Exercise
-
-coverUpExercise :: Exercise (OrList (Equation Expr))
-coverUpExercise = makeExercise
-   { exerciseId   = describe "solve an equation by covering up" $
-                       newId "algebra.equations.coverup"
-   , status       = Provisional
-   , parser       = parseOrsEqExpr
-   , equivalence  = withoutContext eqCoverUp
-   , similarity   = withoutContext myEq
-   , ready        = predicateView equationsSolvedForm
-   , extraRules   = coverUpRulesOr
-   , strategy     = coverUpStrategy
-   , navigation   = termNavigator
-   , examples     = level Medium $ map singleton (concat (fillInResult ++ coverUpEquations))
-   }
-
-------------------------------------------------------------
--- Strategy and rules
-
-coverUpStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))
-coverUpStrategy = cleanUpStrategyAfter (applyTop $ fmap $ fmap cleanUpExpr) $
-   label "Cover-up" $
-   repeatS $ somewhere $ alternatives coverUpRulesOr
-
-eqCoverUp :: OrList (Equation Expr) -> OrList (Equation Expr) -> Bool
-eqCoverUp a b = myEq (f a) (f b)
- where
-   inc = inContext coverUpExercise
-   f x = fromMaybe x $ fromContext $ applyD coverUpStrategy $ inc x
-
-myEq :: OrList (Equation Expr) -> OrList (Equation Expr) -> Bool
-myEq = viewEquivalent (traverseView (traverseView cleanUpView))
− src/Domain/Math/Equation/CoverUpRules.hs 
@@ -1,203 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Equation.CoverUpRules
-   ( coverUpRules, coverUpRulesOr
-   , coverUp, coverUpOrs
-   , coverUpPower, coverUpPlus, coverUpMinusLeft, coverUpMinusRight
-   , coverUpTimes, coverUpNegate
-   , coverUpNumerator, coverUpDenominator, coverUpSqrt
-     -- parameterized rules
-   , ConfigCoverUp, configName, predicateCovered, predicateCombined
-   , coverLHS, coverRHS, configCoverUp
-   , coverUpPowerWith, coverUpTimesWith, coverUpNegateWith
-   , coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith
-   , coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith
-     -- temporarily exported
-   , coverUpBinaryRule, commOp, flipOp
-   ) where
-
-import Common.Library hiding (root)
-import Control.Monad
-import Data.Foldable
-import Data.Maybe
-import Data.Traversable (Traversable, mapM)
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-
----------------------------------------------------------------------
--- Constructors for cover-up rules
-
-coverUpFunction :: (Traversable f, Relational r)
-                   => (Expr -> [(Expr, Expr)])
-                   -> (Expr -> Expr -> [f Expr])
-                   -> ConfigCoverUp -> r Expr -> [f (r Expr)]
-coverUpFunction fm fb cfg eq0 =
-   (guard (coverLHS cfg) >> coverLeft eq0) ++
-   (guard (coverRHS cfg) >> coverRight eq0)
- where
-   coverRight   = map (fmap flipSides) . coverLeft . flipSides
-   coverLeft eq = do
-      (e1, e2) <- fm (leftHandSide eq)
-      guard (predicateCovered  cfg e1)
-      new <- fb (rightHandSide eq) e2
-      _   <- Data.Traversable.mapM (guard . predicateCombined cfg) new
-      return (fmap (constructor eq e1) new)
-
-coverUpBinaryOrRule :: Relational r
-                   => String -> (Expr -> [(Expr, Expr)])
-                   -> (Expr -> Expr -> [OrList Expr])
-                   -> ConfigCoverUp -> Rule (OrList (r Expr))
-coverUpBinaryOrRule opName fm fb cfg =
-   let name = coverUpRuleName opName (configName cfg)
-   in makeSimpleRuleList name $ oneDisjunct $ coverUpFunction fm fb cfg
-
-coverUpBinaryRule :: Relational r => String
-                  -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr)
-                  -> ConfigCoverUp -> Rule (r Expr)
-coverUpBinaryRule opName fm fb cfg =
-   let name = coverUpRuleName opName (configName cfg)
-       fb2 a b = [[fb a b]]
-   in makeSimpleRuleList name $ map head . coverUpFunction fm fb2 cfg
-
-coverUpUnaryRule :: Relational r => String -> (Expr -> [Expr]) -> (Expr -> Expr)
-               -> ConfigCoverUp -> Rule (r Expr)
-coverUpUnaryRule opName fm fb =
-   coverUpBinaryRule opName (map (\e -> (e, e)) . fm) (const . fb)
-
-coverUpRuleName :: String -> String -> Id
-coverUpRuleName opName cfg =
-   let f = if null cfg then newId else ( cfg # )
-   in "algebra.equations.coverup" # f opName
-
----------------------------------------------------------------------
--- Configuration for cover-up rules
-
-data ConfigCoverUp = Config
-   { configName        :: String
-   , predicateCovered  :: Expr -> Bool
-   , predicateCombined :: Expr -> Bool
-   , coverLHS          :: Bool
-   , coverRHS          :: Bool
-   }
-
--- Default configuration: cover-up part with variables
-configCoverUp :: ConfigCoverUp
-configCoverUp = Config
-   { configName        = ""
-   , predicateCovered  = hasSomeVar
-   , predicateCombined = hasNoVar
-   , coverLHS          = True
-   , coverRHS          = True
-   }
-
----------------------------------------------------------------------
--- Parameterized cover-up rules
-
-coverUpPowerWith :: ConfigCoverUp -> Rule (OrList (Equation Expr))
-coverUpPowerWith = coverUpBinaryOrRule "power" (isBinary powerSymbol) fb
- where
-   fb rhs e2 = do
-      n <- isNat e2
-      guard (n > 0)
-      let new1 = root rhs (fromIntegral n)
-          new2 = neg new1
-      return $ singleton new1 <>
-         if even n && new1 /= new2 then singleton new2 else false
-
-coverUpPlusWith :: ConfigCoverUp -> Rule (Equation Expr)
-coverUpPlusWith = coverUpBinaryRule "plus" (commOp . isPlus) (-)
-
-coverUpMinusLeftWith :: ConfigCoverUp -> Rule (Equation Expr)
-coverUpMinusLeftWith = coverUpBinaryRule "minus-left" isMinus (+)
-
-coverUpMinusRightWith :: ConfigCoverUp -> Rule (Equation Expr)
-coverUpMinusRightWith = coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-))
-
--- | Negations are pushed inside
-coverUpTimesWith :: ConfigCoverUp -> Rule (Equation Expr)
-coverUpTimesWith = coverUpBinaryRule "times" (map signs . commOp . matchM timesView) (/)
- where
-   signs (Negate x, y) = (x, neg y) -- puts negation at combined term
-   signs (x, y) = (x, y)
-
-coverUpNegateWith :: ConfigCoverUp -> Rule (Equation Expr)
-coverUpNegateWith = coverUpUnaryRule "negate" isNegate negate
-
--- | Negations are pushed inside
-coverUpNumeratorWith :: ConfigCoverUp -> Rule (Equation Expr)
-coverUpNumeratorWith = coverUpBinaryRule "numerator" (matchM divView) (*)
-
--- | Negations are pushed inside
-coverUpDenominatorWith :: ConfigCoverUp -> Rule (Equation Expr)
-coverUpDenominatorWith = coverUpBinaryRule "denominator" (flipOp . matchM divView) (flip (/))
-
-coverUpSqrtWith :: ConfigCoverUp -> Rule (Equation Expr)
-coverUpSqrtWith = coverUpUnaryRule "sqrt" isSqrt (\x -> x*x)
- where
-   isSqrt (Sqrt a) = return a
-   isSqrt _        = []
-
----------------------------------------------------------------------
--- Cover-up rules for variables
-
-coverUpOrs :: OrList (Equation Expr) -> OrList (Equation Expr)
-coverUpOrs = foldMap  (f . coverUp)
- where
-   f :: Equation Expr -> OrList (Equation Expr)
-   f eq = case apply coverUpPower (singleton eq) of
-             Just xs -> coverUpOrs xs
-             Nothing -> singleton eq
-
-coverUp :: Equation Expr -> Equation Expr
-coverUp eq =
-   case mapMaybe (`apply` eq) coverUpRules of
-      hd:_ -> coverUp hd
-      _    -> eq
-
-coverUpRulesOr :: IsTerm a => [Rule (Context a)]
-coverUpRulesOr = use coverUpPower : map use coverUpRules
-
-coverUpRules :: [Rule (Equation Expr)]
-coverUpRules =
-   [ coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpNegate
-   , coverUpTimes, coverUpNumerator, coverUpDenominator, coverUpSqrt
-   ]
-
-coverUpPower :: Rule (OrList (Equation Expr))
-coverUpPlus, coverUpMinusLeft, coverUpMinusRight, coverUpTimes, coverUpNegate,
-   coverUpNumerator, coverUpDenominator, coverUpSqrt :: Rule (Equation Expr)
-
-coverUpPower       = coverUpPowerWith       configCoverUp
-coverUpPlus        = coverUpPlusWith        configCoverUp
-coverUpMinusLeft   = coverUpMinusLeftWith   configCoverUp
-coverUpMinusRight  = coverUpMinusRightWith  configCoverUp
-coverUpTimes       = coverUpTimesWith       configCoverUp
-coverUpNegate      = coverUpNegateWith      configCoverUp
-coverUpNumerator   = coverUpNumeratorWith   configCoverUp
-coverUpDenominator = coverUpDenominatorWith configCoverUp
-coverUpSqrt        = coverUpSqrtWith        configCoverUp
-
----------------------------------------------------------------------
--- Some helper-functions
-
-commOp :: MonadPlus m => m (a, a) -> m (a, a)
-commOp m = do
-   (a, b) <- m
-   return (a, b) `mplus` return (b, a)
-
-flipOp :: Monad m => m (a, a) -> m (a, a)
-flipOp = liftM (\(x, y) -> (y, x))
-
-isNat :: MonadPlus m => Expr -> m Integer
-isNat (Nat n) = return n
-isNat _       = mzero
− src/Domain/Math/Equation/Examples.hs 
@@ -1,91 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Example exercises from the Digital Mathematics Environment (DWO)
---
------------------------------------------------------------------------------
-module Domain.Math.Equation.Examples
-   ( fillInResult, coverUpEquations
-   ) where
-
-import Common.Rewriting
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Prelude hiding ((^))
-
-fillInResult :: [[Equation Expr]]
-fillInResult = [level1, level2, level3]
- where
-   level1 =
-      let x = variable "x" in
-      [ x-2    :==: 2
-      , -4*x   :==: -28
-      , -8*x   :==: 72
-      , x+4    :==: 09
-      , 4+x    :==: 2
-      , -10-x  :==: -7
-      , x/(-8) :==: -3
-      , 11-x   :==: 14
-      ]
-
-   level2 =
-      let x = variable "x" in
-      [ -5-3*x      :==: -23
-      , 21/x - 4    :==: 3
-      , -3*(x+3)    :==: -27
-      , 2-5*x       :==: 47
-      , 18/(7-x)    :==: 6
-      , -77/x  + 4  :==: -7
-      , -7-(x/(-5)) :==: -15
-      , -18/(-3+x)  :==: 3
-      ]
-
-   level3 =
-      let x = variable "x" in
-      [ -5*(5-(3-x))    :==: -20
-      , (-20-x)/(-5)-2  :==: 3
-      , 4-(x-14)/(-3)   :==: 1
-      , 3*x - 3 - 7     :==: 8
-      , -42/(-2*x+2)    :==: 7
-      , 3*(4+x+2)       :==: 12
-      , -6-(-54/(-3*x)) :==: -12
-      , 14-(x-3)/4      :==: 3
-      ]
-
-coverUpEquations :: [[Equation Expr]]
-coverUpEquations = [level1, level2]
- where
-   level1 =
-      let x = variable "x" in
-      [ 38-7*x       :==: 3
-      , sqrt (125/x) :==: 5
-      , 4*(12-x) + 7 :==: 35
-      , 5*x^2        :==: 80
-      , 5*(5-x)      :==: 35
-      , 32/sqrt x    :==: 8
-      , (21/x)-8     :==: -1
-      , 180/x^2      :==: 5
-      , 3*(x-8)^2    :==: 12
-      , (8-x)/3 + 7  :==: 9
-      ]
-
-   level2 =
-      let x = variable "x" in
-      [ sqrt (x+9)/2       :==: 3
-      , (4*x-18)^2         :==: 4
-      , 3*(13-2*x)^2 - 20  :==: 55
-      , 5*((x/3) - 8)^2    :==: 20
-      , (6/sqrt (x-7))^3   :==: 8
-      , 8-(15/sqrt (31-x))           :==: 5
-      , sqrt (4*(x^2-21))            :==: 4
-      , 3 + (44/sqrt (87 + x))       :==: 7
-      , 13-(56 / (21 + (70/(3+x))))  :==: 12
-      , 12/(2+(24/(8+(28/(2+9/x))))) :==: 3
-      ]
− src/Domain/Math/Equation/Views.hs 
@@ -1,62 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Equation.Views
-   ( relationSolvedForm, relationsSolvedForm
-   , equationSolvedForm, equationsSolvedForm, equationSolvedWith
-   ) where
-
-import Common.Library
-import Data.Traversable
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-
-relationsSolvedForm :: (Traversable f, Relational g) =>
-   View (f (g Expr)) (f (Expr -> Expr -> g Expr, String, Expr))
-relationsSolvedForm = "relations.solved" @> traverseView relationSolvedForm
-
--- The variable may appear on one of the sides of the relation (right-hand side
--- is thus allowed), but must be isolated
-relationSolvedForm :: Relational f =>
-   View (f Expr) (Expr -> Expr -> f Expr, String, Expr)
-relationSolvedForm = "relation.solved" @> makeView f g
- where
-   f r = case (getVariable (leftHandSide r), getVariable (rightHandSide r)) of
-            (Just x, Nothing) | withoutVar x (rightHandSide r) ->
-               return (constructor r, x, rightHandSide r)
-            (Nothing, Just x) | withoutVar x (leftHandSide r) ->
-               return (flip (constructor r), x, leftHandSide r)
-            _ -> Nothing
-   g (make, s, e) = make (Var s) e
-
--------------------------------------------------------------
--- Views on equations
-
-equationsSolvedForm :: View (OrList (Equation Expr)) (OrList (String, Expr))
-equationsSolvedForm = "equations.solved" @> traverseView equationSolvedForm
-
-equationSolvedForm :: View (Equation Expr) (String, Expr)
-equationSolvedForm = "equation.solved" @> makeView f g
- where
-   f (Var x :==: e) | withoutVar x e =
-      return (x, e)
-   f _ = Nothing
-   g (s, e) = Var s :==: e
-
-equationSolvedWith :: View Expr a -> View (Equation Expr) (String, a)
-equationSolvedWith v = "equation.solved-with" @> makeView f g
- where
-   f (lhs :==: rhs) = do
-      x <- getVariable lhs
-      a <- match v rhs
-      return (x, a)
-   g (s, a) = Var s :==: build v a
− src/Domain/Math/ExerciseList.hs 
@@ -1,98 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- All exported exercises in the mathematical domain
---
------------------------------------------------------------------------------
-module Domain.Math.ExerciseList
-   ( exerciseList, viewList, scriptList, testSuiteList
-   ) where
-
-import Common.Library
-import Common.Utils (Some(..))
-import Common.Utils.TestSuite
-import Domain.Math.Data.Interval
-import Domain.Math.Derivative.Exercises
-import Domain.Math.Equation.CoverUpExercise
-import Domain.Math.Expr
-import Domain.Math.Numeric.Exercises
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Balance
-import Domain.Math.Polynomial.Exercises
-import Domain.Math.Polynomial.IneqExercises
-import Domain.Math.Polynomial.LeastCommonMultiple
-import Domain.Math.Polynomial.RationalExercises
-import Domain.Math.Power.Equation.Exercises
-import Domain.Math.Power.Exercises
-import qualified Domain.Math.Numeric.Tests as MathNum
-import qualified Domain.Math.Polynomial.Tests as MathPoly
-import qualified Domain.Math.SquareRoot.Tests as MathSqrt
-
-exerciseList :: [Some Exercise]
-exerciseList =
-   [ -- basic math
-   -- , Some naturalExercise
-   -- , Some integerExercise
-   -- , Some rationalExercise
-     Some fractionExercise
-   , Some coverUpExercise
-   , Some linearExercise
-   , Some linearMixedExercise
-   , Some balanceExercise
-   , Some quadraticExercise
-   , Some higherDegreeExercise
-   , Some findFactorsExercise
-   , Some expandExercise
-   , Some ineqLinearExercise
-   , Some ineqQuadraticExercise
-   , Some ineqHigherDegreeExercise
-   , Some rationalEquationExercise
-   , Some simplifyRationalExercise
-   -- , Some divisionBrokenExercise
-   , Some quadraticNoABCExercise
-   , Some quadraticWithApproximation
-   , Some derivativeExercise
-   , Some derivativePolyExercise
-   , Some derivativeProductExercise
-   , Some derivativeQuotientExercise
-   -- , Some derivativePowerExercise
-   , Some simplifyPowerExercise
-   , Some powerOfExercise
-   , Some nonNegBrokenExpExercise
-   , Some calcPowerExercise
-   , Some powerEqExercise
-   , Some expEqExercise
-   , Some logEqExercise
---   , Some higherPowerEqExercise
-   ]
-
-viewList :: [ViewPackage]
-viewList =
-   [ exprVP sumView
-   , exprVP naturalView, exprVP naturalNF
-   , exprVP integerView, exprVP integerNF
-   , exprVP decimalFractionView
-   , exprVP rationalView, exprVP rationalNF
-   , exprVP mixedFractionView, exprVP mixedFractionNF
-   , exprVP doubleView, exprVP doubleNF
-   ]
- where
-   exprVP :: (IsView f, Show a) => f Expr a -> ViewPackage
-   exprVP a = ViewPackage parseExprM (toView a)
-
-scriptList :: [(Id, FilePath)]
-scriptList =
-   [ (getId linearExercise,       "math.lineq-en.txt")
-   , (getId quadraticExercise,    "math.quadreq-en.txt")
-   , (getId higherDegreeExercise, "math.polyeq-en.txt")
-   ]
-
-testSuiteList :: [TestSuite]
-testSuiteList = [MathNum.main, MathPoly.tests, MathSqrt.tests, testMe, testLCM]
− src/Domain/Math/Expr.hs 
@@ -1,18 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Expr (module Export) where
-
-import Domain.Math.Expr.Clipboard as Export
-import Domain.Math.Expr.Data as Export
-import Domain.Math.Expr.Parser as Export
-import Domain.Math.Expr.Symbols as Export
-import Domain.Math.Expr.Views as Export
− src/Domain/Math/Expr/Clipboard.hs 
@@ -1,115 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Support for a clipboard, on which expressions can be placed. The clipboard
--- is part of the environment (terms that are placed in a context)
---
------------------------------------------------------------------------------
-module Domain.Math.Expr.Clipboard
-   ( addToClipboard, addListToClipboard
-   , lookupClipboard, lookupListClipboard, removeClipboard
-     -- generalized interface
-   , addToClipboardG, addListToClipboardG
-   , lookupClipboardG, lookupListClipboardG
-   , maybeOnClipboardG
-   ) where
-
-import Common.Context
-import Common.Rewriting
-import Control.Monad
-import Data.Maybe
-import Domain.Math.Data.Relation
-import Domain.Math.Expr.Data
-import Domain.Math.Expr.Parser
-import qualified Data.Map as M
-
----------------------------------------------------------------------
--- Expression variables (internal)
-
-newtype ExprVar a = ExprVar (Var Term)
-
-exprVar :: (Show a, IsTerm a) => String -> a -> ExprVar a
-exprVar s a = ExprVar (makeVar showF readF s (toTerm a))
- where
-   showF = show . toExpr -- pretty-print as an Expr
-   readF = liftM toTerm . parseExprM
-
-readExprVar :: IsTerm a => ExprVar a -> ContextMonad a
-readExprVar (ExprVar var) = do
-   term <- readVar var
-   maybeCM (fromTerm term)
-
-modifyExprVar :: IsTerm a => ExprVar a -> (a -> a) -> ContextMonad ()
-modifyExprVar (ExprVar var) f =
-   let safe h a = fromMaybe a (h a)
-       g = fmap (toTerm . f) . fromTerm
-   in modifyVar var (safe g)
-
----------------------------------------------------------------------
--- Clipboard variable
-
-newtype Key = Key String deriving (Show, Eq, Ord)
-
-instance (IsTerm k, Ord k, IsTerm a) => IsTerm (M.Map k a) where
-   toTerm = toTerm . map (\(k, a) -> toTerm k :==: toTerm a) . M.toList
-   fromTerm term = do
-      eqs <- fromTerm term
-      xs  <- forM eqs $ \(a :==: b) ->
-                liftM2 (,) (fromTerm a) (fromTerm b)
-      return (M.fromList xs)
-
-instance IsTerm Key where
-   toTerm (Key s) = variable s
-   fromTerm       = liftM Key . getVariable
-
-clipboard :: ExprVar (M.Map Key Expr)
-clipboard = exprVar "clipboard" M.empty
-
----------------------------------------------------------------------
--- Interface to work with clipboard
-
-addToClipboard :: String -> Expr -> ContextMonad ()
-addToClipboard = addToClipboardG
-
-addListToClipboard :: [String] -> [Expr] -> ContextMonad ()
-addListToClipboard = addListToClipboardG
-
-lookupClipboard :: String -> ContextMonad Expr
-lookupClipboard = lookupClipboardG
-
-lookupListClipboard :: [String] -> ContextMonad [Expr]
-lookupListClipboard = lookupListClipboardG
-
-removeClipboard :: String -> ContextMonad ()
-removeClipboard s =
-   modifyExprVar clipboard (M.delete (Key s))
-
----------------------------------------------------------------------
--- Generalized interface to work with clipboard
-
-addToClipboardG :: IsTerm a => String -> a -> ContextMonad ()
-addToClipboardG s a = modifyExprVar clipboard (M.insert (Key s) (toExpr a))
-
-addListToClipboardG :: IsTerm a => [String] -> [a] -> ContextMonad ()
-addListToClipboardG = zipWithM_ addToClipboardG
-
-lookupClipboardG :: IsTerm a => String -> ContextMonad a
-lookupClipboardG s = do
-   m    <- readExprVar clipboard
-   expr <- maybeCM (M.lookup (Key s) m)
-   fromExpr expr
-
-maybeOnClipboardG :: IsTerm a => String -> ContextMonad (Maybe a)
-maybeOnClipboardG s = do
-   m <- readExprVar clipboard
-   return (M.lookup (Key s) m >>= fromExpr)
-
-lookupListClipboardG :: IsTerm a => [String] -> ContextMonad [a]
-lookupListClipboardG = mapM lookupClipboardG
− src/Domain/Math/Expr/Data.hs 
@@ -1,274 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Expr.Data
-   ( Expr(..), toExpr, fromExpr, fromDouble
-   ) where
-
-import Common.Algebra.Field
-import Common.Rewriting
-import Common.Utils (commaList)
-import Common.Utils.Uniplate
-import Control.Monad
-import Data.Char (isAlphaNum)
-import Data.Maybe
-import Data.Ratio
-import Data.Typeable
-import Domain.Math.Data.Relation (relationSymbols)
-import Domain.Math.Expr.Symbols
-import Test.QuickCheck
-import qualified Common.Algebra.CoField as F
-
------------------------------------------------------------------------
--- Expression data type
-
-data Expr = -- Num
-            Expr :+: Expr
-          | Expr :*: Expr
-          | Expr :-: Expr
-          | Negate Expr
-          | Nat Integer
-            -- Fractional
-          | Expr :/: Expr
-            -- Floating-point
-          | Sqrt Expr
-          | Number Double -- positive only
-            -- Symbolic
-          | Var String
-          | Sym Symbol [Expr]
-   deriving (Eq, Ord, Typeable)
-
------------------------------------------------------------------------
--- Numeric instances (and symbolic)
-
-instance Num Expr where
-   (+) = (:+:)
-   (*) = (:*:)
-   (-) = (:-:)
-   fromInteger n
-      | n < 0     = negate $ Nat $ abs n
-      | otherwise = Nat n
-   negate = Negate
-   abs    = unary absSymbol
-   signum = unary signumSymbol
-
-instance Fractional Expr where
-   (/) = (:/:)
-   fromRational r
-      | denominator r == 1 =
-           fromIntegral (numerator r)
-      | numerator r < 0 =
-           Negate (fromIntegral (abs (numerator r)) :/: fromIntegral (denominator r))
-      | otherwise =
-           fromIntegral (numerator r) :/: fromIntegral (denominator r)
-
-instance Floating Expr where
-   pi      = symbol piSymbol
-   sqrt    = Sqrt
-   (**)    = binary powerSymbol
-   logBase = binary logSymbol
-   exp     = unary expSymbol
-   log     = unary logSymbol
-   sin     = unary sinSymbol
-   tan     = unary tanSymbol
-   cos     = unary cosSymbol
-   asin    = unary asinSymbol
-   atan    = unary atanSymbol
-   acos    = unary acosSymbol
-   sinh    = unary sinhSymbol
-   tanh    = unary tanhSymbol
-   cosh    = unary coshSymbol
-   asinh   = unary asinhSymbol
-   atanh   = unary atanhSymbol
-   acosh   = unary acoshSymbol
-
-instance WithFunctions Expr where
-   function s [a, b]
-      | s == plusSymbol   = a :+: b
-      | s == timesSymbol  = a :*: b
-      | s == minusSymbol  = a :-: b
-      | s == divideSymbol = a :/: b
-      | isRootSymbol s && b == Nat 2 = Sqrt a
-   function s [a]
-      | s == negateSymbol = Negate a
-   function s as = Sym s as
-
-   getFunction expr =
-      case expr of
-         a :+: b  -> return (plusSymbol,   [a, b])
-         a :*: b  -> return (timesSymbol,  [a, b])
-         a :-: b  -> return (minusSymbol,  [a, b])
-         Negate a -> return (negateSymbol, [a])
-         a :/: b  -> return (divideSymbol, [a, b])
-         Sqrt a   -> return (rootSymbol,   [a, Nat 2])
-         Sym s as -> return (s, as)
-         _ -> fail "Expr.getFunction"
-
-instance WithVars Expr where
-   variable = Var
-   getVariable (Var s) = return s
-   getVariable _       = fail "Expr.getVariable"
-
-fromDouble :: Double -> Expr
-fromDouble d
-   | d < 0     = negate (Number (abs d))
-   | otherwise = Number d
-
------------------------------------------------------------------------
--- Uniplate instance
-
-instance Uniplate Expr where
-   uniplate expr =
-      case getFunction expr of
-         Just (s, as) -> plate function |- s ||* as
-         _            -> plate expr
-
------------------------------------------------------------------------
--- Arbitrary instance
-
-instance Arbitrary Expr where
-   arbitrary = liftM fromInteger arbitrary
-      -- before changing this instance, check that the
-      -- Gaussian elimination exercise still works (with checkExercise)
-      {-
-      let syms = [plusSymbol, timesSymbol, minusSymbol, negateSymbol, divSymbol]
-      in sized (symbolGenerator (const [natGenerator]) syms) -}
-
------------------------------------------------------------------------
--- Pretty printer
-
-instance Show Expr where
-   show = showExpr operatorTable
-
-showExpr :: OperatorTable -> Expr -> String
-showExpr table = rec 0
- where
-   rec :: Int -> Expr -> String
-   rec _ (Nat n)    = if n>=0 then show n else "(ERROR)" ++ show n
-   rec _ (Number d) = if d>=0 then show d else "(ERROR)" ++ show d
-   rec _ (Var s)
-      | all isAlphaNum s = s
-      | otherwise        = "\"" ++ s ++ "\""
-   rec i expr =
-      case getFunction expr of
-         Just (s1, [Sym s2 [Var x, a]]) | s1 == diffSymbol && s2 == lambdaSymbol ->
-            parIf (i>10000) $ "D(" ++ x ++ ") " ++ rec 10001 a
-         Just (s, [Nat a, Nat b, Nat c]) | s == mixedFractionSymbol ->
-            let ok  = all (>= 0) [a, b, c]
-                err = if ok then "" else "(ERROR)"
-            in err ++ show a ++ "[" ++ show b ++ "/" ++ show c ++ "]"
-         -- To do: remove special case for sqrt
-         Just (s, [a, b]) | isRootSymbol s && b == Nat 2 ->
-            parIf (i>10000) $ unwords ["sqrt", rec 10001 a]
-         Just (s, xs) | s == listSymbol ->
-            "[" ++ commaList (map (rec 0) xs) ++ "]"
-         Just (s, as) ->
-            case (lookup s symbolTable, as) of
-               (Just (InfixLeft, n, op), [x, y]) ->
-                  parIf (i>n) $ rec n x ++ op ++ rec (n+1) y
-               (Just (InfixRight, n, op), [x, y]) ->
-                  parIf (i>n) $ rec (n+1) x ++ op ++ rec n y
-               (Just (InfixNon, n, op), [x, y]) ->
-                  parIf (i>n) $ rec (n+1) x ++ op ++ rec (n+1) y
-               (Just (PrefixNon, n, op), [x]) ->
-                  parIf (i>=n) $ op ++ rec (n+1) x
-               _ ->
-                  parIf (not (null as) && i>10000) $ unwords (showSymbol s : map (rec 10001) as)
-         Nothing ->
-            error "showExpr"
-
-   showSymbol s
-      | isRootSymbol s = "root"
-      | isLogSymbol s  = "log"
-      | otherwise = show s
-
-   symbolTable = [ (s, (a, n, op)) | (n, (a, xs)) <- zip [1..] table, (s, op) <- xs ]
-
-   parIf b = if b then par else id
-   par s   = "(" ++ s ++ ")"
-
-type OperatorTable = [(Associativity, [(Symbol, String)])]
-
-data Associativity = InfixLeft | InfixRight | PrefixNon
-                   | InfixNon
-   deriving (Show, Eq)
-
-operatorTable :: OperatorTable
-operatorTable =
-     (InfixNon, [ (s, op) | (_, (op, s)) <- relationSymbols]) :
-   [ (InfixLeft,  [(plusSymbol, "+"), (minusSymbol, "-")])    -- 6
-   , (PrefixNon,  [(negateSymbol, "-")])                      -- 6+
-   , (InfixLeft,  [(timesSymbol, "*"), (divideSymbol, "/")])  -- 7
-   , (InfixRight, [(powerSymbol, "^")])                       -- 8
-   ]
-
-instance SemiRing Expr where
-   (<+>) = (+)
-   zero  = 0
-   (<*>) = (*)
-   one   = 1
-
-instance Ring Expr where
-   plusInverse = negate
-   (<->)       = (-)
-
-instance Field Expr where
-   timesInverse = recip
-   (</>)        = (/)
-
-instance F.CoSemiRing Expr where
-   isPlus  = isPlus
-   isZero  = (==0)
-   isTimes = isTimes
-   isOne   = (==1)
-
-instance F.CoRing Expr where
-   isNegate = isNegate
-   isMinus  = isMinus
-
-instance F.CoField Expr where
-   isRecip _  = Nothing
-   isDivision = isDivide
-
-instance Different Expr where
-   different = (Nat 0, Nat 1)
-
-instance IsTerm Expr where
-   toTerm (Nat n)    = TNum n
-   toTerm (Number d) = TFloat d
-   toTerm (Var v)    = TVar v
-   toTerm expr =
-      case getFunction expr of
-         Just (s, xs) -> function s (map toTerm xs)
-         Nothing      -> error "IsTerm Expr"
-
-   fromTerm (TNum n)   = return (fromInteger n)
-   fromTerm (TFloat d) = return (fromDouble d)
-   fromTerm (TVar v)   = return (Var v)
-   fromTerm t =
-      case getFunction t of
-         Just (s, xs) -> do
-            ys <- mapM fromTerm xs
-            return (function s ys)
-         _ -> fail "fromTerm"
-
-instance IsTerm a => IsTerm [a] where
-   toTerm = function listSymbol . map toTerm
-   fromTerm a = do
-      xs <- isFunction listSymbol a
-      mapM fromTerm xs
-
-toExpr :: IsTerm a => a -> Expr
-toExpr = fromJust . fromTerm . toTerm
-
-fromExpr :: (MonadPlus m, IsTerm a) => Expr -> m a
-fromExpr = fromTerm . toTerm
− src/Domain/Math/Expr/Parser.hs 
@@ -1,203 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Expr.Parser
-   ( parseExpr, parseExprM
-   , parseEqExpr, parseBoolEqExpr, parseRelExpr
-   , parseOrsEqExpr, parseOrsRelExpr
-   , parseLogicRelExpr
-   , parseExprTuple
-   ) where
-
-import Common.Algebra.Boolean hiding (ors)
-import Common.Classes
-import Common.Id
-import Common.Rewriting
-import Common.Transformation
-import Control.Monad
-import Data.Monoid
-import Domain.Logic.Formula (Logic, catLogic)
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Data.WithBool
-import Domain.Math.Expr.Data
-import Domain.Math.Expr.Symbols
-import Prelude hiding ((^))
-import Test.QuickCheck (arbitrary)
-import Text.Parsing
-import qualified Text.ParserCombinators.Parsec.Token as P
-
-parseExpr :: String -> Either String Expr
-parseExpr = parseSimple expr
-
-parseExprM :: Monad m => String -> m Expr
-parseExprM = either fail return . parseExpr
-
-parseEqExpr :: String -> Either String (Equation Expr)
-parseEqExpr = parseSimple (equation expr)
-
-parseBoolEqExpr :: String -> Either String (WithBool (Equation Expr))
-parseBoolEqExpr = parseSimple (boolAtom (equation expr))
-
-parseRelExpr :: String -> Either String (Relation Expr)
-parseRelExpr = parseSimple (relation expr)
-
-parseOrsEqExpr :: String -> Either String (OrList (Equation Expr))
-parseOrsEqExpr = parseSimple (ors (equation expr))
-
-parseOrsRelExpr :: String -> Either String (OrList (Relation Expr))
-parseOrsRelExpr = parseSimple (ors (relation expr))
-
-parseLogicRelExpr :: String -> Either String (Logic (Relation Expr))
-parseLogicRelExpr = parseSimple (catLogic <$> logic (relationChain expr))
-
-parseExprTuple :: String -> Either String [Expr]
-parseExprTuple = parseSimple (tuple expr)
-
-ors :: Parser a -> Parser (OrList a)
-ors p = mconcat <$> sepBy1 (boolAtom p) (reserved "or")
-
-logic :: Parser a -> Parser (Logic a)
-logic p = buildExpressionParser table (boolAtom p)
- where
-   table =
-      [ [Infix ((<&&>) <$ reservedOp "and") AssocRight]
-      , [Infix ((<||>) <$ reservedOp "or" ) AssocRight]
-      ]
-
-boolAtom :: (Container f, BoolValue (f a)) => Parser a -> Parser (f a)
-boolAtom p = choice
-   [ true      <$  reserved "true"
-   , false     <$  reserved "false"
-   , singleton <$> p
-   ]
-
-equation :: Parser a -> Parser (Equation a)
-equation p = (:==:) <$> p <* reservedOp "==" <*> p
-
-relation :: Parser a -> Parser (Relation a)
-relation p = p <**> relType <*> p
-
-relationChain :: Parser a -> Parser (Logic (Relation a))
-relationChain p = (\x -> ands . make x) <$> p <*> many1 ((,) <$> relType <*> p)
- where
-   make _ []             = []
-   make a ((f, b): rest) = singleton (f a b) : make b rest
-
-relType :: Parser (a -> a -> Relation a)
-relType = choice (map make table)
- where
-   make (s, f) = reserved s >> return f
-   table =
-      [ ("==", (.==.)), ("<=", (.<=.)), (">=", (.>=.))
-      , ("<", (.<.)), (">", (.>.)), ("~=", (.~=.))
-      ]
-
-tuple :: Parser a -> Parser [a]
-tuple p = parens (sepBy p comma)
-
-expr :: Parser Expr
-expr = buildExpressionParser exprTable term
-
-term :: Parser Expr
-term = choice
-   [ sqrt <$ reserved "sqrt" <*> atom
-   , binary rootSymbol <$ reserved "root" <*> atom <*> atom
-   , binary logSymbol  <$ reserved "log"  <*> atom <*> atom
-   , do reserved "D"
-        x <- identifier <|> parens identifier
-        a <- atom
-        return $ unary diffSymbol (binary lambdaSymbol (Var x) a)
-   , do a  <- qualId
-        as <- many atom
-        return (function (newSymbol a) as)
-   , atom
-   ]
-
-pmixed :: Parser Expr
-pmixed = do
-   a      <- natural
-   P.brackets lexer $ do
-      b <- natural
-      reservedOp "/"
-      c <- natural
-      return $ mixed a b c
-
-atom :: Parser Expr
-atom = choice
-   [ try pmixed
-   , do notFollowedBy (char '-')
-        either fromInteger fromDouble <$> naturalOrFloat
-   , variable <$> identifier
-   , parens expr
-   ]
-
-exprTable :: [[Operator Char () Expr]]
-exprTable =
-   [ -- precedence level 7
-     [ Infix ((^) <$ reservedOp "^") AssocRight
-     ]
-     -- precedence level 7
-   , [ Infix ((*) <$ reservedOp "*") AssocLeft
-     , Infix ((/) <$ reservedOp "/") AssocLeft
-     ]
-     -- precedence level 6+
-   , [ Prefix (negate <$ reservedOp "-")
-     ]
-     -- precedence level 6
-   , [ Infix ((+) <$ reservedOp "+") AssocLeft
-     , Infix ((-) <$ reservedOp "-") AssocLeft
-     ]
-   ]
-
---------------------------------------------------------------------------
--- Lexing
-
-lexer :: P.TokenParser a
-lexer = P.makeTokenParser $ emptyDef
-   { reservedNames   = ["sqrt", "root", "log", "and", "or", "true", "false", "D"]
-   , reservedOpNames = ["==", "<=", ">=", "<", ">", "~=", "+", "-", "*", "^", "/"]
-   }
-
-identifier :: Parser String
-identifier = P.identifier lexer
-
-qualId :: CharParser st Id
-qualId = try (P.lexeme lexer (do
-   xs <- idPart `sepBy1` char '.'
-   guard (length xs > 1)
-   return (mconcat (map newId xs)))
- <?> "qualified identifier")
- where
-   idPart   = (:) <$> letter <*> many idLetter
-   idLetter = alphaNum <|> oneOf "-_"
-
-natural :: Parser Integer
-natural = P.natural lexer
-
-reserved :: String -> Parser ()
-reserved = P.reserved lexer
-
-reservedOp :: String -> Parser ()
-reservedOp = P.reservedOp lexer
-
-comma :: Parser String
-comma = P.comma lexer
-
-parens :: Parser a -> Parser a
-parens = P.parens lexer
-
------------------------------------------------------------------------
--- Argument descriptor (for parameterized rules)
-
-instance Argument Expr where
-   makeArgDescr descr =
-      ArgDescr descr Nothing parseExprM show termView arbitrary
− src/Domain/Math/Expr/Symbols.hs 
@@ -1,144 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Exports relevant OpenMath symbols
---
------------------------------------------------------------------------------
-module Domain.Math.Expr.Symbols
-   ( -- OpenMath dictionary symbols
-     plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol
-   , powerSymbol, negateSymbol, sinSymbol, cosSymbol, lnSymbol
-   , diffSymbol, piSymbol, lambdaSymbol, listSymbol
-   , absSymbol, signumSymbol, logSymbol, expSymbol, tanSymbol, asinSymbol
-   , atanSymbol, acosSymbol, sinhSymbol, tanhSymbol, coshSymbol, asinhSymbol
-   , atanhSymbol, acoshSymbol, bottomSymbol, fcompSymbol, mixedFractionSymbol
-     -- Matching
-   , isPlus, isTimes, isMinus, isDivide, isPower, isNegate, isRoot
-   , isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol
-   , isMixedFractionSymbol
-   , (^), root, mixed
-   ) where
-
-import Common.Rewriting
-import Control.Monad
-import Prelude hiding ((^))
-import qualified Text.OpenMath.Dictionary.Arith1 as OM
-import qualified Text.OpenMath.Dictionary.Calculus1 as OM
-import qualified Text.OpenMath.Dictionary.Fns1 as OM
-import qualified Text.OpenMath.Dictionary.List1 as OM
-import qualified Text.OpenMath.Dictionary.Nums1 as OM
-import qualified Text.OpenMath.Dictionary.Transc1 as OM
-
--------------------------------------------------------------
--- Arith1 dictionary
-
-plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol,
-   powerSymbol, negateSymbol, absSymbol :: Symbol
-
-plusSymbol   = newSymbol OM.plusSymbol
-timesSymbol  = newSymbol OM.timesSymbol
-minusSymbol  = newSymbol OM.minusSymbol
-divideSymbol = newSymbol OM.divideSymbol
-rootSymbol   = newSymbol OM.rootSymbol
-powerSymbol  = newSymbol OM.powerSymbol
-negateSymbol = newSymbol OM.unaryMinusSymbol
-absSymbol    = newSymbol OM.absSymbol
-
--------------------------------------------------------------
--- Transc1 dictionary
-
-logSymbol, sinSymbol, cosSymbol, lnSymbol, expSymbol, tanSymbol,
-   sinhSymbol, tanhSymbol, coshSymbol :: Symbol
-
-logSymbol  = newSymbol OM.logSymbol
-sinSymbol  = newSymbol OM.sinSymbol
-cosSymbol  = newSymbol OM.cosSymbol
-lnSymbol   = newSymbol OM.lnSymbol
-expSymbol  = newSymbol OM.expSymbol
-tanSymbol  = newSymbol OM.tanSymbol
-sinhSymbol = newSymbol OM.sinhSymbol
-tanhSymbol = newSymbol OM.tanhSymbol
-coshSymbol = newSymbol OM.coshSymbol
-
--------------------------------------------------------------
--- Other dictionaries
-
-diffSymbol, lambdaSymbol, listSymbol, piSymbol :: Symbol
-
-diffSymbol   = newSymbol OM.diffSymbol
-lambdaSymbol = newSymbol OM.lambdaSymbol
-listSymbol   = newSymbol OM.listSymbol
-piSymbol     = newSymbol OM.piSymbol
-
--------------------------------------------------------------
--- Extra math symbols
-
-signumSymbol, asinSymbol, atanSymbol, acosSymbol, asinhSymbol, atanhSymbol,
-   acoshSymbol, bottomSymbol, fcompSymbol, mixedFractionSymbol :: Symbol
-
-signumSymbol = newSymbol "signum"
-asinSymbol   = newSymbol "asin"
-atanSymbol   = newSymbol "atan"
-acosSymbol   = newSymbol "acos"
-asinhSymbol  = newSymbol "asinh"
-atanhSymbol  = newSymbol "atanh"
-acoshSymbol  = newSymbol "acosh"
-bottomSymbol = newSymbol "error"
-fcompSymbol  = newSymbol "compose"
-
--- support for mixed fractions
-mixedFractionSymbol = newSymbol ("extra", "mixedfraction")
-
--------------------------------------------------------------
--- Some match functions
-
-isPlus, isTimes, isMinus, isDivide, isPower, isRoot ::
-   (WithFunctions a, MonadPlus m) => a -> m (a, a)
-isNegate :: (WithFunctions a, MonadPlus m) => a -> m a
-
-isPlus   = isAssoBinary plusSymbol
-isTimes  = isAssoBinary timesSymbol
-isMinus  = isBinary     minusSymbol
-isDivide = isBinary     divideSymbol
-isNegate = isUnary      negateSymbol
-isPower  = isBinary     powerSymbol
-isRoot   = isBinary     rootSymbol
-
-isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol,
-   isMixedFractionSymbol :: Symbol -> Bool
-
-isPowerSymbol  = (== powerSymbol)
-isRootSymbol   = (== rootSymbol)
-isLogSymbol    = (== logSymbol)
-isDivideSymbol = (== divideSymbol)
-
-isMixedFractionSymbol = (== mixedFractionSymbol)
-
-infixr 8 ^
-
-(^) :: WithFunctions a => a -> a -> a
-(^) = binary powerSymbol
-
-root :: WithFunctions a => a -> a -> a
-root = binary rootSymbol
-
-mixed :: (Num a, WithFunctions a) => Integer -> Integer -> Integer -> a
-mixed a b c = function mixedFractionSymbol $ map fromInteger [a, b, c]
-
--------------------------------------------------------------
--- Helper
-
--- left-associative
-isAssoBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a)
-isAssoBinary s a =
-   case isFunction s a of
-      Just [x, y] -> return (x, y)
-      Just (x:xs) | length xs > 1 -> return (x, function s xs)
-      _ -> fail "isAssoBinary"
− src/Domain/Math/Expr/Views.hs 
@@ -1,152 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Expr.Views
-   ( module Domain.Math.Expr.Views
-   , (.+.), (.-.), neg, (.*.), (./.)
-   ) where
-
-import Common.Algebra.CoField
-import Common.Algebra.Group
-import Common.Library
-import Common.Utils.Uniplate
-import Domain.Math.Expr.Data
-import Domain.Math.Expr.Symbols
-import Prelude hiding ((^))
-import qualified Data.Set as S
-
-------------------------------------------------------------
--- Smart constructors
-
-infixr 8 .^.
-
-(.^.) :: Expr -> Expr -> Expr
-Nat 0 .^. _ = Nat 0
-Nat 1 .^. _ = Nat 1
-_ .^. Nat 0 = Nat 1
-a .^. Nat 1 = a
-a .^. b     = a ^ b
-
-------------------------------------------------------------
--- Views of binary constructors
-
-plusView :: View Expr (Expr, Expr)
-plusView = makeView matchPlus (uncurry (.+.))
- where
-   matchPlus (a :+: b)  = Just (a, b)
-   matchPlus (a :-: b)  = Just (a, neg b)
-   matchPlus (Negate a) = do (x, y) <- matchPlus a
-                             Just (neg x, neg y)
-   matchPlus _          = Nothing
-
-timesView :: View Expr (Expr, Expr)
-timesView = makeView matchTimes (uncurry (.*.))
- where
-   matchTimes (a :*: b)  = Just (a, b)
-   matchTimes (Negate a) = do (x, y) <- matchTimes a
-                              Just (neg x, y)
-   matchTimes _          = Nothing
-
-divView :: View Expr (Expr, Expr)
-divView = makeView matchDiv (uncurry (./.))
- where
-   matchDiv (a :/: b)  = Just (a, b)
-   matchDiv (Negate a) = do (x, y) <- matchDiv a
-                            Just (neg x, y)
-   matchDiv _          = Nothing
-
--------------------------------------------------------------
--- Sums and products
-
-sumView :: Isomorphism Expr [Expr]
-sumView = describe "View an expression as the sum of a list of elements, \
-   \taking into account associativity of plus, its unit element zero, and \
-   \inverse (both unary negation, and binary subtraction)." $
-   "math.sum" @> sumEP
- where
-   sumEP = (($ []) . f False) <-> foldl (.+.) 0
-
-   f n (a :+: b)  = f n a . f n b
-   f n (a :-: b)  = f n a . f (not n) b
-   f n (Negate a) = f (not n) a
-   f _ (Nat 0)    = id
-   f n e          = if n then (neg e:) else (e:)
-
--- no distribution
-simpleSumView :: Isomorphism Expr [Expr]
-simpleSumView = sumEP
- where
-   sumEP = f <-> foldl (.+) 0
-
-   f (a :+: b)           = f a <> f b
-   f (a :-: b)           = f a <> f (-b)
-   f (Nat 0)             = mempty
-   f (Negate (Nat 0))    = mempty
-   f (Negate (Negate a)) = f a
-   f a                   = return a
-
-   Nat 0 .+ b = b
-   a .+ Nat 0 = a
-   a .+ Negate b  = a :-: b
-   a .+ b = a :+: b
-
-productView :: Isomorphism Expr (Bool, [Expr])
-productView = "math.product" @> productEP
- where
-   productEP = (second ($ []) . f False) <-> g
-
-   f r (a :*: b)  = f r a .&&. f r b
-   f r (a :/: b)  = case a of -- two special cases (for efficiency)
-                       Nat 1          -> f (not r) b
-                       Negate (Nat 1) -> first not (f (not r) b)
-                       _              -> f r a .&&. f (not r) b
-   f r (Negate a) = first not (f r a)
-   f r e          = (False, if r then (recip e:) else (e:))
-
-   (n1, g1) .&&. (n2, g2) = (n1 /= n2, g1 . g2)
-
-   g (b, xs) = (if b then neg else id) (foldl (.*.) 1 xs)
-
-simpleProductView :: Isomorphism Expr (Bool, [Expr])
-simpleProductView = "math.product.simple" @> simpleProductEP
- where
-   simpleProductEP = (second ($ []) . f) <-> g
-
-   f (a :*: b)  = f a .&&. f b
-   f (Nat 1)    = (False, id)
-   f (Negate a) = first not (f a)
-   f e          = (False, (e:))
-
-   (n1, g1) .&&. (n2, g2) = (n1 /= n2, g1 . g2)
-
-   g (b, xs) = (if b then myNeg else id) (foldl (.*) 1 xs)
-
-   Nat 1 .* a = a
-   a .* Nat 1 = a
-   Nat 0 .* a | ok a = 0
-   a .* Nat 0 | ok a = 0
-   Negate a .* b = myNeg (a .* b)
-   a .* Negate b = myNeg (a .* b)
-   a .* b = a :*: b
-
-   myNeg (Negate a) = a
-   myNeg a = Negate a
-
-   ok (a :/: b) = b /= 0 && ok a && ok b -- to do: evaluate b before b/=0
-   ok a = all ok (children a)
-
--- helper to determine the name of the variable (move to a different module?)
-selectVar :: Expr -> Maybe String
-selectVar = f  . S.toList . varSet
- where
-   f []  = Just "x" -- exceptional case (e.g., for constants)
-   f [a] = Just a
-   f _   = Nothing
− src/Domain/Math/Numeric/Exercises.hs 
@@ -1,79 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Numeric.Exercises
-   ( naturalExercise, integerExercise
-   , rationalExercise, fractionExercise
-   ) where
-
-import Common.Library
-import Domain.Math.Expr
-import Domain.Math.Numeric.Generators
-import Domain.Math.Numeric.Strategies
-import Domain.Math.Numeric.Views
-
-------------------------------------------------------------
--- Exercises
-
-numericExercise :: LabeledStrategy (Context Expr) -> Exercise Expr
-numericExercise s = makeExercise
-   { status       = Alpha
-   , parser       = parseExpr
-   , equivalence  = withoutContext (viewEquivalent rationalView)
-   , strategy     = s
-   , navigation   = termNavigator
-   }
-
-naturalExercise :: Exercise Expr
-naturalExercise = (numericExercise naturalStrategy)
-   { exerciseId   = describe "simplify expression (natural numbers)" $
-                       newId "numbers.natural"
-   , ready        = predicateView integerNF
-   , examples     = level Medium $ concat calculateResults
-   }
-
-integerExercise :: Exercise Expr
-integerExercise = (numericExercise integerStrategy)
-   { exerciseId   = describe "simplify expression (integers)" $
-                       newId "numbers.integers"
-   , ready        = predicateView integerNF
-   , examples     = level Medium $ concat calculateResults
-   }
-
-rationalExercise :: Exercise Expr
-rationalExercise = (numericExercise rationalStrategy)
-   { exerciseId     = describe "simplify expression (rational numbers)" $
-                         newId "numbers.rational"
-   , ready          = predicateView rationalNF
-   , randomExercise = simpleGenerator (rationalGenerator 5)
-   }
-
-fractionExercise :: Exercise Expr
-fractionExercise = (numericExercise fractionStrategy)
-   { exerciseId     = describe "simplify expression (fractions)" $
-                         newId "arithmetic.fractions"
-   , ready          = predicateView rationalNF
-   , randomExercise = simpleGenerator (rationalGenerator 5)
-   }
-
-calculateResults :: [[Expr]]
-calculateResults = [level1, level2, level3]
- where
-   level1 =
-      [ -8*(-3), -3-9, 55/(-5), -6*9, -11- (-3), 6-(-9), -10+3, 6+(-5) ]
-   level2 =
-      [ -3-(6*(-3)), -12/3 - 3, -4*(2+3), 2-6*6
-      , -27/(4-(-5)), (-24/(-6)) - 3, 8-(-77/(-11)), 4/(-4+5)
-      ]
-   level3 =
-      [ 4*(3-(6-2)), (-16-9)/5 - 3, 4- (4-13)/(-3), (3*(-3))-5-4
-      , -55/(3*(-5)+4), -4*(-2+ (-4)+7), -8 - (140/4*5), (13-(2-1)) / 3
-      ]
− src/Domain/Math/Numeric/Generators.hs 
@@ -1,109 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Numeric.Generators
-   ( integerGenerator, rationalGenerator, numGenerator
-   , ratioGen, ratioExprGen, ratioExprGenNonZero, nonZero
-   ) where
-
-import Common.Rewriting
-import Common.View
-import Control.Monad
-import Data.Ratio
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Test.QuickCheck
-
--------------------------------------------------------------------
--- Generators
-
--- tailored towards generating "int" expressions (also prevents
--- division by zero)
-integerGenerator :: Int -> Gen Expr
-integerGenerator = symbolGenerator extras numSymbols
- where
-   extras n = natGenerator : [ divGen n | n > 0 ]
-   divGen n = do
-      e1 <- integerGenerator (n `div` 2)
-      e2 <- integerGenerator (n `div` 2)
-      case (match integerView e1, match integerView e2) of
-         (Just a, Just b)
-            | b == 0 -> elements
-                 [ e1 :/: (e2 + 1), e1 :/: (e2 - 1)
-                 , e1 :/: (1 + e2), e1 :/: (1 - e2)
-                 ]
-            | a `mod` b == 0 ->
-                 return (e1 :/: e2)
-            | otherwise -> do -- change numerator
-                i <- arbitrary
-                let m1 = fromInteger ((a `mod` b) + i*b)
-                    m2 = fromInteger (b - (a `mod` b) + i*b)
-                elements
-                   [ (e1 - m1) :/: e2, (m1 - e1) :/: e2
-                   , (e1 + m2) :/: e2, (m2 + e1) :/: e2
-                   ]
-         _ -> error "integerGenerator"
-
--- Prevents division by zero
-rationalGenerator :: Int -> Gen Expr
-rationalGenerator = symbolGenerator extras numSymbols
- where
-   extras n = natGenerator : [ divGen n | n > 0 ]
-   divGen n = do
-      e1 <- rationalGenerator (n `div` 2)
-      e2 <- rationalGenerator (n `div` 2)
-      case match rationalView e2 of
-         Just b | b == 0 -> return e1
-         _               -> return (e1 :/: e2)
-
--- Also generates "division-by-zero" expressions
-numGenerator :: Int -> Gen Expr
-numGenerator = symbolGenerator (const [natGenerator]) $
-   (divideSymbol, Just 2):numSymbols
-
-ratioExprGen :: Int -> Gen Expr
-ratioExprGen n = liftM fromRational $ ratioGen n (n `div` 4)
-
-ratioExprGenNonZero :: Int -> Gen Expr
-ratioExprGenNonZero n = liftM fromRational $ nonZero $ ratioGen n (n `div` 4)
-
-nonZero :: Num a => Gen a -> Gen a
-nonZero = liftM (\a -> if a==0 then 1 else a)
-
-numSymbols :: [(Symbol, Maybe Int)]
-numSymbols = (negateSymbol, Just 1)
-           : zip [plusSymbol, timesSymbol, minusSymbol] (repeat (Just 2))
-
--------------------------------------------------------------------
--- Helpers
-
-symbolGenerator :: (Int -> [Gen Expr]) -> [(Symbol, Maybe Int)] -> Int -> Gen Expr
-symbolGenerator extras syms = f
- where
-   f n = oneof $  map (g n) (filter (\(_, a) -> n > 0 || a == Just 0) syms)
-               ++ extras n
-   g n (s, arity) = do
-      i  <- case arity of
-               Just i  -> return i
-               Nothing -> choose (0, 5)
-      as <- replicateM i (f (n `div` i))
-      return (function s as)
-
-natGenerator :: Gen Expr
-natGenerator = liftM (Nat . abs) arbitrary
-
--- | Prevents a bias towards small numbers
-ratioGen :: Integral a => Int -> Int -> Gen (Ratio a)
-ratioGen n m = do
-   a <- choose (-n, n)
-   b <- liftM (succ . abs) (choose (-m, m))
-   c <- choose (1-b, b-1)
-   return (fromIntegral a + (fromIntegral c / fromIntegral b))
− src/Domain/Math/Numeric/Rules.hs 
@@ -1,164 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Numeric.Rules where
-
-import Common.Transformation
-import Common.View
-import Control.Monad
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-
-------------------------------------------------------------
--- Rules
-
-alg :: String
-alg = "algebra.manipulation"
-
-calcRuleName :: String -> String -> String
-calcRuleName opName viewName =
-   "arithmetic.operation." ++ viewName ++ "." ++ opName
-
-calcBinRule :: String -> (a -> a -> a) -> (e -> Maybe (e, e)) -> String -> View e a -> Rule e
-calcBinRule opName op m viewName v =
-   makeSimpleRule (calcRuleName opName viewName) $ \e ->
-   do (e1, e2) <- m e
-      a <- match v e1
-      b <- match v e2
-      return (build v (op a b))
-
-calcPlusWith :: Num a => String -> View Expr a -> Rule Expr
-calcPlusWith = calcBinRule "plus" (+) isPlus
-
-calcMinusWith :: Num a => String -> View Expr a -> Rule Expr
-calcMinusWith = calcBinRule "minus" (-) isMinus
-
-calcTimesWith :: Num a => String -> View Expr a -> Rule Expr
-calcTimesWith = calcBinRule "times" (*) isTimes
-
-calcDivisionWith :: Integral a => String -> View Expr a -> Rule Expr
-calcDivisionWith viewName v =
-   makeSimpleRule (calcRuleName "division" viewName) $ \e ->
-   do (e1, e2) <- isDivide e
-      a <- match v e1
-      b <- match v e2
-      let (d, m) = divMod a b
-      guard (b /= 0 && m == 0)
-      return (build v d)
-
-negateZero :: Rule Expr
-negateZero = makeSimpleRule (alg, "negate-zero") f
- where
-   f (Negate (Nat n)) | n == 0 = Just 0
-   f _                         = Nothing
-
-doubleNegate :: Rule Expr
-doubleNegate = makeSimpleRule (alg, "double-negate") f
- where
-   f (Negate (Negate a)) = Just a
-   f _                   = Nothing
-
-plusNegateLeft :: Rule Expr
-plusNegateLeft = makeSimpleRule (alg, "plus-negate-left") f
- where
-   f (Negate a :+: b) = Just (b :-: a)
-   f _                = Nothing
-
-plusNegateRight :: Rule Expr
-plusNegateRight = makeSimpleRule (alg, "plus-negate-right") f
- where
-   f (a :+: Negate b) = Just (a :-: b)
-   f _                = Nothing
-
-minusNegateLeft :: Rule Expr
-minusNegateLeft = makeSimpleRule (alg, "minus-negate-left") f
- where
-   f (Negate a :-: b) = Just (Negate (a :+: b))
-   f _                = Nothing
-
-minusNegateRight :: Rule Expr
-minusNegateRight = makeSimpleRule (alg, "minus-negate-right") f
- where
-   f (a :-: Negate b) = Just (a :+: b)
-   f _                = Nothing
-
-timesNegateLeft :: Rule Expr
-timesNegateLeft = makeSimpleRule (alg, "times-negate-left") f
- where
-   f (Negate a :*: b) = Just (Negate (a :*: b))
-   f _                = Nothing
-
-timesNegateRight :: Rule Expr
-timesNegateRight = makeSimpleRule (alg, "times-negate-right") f
- where
-   f (a :*: Negate b) = Just (Negate (a :*: b))
-   f _                = Nothing
-
-divisionNegateLeft :: Rule Expr
-divisionNegateLeft = makeSimpleRule (alg, "division-negate-left") f
- where
-   f (Negate a :/: b) = Just (Negate (a :/: b))
-   f _                = Nothing
-
-divisionNegateRight :: Rule Expr
-divisionNegateRight = makeSimpleRule (alg, "division-negate-right") f
- where
-   f (a :/: Negate b) = Just (Negate (a :/: b))
-   f _                = Nothing
-
-divisionNumerator :: Rule Expr
-divisionNumerator = makeSimpleRule (alg, "division-numerator") f
- where
-   f ((a :/: b) :/: c)        = Just (a :/: (b :*: c))
-   f (Negate (a :/: b) :/: c) = Just (Negate (a :/: (b :*: c)))
-   f _                        = Nothing
-
-divisionDenominator :: Rule Expr
-divisionDenominator = makeSimpleRule (alg, "division-denominator") f
- where
-   f (a :/: (b :/: c))        = Just ((a :*: c) :/: b)
-   f (a :/: Negate (b :/: c)) = Just (Negate ((a :*: c) :/: b))
-   f _                        = Nothing
-
-simplerFraction :: Rule Expr
-simplerFraction = makeSimpleRule (alg, "simpler-fraction") $ \expr -> do
-   new <- canonical rationalRelaxedForm expr
-   guard (expr /= new)
-   return new
-
-fractionPlus :: Rule Expr -- also minus
-fractionPlus = makeSimpleRule (alg, "fraction-plus") $ \expr -> do
-   (e1, e2) <- match plusView expr
-   (a, b)   <- match fractionForm e1
-   (c, d)   <- match fractionForm e2
-   guard (b == d)
-   return (build fractionForm (a+c, b))
-
-fractionPlusScale :: Rule Expr -- also minus
-fractionPlusScale = makeSimpleRuleList (alg, "fraction-plus-scale") $ \expr -> do
-   (e1, e2) <- matchM plusView expr
-   (a, b)   <- matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e1)
-   (c, d)   <- matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e2)
-   guard (b /= 0 && d /= 0 && b /= d)
-   let bd  = lcm b d
-       e1n = build fractionForm (a * (bd `div` b), bd)
-       e2n = build fractionForm (c * (bd `div` d), bd)
-   [ build plusView (e1n, e2) | b /= bd ] ++ [
-     build plusView (e1, e2n) | d /= bd ]
-
-fractionTimes :: Rule Expr
-fractionTimes = makeSimpleRule (alg, "fraction-times") f
- where
-   f (e1 :*: e2) = do
-      (a, b)   <- matchM fractionForm e1 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e1)
-      (c, d)   <- matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNF e2)
-      return (build fractionForm (a*c, b*d))
-   f _ = Nothing
− src/Domain/Math/Numeric/Strategies.hs 
@@ -1,77 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Numeric.Strategies
-   ( naturalStrategy, integerStrategy
-   , rationalStrategy, fractionStrategy
-   ) where
-
-import Common.Library
-import Domain.Math.Expr
-import Domain.Math.Numeric.Rules
-import Domain.Math.Numeric.Views
-
-------------------------------------------------------------
--- Strategies
-
-naturalStrategy :: LabeledStrategy (Context Expr)
-naturalStrategy = label "simplify" $
-   repeatS $ somewhere $ alternatives $ map use
-      [ calcPlusWith     "natural" natView
-      , calcMinusWith    "natural" natView
-      , calcTimesWith    "natural" natView
-      , calcDivisionWith "natural" natView
-      , doubleNegate, negateZero, plusNegateLeft, plusNegateRight
-      , minusNegateLeft, minusNegateRight, timesNegateLeft
-      , timesNegateRight, divisionNegateLeft, divisionNegateRight
-      ]
- where
-   natView = makeView f fromInteger
-    where
-      f (Nat n) = Just n
-      f _       = Nothing
-
-integerStrategy :: LabeledStrategy (Context Expr)
-integerStrategy = label "simplify" $
-   repeatS $ somewhere $ alternatives $ map use
-      [ calcPlusWith     "integer" integerNF
-      , calcMinusWith    "integer" integerNF
-      , calcTimesWith    "integer" integerNF
-      , calcDivisionWith "integer" integerNF
-      , doubleNegate, negateZero
-      ]
-
-rationalStrategy :: LabeledStrategy (Context Expr)
-rationalStrategy = label "simplify" $
-   repeatS $ somewhere $ alternatives $ map use
-      [ calcPlusWith     "rational" rationalRelaxedForm
-      , calcMinusWith    "rational" rationalRelaxedForm
-      , calcTimesWith    "rational" rationalRelaxedForm
-      , calcDivisionWith "integer"  integerNF
-      , doubleNegate, negateZero, divisionDenominator
-      , divisionNumerator, simplerFraction
-      ]
-
-fractionStrategy :: LabeledStrategy (Context Expr)
-fractionStrategy = label "simplify" $
-   repeatS $
-      somewhere
-         (  use (calcPlusWith     "integer" integerNF)
-        <|> use (calcMinusWith    "integer" integerNF)
-        <|> use (calcTimesWith    "integer" integerNF) -- not needed?
-        -- <|> use (calcDivisionWith "integer" integerNF)  -- not needed?
-         ) |>
-      somewhere
-         (  use doubleNegate <|> use negateZero <|> use divisionDenominator
-        <|> use fractionPlus <|> use fractionTimes <|> use divisionNumerator
-         ) |>
-      somewhere (use fractionPlusScale) |>
-      somewhere (use simplerFraction)
− src/Domain/Math/Numeric/Tests.hs 
@@ -1,89 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Numeric.Tests (main) where
-
-import Common.Classes
-import Common.Context
-import Common.Utils.TestSuite
-import Common.View
-import Control.Monad
-import Data.Maybe
-import Domain.Math.Expr
-import Domain.Math.Numeric.Generators
-import Domain.Math.Numeric.Strategies
-import Domain.Math.Numeric.Views
-import Test.QuickCheck
-
-main :: TestSuite
-main = suite "Numeric tests" $ do
-
-   suite "Correctness numeric views" $ do
-      let f s v = forM_ numGenerators $ \g -> do
-             addProperty ("idempotence " ++ s) $ propIdempotence g v
-             addProperty ("soundness " ++ s)   $ propSoundness semEqDouble g v
-      f "integer view"          integerView
-      f "rational view"         rationalView
-      f "integer normal form"   integerNF
-      f "rational normal form"  rationalNF
-      f "rational relaxed form" rationalRelaxedForm
-
-   suite "Normal forms" $ do
-      let f s v = forM_ numGenerators $ \g ->
-             addProperty s $ propNormalForm g v
-      f "integer normal form" integerNF
-    -- f rationalNF -- no longer a normal form
-
-   suite "Correctness generators" $ do
-      let f s g v = addProperty s $ forAll (sized g) (`belongsTo` v)
-      f "integer" integerGenerator integerView
-      f "rational" rationalGenerator rationalView
-      f "ratio expr" ratioExprGen rationalNF
-      f "ratio expr nonzero" ratioExprGenNonZero rationalNF
-
-   suite "View relations" $ do
-      let va .>. vb = forM_ numGenerators $ \g ->
-             addProperty "" $ forAll g $ \a ->
-                not (a `belongsTo` va) || a `belongsTo` vb
-      integerNF .>. integerView
-      rationalNF .>. rationalRelaxedForm
-      rationalRelaxedForm .>. rationalView
-      integerNF .>. rationalNF
-      integerView .>. rationalView
-
-   suite "Pre/post conditions strategies" $ do
-      let f l s pre post = forM_ numGenerators $ \g ->
-             addProperty l $ forAll g $ \a ->
-                let run = fromMaybe a . fromContext . applyD s
-                        . newContext emptyEnv . termNavigator
-                in not (a `belongsTo` pre) || run a `belongsTo` post
-      f "natural"  naturalStrategy  integerView  integerNF
-      f "integer"  integerStrategy  integerView  integerNF
-      f "rational" rationalStrategy rationalView rationalNF
-      f "fraction" fractionStrategy rationalView rationalNF
-
-numGenerators :: [Gen Expr]
-numGenerators = map sized
-   [ integerGenerator, rationalGenerator
-   , ratioExprGen, ratioExprGenNonZero, numGenerator
-   ]
-
-semEqDouble :: Expr -> Expr -> Bool
-semEqDouble a b =
-   case (match doubleView a, match doubleView b) of
-      (Just x, Just y)   -> x ~= y
-      (Nothing, Nothing) -> True
-      _                  -> False
- where
-   delta = 0.0001
-
-   (~=) :: Double -> Double -> Bool
-   x ~= y = abs x < delta || abs y < delta || abs (1 - (x/y)) < delta
− src/Domain/Math/Numeric/Views.hs 
@@ -1,238 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Numeric.Views
-   ( -- * Natural numbers
-     naturalView, naturalNF
-     -- * Integers
-   , integerView, integerNF
-     -- * Decimal fractions
-   , decimalFractionView
-     -- * Rational numbers
-   , rationalView, rationalNF
-   , rationalRelaxedForm, fractionForm
-     -- * Mixed fractions
-   , mixedFractionView, mixedFractionNF
-     -- * Double
-   , doubleView, doubleNF
-   ) where
-
-import Common.Id
-import Common.Rewriting (function)
-import Common.View
-import Control.Monad
-import Data.Ratio
-import Domain.Math.Expr hiding ((^))
-import Domain.Math.Safe
-import qualified Domain.Math.Data.DecimalFraction as DF
-import qualified Domain.Math.Data.MixedFraction as MF
-
--------------------------------------------------------------------
--- Natural numbers
-
--- |Non-negative numbers only, also for intermediate results
-naturalView :: View Expr Integer
-naturalView = "num.natural" @> makeView rec (fromInteger . abs)
- where
-   rec :: Expr -> Maybe Integer
-   rec expr = do
-      x <- matchInteger rec expr
-      guard (x >= 0)
-      return x
-
-naturalNF :: View Expr Integer
-naturalNF = "num.natural.nf" @> makeView f (build naturalView)
- where
-   f (Nat n) = Just n
-   f _       = Nothing
-
--------------------------------------------------------------------
--- Integers
-
-integerView :: View Expr Integer
-integerView = "num.integer" @> makeView (fix matchInteger) fromIntegral
-
--- N or -N (where n is a natural number)
-integerNF :: View Expr Integer
-integerNF = "num.integer.nf" @> makeView (optionNegate f) fromInteger
- where
-   f (Nat n) = Just n
-   f _       = Nothing
-
-matchInteger :: (Expr -> Maybe Integer) -> Expr -> Maybe Integer
-matchInteger f expr =
-   case expr of
-      a :/: b -> join (liftM2 safeDiv (f a) (f b))
-      Sym s [a, b]
-         | isPowerSymbol s -> join (liftM2 safePower (f a) (f b))
-      _ -> matchNum f expr
-
-matchNum :: Num a => (Expr -> Maybe a) -> Expr -> Maybe a
-matchNum f expr =
-   case expr of
-      Nat n    -> return (fromInteger n)
-      a :+: b  -> liftM2 (+) (f a) (f b)
-      a :-: b  -> liftM2 (-) (f a) (f b)
-      Negate a -> liftM negate (f a)
-      a :*: b  -> liftM2 (*) (f a) (f b)
-      _        -> Nothing
-
--------------------------------------------------------------------
--- Decimal fractions
-
-decimalFractionView :: View Expr DF.DecimalFraction
-decimalFractionView = "num.decimal" @> makeView (fix matchDecimal) f
- where
-   f = fromDouble . fromRational . toRational
-
-matchDecimal :: (Expr -> Maybe DF.DecimalFraction) -> Expr -> Maybe DF.DecimalFraction
-matchDecimal f expr =
-   case expr of
-      Number d -> Just (DF.fromDouble d)
-      a :/: b  -> join (liftM2 safeDiv (f a) (f b))
-      Sym s [a, b]
-         | isPowerSymbol s -> join (liftM2 safePower (f a) (f b))
-      Sym s [a, b, c]
-         | isMixedFractionSymbol s -> f (a+b/c)
-      _ -> matchNum f expr
-
--------------------------------------------------------------------
--- Rational numbers
-
--- |like  the original defintion, except that this view
--- now also converts floating point numbers (using an exact approximation)
-rationalView :: View Expr Rational
-rationalView = describe "Interpret an expression as a (normalized) rational \
-   \number, performing computations such as addition and multiplication if \
-   \necessary." $
-   "number.rational" @> makeView f fromRational
- where
-   f a = matchExact a >>= either (const Nothing) Just
-
-matchRational :: (Expr -> Maybe Rational) -> Expr -> Maybe Rational
-matchRational f expr =
-   case expr of
-      Number d -> return $ fromRational $ toRational $ DF.fromDouble d
-      a :/: b  -> join (liftM2 safeDiv (f a) (f b))
-      Sym s [a, b]
-         | isPowerSymbol s -> join (liftM2 safePower (f a) (f b))
-      Sym s [a, b, c]
-         | isMixedFractionSymbol s -> f (a+b/c)
-      _ -> matchNum f expr
-
-matchExact :: Expr -> Maybe (Either Double Rational)
-matchExact expr =
-   fmap Left (match doubleNF expr) `mplus`
-   fmap Right (fix matchRational expr)
-
--- 5, -(2/5), (-2)/5, but not 2/(-5), 6/8, or -((-2)/5)
-rationalNF :: View Expr Rational
-rationalNF = "num.rational.nf" @> makeView f fromRational
- where
-   f (Nat a :/: Nat b) = simpleRational a b
-   f (Negate (Nat a :/: Nat b)) = fmap negate (simpleRational a b)
-   f (Negate (Nat a) :/: Nat b) = fmap negate (simpleRational a b)
-   f a = fmap fromInteger (match integerNF a)
-
-simpleRational :: Integer -> Integer -> Maybe Rational
-simpleRational a b = do
-   guard (a > 0 && b > 1 && gcd a b == 1)
-   return (fromInteger a / fromInteger b)
-
-fractionForm :: View Expr (Integer, Integer)
-fractionForm = "num.fraction-form" @> makeView f g
- where
-   f = match (divView >>> integerNF *** integerNF)
-   g (a, b) = fromInteger a :/: fromInteger b
-
-rationalRelaxedForm :: View Expr Rational
-rationalRelaxedForm = "num.rational-relaxed" @> makeView (optionNegate f) fromRational
- where
-   f (e1 :/: e2) = do
-      a <- match integerNF e1
-      b <- match integerNF e2
-      safeDiv (fromInteger a) (fromInteger b)
-   f (Nat n) = Just (fromInteger n)
-   f _       = Nothing
-
--------------------------------------------------------------------
--- Mixed fractions
-
-mixedFractionView :: View Expr MF.MixedFraction
-mixedFractionView = "num.mixed-fraction" @> makeView f (sign g)
- where
-   f = fmap fromRational . fix matchRational
-
-   sign k a | a < 0     = negate (k (abs a))
-            | otherwise = k a
-
-   g a
-      | frac  == 0 = fromInteger  whole
-      | whole == 0 = fromRational frac
-      | otherwise  = function mixedFractionSymbol $ map fromInteger parts
-    where
-      whole = MF.wholeNumber a
-      frac  = MF.fractionPart a
-      parts = [whole, numerator frac, denominator frac]
-
-mixedFractionNF :: View Expr MF.MixedFraction
-mixedFractionNF = describe "A normal form for mixed fractions. \
-   \Improper fractions (numerator greater or equal to denominator) are not \
-   \allowed." $
-   "number.mixed-fraction.nf" @> makeView f (build mixedFractionView)
- where
-   f (Sym s [Nat a, Nat b, Nat c])
-      | isMixedFractionSymbol s = simple a b c
-   f (Negate (Sym s [Nat a, Nat b, Nat c]))
-      | isMixedFractionSymbol s = liftM negate (simple a b c)
-   f expr = do r <- match rationalNF expr
-               guard ((-1 < r && r < 1) || denominator r == 1)
-               return (fromRational r)
-
-   simple a b c = do
-      guard (a > 0 && b > 0 && b < c)
-      r <- simpleRational b c
-      return (fromInteger a + fromRational r)
-
--------------------------------------------------------------------
--- Double (imprecise floating-points)
-
-doubleView :: View Expr Double
-doubleView = "num.double" @> makeView (fix matchDouble) fromDouble
-
-doubleNF :: View Expr Double
-doubleNF = "num.double.nf" @> makeView (optionNegate f) fromDouble
- where
-   f (Number d) = Just d
-   f _          = Nothing
-
-matchDouble :: (Expr -> Maybe Double) -> Expr -> Maybe Double
-matchDouble f expr =
-   case expr of
-      Number d -> Just d
-      a :/: b  -> join (liftM2 safeDiv (f a) (f b))
-      Sqrt a   -> f a >>= safeSqrt
-      Sym s [a, b]
-         | isPowerSymbol s -> join (liftM2 safePower (f a) (f b))
-         | isRootSymbol s  -> join (liftM2 safeRoot (f a) (f b))
-      Sym s [a, b, c]
-         | isMixedFractionSymbol s -> f (a+b/c)
-      _ -> matchNum f expr
-
--------------------------------------------------------------------
--- Helper functions
-
-optionNegate :: Num a => (Expr -> Maybe a) -> Expr -> Maybe a
-optionNegate f (Negate a) = do b <- f a; guard (b /= 0); return (negate b)
-optionNegate f a          = f a
-
-fix :: (a -> a) -> a
-fix f = f (fix f)
− src/Domain/Math/Polynomial/Balance.hs 
@@ -1,263 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.Balance (balanceExercise) where
-
-import Common.Library
-import Common.Utils (fixpoint)
-import Common.Utils.Uniplate
-import Control.Monad
-import Data.Function
-import Data.Maybe
-import Data.Ratio
-import Domain.Math.Data.Relation
-import Domain.Math.Data.WithBool
-import Domain.Math.Equation.BalanceRules
-import Domain.Math.Equation.Views
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.BalanceUtils
-import Domain.Math.Polynomial.BuggyBalance
-import Domain.Math.Polynomial.Examples
-import Domain.Math.Polynomial.Generators
-import Domain.Math.Polynomial.Rules (conditionVarsRHS, flipEquation)
-import Domain.Math.Polynomial.Views
-import Test.QuickCheck (sized)
-
-------------------------------------------------------------
--- Exercise
-
-balanceExercise :: Exercise (WithBool (Equation Expr))
-balanceExercise = makeExercise
-   { exerciseId    = describe "Solve a linear equation using only balance rules." $
-                     newId "algebra.equations.linear.balance"
-   , status        = Provisional
-   , parser        = parseBoolEqExpr
-   , similarity    = withoutContext ((==) `on` cleaner)
-   , equivalence   = withoutContext (viewEquivalent eqView)
-   , suitable      = predicateView (traverseView linearEquationView)
-   , ready         = predicateView (traverseView (equationSolvedWith mixedFractionNF))
-                     <||> predicateView (traverseView (equationSolvedWith rationalNF))
-                     <||> predicateView (traverseView (equationSolvedWith doubleNF))
-   , strategy      = balanceStrategy
-   , extraRules    = map use buggyBalanceRules
-   , ruleOrdering  = ruleOrderingWithId (balanceOrder ++ buggyPriority)
-   , navigation    = termNavigator
-   , testGenerator = Just $ liftM2 (\a b -> singleton (a :==: b)) (sized linearGen) (sized linearGen)
-   , examples      = map (mapSecond singleton) linearExamples
-   }
-
-balanceOrder :: [Id]
-balanceOrder =
-   [ getId removeDivision, getId collect
-   , getId varRightMinus, getId varRightPlus
-   , getId conLeftMinus, getId conLeftPlus
-   , getId varLeftMinus, getId varLeftPlus
-   , getId conRightMinus, getId conRightPlus
-   , getId scaleToOne, getId flipEquation
-   , getId divideCommonFactor, getId distribute
-   , getId collect, getId divisionToFraction
-   ]
-
-------------------------------------------------------------
--- Strategy
-
-balanceStrategy :: LabeledStrategy (Context (WithBool (Equation Expr)))
-balanceStrategy = cleanUpStrategyAfter (applyTop cleaner) $
-   label "Balance equation" $
-       label "Phase 1" (repeatS
-           (  use collect
-          <|> use distribute
-          <|> use removeDivision
-          <|> somewhere (use divisionToFraction)
-           ))
-   <*> label "Phase 2" (repeatS
-           (  use varLeftMinus <|> use varLeftPlus
-          <|> use conRightMinus <|> use conRightPlus
-          <|> (check p2 <*> (use varRightMinus <|> use varRightPlus))
-          <|> (check p1 <*> (use conLeftMinus <|> use conLeftPlus)
-           ))
-       <*> try (use scaleToOne)
-       <*> try (use calculate))
-       -- flip sides of an equation (at most once)
-   <%> try (atomic (use conditionVarsRHS <*> use flipEquation))
-       -- divide by a common factor (but not as final "scale-to-one" step)
-   <%> many (notS (use scaleToOne) <*> use divideCommonFactor)
- where
-   -- move constants to left only if there are no variables on the left
-   p1 = maybe False (either (const False) (hasNoVar . leftHandSide) . fromWithBool) . fromContext
-   p2 ceq = fromMaybe False $ do
-      wb           <- fromContext ceq
-      lhs :==: rhs <- either (const Nothing) Just (fromWithBool wb)
-      (x1, a, _)   <- matchLin lhs
-      (x2, b, _)   <- matchLin rhs
-      return (x1 == x2 && b > a && a /= 0)
-
-------------------------------------------------------------
--- Rules
-
-calculate :: Rule (WithBool (Equation Expr))
-calculate = makeSimpleRule (linbal, "calculate") $ checkForChange $
-   Just . cleaner
-
--- factor is always positive due to lcm function
-removeDivision :: Rule (Equation Expr)
-removeDivision = doAfter (fmap distributeTimes) $
-   describe "remove division" $
-   makeRule (linbal, "remove-div") $ useSimpleRecognizer isTimesT $
-   supply1 "factor" removeDivisionArg timesT
- where
-   removeDivisionArg (lhs :==: rhs) = do
-      xs <- match simpleSumView lhs
-      ys <- match simpleSumView rhs
-      -- also consider parts without variables
-      -- (but at least one participant should have a variable)
-      zs <- mapM getFactor (xs++ys)
-      let (b, result) = foldr op (False, 1) zs
-          op (b1, a1) (b2, a2) = (b1 || b2, a1 `lcm` a2)
-      guard (b && result > 1)
-      return (fromInteger result)
-
-   getFactor (Negate a) = getFactor a
-   getFactor expr = do
-      (b, c) <- match (divView >>> second integerView) expr
-      return (hasSomeVar b, c)
-    `mplus` do
-      r <- match rationalView expr
-      return (False, denominator r)
-    `mplus` do
-      (r, c) <- match (timesView >>> first rationalView) expr
-      return (hasSomeVar c, denominator r)
-    `mplus` do
-      (b, r) <- match (timesView >>> second rationalView) expr
-      return (hasSomeVar b, denominator r)
-    `mplus` do
-      (_, ps) <- match simpleProductView expr
-      guard (any (`belongsTo` rationalView) ps)
-      return (False, 1)
-    `mplus` do
-      guard (isVariable expr)
-      return (False, 1)
-
-divisionToFraction :: Rule Expr
-divisionToFraction =
-   describe "turn a division into a multiplication with a fraction" $
-   makeSimpleRule (linbal, "div-to-fraction") $ \expr -> do
-      (a, r) <- match (divView >>> second rationalView) expr
-      guard (hasSomeVar a && r /= 0)
-      return (fromRational (1/r)*a)
-
-divideCommonFactor :: Rule (Equation Expr)
-divideCommonFactor = doAfter (fmap distributeDiv) $
-   describe "divide by common factor" $
-   makeRule (linbal, "smart-div") $ useSimpleRecognizer isTimesT $
-   supply1 "factor" getArg divisionT
- where
-   getArg (lhs :==: rhs)
-      | all (/=0) ns && n > 1 = Just (fromInteger n)
-      | otherwise             = Nothing
-    where
-       xs = from sumView lhs ++ from sumView rhs
-       ns = map getFactor xs
-       n  = foldr1 gcd ns
-
-   getFactor expr
-      | hasNoVar expr = fromMaybe 1 $ match integerView expr
-      | otherwise = fromMaybe 1 $ do
-           (a, b) <- match timesView expr
-           case (match integerView a, match integerView b) of
-              (Just n, _) | hasSomeVar b -> return n
-              (_, Just n) | hasSomeVar a -> return n
-              _ -> Nothing
-
-varLeftMinus, varLeftPlus :: Rule (Equation Expr)
-varLeftMinus = varLeft True  (linbal, "var-left-minus")
-varLeftPlus  = varLeft False (linbal, "var-left-plus")
-
-varLeft :: IsId a => Bool -> a -> Rule (Equation Expr)
-varLeft useMinus rid = doAfter (fmap collectLocal) $
-   makeRule rid $ useSimpleRecognizer isPlusT $
-   supply1 "term" varLeftArg (if useMinus then minusT else plusT)
- where
-    varLeftArg :: Equation Expr -> Maybe Expr
-    varLeftArg (lhs :==: rhs) = do
-       guard (hasSomeVar lhs)
-       (x, a, _) <- matchLin rhs
-       guard (if useMinus then a > 0 else a < 0)
-       return (fromRational (abs a) .*. x)
-
-conRightMinus, conRightPlus :: Rule (Equation Expr)
-conRightMinus = conRight True  (linbal, "con-right-minus")
-conRightPlus  = conRight False (linbal, "con-right-plus")
-
-conRight :: IsId a => Bool -> a -> Rule (Equation Expr)
-conRight useMinus rid = doAfter (fmap collectLocal) $
-   makeRule rid $ useSimpleRecognizer isPlusT $
-   supply1 "term" conRightArg (if useMinus then minusT else plusT)
- where
-    conRightArg :: Equation Expr -> Maybe Expr
-    conRightArg (lhs :==: _) = do
-       guard (hasSomeVar lhs)
-       (_, _, b) <- matchLin lhs
-       guard (if useMinus then b > 0 else b < 0)
-       return (fromRational (abs b))
-
-varRightMinus, varRightPlus :: Rule (Equation Expr)
-varRightMinus = flipped (linbal, "var-right-minus") varLeftMinus
-varRightPlus  = flipped (linbal, "var-right-plus")  varLeftPlus
-
-conLeftMinus, conLeftPlus :: Rule (Equation Expr)
-conLeftMinus = flipped (linbal, "con-left-minus") conRightMinus
-conLeftPlus  = flipped (linbal, "con-left-plus")  conRightPlus
-
-flipped :: IsId a => a -> Rule (Equation b) -> Rule (Equation b)
-flipped rid = liftRule flipView . changeId (const (newId rid))
- where flipView = makeView (Just . flipSides) flipSides
-
-scaleToOne :: Rule (Equation Expr)
-scaleToOne = doAfter (fmap distributeDiv) $
-   makeRule (linbal, "scale-to-one") $ useSimpleRecognizer isTimesT $
-   supply1 "factor" scaleToOneArg divisionT
- where
-   scaleToOneArg :: Equation Expr -> Maybe Expr
-   scaleToOneArg (lhs :==: rhs) = f lhs rhs `mplus` f rhs lhs
-
-   f :: Expr -> Expr -> Maybe Expr
-   f expr c = do
-      (_, a1, b1) <- matchLin expr
-      guard (a1 /= 0 && a1 /= 1 && b1 == 0 && hasNoVar c)
-      return (fromRational a1)
-
-collect :: Rule (Equation Expr)
-collect = makeSimpleRule (linbal, "collect") $
-   -- don't use this rule just for cleaning up
-   checkForChange (Just . fmap collectGlobal) . fmap cleanerExpr
-
-distribute :: Rule (Equation Expr)
-distribute = makeSimpleRule (linbal, "distribute") $ checkForChange $
-   Just . fmap (fixpoint f)
- where
-   f (a :*: (b :+: c))  = f (a*b+a*c)
-   f (a :*: (b :-: c))  = f (a*b-a*c)
-   f ((a :+: b) :*: c)  = f (a*c+b*c)
-   f ((a :-: b) :*: c)  = f (a*c-b*c)
-   f (Negate (a :+: b)) = f (-a-b)
-   f (Negate (a :-: b)) = f (-a+b)
-   f (Negate (Negate a)) = f a
-   f (a :-: (b :+: c)) = f (a-b-c)
-   f (a :-: (b :-: c)) = f (a-b+c)
-   f (a :-: Negate b)  = f (a+b)
-   f a = descend f a
-
--- for debugging
-{-
-go = printDerivation balanceExercise $ singleton $ let x=Var "x" in
-   (x+2+7/2*x)/(3/2) :==: -3/2*x/4*0 -}
− src/Domain/Math/Polynomial/BalanceUtils.hs 
@@ -1,245 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.BalanceUtils
-   ( eqView, minusView, negView
-   , matchLin, matchPlusCon
-   , cleaner, cleanerExpr
-   , linbal, checkForChange
-   , termArg, factorArg, factorArgs
-   , buggyBalanceRule, buggyBalanceRuleArgs
-   , buggyBalanceExprRule, buggyBalanceRecognizer
-   , collectLocal, collectGlobal
-   , distributeDiv, distributeTimes
-   , isPlusT, diffPlus
-   , isTimesT, diffTimes
-   ) where
-
-import Common.Library
-import Common.Utils (fixpoint)
-import Common.Utils.Uniplate
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Domain.Math.Data.Polynomial
-import Domain.Math.Data.Relation
-import Domain.Math.Data.WithBool
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Views
-import Domain.Math.Safe
-import Domain.Math.Simplification (mergeAlikeSum)
-
-eqView :: View (WithBool (Equation Expr)) (WithBool (String, Rational))
-eqView = makeView (either (Just . fromBool) f . fromWithBool) (fmap g)
- where
-   f (lhs :==: rhs) = do
-      (s, p) <- match (polyViewWith rationalView) (lhs-rhs)
-      case degree p of
-         0 -> Just $ fromBool $ coefficient 0 p == 0
-         1 -> Just $ singleton (s, - coefficient 0 p / coefficient 1 p)
-         _ -> Nothing
-   g (s, r) = Var s :==: fromRational r
-
-minusView :: View Expr (Expr, Expr)
-minusView = makeView isMinus (uncurry (:-:))
-
-negView :: View Expr Expr
-negView = makeView isNegate Negate
-
-matchLin :: Expr -> Maybe (Expr, Rational, Rational)
-matchLin expr = do
-   (s, p) <- match (polyNormalForm rationalView) expr
-   guard (degree p == 1)
-   return (Var s, coefficient 1 p, coefficient 0 p)
-
-matchPlusCon :: Expr -> Maybe (Expr, Rational)
-matchPlusCon expr =
-   match (plusView >>> second rationalView) expr
- `mplus`
-   match (plusView >>> toView swapView >>> second rationalView) expr
-
-------------------------------------------------------------
--- Strategy
-
-cleaner :: WithBool (Equation Expr) -> WithBool (Equation Expr)
-cleaner = join . fmap (trivial . fmap cleanerExpr)
-
-cleanerExpr :: Expr -> Expr
-cleanerExpr = transform f -- no fixpoint is needed
- where
-   f (a :/: Nat 1) = f a
-   f (a :/: Negate (Nat 1)) = f $ Negate a
-   f (Negate a :/: Negate b) = f (a/b)
-   f (a :/: Negate b) = f $ Negate (a/b)
-   f (Negate a :/: b) = f $ Negate (a/b)
-   f (Negate (Negate a)) = f a
-   f e = cleanSum (cleanProduct (simplify rationalView e))
-
-   cleanSum =
-      let g x y = canonical rationalView (x :+: y)
-      in simplifyWith (adjacent g) simpleSumView
-
-   cleanProduct =
-      let g x y = canonical rationalView (x :*: y)
-      in simplifyWith (mapSecond (adjacent g)) simpleProductView
-
-adjacent :: (a -> a -> Maybe a) -> [a] -> [a]
-adjacent f = rec
- where
-   rec (x:y:rest) =
-      case f x y of
-         Just xy -> rec (xy:rest)
-         Nothing -> x:rec (y:rest)
-   rec xs = xs
-
-trivial :: Equation Expr -> WithBool (Equation Expr)
-trivial eq@(lhs :==: rhs) =
-   case (match rationalView lhs, match rationalView rhs) of
-      (Just r1, Just r2)
-         | r1 == r2                -> true
-         | otherwise               -> false
-      _  | any nonsense [lhs, rhs] -> false
-         | lhs == rhs              -> true
-         | otherwise               -> singleton eq
-
-nonsense :: Expr -> Bool
-nonsense = any p . universe
- where
-   p (_ :/: a) = maybe False (==0) (match rationalView a)
-   p _         = False
-
-------------------------------------------------------------
--- Arguments
-
-termArg :: Expr -> ArgValues
-termArg expr = [ArgValue (makeArgDescr "term") expr]
-
-factorArg :: Expr -> ArgValues
-factorArg expr = [ArgValue (makeArgDescr "factor") expr]
-
-factorArgs :: [Expr] -> ArgValues
-factorArgs =
-   let f = ArgValue . makeArgDescr . ("factor" ++) . show
-   in zipWith f [1::Int ..]
-
-------------------------------------------------------------
--- Rules
-
-linbal :: Id
-linbal = newId "algebra.equations.linear.balance"
-
-checkForChange :: (MonadPlus m, Eq a) => (a -> m a) -> a -> m a
-checkForChange f a = f a >>= \b -> guard (a /= b) >> return b
-
-buggyBalanceRule :: IsId n => n -> (Equation Expr -> Maybe (Equation Expr)) -> Rule (Equation Expr)
-buggyBalanceRule n f = buggyBalanceRuleArgs n (fmap (\x -> (x, [])) . f)
-
-buggyBalanceRuleArgs :: IsId n => n -> (Equation Expr -> Maybe (Equation Expr, ArgValues)) -> Rule (Equation Expr)
-buggyBalanceRuleArgs n f = bugbalRule n (fmap fst . f) $ \old (a1 :==: a2) -> do
-   (b1 :==: b2, as) <- f old
-   let h = viewEquivalent (polyViewWith rationalView)
-   guard (h a1 b1 && h a2 b2)
-   return as
-
-buggyBalanceExprRule :: IsId n => n -> (Expr -> Maybe Expr) -> Rule (Equation Expr)
-buggyBalanceExprRule n f = buggyBalanceRule n $ \(lhs :==: rhs) ->
-   let -- to do: deal with associativity
-       rec = msum .  map (\(a,h) -> liftM h (f a)) . contexts
-   in liftM (:==: rhs) (rec lhs) `mplus` liftM (lhs :==:) (rec rhs)
-
-buggyBalanceRecognizer :: IsId n => n -> (a -> a -> Maybe ArgValues) -> Rule a
-buggyBalanceRecognizer n = bugbalRule n(const Nothing)
-
--- generalized helper
-bugbalRule :: IsId n => n -> (a -> Maybe a) -> (a -> a -> Maybe ArgValues) -> Rule a
-bugbalRule n f p =
-   buggyRule $ makeRule (linbal, "buggy", n) $ useRecognizer p $ makeTrans f
-
-------------------------------------------------------------
--- Helpers
-
-collectLocal :: Expr -> Expr
-collectLocal = simplifyWith (mapSecond f) simpleProductView
-             . simplifyWith mergeAlikeSum simpleSumView
- where
-   f xs | length ys > 1 = ys++zs
-        | otherwise     = xs
-    where
-      (ys, zs) = partition hasNoVar xs
-
-collectGlobal :: Expr -> Expr
-collectGlobal = fixpoint (transform collectLocal)
-
-distributeDiv :: Expr -> Expr
-distributeDiv expr = fromMaybe expr $ do
-   (a, r) <- match (divView >>> second rationalView) expr
-   return $ simplifyWith (fmap (`divide` r)) simpleSumView a
- where
-   divide x r = fromMaybe (x/fromRational r) $ do
-      (y, z) <- match (timesView >>> first rationalView) x
-      new    <- y `safeDiv` r
-      return (fromRational new * z)
-    `mplus` do
-      (y, z) <- match (timesView >>> second rationalView) x
-      new    <- z `safeDiv` r
-      return (y * fromRational new)
-
-distributeTimes :: Expr -> Expr
-distributeTimes expr = fromMaybe expr $ do
-   (r, a) <- match (timesView >>> first rationalView) expr
-              `mplus`
-             match (timesView >>> second rationalView >>> toView swapView) expr
-   return $ simplifyWith (fmap (times r)) simpleSumView a
- where
-   times r x = fromMaybe (fromRational r*x) $ do
-      (a, b) <- match (divView >>> second rationalView) x
-      guard (b /= 0)
-      return (fromRational (r/b) * a)
-
-isPlusT :: Equation Expr -> Equation Expr -> Bool
-isPlusT old new = isJust (diffPlusEq old new)
-
-diffPlusEq :: Equation Expr -> Equation Expr -> Maybe Expr
-diffPlusEq (a1 :==: a2) (b1 :==: b2) = do
-   d1 <- diffPlus a1 b1
-   d2 <- diffPlus a2 b2
-   guard (d1 == d2)
-   return d1
-
-diffPlus :: Expr -> Expr -> Maybe Expr
-diffPlus a b = do
-   let myView = polyViewWith rationalView
-   (x, pa) <- matchM myView a
-   (y, pb) <- matchM myView b
-   guard (x==y)
-   let d = pb - pa
-   return $ build myView (x, d)
-
-isTimesT :: Equation Expr -> Equation Expr -> Bool
-isTimesT old new = isJust (diffTimesEq old new)
-
-diffTimesEq :: Equation Expr -> Equation Expr -> Maybe Expr
-diffTimesEq (a1 :==: a2) (b1 :==: b2) = do
-   d1 <- diffTimes a1 b1
-   d2 <- diffTimes a2 b2
-   guard (d1 == d2)
-   return d1
-
-diffTimes :: Expr -> Expr -> Maybe Expr
-diffTimes a b = do
-   let myView = polyViewWith rationalView
-   (x, pa) <- matchM myView a
-   (y, pb) <- matchM myView b
-   guard (x==y)
-   if pa==0 && pb==0 then return 1 else do
-   d <- pb `safeDiv` pa
-   return $ build myView (x, d)
− src/Domain/Math/Polynomial/BuggyBalance.hs 
@@ -1,474 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.BuggyBalance
-   ( buggyBalanceRules, buggyPriority
-   ) where
-
-import Common.Library
-import Control.Monad
-import Data.Ratio
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.BalanceUtils
-import Domain.Math.Polynomial.Views
-
-buggyBalanceRules :: [Rule (Equation Expr)]
-buggyBalanceRules =
-   [ rule121, rule122, rule1231, rule1232, rule1234
-   , rule1311, rule1312, rule1314, rule1321, rule1322
-   , rule133, rule134, rule135, rule136, rule137
-   , rule201
-   , rule2111, rule2112, rule2113, rule2114
-   , rule2121, rule2122, rule2131, rule2132
-   , rule2141, rule2142
-   , rule221, rule222, rule2231, rule2232, rule2233, rule227
-   , rule311, rule321, rule322, rule323
-   ]
-
-buggyPriority :: [Id]
-buggyPriority = map getId
-   [rule1312, rule121, rule221, rule222, rule2232, rule2233, rule227, rule323]
-
--------------------------------------------------------------------
--- 1.2 Fout bij vermenigvuldigen
-
--- (a*b)/c  ->  a/(b*c)
-rule121 :: Rule (Equation Expr)
-rule121 = describe "1.2.1: fout bij vermenigvuldigen" $
-   buggyBalanceExprRule "multiply1" f
- where
-   f (expr :/: c) = do
-      (a, b) <- match timesView expr
-      return $ a/(b*c)
-   f _ = Nothing
-
--- a*(bx+c)  ->  x/(ab) + ac
-rule122 :: Rule (Equation Expr)
-rule122 = describe "1.2.2: fout bij vermenigvuldigen" $
-   buggyBalanceExprRule "multiply2" f
- where
-   f (a :*: expr) = do
-      ((b, x), c) <- match (plusView >>> first timesView) expr
-      return $ x/(a*b) + a*c
-   f _ = Nothing
-
--- a(b-cx)  -> ab+acx
-rule1231 :: Rule (Equation Expr)
-rule1231 = describe "1.2.3.1: fout bij vermenigvuldigen; min raakt kwijt" $
-   buggyBalanceExprRule "multiply3" f
- where
-   f (a :*: expr) = do
-      (b, (c, x)) <- match (minusView >>> second timesView) expr
-      return $ a*b+a*c*x
-   f _ = Nothing
-
--- -a*(x-b)  -> -ax-ab
-rule1232 :: Rule (Equation Expr)
-rule1232 = describe "1.2.3.2: fout bij vermenigvuldigen; min te veel" $
-   buggyBalanceExprRule "multiply4" f
- where
-   f expr = do
-      (a, (x, b)) <- match (timesView >>> negView *** minusView) expr
-      return $ -a*x-a*b
-
--- -ax=b  ->  x=b/a
-rule1234 :: Rule (Equation Expr)
-rule1234 = describe "1.2.3.4: fout bij vermenigvuldigen; delen door negatief getal" $
-   buggyBalanceRule "multiply5" f
- where
-   f (expr :==: b) = do
-      (a, x) <- match (timesView >>> first negView) expr
-      return $ x :==: b/a
-
--------------------------------------------------------------------
--- 1.3 Fout bij haakjes wegwerken
-
--- a(x-b)  ->  ax-b    (verruimt naar +)
-rule1311 :: Rule (Equation Expr)
-rule1311 = describe "1.3.1.1: fout bij haakjes wegwerken; haakjes staan er niet voor niets" $
-   buggyBalanceExprRule "par1" f
- where
-   f expr = do
-      (a, (x, b)) <- match (timesView >>> second plusView) expr
-      return $ a*x+b
-
--- 1/a*(x-b)  -> 1/a*x-b   (specialized version of par1)
-rule1312 :: Rule (Equation Expr)
-rule1312 = describe "1.3.1.2: fout bij haakjes wegwerken; haakjes staan er niet voor niets" $
-   buggyBalanceExprRule "par2" f
- where
-   f (e1 :*: e2) = do
-      (n, a) <- match (divView >>> first integerView) e1
-      guard (n==1)
-      (x, b) <- match plusView e2
-      return $ 1/a*x+b
-   f _ = Nothing
-
--- a(b-cx)  -> ab-cx
-{- zie par1
-rule1313 :: Rule (Equation Expr)
-rule1313 = describe "1.3.1.3: fout bij haakjes wegwerken; haakjes staan e
-r niet voor niets" $
-
-   buggyBalanceExprRule "par3") f
- where
-   f (a :*: expr) = do
-      (b, (c, x)) <- match (minusView >>> second timesView) expr
-      return $ a*b-c*x
-   f _ = Nothing -}
-
--- -(a+b)  ->  -a+b
-rule1314 :: Rule (Equation Expr)
-rule1314 = describe "1.3.1.4: fout bij haakjes wegwerken met unaire min; haakjes staan er niet voor niets" $
-   buggyBalanceExprRule "par11" f
- where
-   f expr = do
-      (a, b) <- match (negView >>> plusView) expr
-      return $ -a+b
-
--- a(bx+c)  ->  ax+ac
-rule1321 :: Rule (Equation Expr)
-rule1321 = describe "1.3.2.1: fout bij haakjes wegwerken; haakjes goed uitwerken" $
-   buggyBalanceExprRule "par4" f
- where
-   f (a :*: expr) = do
-      ((_, x), c) <- match (plusView >>> first timesView) expr
-      return $ a*x+a*c
-   f _ = Nothing
-
--- a(b-cx)  -> ab-ax
-rule1322 :: Rule (Equation Expr)
-rule1322 = describe "1.3.2.2: fout bij haakjes wegwerken; haakjes goed uitwerken" $
-   buggyBalanceExprRule "par5" f
- where
-   f (a :*: expr) = do
-      (b, (_, x)) <- match (minusView >>> second timesView) expr
-      return $ a*b-a*x
-   f _ = Nothing
-
--- a(bx+c)  -> bx+ac
-rule133 :: Rule (Equation Expr)
-rule133 = describe "1.3.3: fout bij haakjes wegwerken; haakjes goed uitwerken" $
-   buggyBalanceExprRule "par6" f
- where
-   f (a :*: expr) = do
-      ((b, x), c) <- match (plusView >>> first timesView) expr
-      return $ b*x+a*c
-   f _ = Nothing
-
--- a-(b+c)  -> a-b+c
-rule134 :: Rule (Equation Expr)
-rule134 = describe "1.3.4: fout bij haakjes wegwerken; haakjes goed uitwerken" $
-   buggyBalanceExprRule "par7" f
- where
-   f expr = do
-      (a, (b, c)) <- match (minusView >>> second plusView) expr
-      return $ a-b+c
-
--- a*(b-c)-d  ->  ab-ac-ad
-rule135 :: Rule (Equation Expr)
-rule135 = describe "1.3.5: fout bij haakjes wegwerken; kijk goed waar de haakjes staan" $
-   buggyBalanceExprRule "par8" f
- where
-   f expr = do
-      ((a, (b, c)), d) <- match (minusView >>> first (timesView >>> second minusView)) expr
-      return $ a*b-a*c-a*d
-
---  a(bx+c)  ->  (a+b)x+ac
-rule136 :: Rule (Equation Expr)
-rule136 = describe "1.3.6: fout bij haakjes wegwerken; haakjes goed uitwerken" $
-   buggyBalanceExprRule "par9" f
- where
-   f (a :*: expr) = do
-      ((b, x), c) <- match (plusView >>> first timesView) expr
-      return $ (a+b)*x+a*c
-   f _ = Nothing
-
--- a+b(x-c)  -> (a+b)(x-c)
-rule137 :: Rule (Equation Expr)
-rule137 = describe "1.3.7: fout bij haakjes wegwerken; denk aan 'voorrangsregels'" $
-   buggyBalanceExprRule "par10" f
- where
-   f (a :+: expr) = do
-      (b, (x, c)) <- match (timesView >>> second plusView) expr
-      return $ (a+b)*(x+c)
-   f _ = Nothing
-
--------------------------------------------------------------------
--- 2.0 Links en rechts hetzelfde doen, of verwisselen
-
--- a=b-c  ->  c-b=a
-rule201 :: Rule (Equation Expr)
-rule201 = describe "2.0.1: Links en rechts alleen maar verwisseld?" $
-   buggyBalanceRule "flip1" f
- where
-   f (a :==: rhs) = do
-      (b, c) <- match minusView rhs
-      return $ c-b :==: a
-
--------------------------------------------------------------------
--- 2.1 Links en rechts hetzelfde optellen/aftrekken
-
-{- schema addbal regels: (telkens paren met positief/negatief argument)
-   1+2   constante naar rechts
-   3+4   variabele naar links
-   7+8   variabele naar rechts
-   9+10  constante naar links
-   ---
-   5/6   constante links weggehaald, maar rechts onveranderd gelaten
--}
-
--- ax+b=[cx]+d  -> ax=[cx]+d+b
-rule2111 :: Rule (Equation Expr)
-rule2111 = describe "2.1.1.1: Links en rechts hetzelfde optellen; links +b en rechts -b" $
-   buggyBalanceRuleArgs "addbal1" f
- where
-   f (lhs :==: rhs) = do
-      (ax, b) <- matchPlusCon lhs
-      guard (b>0)
-      return (ax :==: rhs+fromRational b, termArg (fromRational b))
-
--- ax-b=[cx]+d  -> ax=[cx+d-b
-rule2112 :: Rule (Equation Expr)
-rule2112 = describe "2.1.1.2: Links en rechts hetzelfde optellen; links -b en rechts +b" $
-   buggyBalanceRuleArgs "addbal2" f
- where
-   f (lhs :==: rhs) = do
-      (ax, b) <- matchPlusCon lhs
-      guard (b<0)
-      return (ax :==: rhs+fromRational b, termArg (fromRational (abs b)))
-
--- a=cx+d  -> a+d=cx
-rule2113 :: Rule (Equation Expr)
-rule2113 = describe "2.1.1.3: Je trekt er rechts {?} vanaf, maar links tel je {?} erbij op." $
-   buggyBalanceRuleArgs "addbal9" f
- where
-   f (lhs :==: rhs) = do
-      (cx, d) <- matchPlusCon rhs
-      guard (d>0)
-      return (lhs+fromRational d :==: cx, termArg (fromRational d))
-
--- a=cx-d  -> a-d=cx
-rule2114 :: Rule (Equation Expr)
-rule2114 = describe "2.1.1.4: Je telt er rechts {?} bij op, maar links trek je {?} er vanaf." $
-   buggyBalanceRuleArgs "addbal10" f
- where
-   f (lhs :==: rhs) = do
-      (cx, d) <- matchPlusCon rhs
-      guard (d<0)
-      return (lhs+fromRational d :==: cx, termArg (fromRational (abs d)))
-
--- ax[+b]=cx+d  ->  (a+c)x[+b]=d
-rule2121 :: Rule (Equation Expr)
-rule2121 = describe "2.1.2.1: Links en rechts hetzelfde optellen; links +cx en rechts -cx" $
-   buggyBalanceRuleArgs "addbal3" f
- where
-   f (lhs :==: rhs) = do
-      (x, a, b) <- matchLin lhs
-      (y, c, d) <- matchLin rhs
-      guard (c>0 && x==y)
-      return ( fromRational (a+c)*x+fromRational b :==: fromRational d
-             , termArg (fromRational c*x)
-             )
-
--- ax[+b]=-cx+d  -> (a-c)x[+b]=d
-rule2122 :: Rule (Equation Expr)
-rule2122 = describe "2.1.2.2: Links en rechts hetzelfde optellen; links -cx en rechts +cx" $
-   buggyBalanceRuleArgs "addbal4" f
- where
-   f (lhs :==: rhs) = do
-      (x, a, b) <- matchLin lhs
-      (y, c, d) <- matchLin rhs
-      guard (c<0 && x==y)
-      return ( fromRational (a+c)*x+fromRational b :==: fromRational d
-             , termArg (fromRational (abs c)*x)
-             )
-
--- ax+b=[cx]+d  -> ax=[cx]+d
-rule2131 :: Rule (Equation Expr)
-rule2131 = describe "2.1.3.1: Links en rechts hetzelfde optellen; links -b rechts niet(s)" $
-   buggyBalanceRuleArgs "addbal5" f
- where
-   f (lhs :==: rhs) = do
-      (ax, b) <- matchPlusCon lhs
-      guard (b > 0)
-      return (ax :==: rhs, termArg (fromRational b))
-
--- ax-b=[cx]+d  -> ax=[cx]+d
-rule2132 :: Rule (Equation Expr)
-rule2132 = describe "2.1.3.2: Links en rechts hetzelfde optellen; links+b en rechts niet(s)" $
-   buggyBalanceRuleArgs "addbal6" f
- where
-   f (lhs :==: rhs) = do
-      (ax, b) <- matchPlusCon lhs
-      guard (b < 0)
-      return (ax :==: rhs, termArg (fromRational (abs b)))
-
--- ax+b=cx+d  ->  b=(a+c)*x+d
-rule2141 :: Rule (Equation Expr)
-rule2141 = describe "2.1.4.1: Links en rechts hetzelfde optellen; links -ax en rechts +ax" $
-   buggyBalanceRuleArgs "addbal7" f
- where
-   f (lhs :==: rhs) = do
-      (x, a, b) <- matchLin lhs
-      (y, c, d) <- matchLin rhs
-      guard (a>0 && x==y)
-      return ( fromRational b :==: fromRational (a+c)*x+fromRational d
-             , termArg (fromRational a*x)
-             )
-
--- -ax+b=cx+d  ->  b=(-a+c)*x+d
-rule2142 :: Rule (Equation Expr)
-rule2142 = describe "2.1.4.2: Links en rechts hetzelfde optellen; links -cx en rechts +cx" $
-   buggyBalanceRuleArgs "addbal8" f
- where
-   f (lhs :==: rhs) = do
-      (x, a, b) <- matchLin lhs
-      (y, c, d) <- matchLin rhs
-      guard (a<0 && x==y)
-      return ( fromRational b :==: fromRational (a+c)*x+fromRational d
-             , termArg (fromRational (abs a)*x)
-             )
-
--------------------------------------------------------------------
--- 2.2 Links en rechts hetzelfde vermenigvuldigen/delen
-
--- ax=c  -> x=a/c
-rule221 :: Rule (Equation Expr)
-rule221 = describe "2.2.1: Links en rechts hetzelfde vermenigvuldigen; verkeerd om gedeeld" $
-   buggyBalanceRule "mulbal1" f
- where
-   f (expr :==: c) = do
-      (a, x) <- match timesView expr
-      return $ x :==: a/c
-
--- 1/*a+b=2/c*x+d  -> x+ba  -> 2x+cd
-rule222 :: Rule (Equation Expr)
-rule222 = describe "2.2.2: Links en rechts hetzelfde vermenigvuldigen; links *a; rechts *b" $
-   buggyBalanceRuleArgs "mulbal2" f
- where
-   f (lhs :==: rhs) = do
-      (x, ra, b) <- matchLin lhs
-      (y, rc, d) <- matchLin rhs
-      let a = denom ra
-          c = denom rc
-          denom = fromInteger . denominator
-          num   = fromInteger . numerator
-      guard (a /= c && (a /= 1 || c /= 1))
-      return ( num ra*x+fromRational b*a :==: num rc*y+c*fromRational d
-             , factorArgs [a, c]
-             )
-
--- ax-b=cx+d  -> pax-pb=cx+d
-rule2231 :: Rule (Equation Expr)
-rule2231 = describe "2.2.3.1: Links en rechts hetzelfde vermenigvuldigen; links *p, rechts niet (of andersom)" $
-   buggyBalanceRecognizer "mulbal3" p
- where -- currently, symmetric
-   p (a1 :==: a2) (b1 :==: b2) = do
-      dl <- diffTimes a1 b1
-      dr <- diffTimes a2 b2
-      if dl == 1 && dr /= 1
-        then return (factorArg dr)
-        else if dl /= 1 && dr == 1
-               then return (factorArg dl)
-               else Nothing
-
--- (x+a)/b=c  -> x+a=c
-rule2232 :: Rule (Equation Expr)
-rule2232 = describe "2.2.3.2: Links en rechts hetzelfde vermenigvuldigen; links /p, rechts niet" $
-   buggyBalanceRuleArgs "mulbal4" f
- where
-   f (expr :==: c) = do
-      (a, b) <- match divView expr
-      return (a :==: c, factorArg b)
-
--- a+b=c  -> -a-b=c
-rule2233 :: Rule (Equation Expr)
-rule2233 = describe "2.2.3.3: Links en rechts hetzelfde vermenigvuldigen; links en rechts *-1" $
-   buggyBalanceRule "mulbal5" f
- where
-   f (expr :==: c) = do
-      (a, b) <- match plusView expr
-      return $ -a-b :==: c
-
--- pa+pb=c -> a+b=c
-rule227 :: Rule (Equation Expr)
-rule227 = describe "2.2.7: Links en rechts hetzelfde vermenigvuldigen; een kant door p delen, andere kant niets" $
-   buggyBalanceRecognizer "mulbal6" p
- where -- currently, symmetric
-   p (a1 :==: a2) (b1 :==: b2) = do
-      dl <- diffTimes a1 b1
-      dr <- diffTimes a2 b2
-      rl <- match rationalView dl
-      rr <- match rationalView dr
-      if rl == 1 && rr /= 1 && numerator rr == 1
-        then return (factorArg (fromIntegral (denominator rr)))
-        else if rl /= 1 && rr == 1 && numerator rl == 1
-                then return (factorArg (fromIntegral (denominator rl)))
-                else Nothing
-
--------------------------------------------------------------------
--- 3.1 Doe je wat je wilt doen?
-
--- ax-b=cx-d  -> (c-a)x-b=-d
-rule311 :: Rule (Equation Expr)
-rule311 = describe "3.1.1: Doe je wat je wilt doen?" $
-   buggyBalanceRule "misc1" f
- where
-   f (lhs :==: rhs) = do
-      (x, a, b) <- matchLin lhs
-      (y, c, d) <- matchLin rhs
-      guard (x==y)
-      return (fromRational (c-a)*x+fromRational b :==: fromRational d)
-
--- ax-b=cd+d  -> pax-b=pcx+pd
-rule321 :: Rule (Equation Expr)
-rule321 = describe "3.2.1: Doe je wat je wilt doen? vermenigvuldig de hele linkerkant met p" $
-   buggyBalanceRecognizer "misc2" p
- where -- currently, not symmetric
-   p (a1 :==: a2) (b1 :==: b2) = do
-      d <- diffTimes a2 b2
-      let as  = from simpleSumView a1
-      guard (d `notElem` [1, -1] && length as > 1)
-      guard $ flip any (take (length as) [0..]) $ \i ->
-         let (xs,y:ys) = splitAt i as
-             aps = to sumView $ map (d*) xs ++ [y] ++ map (d*) ys
-         in viewEquivalent (polyViewWith rationalView) aps b1
-      return (factorArg d)
-
--- a-b=c  -> -a-b=-c
-rule322 :: Rule (Equation Expr)
-rule322 = describe "3.2.2: Doe je wat je wilt doen? neem het tegengestelde van de hele linkerkant" $
-   buggyBalanceRule "misc3" f
- where
-   f (expr :==: c) = do
-      (a, b) <- match minusView expr
-      return $ -a-b :==: -c
-
--- pax+pb=pc  ->  ax+pb=c
-rule323 :: Rule (Equation Expr)
-rule323 = describe "3.2.3: Doe je wat je wilt doen? Deel de hele linkerkant door p" $
-   buggyBalanceRecognizer "misc4" p
-   -- REFACTOR: code copied from rule misc2
- where -- currently, not symmetric
-   p (a1 :==: a2) (b1 :==: b2) = do
-      d  <- diffTimes a2 b2
-      dr <- match rationalView d
-      let as  = from simpleSumView a1
-      guard (dr `notElem` [0, 1, -1] && numerator dr == 1 && length as > 1)
-      guard $ flip any (take (length as) [0..]) $ \i ->
-         let (xs,y:ys) = splitAt i as
-             aps = to sumView $ map (d*) xs ++ [y] ++ map (d*) ys
-         in viewEquivalent (polyViewWith rationalView) aps b1
-      return (factorArg (fromRational (1/dr)))
− src/Domain/Math/Polynomial/BuggyRules.hs 
@@ -1,463 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Some buggy rules catching common misconceptions (also on the abc-formula)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.BuggyRules where
-
-import Common.Library hiding (makeRule, makeSimpleRule, makeSimpleRuleList,
-                              ruleList, root)
-import Control.Monad
-import Domain.Math.CleanUp
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Polynomial
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Rules
-import Domain.Math.Polynomial.Views
-import Prelude hiding ((^))
-import qualified Common.Transformation as Rule
-
-makeRule :: IsId n => n -> Transformation a -> Rule a
-makeSimpleRule :: IsId n => n -> (a -> Maybe a) -> Rule a
-makeSimpleRuleList :: IsId n => n -> (a -> [a]) -> Rule a
-ruleList :: (RuleBuilder f a, IsId n) => n -> [f] -> Rule a
-
-makeRule           = buggyName Rule.makeRule
-makeSimpleRule     = buggyName Rule.makeSimpleRule
-makeSimpleRuleList = buggyName Rule.makeSimpleRuleList
-ruleList           = buggyName Rule.ruleList
-
-buggyName :: IsId n => (Id -> a) -> n -> a
-buggyName f s = f ("algebra.equations.buggy" # s)
-
-buggyRulesExpr :: [Rule Expr]
-buggyRulesExpr =
-   map (siblingOf distributeTimes)
-   [ buggyDistrTimes, buggyDistrTimesForget, buggyDistrTimesSign
-   , buggyDistrTimesTooMany, buggyDistrTimesDenom
-   ] ++
-   [ buggyMinusMinus, buggyPriorityTimes -- no sibling defined
-   ]
-
-buggyRulesEquation :: [Rule (Equation Expr)]
-buggyRulesEquation =
-   [ buggyPlus, buggyNegateOneSide, siblingOf flipEquation buggyFlipNegateOneSide
-   , buggyNegateAll
-   , buggyDivNegate, buggyDivNumDenom, buggyCancelMinus
-   , buggyMultiplyOneSide, buggyMultiplyForgetOne
-   ]
-
-buggyPlus :: Rule (Equation Expr)
-buggyPlus = describe "Moving a term from the left-hand side to the \
-   \right-hand side (or the other way around), but forgetting to change \
-   \the sign." $
-   buggyRule $ makeSimpleRuleList "plus" $ \(lhs :==: rhs) -> do
-      (a, b) <- matchM plusView lhs
-      [ a :==: rhs + b, b :==: rhs + a ]
-    `mplus` do
-      (a, b) <- matchM plusView rhs
-      [ lhs + a :==: b, lhs + b :==: a ]
-
-buggyNegateOneSide :: Rule (Equation Expr)
-buggyNegateOneSide = describe "Negate terms on one side only." $
-   buggyRule $ makeSimpleRuleList "negate-one-side" $ \(lhs :==: rhs) ->
-      [ -lhs :==: rhs, lhs :==: -rhs  ]
-
-buggyFlipNegateOneSide :: Rule (Equation Expr)
-buggyFlipNegateOneSide = describe "Negate terms on one side only." $
-   buggyRule $ makeSimpleRuleList "flip-negate-one-side" $ \(lhs :==: rhs) ->
-      [ -rhs :==: lhs, rhs :==: -lhs  ]
-
-buggyNegateAll :: Rule (Equation Expr)
-buggyNegateAll = describe "Negating all terms (on both sides of the equation, \
-   \but forgetting one term." $
-   buggyRule $ makeSimpleRuleList "negate-all" $ \(lhs :==: rhs) -> do
-      xs <- matchM sumView lhs
-      ys <- matchM sumView rhs
-      let makeL i = makeEq (zipWith (f i) [0..] xs) (map negate ys)
-          makeR i = makeEq (map negate xs) (zipWith (f i) [0..] ys)
-          makeEq as bs = build sumView as :==: build sumView bs
-          f i j = if i==j then id else negate
-          len as = let n = length as in if n < 2 then -1 else n
-      map makeL [0 .. len xs] ++ map makeR [0 .. len ys]
-
-buggyDivNegate :: Rule (Equation Expr)
-buggyDivNegate = describe "Dividing, but wrong sign." $
-   buggyRule $ makeSimpleRuleList "divide-negate" $ \(lhs :==: rhs) -> do
-      (a, b) <- matchM timesView lhs
-      [ b :==: rhs/(-a) | hasNoVar a ] ++ [ a :==: rhs/(-b) | hasNoVar b ]
-    `mplus` do
-      (a, b) <- matchM timesView rhs
-      [ lhs/(-a) :==: b | hasNoVar a ] ++ [ lhs/(-b) :==: a | hasNoVar b ]
-
-buggyDivNumDenom :: Rule (Equation Expr)
-buggyDivNumDenom = describe "Dividing both sides, but swapping \
-   \numerator/denominator." $
-   buggyRule $ makeSimpleRuleList "divide-numdenom" $ \(lhs :==: rhs) -> do
-      (a, b) <- matchM timesView lhs
-      [ b :==: a/rhs | hasNoVar rhs ] ++ [ a :==: b/rhs | hasNoVar rhs ]
-    `mplus` do
-      (a, b) <- matchM timesView rhs
-      [ a/lhs :==: b | hasNoVar lhs ] ++ [ b/lhs :==: a | hasNoVar lhs ]
-
-buggyDistrTimes :: Rule Expr
-buggyDistrTimes = describe "Incorrect distribution of times over plus: one \
-   \term is not multiplied." $
-   buggyRule $ makeSimpleRuleList "distr-times-plus" $ \expr -> do
-      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
-      [ a*b+c, b+a*c ]
-    `mplus` do
-      ((a, b), c) <- matchM (timesView >>> first plusView) expr
-      [ a*c+b, a+b*c ]
-
-buggyDistrTimesForget :: Rule Expr
-buggyDistrTimesForget = describe "Incorrect distribution of times over plus: \
-   \one term is forgotten." $
-   buggyRule $ makeSimpleRuleList "distr-times-plus-forget" $ \expr -> do
-      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
-      [ a*bn+a*c | bn <- forget b ] ++ [ a*b+a*cn | cn <- forget c ]
-    `mplus` do
-      ((a, b), c) <- matchM (timesView >>> first plusView) expr
-      [ an*c+b*c | an <- forget a] ++ [ a*c+bn*c | bn <- forget b]
- where
-   forget :: Expr -> [Expr]
-   forget expr =
-      case match productView expr of
-         Just (b, xs) | n > 1 ->
-            [ build productView (b, make i) | i <- [0..n-1] ]
-          where
-            make i = [ x | (j, x) <- zip [0..] xs, i/=j ]
-            n = length xs
-         _ -> [0]
-
-buggyDistrTimesSign :: Rule Expr
-buggyDistrTimesSign = describe "Incorrect distribution of times over plus: \
-   \changing sign of addition." $
-   buggyRule $ makeSimpleRuleList "distr-times-plus-sign" $ \expr -> do
-      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
-      [ a.*.b .-. a.*.c ]
-    `mplus` do
-      ((a, b), c) <- matchM (timesView >>> first plusView) expr
-      [ a.*.c .-. b.*.c ]
-
-buggyDistrTimesTooMany :: Rule Expr
-buggyDistrTimesTooMany = describe "Strange distribution of times over plus: \
-   \a*(b+c)+d, where 'a' is also multiplied to d." $
-   buggyRule $ makeSimpleRuleList "distr-times-too-many" $ \expr -> do
-      ((a, (b, c)), d) <- matchM (plusView >>> first (timesView >>> second plusView)) expr
-      [cleanUpExpr $ a*b+a*c+a*d]
-
-buggyDistrTimesDenom :: Rule Expr
-buggyDistrTimesDenom = describe "Incorrct distribution of times over plus: \
-   \one of the terms is a fraction, and the outer expression is multiplied by \
-   \the fraction's denominator." $
-   buggyRule $ makeSimpleRuleList "distr-times-denom" $ \expr -> do
-      (a, (b, c)) <- matchM (timesView >>> second plusView) expr
-      [(1/a)*b + a*c, a*b + (1/a)*c]
-    `mplus` do
-      ((a, b), c) <- matchM (timesView >>> first plusView) expr
-      [a*(1/c) + b*c, a*c + b*(1/c)]
-
-buggyMinusMinus :: Rule Expr
-buggyMinusMinus = describe "Incorrect rewriting of a-(b-c): forgetting to \
-   \change sign." $
-   buggyRule $ makeSimpleRule "minus-minus" $ \expr ->
-      case expr of
-         a :-: (b :-: c)  -> Just (a-b-c)
-         Negate (a :-: b) -> Just (a-b)
-         _ -> Nothing
-
-buggyCancelMinus :: Rule (Equation Expr)
-buggyCancelMinus = describe "Cancel terms on both sides, but terms have \
-   \different signs." $
-   buggyRule $ makeSimpleRuleList "cancel-minus" $ \(lhs :==: rhs) -> do
-      xs <- matchM sumView lhs
-      ys <- matchM sumView rhs
-      [ eq | (i, x) <- zip [0..] xs, (j, y) <- zip [0..] ys
-           , cleanUpExpr x == cleanUpExpr (-y)
-           , let f n as = build sumView $ take n as ++ drop (n+1) as
-           , let eq = f i xs :==: f j ys
-           ]
-
-buggyPriorityTimes :: Rule Expr
-buggyPriorityTimes = describe "Prioity of operators is changed, possibly by \
-   \ignoring some parentheses." $
-   buggyRule $ makeSimpleRuleList "priority-times" $ \expr -> do
-      (a, (b, c)) <- matchM (plusView >>> second timesView) expr
-      [(a+b)*c]
-    `mplus` do
-      ((a, b), c) <- matchM (plusView >>> first timesView) expr
-      [a*(b+c)]
-
-buggyMultiplyOneSide :: Rule (Equation Expr)
-buggyMultiplyOneSide = describe "Multiplication on one side of the equation only" $
-   buggyRule $ makeRule "multiply-one-side" $
-   useSimpleRecognizer recognizeEq $ supply1 "factor" (const (Just 2)) multiplyOneSide
- where
-   recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) =
-      let p r  = r `notElem` [-1, 0, 1] &&
-                 any (myEq eq2) (applyAll (multiplyOneSide (fromRational r)) eq1)
-      in maybe False p (recognizeMultiplication a1 b1)
-      || maybe False p (recognizeMultiplication a2 b2)
-
-recognizeMultiplication :: Expr -> Expr -> Maybe Rational
-recognizeMultiplication a b = do
-   (_, pa) <- match (polyViewWith rationalView) a
-   (_, pb) <- match (polyViewWith rationalView) b
-   let d = coefficient (degree pa) pa
-   guard (d /= 0)
-   return (coefficient (degree pb) pb / d)
-
-multiplyOneSide :: Expr -> Transformation (Equation Expr)
-multiplyOneSide r = makeTransList $ \(lhs :==: rhs) -> do
-      xs <- matchM sumView lhs
-      ys <- matchM sumView rhs
-      let f = map (*r)
-      [build sumView (f xs) :==: rhs, lhs :==: build sumView (f ys)]
-
-buggyMultiplyForgetOne :: Rule (Equation Expr)
-buggyMultiplyForgetOne = describe "Multiply the terms on both sides of the \
-   \equation, but forget one." $
-   buggyRule $ makeRule "multiply-forget-one" $
-   useSimpleRecognizer recognizeEq $ supply1 "factor" (const (Just 2)) multiplyForgetOne
- where
-   recognizeEq eq1@(a1 :==: a2) eq2@(b1 :==: b2) =
-      let p r  = r `notElem` [-1, 0, 1] &&
-                 any (myEq eq2) (applyAll (multiplyForgetOne (fromRational r)) eq1)
-      in maybe False p (recognizeMultiplication a1 b1)
-      || maybe False p (recognizeMultiplication a2 b2)
-
-multiplyForgetOne :: Expr -> Transformation (Equation Expr)
-multiplyForgetOne r = makeTransList $ \(lhs :==: rhs) -> do
-   xs <- matchM sumView lhs
-   ys <- matchM sumView rhs
-   let makeL i = f (zipWith (mul . (/=i)) [0..] xs) (map (mul True) ys)
-       makeR i = f (map (mul True) xs) (zipWith (mul . (/=i)) [0..] ys)
-       f as bs = build sumView as :==: build sumView bs
-       mul b   = if b then (*r) else id
-   do guard (length xs > 1)
-      map makeL [0 .. length xs-1]
-    `mplus` do
-      guard (length ys > 1)
-      map makeR [0 .. length ys-1]
-
--- Redundant function; should come from exercise
-myEq :: Equation Expr -> Equation Expr -> Bool
-myEq = let eqR f x y = fmap f x == fmap f y in eqR (acExpr . cleanUpExpr)
-
----------------------------------------------------------
--- Quadratic and Higher-Degree Polynomials
-
-buggyQuadratic :: IsTerm a => [Rule (Context a)]
-buggyQuadratic =
-   map use
-      [ buggyCoverUpTimesMul, buggyCoverUpEvenPower
-      , buggyCoverUpTimesWithPlus, buggyDivisionByVarBoth
-      , buggyDivisionByVarZero
-      ] ++
-   map use
-      [ buggyDistributionSquare, buggyDistributionSquareForget
-      , buggySquareMultiplication
-      ] ++
-   map use
-      [ buggyCoverUpEvenPowerTooEarly, buggyCoverUpEvenPowerForget
-      , buggyCoverUpSquareMinus
-      ]
-
-buggyCoverUpEvenPower :: Rule (Equation Expr)
-buggyCoverUpEvenPower = describe "Covering up an even power, but forgetting \
-   \the negative root" $ buggyRule $ siblingOf coverUpPower $
-   makeSimpleRuleList "coverup.even-power" $ \(lhs :==: rhs) ->
-      make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs
- where
-   make equals ab c = do
-      (a, b) <- isBinary powerSymbol ab
-      n <- matchM integerView b
-      guard (n > 0 && even n)
-      return (a `equals` root c (fromInteger n))
-
-buggyCoverUpEvenPowerTooEarly :: Rule (OrList (Equation Expr))
-buggyCoverUpEvenPowerTooEarly = describe "Trying to cover up an even power, \
-   \but there is some other operation to be done first. Example: x^2+1=9" $
-   buggyRule $ siblingOf coverUpPower $
-   makeSimpleRuleList "coverup.even-power-too-early" $
-      oneDisjunct $ helperBuggyCUPower True
-
-buggyCoverUpEvenPowerForget :: Rule (OrList (Equation Expr))
-buggyCoverUpEvenPowerForget = describe "Trying to cover up an even power, \
-   \but there is some other operation to be done first. Example: 9*x^2=81, \
-   \ and rewriting this into x=9 or x=-9." $
-   buggyRule $ siblingOf coverUpPower $
-   makeSimpleRuleList "coverup.even-power-forget" $
-      oneDisjunct $ helperBuggyCUPower False
-
-helperBuggyCUPower :: Bool -> Equation Expr -> [OrList (Equation Expr)]
-helperBuggyCUPower mode (lhs :==: rhs) =
-   make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs
- where
-   make equals ab c = do
-      (sym, xs) <- getFunction ab
-      (i, x)    <- zip [0..] xs
-      (a, b)    <- isBinary powerSymbol x
-      n         <- matchM integerView b
-      guard (n > 0 && even n)
-      let opa | mode      = function sym (take i xs ++ [a] ++ drop (i+1) xs)
-              | otherwise = a
-          rb  = root c (fromInteger n)
-      return $ toOrList [opa `equals` rb, opa `equals` (-rb)]
-
-buggyCoverUpTimesMul :: Rule (Equation Expr)
-buggyCoverUpTimesMul = describe "Covering-up a multiplication, but instead of \
-   \dividing the right-hand side, multiplication is used." $
-   buggyRule $ siblingOf coverUpTimes $
-   makeSimpleRuleList "coverup.times-mul" $ \(lhs :==: rhs) -> do
-      guard (rhs /= 0)
-      (a, b) <- isTimes lhs
-      [a :==: rhs*b, b :==: rhs*a]
-    `mplus` do
-      guard (lhs /= 0)
-      (a, b) <- isTimes rhs
-      [lhs*a :==: b, lhs*b :==: a]
-
-buggyDistributionSquare :: Rule Expr
-buggyDistributionSquare = describe "Incorrect removal of parentheses in a squared \
-   \addition: forgetting the 2ab term" $
-   buggyRule $ siblingOf distributionSquare $
-   ruleList "distr-square"
-      [ \a b -> (a+b)^2 :~> a^2+b^2
-      , \a b -> (a-b)^2 :~> a^2-b^2
-      , \a b -> (a-b)^2 :~> a^2+b^2
-      ]
-
-buggyDistributionSquareForget :: Rule Expr
-buggyDistributionSquareForget = describe "Incorrect removal of parentheses in a squared \
-   \addition: squaring only one term" $
-   buggyRule $ siblingOf distributionSquare $
-   ruleList "distr-square-forget"
-      [ \a b -> (a+b)^2 :~> a^2+b
-      , \a b -> (a+b)^2 :~> a+b^2
-      , \a b -> (a-b)^2 :~> a^2-b
-      , \a b -> (a-b)^2 :~> a-b^2
-      ]
-
-buggySquareMultiplication :: Rule Expr
-buggySquareMultiplication = describe "Incorrect square of a term that involves \
-   \a multiplication." $ buggyRule $
-   ruleList "square-multiplication"
-      [ \a b -> (a*b)^2 :~> a*b^2
-      , \a b -> (a*b)^2 :~> a^2*b
-      , \a b -> a*b^2   :~> (a*b)^2
-      , \a b -> a^2*b   :~> (a*b)^2
-      ]
-
-buggyCoverUpSquareMinus :: Rule (OrList (Equation Expr))
-buggyCoverUpSquareMinus = describe "A squared term is equal to a negative term \
-   \on the right-hand side, resulting in an error in the signs" $
-   buggyRule $ makeSimpleRule "coverup.square-minus" $ oneDisjunct $ \eq ->
-      case eq of
-         Sym s [a, 2] :==: b | isPowerSymbol s ->
-            Just $ toOrList [a :==: sqrt b, a :==: sqrt (-b)]
-         _ -> Nothing
-
-buggyCoverUpTimesWithPlus :: Rule (Equation Expr)
-buggyCoverUpTimesWithPlus = describe "Covering-up a multiplication, with an \
-   \addition on the other side. Only one of the terms is divided." $
-   buggyRule $ makeSimpleRuleList "coverup.times-with-plus" $
-   \(lhs :==: rhs) -> make (:==:) lhs rhs ++ make (flip (:==:)) rhs lhs
- where
-   make equals ab cd = do
-      (a, b) <- isTimes ab
-      (c, d) <- isPlus cd
-      [ a `equals` (c/b+d), a `equals` (c+d/b),
-        b `equals` (c/a+d), b `equals` (c+d/a) ]
-
-buggyDivisionByVarBoth :: Rule (Equation Expr)
-buggyDivisionByVarBoth = describe "Divide both sides by variable, without \
-   \introducing the x=0 alternative." $
-   buggyRule $ makeSimpleRule "division-by-var-both" $
-   \(lhs :==: rhs) -> do
-      (s1, p1) <- match polyView lhs
-      (s2, p2) <- match polyView rhs
-      let n = lowestDegree p1 `min` lowestDegree p2
-      guard (n > 0 && s1==s2)
-      let f p = build polyView (s1, raise (-n) p)
-      return (f p1 :==: f p2)
-
-buggyDivisionByVarZero :: Rule (Equation Expr)
-buggyDivisionByVarZero = describe "Divide both sides by variable, without \
-   \introducing the x=0 alternative." $
-   buggyRule $ makeSimpleRuleList "division-by-var-zero" $
-   \(lhs :==: rhs) -> do
-      guard (rhs == 0)
-      (s, p) <- matchM polyView lhs
-      let n = lowestDegree p
-      guard (n > 0)
-      -- Quick fix to do some trivial steps for a linear equation, so that
-      -- buggy rules are recognized.
-      let eq = build polyView (s, raise (-n) p) :==: 0
-      eq : applyM coverUpPlus eq
-
----------------------------------------------------------
--- ABC formula misconceptions
-
-abcBuggyRules :: [Rule (OrList (Equation Expr))]
-abcBuggyRules = map (siblingOf abcFormula) [ minusB, twoA, minus4AC, oneSolution ]
-
-abcMisconception :: (String -> Rational -> Rational -> Rational -> [OrList (Equation Expr)])
-                 -> Transformation (OrList (Equation Expr))
-abcMisconception f = makeTransList $
-   oneDisjunct $ \(lhs :==: rhs) -> do
-      guard (rhs == 0)
-      (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs
-      f x a b c
-
-minusB :: Rule (OrList (Equation Expr))
-minusB = buggyRule $ makeRule "abc.minus-b" $
-   abcMisconception $ \x a b c -> do
-      let discr = sqrt (fromRational (b*b - 4 * a * c))
-          f (?) buggy =
-             let minus = if buggy then id else negate
-             in Var x :==: (minus (fromRational b) ? discr) / (2 * fromRational a)
-      [ toOrList [ f (+) True,  f (-) True  ],
-        toOrList [ f (+) False, f (-) True  ],
-        toOrList [ f (+) True,  f (-) False ]]
-
-twoA :: Rule (OrList (Equation Expr))
-twoA = buggyRule $ makeRule "abc.two-a" $
-   abcMisconception $ \x a b c -> do
-      let discr = sqrt (fromRational (b*b - 4 * a * c))
-          f (?) buggy =
-             let twice = if buggy then id else (2*)
-             in Var x :==: (-fromRational b ? discr) / twice (fromRational a)
-      [ toOrList [ f (+) True,  f (-) True  ],
-        toOrList [ f (+) False, f (-) True  ],
-        toOrList [ f (+) True,  f (-) False ]]
-
-minus4AC :: Rule (OrList (Equation Expr))
-minus4AC = buggyRule $ makeRule "abc.minus-4ac" $
-   abcMisconception $ \x a b c -> do
-      let discr (?) = sqrt (fromRational ((b*b) ? (4 * a * c)))
-          f (?) buggy =
-             let op = if buggy then (+) else (-)
-             in Var x :==: (-fromRational b ? discr op) / (2 * fromRational a)
-      [ toOrList [ f (+) True,  f (-) True  ],
-        toOrList [ f (+) False, f (-) True  ],
-        toOrList [ f (+) True,  f (-) False ]]
-
-oneSolution :: Rule (OrList (Equation Expr))
-oneSolution = buggyRule $ makeRule "abc.one-solution" $
-   abcMisconception $ \x a b c ->
-      let discr = sqrt (fromRational (b*b - 4 * a * c))
-          f (?) = Var x :==: (-fromRational b ? discr) / (2 * fromRational a)
-      in [ singleton $ f (+), singleton $ f (-) ]
− src/Domain/Math/Polynomial/Equivalence.hs 
@@ -1,277 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.Equivalence
-   ( linEq, quadrEqContext, highEqContext, simLogic, flipGT
-   , eqAfterSubstitution, intervalRelations
-   ) where
-
-import Common.Algebra.Boolean
-import Common.Context
-import Common.Rewriting
-import Common.Utils.Uniplate
-import Common.View
-import Control.Monad
-import Data.Maybe
-import Data.Ord
-import Domain.Logic.Formula hiding (Var)
-import Domain.Math.CleanUp
-import Domain.Math.Data.Interval
-import Domain.Math.Data.Polynomial hiding (eval)
-import Domain.Math.Data.Relation hiding (eval)
-import Domain.Math.Data.SquareRoot
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Views
-import Domain.Math.SquareRoot.Views
-import Prelude hiding ((^), sqrt)
-import qualified Data.Traversable as T
-import qualified Domain.Logic.Formula as Logic
-import qualified Domain.Logic.Generator as Logic
-
-relationInterval :: Ord a => RelationType -> a -> Interval a
-relationInterval relType =
-   case relType of
-      EqualTo              -> point
-      NotEqualTo           -> except
-      LessThan             -> lessThan
-      GreaterThan          -> greaterThan
-      LessThanOrEqualTo    -> lessThanOrEqualTo
-      GreaterThanOrEqualTo -> greaterThanOrEqualTo
-      Approximately        -> point -- i.e., equalTo
-
-intervalRelations :: Eq a => a -> Interval a -> Logic (Relation a)
-intervalRelations v = ors . map (ands . map Logic.Var . make) . segments
- where
-   make pair =
-      case pair of
-         (Unbounded, Unbounded)   -> []
-         (Unbounded, Including b) -> [v .<=. b]
-         (Unbounded, Excluding b) -> [v .<. b]
-         (Including a, Unbounded) -> [v .>=. a]
-         (Excluding a, Unbounded) -> [v .>. a]
-         (Including a, Including b)
-            | a == b    -> [v .==. a]
-            | otherwise -> [v .>=. a, v .<=. b]
-         (Including a, Excluding b) -> [v .>=. a, v .<. b]
-         (Excluding a, Including b) -> [v .>. a, v .<=. b]
-         (Excluding a, Excluding b) -> [v .>. a, v .<. b]
-
-logicInterval :: Ord a => Logic (Interval a) -> Interval a
-logicInterval =
-   foldLogic (id, implies, equivalent, intersect, union, complement, true, false)
-
------------------------------------------------------------
-
-linEq :: Relation Expr -> Relation Expr -> Bool
-linEq a b = fromMaybe False $ liftM2 (==) (linRel a) (linRel b)
-
-linRel :: Relation Expr -> Maybe (String, Interval Rational)
-linRel = linRelWith rationalView
-
-linRelWith :: (Ord a, Fractional a)
-           => View Expr a -> Relation Expr -> Maybe (String, Interval a)
-linRelWith v rel =
-   case match (linearViewWith v) (lhs - rhs) of
-      Nothing -> do
-         (s, p) <- match (polyViewWith v) (lhs - rhs)
-         guard (degree p == 0)
-         let list = case compare (coefficient 0 p) 0 of
-                       LT -> [LessThan, LessThanOrEqualTo]
-                       EQ -> [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo]
-                       GT -> [GreaterThan, GreaterThanOrEqualTo]
-         return (s, fromBool $ relationType rel `elem` list)
-      Just (s, a, b)
-         | a==0 ->
-              return (s, fromBool (b==0))
-         | otherwise -> do
-              let zero = -b/a
-                  tp = relationType $ (if a<0 then flipSides else id) rel
-              return (s, relationInterval tp zero)
- where
-   lhs = leftHandSide rel
-   rhs = rightHandSide rel
-
-newtype Q = Q (SquareRoot Rational) deriving (Show, Eq, Num, Fractional)
-
--- Use normal (numeric) ordering on square roots
-instance Ord Q where
-   Q a `compare` Q b = comparing f a b
-    where
-      f :: SquareRoot Rational -> Double
-      f = eval . fmap fromRational
-
-qView :: View (SquareRoot Rational) Q
-qView = makeView (return . Q) (\(Q a) -> a)
-
-quadrEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool
-quadrEqContext = eqContextWith (polyEq quadrRel)
-
-highEqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool
-highEqContext = eqContextWith (polyEq highRel)
-
-eqContextWith :: (Logic (Relation Expr) -> Logic (Relation Expr) -> Bool)
-              -> Context (Logic (Relation Expr))
-              -> Context (Logic (Relation Expr))
-              -> Bool
-eqContextWith eq a b = isJust $ do
-   termA <- fromContext a
-   termB <- fromContext b
-   guard $
-      case (ineqOnClipboard a, ineqOnClipboard b) of
-         (Just x,  Just y)  -> eq x y && eq termA termB
-         (Just x,  Nothing) -> eq (fmap toEq x) termA && eq x termB
-         (Nothing, Just y)  -> eq (fmap toEq y) termB && eq termA y
-         (Nothing, Nothing) -> eq termA termB
- where
-   toEq :: Relation Expr -> Relation Expr
-   toEq r = leftHandSide r .==. rightHandSide r
-
-ineqOnClipboard :: Context a -> Maybe (Logic (Relation Expr))
-ineqOnClipboard = evalCM $ const $ do
-   expr <- lookupClipboard "ineq"
-   fromExpr expr
-
-polyEq :: (Relation Expr -> Maybe (String, Interval Q)) -> Logic (Relation Expr) -> Logic (Relation Expr) -> Bool
-polyEq f p q = fromMaybe False $ do
-   xs <- T.mapM f p
-   ys <- T.mapM f q
-   let vs = map fst (varsLogic xs ++ varsLogic ys)
-   guard (null vs || all (==head vs) vs)
-   let ix = logicInterval (fmap snd xs)
-       iy = logicInterval (fmap snd ys)
-   if ix == iy then return True else return False
-
-cuPlus :: Relation Expr -> Maybe (Relation Expr)
-cuPlus rel = do
-   (a, b) <- match plusView (leftHandSide rel)
-   guard (hasNoVar b && hasNoVar (rightHandSide rel))
-   return $ constructor rel a (rightHandSide rel - b)
- `mplus` do
-   (a, b) <- match plusView (leftHandSide rel)
-   guard (hasNoVar a && hasNoVar (rightHandSide rel))
-   return $ constructor rel b (rightHandSide rel - a)
- `mplus` do
-   a <- isNegate (leftHandSide rel)
-   return $ constructor (flipSides rel) a (-rightHandSide rel)
-
-cuTimes :: Relation Expr -> Maybe (Relation Expr)
-cuTimes rel = do
-   (a, b) <- match timesView (leftHandSide rel)
-   r1 <- match rationalView a
-   r2 <- match rationalView (rightHandSide rel)
-   guard (r1 /= 0)
-   let make = if r1>0 then constructor rel else constructor (flipSides rel)
-       new   = make b (build rationalView (r2/r1))
-   return new
-
-cuPower :: Relation Expr -> Maybe (Logic (Relation Expr))
-cuPower rel = do
-   (a, b) <- isBinary powerSymbol (leftHandSide rel)
-   n <- match integerView b
-   guard (n > 0 && hasNoVar (rightHandSide rel))
-   let expr = cleanUpExpr (root (rightHandSide rel) (fromIntegral n))
-       new = constructor rel a expr
-       opp = constructor (flipSides rel) a (-expr)
-       rt  = relationType rel
-   return $ if odd n
-            then Logic.Var new
-            else if rt `elem` [LessThan, LessThanOrEqualTo]
-                 then Logic.Var new :&&: Logic.Var opp
-                 else Logic.Var new :||: Logic.Var opp
-
-highRel2 :: Logic (Relation Expr) -> Maybe (String, Interval Q)
-highRel2 p = do
-   xs <- T.mapM highRel p
-   let vs = map fst (varsLogic xs)
-   guard (null vs || all (==head vs) vs)
-   return (head vs, logicInterval (fmap snd xs))
-
-highRel :: Relation Expr -> Maybe (String, Interval Q)
-highRel rel = msum
-   [ cuTimes rel >>= highRel
-   , cuPower rel >>= highRel2
-   , cuPlus rel >>= highRel
-   , quadrRel rel
-   ]
-
-quadrRel :: Relation Expr -> Maybe (String, Interval Q)
-quadrRel rel =
-   case match (quadraticViewWith rationalView) (lhs - rhs) of
-      Nothing ->
-         linRelWith (squareRootViewWith rationalView >>> qView) rel
-      Just (s, xa, xb, xc) -> do
-         let (tp, a, b, c)
-                | xa<0 =
-                     (relationType (flipSides rel), -xa, -xb, -xc)
-                | otherwise =
-                     (relationType rel, xa, xb, xc)
-             discr = b*b - 4*a*c
-             pa = Q ((-fromRational b-sqrtRational discr) / (2 * fromRational a))
-             pb = Q ((-fromRational b+sqrtRational discr) / (2 * fromRational a))
-         guard (a/=0)
-         (\is -> Just (s, is)) $
-          case compare discr 0 of
-            LT -> fromBool $ tp `elem` [NotEqualTo, GreaterThan, GreaterThanOrEqualTo]
-            EQ | tp `elem` [EqualTo, Approximately, LessThanOrEqualTo] ->
-                    point pa
-               | tp == NotEqualTo           -> except pa
-               | tp == LessThan             -> false
-               | tp == GreaterThan          -> except pa
-               | tp == GreaterThanOrEqualTo -> true
-            GT | tp `elem` [EqualTo, Approximately] ->
-                    point pa <||> point pb
-               | tp == NotEqualTo ->
-                    except pa `intersect` except pb
-               | tp == LessThan ->
-                    open pa pb
-               | tp == LessThanOrEqualTo ->
-                    closed pa pb
-               | tp == GreaterThan ->
-                    lessThan pa <||> greaterThan pb
-               | tp == GreaterThanOrEqualTo ->
-                    lessThanOrEqualTo pa <||> greaterThanOrEqualTo pb
-            _ -> error "unknown case in quadrRel"
- where
-   lhs = leftHandSide rel
-   rhs = rightHandSide rel
-
-flipGT :: Relation a -> Relation a
-flipGT r
-   | relationType r == GreaterThan =
-        rightHandSide r .<. leftHandSide r
-   | relationType r == GreaterThanOrEqualTo =
-        rightHandSide r .<=. leftHandSide r
-   | otherwise = r
-
--- for similarity
-simLogic :: Ord a => (a -> a) -> Logic a -> Logic a -> Bool
-simLogic f p0 q0 = Logic.equalLogicACI (fmap f p0) (fmap f q0)
-
-eqAfterSubstitution :: (Functor f, Functor g)
-   => (f (g Expr) -> f (g Expr) -> Bool) -> Context (f (g Expr)) -> Context (f (g Expr)) -> Bool
-eqAfterSubstitution eq ca cb = fromMaybe False $ do
-   a <- fromContext ca
-   b <- fromContext cb
-   let f = maybe id (fmap . fmap . substitute) . substOnClipboard
-   return (f ca a `eq` f cb b)
-
-substitute :: (String, Expr) -> Expr -> Expr
-substitute (s, a) (Var b) | s==b = a
-substitute pair expr = descend (substitute pair) expr
-
-substOnClipboard :: Context a -> Maybe (String, Expr)
-substOnClipboard = evalCM $ const $ do
-   eq <- lookupClipboardG "subst"
-   case eq of
-      Var s :==: a -> return (s, a)
-      _            -> fail "not a substitution"
− src/Domain/Math/Polynomial/Examples.hs 
@@ -1,394 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Example exercises from the Digital Mathematics Environment (DWO)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.Examples
-   ( linearExamples, quadraticExamples, higherDegreeExamples
-   , factorizeExamples, expandExamples
-   , ineqLin1, ineqQuad1, ineqQuad2, extraIneqQuad, ineqHigh
-   ) where
-
-import Common.Exercise
-import Common.Rewriting
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Prelude hiding ((^))
-
-x :: Expr
-x = variable "x"
-
-linearExamples :: Examples (Equation Expr)
-linearExamples =
-   level Easy -- applet level 1
-      [ 5*x + 3   :==: 18
-      , 11*x - 12 :==: 21
-      , 19 - 3*x  :==: -5
-      , -12 + 5*x :==: 33
-      , 15 - 9*x  :==: 6
-      , 4*x + 18  :==: 0
-      , 11*x - 12 :==: -34
-      , -2*x - 3  :==: -4
-      , 6*x - 12  :==: 2
-      , -4*x - 13 :==: -11
-      ] ++
-   level Easy -- applet level 2
-      [ 6*x-2    :==: 2*x+14
-      , 3+6*x    :==: 3*x+24
-      , 5*x+7    :==: 2*x - 10
-      , 2*x-8    :==: 18 - x
-      , 4*x - 6  :==: 7*x - 14
-      , -1 -5*x  :==: 3*x - 20
-      , 4*x - 7  :==: -5*x - 24
-      , 4*x - 18 :==: 14 + 11*x
-      , 17       :==: 4 - 10*x
-      , -5*x + 6 :==: 2 - 3*x
-      ] ++
-   level Medium -- applet level 3
-      [ 4*(x-1)          :==: 11*x - 12
-      , 4*(x-4)          :==: 5*(2*x+1)
-      , 2*(5-3*x)        :==: 6-x
-      , 4*x - (x-2)      :==: 12 + 5*(x-1)
-      , -3*(x-2)         :==: 3*(x+4) - 7
-      , 3*(4*x-1) + 3    :==: 7*x - 14
-      , 4*(4*x - 1) - 2  :==: -3*x + 3*(2*x -5)
-      , 2*x - (3*x + 5)  :==: 10 + 5*(x-1)
-      , -5*(x+1)         :==: 9*(x+4)-5
-      , 18 - 2*(4*x + 2) :==: 7*x - 4*(4*x -2)
-      ] ++
-   level Medium -- applet level 4
-      [ (1/2)*x - 4            :==: 2*x + mixed 2 1 2
-      , (1/4)*x + (1/2)        :==: (5/2)*x + 2
-      , (1/4)*x - (3/4)        :==: 2*x + (1/2)
-      , -(1/2)*x + (3/4)       :==: (5/2)*x + 3
-      , -(1/2)*x + mixed 1 1 2 :==: 2*x - 5
-      , -(1/3)*x + (3/4)       :==: (1/4)*x + (1/6)
-      , (3/4)*x - (1/3)        :==: (2/3)*x - (3/4)
-      , (2/5)*x - (1/4)        :==: (1/2)*x + (3/4)
-      , (2/3)*x - 2            :==: (1/5)*x - (3/5)
-      , (-mixed 1 2 5)*x + mixed 3 1 2 :==: (3/5)*x + (9/10)
-      ] ++
-   level Medium -- applet level 4
-      [ (1/4)*(x-3)         :==: (1/2)*x - 4
-      , (x+3)/2             :==: 5*((1/2)*x + mixed 1 1 2)
-      , (1/2)*(7-(2/3)*x)   :==: 2 + (1/9)*x
-      , (3/4)*x - (x-1)     :==: 3 + mixed 2 1 2*(x-1)
-      , -(5/4)*(x-7)        :==: (3/4)*(x+2) - mixed 4 1 2
-      , 3*((1/5)*x - 1) + 5 :==: 7*x - 14
-      , ((5*x - 1) / 6) - 2 :==: -4*x + (3*x - 6)/2
-      , 2*x - ((2*x+2)/5)   :==: 12 + (x-1)/6
-      , (-3*(x+2))/6        :==: 9*((2/3)*x + (1/3)) - (5/3)
-      , 1 - ((4*x + 2)/3)   :==: 3*x - ((5*x - 1) / 4)
-      ]
-
-quadraticExamples :: Examples (Equation Expr)
-quadraticExamples =
-   level Easy -- applet level 1
-      [ x^2            :==: 2
-      , x^2+3          :==: 52
-      , x^2-7          :==: 0
-      , 9*x^2 - 6      :==: 75
-      , 32 - 2*x^2     :==: 14
-      , 2*(x^2 - 3)    :==: 12
-      , (1/4)*x^2 + 12 :==: 16
-      , (x-1)^2        :==: 100
-      , 14 - 2*x^2     :==: 6
-      , (1/4)*(17-x^2) :==: 2
-      ] ++
-   level Medium -- applet level 2
-      [ (x-7)^2 + 3      :==: 11
-      , (6-2*x)^2        :==: 81
-      , (1/2)*(x+9)^2    :==: 4
-      , (3-x^2)/10       :==: 2
-      , 5*x^2 + 3*x      :==: 3*x + 2
-      , 11 - (2*x + 1)^2 :==: 5
-      , (6*x - 3)^2 + 6  :==: 12
-      , (7+2*x)^2        :==: 7
-      , 4 - (x^2 / 10)   :==: 6
-      , 12 - (2*x + 3)^2 :==: 6
-      ] ++
-   level Medium -- applet level 3
-      [ x^2           :==: 5*x
-      , x^2 - 6*x     :==: 0
-      , 6*x + x^2     :==: 0
-      , x*(x+4)       :==: 0
-      , x*(2*x-4)     :==: 0
-      , 3*x^2         :==: 6*x
-      , 3*x           :==: 2*x^2
-      , x*(1-6*x)     :==: 0
-      , (x+5)*(x-8)   :==: 0
-      , (3*x-1)*(x+3) :==: 0
-      ] ++
-   level Medium -- applet level 4
-      [ x^2-2*x     :==: 3
-      , x^2+12*x+20 :==: 0
-      , x^2-x       :==: 30
-      , x*(x+2)     :==: 8
-      , x*(x-3)     :==: 4
-      , 2*x+15      :==: x^2
-      , 4*x         :==: 12 - x^2
-      , x^2         :==: 15 - 8*x
-      , x^2-9*x+18  :==: 0
-      , x^2+14*x+24 :==: 0
-      ] ++
-   level Difficult -- applet level 5
-      [ (3*x+5)^2+(x-5)^2 :==: 40
-      , 4*(10-x^2)        :==: -2*x*(2*x + 10)
-      , x*(x+12)          :==: 2*x^2
-      , 3*(x-2)*(x+6)     :==: 12*x
-      , 8*x^2+4*x-24      :==: (x+3)*(x-8)
-      , 3*x^2 - 11        :==: (3+2*x)^2
-      , 2*x*(x-3)-3       :==: (x+2)*(x+6)
-      , 12*(x^2-3*x)+8    :==: 56
-      , 4*x^2-6*x         :==: x^2+9
-      , (x+1)*(x-5)       :==: (x-2)*(x-3)
-      ] ++
-   level Difficult -- applet level 6
-      [ x^2+4*x-4   :==: 0
-      , x^2-6*x     :==: 4
-      , x^2-12*x+34 :==: 0
-      , 2*x^2+4*x-8 :==: 0
-      , (x-4)*(x-1) :==: 11
-      , (x-(7/2))^2 :==: 2*(x+4)
-      , x^2-3*x     :==: 3*(x-2)
-      , (4-x)*(1-x) :==: 3*x
-      , 2*x^2       :==: x*(x+2)+7
-      , (1-x)^2     :==: x+2
-      ]
-
-factorizeExamples :: Examples Expr
-factorizeExamples =
-   level Easy
-      [ -- (buiten haakjes brengen)
-       4*x^2 -4*x
-      , 36*x^2+30*x
-      , -6*x^2-18*x
-      , 14*x^2-10*x
-        --(product-som methode)
-      , x^2+11*x+24
-      , x^2-8*x+15
-      , x^2-x-2
-      , x^2-11*x+28
-      ]
-
-expandExamples :: Examples Expr
-expandExamples = level Easy
-   [ 5*(x+1), -3*(x-3), (x-1)*7
-   , 4*(3-2*x), (x+1)*(x-3), (x+1)*(1-x)
-   , x*(x-1), 3*(x-2)*2*x
-   , (x-1)^2, (x+1)^2, (x-1)^2*(x+1)
-   , (x+1)^3, (x-1)^3*x, (x-1)*(x+3)*(x-5)
-   , x/2, (x+1)/2, (x+1)/2 + (x+2)/3, ((x+1)/2) * ((x+2)/3)
-   ]
-
---------------------------------------------------------------------
--- Algemene applet
-
-higherDegreeExamples :: Examples (Equation Expr)
-higherDegreeExamples =
-   -- Havo B hoofdstuk 3, Hogeregraadsvgl.
-   level Easy
-      [ -- level 1
-        (1/3)*x^3 :==: 9
-      , x^5 - 12 :==: 20
-      , 1 - 8*x^3 :==: -124
-      , 16 - 32*x^5 :==: - 227
-        -- level 2
-      , 3*x^4 :==: 48
-      , (1/9)*x^6 + 12 :==: 93
-      , 39 - 8*x^2 :==: 21
-      , (1/2)*x^4 - 13 :==: 27.5
-        -- level 3
-      , 3*(2*x-1)^3 + 11 :==: 659
-      , 0.5*(3*x-4)^5 + 7 :==: 23
-      , 2*(0.5*x+3)^7 - 11 :==: -9
-      , 5*(1-4*x)^3 + 4 :==: -621
-        -- level 4
-      , 3*(2*x + 5)^2 + 9 :==: 21
-      , 2*(3*x-6)^6 - 24 :==: -22
-      , -2*(4*x-5)^4 + 192 :==: -8000
-      , (3-2*x)^4 + 23 :==: 279
-      ] ++
-   level Easy
-      [ -- level 1
-        2*x^3 + 9 :==: 19
-      , 4*x^5 - 17 :==: 27
-      , 3*x^7 + 9 :==: 62
-      , 5*x^3 - 1 :==: 9
-      , 6 - 5*x^3 :==: 76
-      , 11 - 7*x^5 :==: 53
-      , 4 - 0.2*x^7 :==: 9
-      , 18 - 11*x^7 :==: 62
-        -- level 2
-      , 0.5*x^4 + 5 :==: 12
-      , 5*x^6 - 37 :==: 68
-      , 4*x^8 - 19 :==: 9
-      , 5*x^6 + 7 :==: 97
-      , 18 - 7*x^4 :==: -38
-      , 3 + (1/3)*x^6 :==: 7
-      , 1 - (1/9)*x^8 :==: -4
-      , 47 + 15*x^8 :==: 77
-        -- level 3
-      , 18*x^8 - 11 :==: 7
-      , (1/4)*x^6 + 14 :==: 30
-      , 5*x^4 + 67 :==: 472
-      , 5*x^4 - 1 :==: 4
-      , (1/8)*x^7 + 24 :==: 40
-      , 0.2*x^3 + 27 :==: 52
-      , 32*x^3 + 18 :==: 22
-      , 4*x^3 - 8 :==: 100
-        -- level 4
-      , 14 -2*x^3 :==: 700
-      , 4-3*x^5 :==: 100
-      , 14 - 11*x^7 :==: 25
-      , 1 - 3*x^5 :==: 97
-      , 3*(x-2)^4 + 7 :==: 37
-      , 6 - (2*x-1)^3 :==: 1
-      , (1/3)*(x+5)^6 - 4 :==: 3
-      , 6 - 0.5*(x-1)^5 :==: 10
-        -- level 5
-      , (1/2)*(3*x-1)^4 :==: 8
-      , 100-(1/3)*(4*x-3)^5 :==: 19
-      , 4*(0.5*x+2)^6 + 5 :==: 9
-      , 3*(2*x + 7)^3 + 11 :==: 35
-      ] ++
-   level Medium
-      -- (Ontbinden applet)
-      [ -- level 1
-        x^3 - 5*x^2 + 4*x :==: 0
-      , x^3 :==: 3*x^2 + 10*x
-      , 14*x :==: x^3 + 5*x^2
-      , (1/2)*x^3 + 3*x^2 + 4*x :==: 0
-      , x^3 + 6*x^2 + 9*x :==: 0
-      , 5*x^2 :==: x^3 + 6*x
-      , x^3 - 5*x^2 :==: 6*x
-      , x^3 :==: 4*x^2 + 12*x
-        -- level 2
-      , x^4 + 36 :==: 13*x^2
-      , x^4 - 9*x^2 + 20 :==: 0
-      , x^4 :==: 2*x^2 + 3
-      , x^4 + 2*x^2 :==: 24
-      , 7*x^2 + 18 :==: x^4
-      , x^4 :==: x^2 + 12
-      , 29*x^2 :==: x^4 + 100
-      , 2*x^4 + 2*x^2 :==: 12
-        -- (abc-form applet)
-        -- level 1
-      , 4*x^4 + 4 :==: 17*x^2
-      , 16*x^4 + 225 :==: 136*x^2
-      , 2*x^4 - 15*x^2 + 25 :==: 0
-      , 9*x^4 - 28*x^2 + 3 :==: 0
-      , 3*x^4 - 14*x^2 - 5 :==: 0
-      , 2*x^4 :==: x^2 + 3
-      , 9*x^4 + 14*x^2 :==: 8
-      , 4*x^4 - 29*x^2 - 24 :==: 0
-        -- level 2
-      , 8*x^6 - 9*x^3 + 1 :==: 0
-      , 27*x^6 + 8 :==: 217*x^3
-      , 2*x^6 + x^3 - 1 :==: 0
-      , 8*x^6 + 31*x^3 :==: 4
-      , 3*x^6 - 80*x^3 - 27 :==: 0
-      , 5*x^6 :==: 39*x^3 + 8
-      , 7*x^6 + 8*x^3 + 1 :==: 0
-      , 4*x^6 + 2 :==: -9*x^3
-      ] ++
-   level Difficult
-      [ x^3 + x^2 :==: 0
-      , x^3 - 5*x :==: 0
-      , x^3 - 11*x^2 + 18*x :==: 0
-      , x^3 + 36*x :==: 13*x^2
-      , x^3 + 2*x^2 :==: 24*x
-      , 7*x^3 :==: 8*x^2
-      , x^4 :==: 9*x^2
-      , 64*x^7 :==: x^5
-      , x^3 - 4*x^2 - 9*x :==: 0
-      , (x-1)*(x^3 - 6*x) :==: 3*x^3 - 3*x^2
-      ]
-
---------------------------------------------------------------------
--- Havo applets
-
--- Havo B Voorkennis: lineaire ongelijkheden
-ineqLin1 :: [[Inequality Expr]]
-ineqLin1 =
-   let a = Var "a" in
-   [ [ 7*x - 12 :<: 5*x + 3
-     , 4*(x-3) :>: 3*(x-4)
-     , 6*(a+1) :<: 3*(a-2)+4
-     , 5 - 2*(a-3) :>: 5*(3-a)
-     ]
-   , [ 4*x+5 :<: 5*x - 3
-     , (1/3)*x+10 :>: (1/2)*x
-     , 3*x+1 :<: 7*x + 5
-     , x+6 :>: 2 - (3/4)*x
-     ]
-   , [ 5*(x-1) :<: 7*x - 1
-     , -3*(4*x-1) :>: 2-(x-1)
-     , 2*(3*x-1) :<: 5-(2-9*x)
-     , 2*(x-1)-3*(x-2) :>: 6
-     ]
-   ]
-
--- Havo B Voorkennis: kwadratische ongelijkheden
--- (door eerst gelijkheid op te lossen)
--- (level 2 uit Hoofdstuk 3)
-ineqQuad1 :: [[Inequality Expr]]
-ineqQuad1 =
-   [ [ x^2 +3*x-4 :<: 0
-     , x^2-4*x-12 :>: 0
-     , -x^2 - 4*x + 5 :<: 0
-     , -x^2 + 3*x + 18 :>: 0
-     , (1/2)*x^2 - 3*x - 8 :<: 0
-     , -2*x^2 + 10*x :>: 0
-     ]
-   , [ x^2 + 9*x :<: 3*x - 5
-     , x^2 - x :>: 12
-     , x^2 - 4.5*x :<: 7-3*x
-     , 2*x^2 - 10*x :>: x^2 - 3*x
-     , 4*x^2 + 6*x :<: x^2 + 3*x + 18
-     , 2*x^2 + 6*x - 10 :>: x^2 + 2*x - 5
-     ]
-   ]
-
--- Havo B hoofdstuk 3, hogeregraadsongelijkheid exact
--- (door eerst gelijkheid op te lossen)
-ineqHigh :: [Inequality Expr]
-ineqHigh =
-   [ 2*x^3 :>: 54
-   , -0.5*x^4 :<: -40.5
-   , 1 - 2*x^5 :<: -485
-   , (2*x-3)^4 :>: 1
-   , -(0.5*x+2)^3 :<: -1
-   , 0.25*(0.5*x-2)^4 :<: 4
-   ]
-
---------------------------------------------------------------------
--- VWO A/C applets
-
--- hoofdstuk 2
-ineqQuad2 :: [Inequality Expr]
-ineqQuad2 =
-   [ x^2 + 9*x :<: 3*x - 5
-   , x^2 - x :>: 12
-   , x^2 - 4.5*x :<: 7 - 3*x
-   , 2*x^2 - 10*x :>: x^2 - 3*x
-   , 4*x^2 + 6*x :<: x^2 + 3*x + 18
-   , 2*x^2 + 6*x - 10 :>: x^2 +2*x - 5
-   ]
-
---------------------------------------------------------------------
--- Extra test cases
-
-extraIneqQuad :: [Inequality Expr]
-extraIneqQuad =
-   [ x^2-x-7 :>: -100, x^2-x-7 :<: -100, x^2 :<: x^2, x :>=: x
-   , x^2 :>=: 0, x^2 :>: 0, x^2 :<: 0, x^2 :<=: 0
-   ]
− src/Domain/Math/Polynomial/Exercises.hs 
@@ -1,220 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.Exercises
-   ( linearExercise, linearMixedExercise
-   , quadraticExercise, quadraticNoABCExercise
-   , quadraticWithApproximation
-   , higherDegreeExercise
-   , findFactorsExercise, expandExercise
-   ) where
-
-import Common.Library
-import Control.Monad
-import Data.Function
-import Data.Maybe
-import Domain.Math.Approximation
-import Domain.Math.CleanUp
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules
-import Domain.Math.Equation.Views
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.BuggyRules
-import Domain.Math.Polynomial.Equivalence
-import Domain.Math.Polynomial.Examples
-import Domain.Math.Polynomial.Rules
-import Domain.Math.Polynomial.Strategies
-import Domain.Math.Polynomial.Views
-import qualified Data.Foldable as F
-import qualified Data.Traversable as T
-
-------------------------------------------------------------
--- Exercises
-
-linearExercise :: Exercise (Equation Expr)
-linearExercise = makeExercise
-   { exerciseId   = describe "solve a linear equation" $
-                       newId "algebra.equations.linear"
-   , status       = Stable
-   , parser       = parseEqExpr
-   , similarity   = withoutContext (viewEquivalent (traverseView cleanUpACView))
-   , equivalence  = withoutContext (viewEquivalent linearEquationView)
-   , suitable     = predicateView linearEquationView
-   , ready        = predicateView (equationSolvedWith mixedFractionNF)
-                    <||> predicateView (equationSolvedWith rationalNF)
-                    <||> predicateView (equationSolvedWith doubleNF)
-   , extraRules   = map use buggyRulesEquation ++
-                    map use buggyRulesExpr
-   , ruleOrdering = ruleOrderingWithId
-                       [ getId coverUpTimes, getId flipEquation
-                       , getId removeDivision
-                       ]
-   , strategy     = linearStrategy
-   , navigation   = termNavigator
-   , examples     = linearExamples
-   }
-
-linearMixedExercise :: Exercise (Equation Expr)
-linearMixedExercise = linearExercise
-   { exerciseId   = describe "solve a linear equation with mixed fractions" $
-                       newId "algebra.equations.linear.mixed"
-   , status       = Provisional
-   , ready        = predicateView (equationSolvedWith mixedFractionNF)
-   , strategy     = linearMixedStrategy
-   }
-
-quadraticExercise :: Exercise (OrList (Relation Expr))
-quadraticExercise = makeExercise
-   { exerciseId   = describe "solve a quadratic equation" $
-                       newId "algebra.equations.quadratic"
-   , status       = Stable
-   , parser       = parseOrsEqExpr
-                       >>> right (build (traverseView equationView))
-   , similarity   = withoutContext (viewEquivalent (traverseView (traverseView cleanUpView)))
-   , equivalence  = withoutContext (equivalentRelation (viewEquivalent quadraticEquationsView))
-   , suitable     = predicateView (traverseView equationView >>> quadraticEquationsView)
-   , ready        = predicateView relationsSolvedForm
-   , extraRules   = map use abcBuggyRules ++ buggyQuadratic ++
-                    map use buggyRulesEquation ++ map use buggyRulesExpr
-   , ruleOrdering = ruleOrderingWithId $
-                       quadraticRuleOrder ++ [getId buggySquareMultiplication]
-   , strategy     = quadraticStrategy
-   , navigation   = termNavigator
-   , examples     = mapExamples (singleton . build equationView) quadraticExamples
-   }
-
-higherDegreeExercise :: Exercise (OrList (Relation Expr))
-higherDegreeExercise = makeExercise
-   { exerciseId    = describe "solve an equation (higher degree)" $
-                        newId "algebra.equations.polynomial"
-   , status        = Stable
-   , parser        = parser quadraticExercise
-   , similarity    = withoutContext (viewEquivalent (traverseView (traverseView cleanUpView)))
-   , equivalence   = eqAfterSubstitution $
-                        equivalentRelation (viewEquivalent higherDegreeEquationsView)
-   , suitable      = predicateView (traverseView equationView >>> higherDegreeEquationsView)
-   , ready         = predicateView relationsSolvedForm
-   , extraRules    = map use abcBuggyRules ++ buggyQuadratic ++
-                     map use buggyRulesEquation ++ map use buggyRulesExpr
-   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder
-   , strategy      = higherDegreeStrategy
-   , navigation    = termNavigator
-   , examples      = mapExamples (singleton . build equationView) higherDegreeExamples
-   }
-
-quadraticNoABCExercise :: Exercise (OrList (Relation Expr))
-quadraticNoABCExercise = quadraticExercise
-   { exerciseId   = describe "solve a quadratic equation without abc-formula" $
-                       newId "algebra.equations.quadratic.no-abc"
-   , status       = Provisional
-   , strategy     = configure cfg quadraticStrategy
-   }
- where
-   cfg = [ (byName prepareSplitSquare, Reinsert)
-         , (byName bringAToOne, Reinsert)
-         , (byName (newId "abc form"), Remove)
-         , (byName simplerPolynomial, Remove)
-         ]
-
-quadraticWithApproximation :: Exercise (OrList (Relation Expr))
-quadraticWithApproximation = quadraticExercise
-   { exerciseId   = describe "solve a quadratic equation with approximation" $
-                       newId "algebra.equations.quadratic.approximate"
-   , status        = Provisional
-   , parser       = parseOrsRelExpr
-   , strategy     = configure cfg quadraticStrategy
-   , equivalence  = withoutContext equivalentApprox
-   }
- where
-   cfg = [ (byName (newId "approximate result"), Reinsert)
-         , (byName (newId "square root simplification"), Remove)
-         ]
-
-findFactorsExercise :: Exercise Expr
-findFactorsExercise = makeExercise
-   { exerciseId   = describe "factorize the expression" $
-                       newId "algebra.manipulation.polynomial.factor"
-   , status       = Provisional
-   , parser       = parseExpr
-   , similarity   = withoutContext ((==) `on` cleanUpExpr)
-   , equivalence  = withoutContext (viewEquivalent (polyViewWith rationalView))
-   , ready        = predicateView linearFactorsView
-   , ruleOrdering = ruleOrderingWithId quadraticRuleOrder
-   , strategy     = findFactorsStrategy
-   , navigation   = termNavigator
-   , extraRules   = map liftToContext buggyRulesExpr
-   , examples     = factorizeExamples
-   }
-
-expandExercise :: Exercise Expr
-expandExercise = makeExercise
-   { exerciseId   = describe "expand an expression to polynomial normal form" $
-                       newId "algebra.manipulation.polynomial.expand"
-   , status       = Provisional
-   , parser       = parseExpr
-   , similarity   = withoutContext ((==) `on` cleanUpExpr)
-   , equivalence  = withoutContext (viewEquivalent (polyViewWith rationalView))
-   , ready        = predicateView (polyNormalForm rationalView)
-   , ruleOrdering = ruleOrderingWithId (getId fractionProduct:quadraticRuleOrder)
-   , strategy     = expandStrategy
-   , navigation   = termNavigator
-   , extraRules   = map liftToContext buggyRulesExpr
-   , examples     = expandExamples
-   }
-
-linearFactorsView :: View Expr (Bool, [(String, Expr, Expr)])
-linearFactorsView = toView productView >>> second (listView myLinearView)
- where
-   myLinearView :: View Expr (String, Expr, Expr)
-   myLinearView = makeView f (build linearView)
-
-   f expr = do
-      triple@(_, e1, e2) <- match linearView expr
-      a <- match integerView e1
-      b <- match integerView e2
-      guard (a > 0 && gcd a b == 1) -- gcd 0 0 is undefined
-      return triple
-    `mplus` do
-      guard (expr `belongsTo` rationalView)
-      return ("x", 0, expr)
-
---------------------------------------------
--- Equality
-
-equivalentApprox :: OrList (Relation Expr) -> OrList (Relation Expr) -> Bool
-equivalentApprox a b
-   | hasApprox a || hasApprox b =
-        let norm = liftM ( simplify orSetView
-                         . fmap (fmap (acExpr . cleanUpExpr) . toApprox)
-                         . simplify quadraticEquationsView
-                         ) . T.mapM toEq
-        in fromMaybe False $ liftM2 (==) (norm a) (norm b)
-   | otherwise =
-        equivalentRelation (viewEquivalent quadraticEquationsView) a b
- where
-   hasApprox = F.any isApproximately
-   isApproximately = (==Approximately) . relationType
-   toEq rel | relationType rel `elem` [EqualTo, Approximately] =
-      Just (leftHandSide rel :==: rightHandSide rel)
-            | otherwise = Nothing
-
-toApprox :: Equation Expr -> Relation Expr
-toApprox (a :==: b) = f a .~=. f b
- where
-   f x = maybe x (fromDouble . precision 4) (match doubleView x)
-
-equivalentRelation :: (OrList (Equation a) -> OrList (Equation a) -> Bool) -> OrList (Relation a) -> OrList (Relation a) -> Bool
-equivalentRelation f ra rb = fromMaybe False $ do
-   a <- T.mapM (match equationView) ra
-   b <- T.mapM (match equationView) rb
-   return (f a b)
− src/Domain/Math/Polynomial/Generators.hs 
@@ -1,63 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.Generators
-   ( polynomialGen, polynomialDegreeGen
-   , cubicGen, quadraticGen, linearGen
-   ) where
-
-import Control.Monad
-import Domain.Math.Expr
-import Domain.Math.Numeric.Generators
-import Prelude hiding ((^))
-import Test.QuickCheck
-
-polynomialGen :: Int -> Gen Expr
-polynomialGen n = do
-   d <- choose (0, n `div` 5)
-   polynomialDegreeGen d n
-
--- Random polynomial generator for (exactly) degree d
--- No division by zero
-polynomialDegreeGen :: Int -> Int -> Gen Expr
-polynomialDegreeGen d n
-   | d==0         = ratGen
-   | n==0 && d==1 = return (Var "x")
-   | n==0         = return (Var "x" ^ fromIntegral d)
-   | otherwise    = oneof $
-        [ timesGen, plusGen
-        , liftM2 (:/:) (rec d) ratGenNZ
-        ] ++ [ powerGen | d > 1 ]
- where
-   rec i = polynomialDegreeGen i (n `div` 2)
-   plusGen = do
-      d1 <- choose (0, d)
-      a <- rec d1
-      b <- rec d
-      elements [a :+: b, b :+: a, a :-: b, b :-: a, Negate b]
-   timesGen = do
-      d1 <- choose (0, d)
-      a  <- rec d1
-      b  <- rec (d-d1)
-      return (a :*: b)
-   powerGen = do
-      i <- elements [ i | i <- [2..d], d `mod` i == 0 ]
-      a <- rec (d `div` i)
-      return (a ^ fromIntegral i)
-
-cubicGen, quadraticGen, linearGen :: Int -> Gen Expr
-cubicGen     = polynomialDegreeGen 3
-quadraticGen = polynomialDegreeGen 2
-linearGen    = polynomialDegreeGen 1
-
-ratGen, ratGenNZ :: Gen Expr
-ratGen   = sized ratioExprGen
-ratGenNZ = sized ratioExprGenNonZero
− src/Domain/Math/Polynomial/IneqExercises.hs 
@@ -1,306 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.IneqExercises
-   ( ineqLinearExercise, ineqQuadraticExercise, ineqHigherDegreeExercise
-   ) where
-
-import Common.Library hiding (isEmpty)
-import Common.Utils.Uniplate (descend)
-import Control.Monad
-import Data.Foldable (toList)
-import Data.Function
-import Data.List
-import Data.Maybe (fromMaybe)
-import Domain.Logic.Formula (Logic((:||:), (:&&:)), catLogic)
-import Domain.Math.CleanUp
-import Domain.Math.Data.Interval
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus)
-import Domain.Math.Equation.Views
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Equivalence
-import Domain.Math.Polynomial.Examples
-import Domain.Math.Polynomial.Rules
-import Domain.Math.Polynomial.Strategies
-import Domain.Math.SquareRoot.Views
-import qualified Domain.Logic.Formula as Logic
-import qualified Domain.Logic.Views as Logic
-
-ineqLinearExercise :: Exercise (Relation Expr)
-ineqLinearExercise = makeExercise
-   { exerciseId   = describe "solve a linear inequation" $
-                       newId "algebra.inequalities.linear"
-   , status       = Provisional
-   , parser       = parseRelExpr
-   , ready        = predicateView relationSolvedForm
-   , equivalence  = withoutContext linEq
-   , similarity   = withoutContext (viewEquivalent (traverseView cleanUpView))
-   , strategy     = ineqLinear
-   , navigation   = termNavigator
-   , examples     = let x = Var "x"
-                        extra = (x-12) / (-2) :>: (x+3)/3
-                    in level Medium $
-                       map (build inequalityView) (concat ineqLin1 ++ [extra])
-   }
-
-ineqQuadraticExercise :: Exercise (Logic (Relation Expr))
-ineqQuadraticExercise = makeExercise
-   { exerciseId    = describe "solve a quadratic inequation" $
-                        newId "algebra.inequalities.quadratic"
-   , status        = Provisional
-   , parser        = parseLogicRelExpr
-   , prettyPrinter = showLogicRelation
-   , ready         = predicateView relationsSolvedForm
-   , equivalence   = quadrEqContext
-   , similarity    = simIneqContext
-   , strategy      = ineqQuadratic
-   , navigation    = termNavigator
-   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder
-   , examples      = level Medium $
-                     map (Logic.Var . build inequalityView)
-                         (concat $ ineqQuad1 ++ [ineqQuad2, extraIneqQuad])
-   }
-
-ineqHigherDegreeExercise :: Exercise (Logic (Relation Expr))
-ineqHigherDegreeExercise = makeExercise
-   { exerciseId    = describe "solve an inequation of higher degree" $
-                        newId "algebra.inequalities.polynomial"
-   , status        = Provisional
-   , parser        = parseLogicRelExpr
-   , prettyPrinter = showLogicRelation
-   , ready         = predicateView relationsSolvedForm
-   , equivalence   = highEqContext
-   , similarity    = simIneqContext
-   , strategy      = ineqHigherDegree
-   , navigation    = termNavigator
-   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder
-   , examples      = level Medium $ map (Logic.Var . build inequalityView) ineqHigh
-   }
-
-ineq :: String
-ineq = "algebra.inequalities"
-
-simIneqContext :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool
-simIneqContext a b =
-   sameClipboard a b &&
-   withoutContext (simLogic (fmap cleanUpExpr . flipGT)) a b
- where
-   sameClipboard = (==) `on` evalCM (const (lookupClipboard "ineq"))
-
---inEquation <- lookupClipboard "ineq" >>= fromExpr
-
-showLogicRelation :: (Eq a, Show a) => Logic (Relation a) -> String
-showLogicRelation logic =
-   case logic of
-      Logic.T     -> "true"
-      Logic.F     -> "false"
-      Logic.Var a -> show a
-      p :||: q    -> showLogicRelation p ++ " or " ++ showLogicRelation q
-      p :&&: q    -> case match betweenView logic of
-                        Just (x, o1, y, o2, z) ->
-                           let f b = if b then "<=" else "<"
-                           in unwords [show x, f o1, show y, f o2, show z]
-                        _ -> showLogicRelation p ++ " and " ++ showLogicRelation q
-      _           -> show logic
-
-betweenView :: Eq a => View (Logic (Relation a)) (a, Bool, a, Bool, a)
-betweenView = makeView f h
- where
-   f (Logic.Var r1 :&&: Logic.Var r2) = do
-      ineq1 <- match inequalityView r1
-      ineq2 <- match inequalityView r2
-      let g (a :>=: b) = b :<=: a
-          g (a :>:  b) = b :<:  a
-          g e          = e
-      make (g ineq1) (g ineq2)
-   f _ = Nothing
-
-   make a b
-      | la == rb && ra /= lb = make b a
-      | ra == lb =
-           Just (la, op a, ra, op b, rb)
-      | otherwise = Nothing
-    where
-      (la, ra) = (leftHandSide a, rightHandSide a)
-      (lb, rb) = (leftHandSide b, rightHandSide b)
-      op (_ :<=: _) = True
-      op _          = False
-
-   h (x, o1, y, o2, z) =
-      let g b = if b then (.<=.) else (.<.)
-      in Logic.Var (g o1 x y) :&&: Logic.Var (g o2 y z)
-
-ineqLinear :: LabeledStrategy (Context (Relation Expr))
-ineqLinear = cleanUpStrategyAfter (applyTop (fmap cleanUpSimple)) ineqLinearG
-
-ineqLinearG :: IsTerm a => LabeledStrategy (Context a)
-ineqLinearG = label "Linear inequation" $
-   label "Phase 1" (repeatS
-       (  use removeDivision
-      <|> multi (showId distributeTimes)
-             (somewhere (useC parentNotNegCheck <*> use distributeTimes))
-      <|> multi (showId merge) (once (use merge))
-       ))
-   <*>
-   label "Phase 2"
-       (  try (use varToLeft)
-      <*> try coverUpPlus
-      <*> try (use flipSign)
-      <*> try (use coverUpTimesPositive)
-       )
-
--- helper strategy (todo: fix needed, because the original rules do not
--- work on relations)
-coverUpPlus :: IsTerm a => Strategy (Context a)
-coverUpPlus = alternatives (map (use . ($ oneVar)) coverUps)
- where
-   coverUps :: [ConfigCoverUp -> Rule (Relation Expr)]
-   coverUps =
-      [ coverUpBinaryRule "plus" (commOp . isPlus) (-)
-      , coverUpBinaryRule "minus-left" isMinus (+)
-      , coverUpBinaryRule "minus-right" (flipOp . isMinus) (flip (-))
-      ]
-
-coverUpTimesPositive :: Rule (Relation Expr)
-coverUpTimesPositive = coverUpBinaryRule "times-positive" (commOp . m) (/) configCoverUp
- where
-   m expr = do
-      (a, b) <- matchM timesView expr
-      r <- matchM rationalView a
-      guard (r>0)
-      return (a, b)
-
-flipSign :: Rule (Relation Expr)
-flipSign = describe "Flip sign of inequality" $
-   makeSimpleRule (ineq, "flip-sign") $ \r -> do
-   let lhs = leftHandSide r
-       rhs = rightHandSide r
-   guard (isNegative lhs)
-   return $ constructor (flipSides r) (neg lhs) (neg rhs)
- where
-   isNegative (Negate _) = True
-   isNegative expr =
-      maybe False fst (match productView expr)
-
-ineqQuadratic :: LabeledStrategy (Context (Logic (Relation Expr)))
-ineqQuadratic = cleanUpStrategyAfter (applyTop cleanUpLogicRelation) $
-   label "Quadratic inequality" $
-      use trivialRelation
-       |> try (useC turnIntoEquation)
-      <*> quadraticStrategyG
-      <*> useC solutionInequation
-
-ineqHigherDegree :: LabeledStrategy (Context (Logic (Relation Expr)))
-ineqHigherDegree = cleanUpStrategyAfter (applyTop cleanUpLogicRelation) $
-   label "Inequality of a higher degree" $
-      use trivialRelation
-       |> try (useC turnIntoEquation)
-      <*> higherDegreeStrategyG
-      <*> useC solutionInequation
-
--- First, cleanup expression. Then, cleanup equations only (there is an
--- explicit rule for the other relations). Finally, simplify the logical
--- proposition (including impotency or).
-cleanUpLogicRelation :: Logic (Relation Expr) -> Logic (Relation Expr)
-cleanUpLogicRelation =
-   let f a | relationType a == EqualTo = build orListView (cleanUpRelation a)
-           | otherwise                 = Logic.Var a
-   in simplifyWith noDuplicates orListView . Logic.simplify
-    . catLogic . fmap (f . fmap cleanUpExpr)
-
-trivialRelation :: Rule (OrList (Relation Expr))
-trivialRelation =
-   makeSimpleRule (ineq, "trivial") $ oneDisjunct $ \a -> do
-      let new = cleanUpRelation a
-      guard (isTrue new || isFalse new)
-      return new
-
-turnIntoEquation :: Rule (Context (Relation Expr))
-turnIntoEquation = describe "Turn into equation" $
-   makeSimpleRule (ineq, "to-equation") $ withCM $ \r -> do
-   guard (relationType r `elem` ineqTypes)
-   addToClipboard "ineq" (toExpr r)
-   return (leftHandSide r .==. rightHandSide r)
- where
-   ineqTypes =
-      [LessThan, GreaterThan, LessThanOrEqualTo, GreaterThanOrEqualTo]
-
--- Todo: cleanup this function
-solutionInequation :: Rule (Context (Logic (Relation Expr)))
-solutionInequation = describe "Determine solution for inequality" $
-   makeSimpleRule (ineq, "give-solution") $ withCM $ \r -> do
-   inEquation <- lookupClipboard "ineq" >>= fromExpr
-   let rt = relationType inEquation
-   removeClipboard "ineq"
-   orv  <- maybeCM (matchM orListView r)
-   case toList orv of
-      _ | isTrue orv ->
-         return $ fromBool $
-            rt `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]
-      _ | isFalse orv -> do -- no solutions found for equations
-         let vs = vars (toExpr inEquation)
-         guard (not (null vs))
-         return $ fromBool $ evalIneq inEquation (head vs) 0
-      xs -> do
-         (vs, ys) <- liftM unzip $ matchM (listView (equationView >>> equationSolvedForm)) xs
-         let v  = head vs
-             zs = nub $ map (simplify (squareRootViewWith rationalView)) ys
-         ds <- matchM (listView doubleView) zs
-         guard (all (==v) vs)
-         let rs = makeRanges including (sort (zipWith A ds zs))
-             including = rt `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]
-         return $ fmap (fmap fromDExpr) $ intervalRelations (A 0 (Var v)) $
-            ors [ this | (d, isP, this) <- rs, isP || evalIneq inEquation v d ]
- where
-   makeRanges :: Bool -> [DExpr] -> [(Double, Bool, Interval DExpr)]
-   makeRanges b xs =
-      [makeLeft $ head xs]
-      ++ concatMap (uncurry makeMiddle) (zip xs (drop 1 xs))
-      ++ [makePoint (last xs) | b]
-      ++ [makeRight $ last xs]
-    where
-      makeLeft  a@(A d _)
-         | b         = (d-1, False, lessThanOrEqualTo a)
-         | otherwise = (d-1, False, lessThan a)
-      makeRight a@(A d _)
-         | b         = (d+1, False, greaterThanOrEqualTo a)
-         | otherwise = (d+1, False, greaterThan a)
-      makePoint a@(A d _) = (d, True, point a)
-      makeMiddle a1@(A d1 _) a2@(A d2 _) =
-         [ makePoint a1 | b ] ++
-         [ ( (d1+d2)/2
-           , False
-           , open a1 a2
-           )
-         ]
-
-   evalIneq :: Relation Expr -> String -> Double -> Bool
-   evalIneq r v d = fromMaybe False $
-      liftM2 (eval (relationType r)) (useSide leftHandSide) (useSide rightHandSide)
-    where
-      useSide f = match doubleView (sub (f r))
-
-      sub (Var x) | x==v = fromDouble d
-      sub expr = descend sub expr
-
-data DExpr = A Double Expr
-
-instance Eq DExpr where
-   A d1 _ == A d2 _ = d1==d2
-
-instance Ord DExpr where
-   A d1 _ `compare` A d2 _ = d1 `compare` d2
-
-fromDExpr :: DExpr -> Expr
-fromDExpr (A _ e) = e
− src/Domain/Math/Polynomial/LeastCommonMultiple.hs 
@@ -1,138 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.LeastCommonMultiple
-   ( lcmExpr, divisionExpr, noCommonFactor, equalFactors, testLCM
-   , powerProductView
-   ) where
-
-import Common.Utils.TestSuite
-import Common.View
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Data.Ratio
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Power.Views
-import Prelude hiding ((^))
-import Test.QuickCheck
-
--- | Returns the least common multiple of two expressions.
-lcmExpr :: Expr -> Expr -> Expr
-lcmExpr a b = fromMaybe (a*b) $ do
-   (ar, as) <- match powerProductView a
-   (br, bs) <- match powerProductView b
-   return $ build powerProductView (lcmR ar br, merge as bs)
- where
-   lcmR :: Rational -> Rational -> Rational
-   lcmR r1 r2 =
-      let f r = numerator r * denominator r
-      in fromIntegral (lcm (f r1) (f r2))
-
-   merge :: [(Expr, Integer)] -> [(Expr, Integer)] -> [(Expr, Integer)]
-   merge = foldr op id
-    where
-      op (e, n1) f ys =
-         let n2   = fromMaybe 0 (lookup e ys)
-             rest = filter ((/=e) . fst) ys
-         in (e, n1 `max` n2) : f rest
-
--- | Only succeeds if there is no remainder
-divisionExpr :: Expr -> Expr -> Maybe Expr
-divisionExpr a b = do
-   (ar, as) <- match powerProductView a
-   (br, bs) <- match powerProductView b
-   xs       <- as `without` bs
-   return $ build powerProductView (ar/br, xs)
- where
-   without :: [(Expr, Integer)] -> [(Expr, Integer)] -> Maybe [(Expr, Integer)]
-   without [] ys =
-      guard (null ys) >> return []
-   without ((e,n1):xs) ys =
-      let n2   = fromMaybe 0 (lookup e ys)
-          rest = filter ((/=e) . fst) ys
-      in liftM ((e,n1-n2):) (without xs rest)
-
-powerProductView :: View Expr (Rational, [(Expr, Integer)])
-powerProductView = makeView f g
- where
-   f expr = do
-      (b, xs) <- match productView expr
-      let (r, ys) = collectPairs xs
-      return (if b then -r else r, merge ys)
-
-   g (r, xs) =
-      build productView (False, fromRational r : map (build pvn) xs)
-
-   pvn :: View Expr (Expr, Integer)
-   pvn = powerView >>> second integerView
-
-   collectPairs :: [Expr] -> (Rational, [(Expr, Integer)])
-   collectPairs = foldr op (1, [])
-    where
-      op e (r, xs) =
-         let mr   = match rationalView e
-             h r2 = (r*r2, xs)
-             pair = fromMaybe (e,1) (match pvn e)
-         in maybe (r, pair:xs) h mr
-
-   merge :: [(Expr, Integer)] -> [(Expr, Integer)]
-   merge [] = []
-   merge xs@((e, _) : _) =
-      let (xs1, xs2) = partition ((==e) . fst) xs
-          n = sum (map snd xs1)
-      in (e, n) : merge xs2
-
-testLCM :: TestSuite
-testLCM = suite "lcmExpr" $ do
-   addProperty "transitivity" $ f3 $ \a b c ->
-      lcmExpr a (lcmExpr b c) ~= lcmExpr (lcmExpr a b) c
-   addProperty "commutativity" $ f2 $ \a b ->
-      lcmExpr a b ~= lcmExpr b a
-   addProperty "idempotency" $ f1 $ \a ->
-      lcmExpr a a ~= absExpr a
-   addProperty "zero" $ f1 $ \a ->
-      lcmExpr a 0 ~= 0
-   addProperty "one" $ f1 $ \a ->
-      lcmExpr a 1 ~= absExpr a
-   addProperty "sign" $ f2 $ \a b ->
-      lcmExpr a b ~= lcmExpr (-a) b
- where
-   f1 g = liftM  g genExpr
-   f2 g = liftM2 g genExpr genExpr
-   f3 g = liftM3 g genExpr genExpr genExpr
-
-   genExpr, genTerm, genAtom :: Gen Expr
-   genExpr = do
-      n  <- choose (0, 10)
-      b  <- arbitrary
-      xs <- replicateM n genTerm
-      return $ build productView (b, xs)
-
-   genTerm = frequency [(3, genAtom), (1, liftM fromInteger arbitrary)]
-
-   genAtom = do
-      v <- elements $ map Var ["a", "b", "c"]
-      i <- choose (-10, 10)
-      n <- choose (0, 10)
-      p <- frequency [(3, return v), (1, return (v .+. fromInteger i))]
-      frequency [(3, return p), (1, return (p^fromInteger n))]
-
-   (~=)    = equalFactors
-   absExpr = simplifyWith (first (const False)) productView
-
-noCommonFactor :: Expr -> Expr -> Bool
-noCommonFactor x y = lcmExpr x y `equalFactors` (x*y)
-
-equalFactors :: Expr -> Expr -> Bool
-equalFactors x y = f x == f y
- where f = simplifyWith (second sort) powerProductView
− src/Domain/Math/Polynomial/RationalExamples.hs 
@@ -1,166 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Example exercises from the Digital Mathematics Environment (DWO),
--- see: http://www.fi.uu.nl/dwo/gr/frameset.html.
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.RationalExamples
-   ( brokenEquations, normBroken, normBroken2, normBrokenCon, deelUit
-   ) where
-
-import Common.Rewriting
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Prelude hiding ((^))
-
-----------------------------------------------------------
--- VWO B applets
-
--- Hoofdstuk 1, gebroken vergelijkingen
-brokenEquations :: [[Equation Expr]]
-brokenEquations =
-   -- Bereken exact de oplossingen
-   let x = Var "x" in
-   [ [ (2*x^2-10) / (x^2+3) :==: 0
-     , (7*x^2-21) / (2*x^2-5) :==: 0
-     , (3*x^2-6) / (4*x^2+1) :==: 0
-     , (4*x^2-24) / (6*x^2-2) :==: 0
-     , x^2 / (x+4) :==: (3*x+4) / (x+4)
-     , (x^2+2) / (x-2) :==: (x+8) / (x-2)
-     , (x^2+6*x-6)/(x^2-1) :==: (4*x+9)/(x^2-1)
-     , (x^2+6)/(x^2-2) :==: (7*x)/(x^2-2)
-     ]
-   , [ (x^2+6*x)/(x^2-1) :==: (3*x+4)/(x^2-1)
-     , (x^2+6)/(x-3) :==: (5*x)/(x-3)
-     , (x^2+4*x)/(x^2-4) :==: (3*x + 6)/(x^2-4)
-     , (x^2+2*x-4)/(x-5) :==: (4*x+11)/(x-5)
-     , (5*x+2)/(2*x-1) :==: (5*x+2)/(3*x+5)
-     , (x^2-9)/(4*x-1) :==: (x^2-9)/(2*x+7)
-     , (3*x-2)/(2*x^2) :==: (3*x-2)/(x^2+4)
-     , (2*x+1)/(x^2+3*x) :==: (2*x+1)/(5*x+8)
-     ]
-   , [ (x^2-1)/(2*x+2) :==: (x^2-1)/(x+8)
-     , (x^2-4)/(3*x-6) :==: (x^2-4)/(2*x+1)
-     , (x^2+5*x)/(2*x^2) :==: (x^2+5*x)/(x^2+4)
-     , (x^2-3*x)/(2*x-6) :==: (x^2-3*x)/(4*x+2)
-     , x/(x+1) :==: 1 + 3/4
-     , (x+2)/(3*x) :==: 1 + 1/3
-     , (2*x+3)/(x-1) :==: 3 + 1/2
-     , (x-3)/(1-x) :==: 1 + 2/5
-     ]
-   , [ (x+4)/(x+3) :==: (x+1)/(x+2)
-     , (2*x+3)/(x-1) :==: (2*x-1) / (x-2)
-     , (3*x+6)/(3*x-1) :==: (x+4)/(x+1)
-     , (x+2)/(2*x+5) :==: (x+4)/(2*x-3)
-     , (x+5)/(2*x) + 2 :==: 5
-     , (3*x+4)/(x+2) - 3 :==: 2
-     , (x^2)/(5*x+6) + 4 :==: 5
-     , (x^2)/(2*x-3) + 3 :==: 7
-     ]
-   , [ (x-2)/(x-3) :==: x/2
-     , (x+9)/(x-5) :==: 2/x
-     , (x+2)/(x+4) :==: 2/(x+1)
-     , (-3)/(x-5) :==: (x+3)/(x+1)
-     , (x+1)/(x+2) :==: (7*x+1)/(2*x-4)
-     , (2*x-7)/(5-x) :==: (x+1)/(3*x-7)
-     , (x+1)/(x-1) :==: (3*x-7)/(x-2)
-     , (3*x-7)/(x-2) :==: (7-x)/(3*x-3)
-     ]
-   ]
-
--- Hoofdstuk 4, gebroken vorm herleiden (1 en 1a)
-normBroken :: [[Expr]]
-normBroken =
-   -- Herleid
-   let x = Var "x" in
-   let y = Var "y" in
-   let a = Var "a" in
-   let b = Var "b" in
-   [ [ 7/(2*x) + 3/(5*x), 3/(2*x) + 2/(3*x), 4/(5*x)-2/(3*x)
-     , 2/(7*x) - 1/(4*x), 5/(6*a)+3/(7*a), 3/(8*a)+5/(3*a)
-     , 7/(2*a)-2/(3*a),  9/(5*a)-1/(2*a)
-     ]
-   , [ 1/x+1/y, 2/(3*x)+1/(2*y), 3/(x^2*y) - 5/(2*x*y), 2/(x*y)-7/(5*y)
-     , 2/a - 3/b, 4/(3*a)-2/(5*b), 2/(a*b)+4/(3*a), 7/(4*a)+3/(4*b)
-     ]
-   , [ 3+1/(2*x), 2*x+(3/(5*x)), 5/(2*x)-3, 3-5/(7*x), 5/(3*a)+1
-     , 4*a+3/(2*a), 2*a-1/(3*a), 7/(5*a)-2
-     ]
-   , [ 5/(x+2)+4/(x+3), 3/(x-1)+2/(x+3), 4/(x+5)+2/(x-3), 3/(x-2)+2/(x-3)
-     , 4/(x+3)-6/(x+2), 1/(x+5)-3/(x-4), 7/(x-3)-2/(x+1), 6/(x-1)-3/(x-2)
-     ]
-   , [ (x+1)/(x+2)+(x+2)/(x-3), (x-2)/(x+3)+(x-1)/(x+2), (x+3)/(x-1)+(x+2)/(x-4)
-     , (x-4)/(x+5)+(x-2)/(x-3), (x-1)/(x+1)-(x+2)/(x-2), (x+5)/(x+3)-(x+3)/(x+5)
-     , (x-1)/(x+2)-(x+4)/(x+1), (x-3)/(x-1)-(x+2)/(x+4)
-     ]
-   , [ (2*x)/(x-1)+x/(x+2), (3*x)/(x-4)+(5*x)/(x-2)
-     , (4*x)/(x+2)-(2*x)/(x+1), x/(x+5)-(4*x)/(x+6)
-     ]
-   ]
-
--- Hoofdstuk 4, gebroken vorm herleiden (2 en 2a)
-normBroken2 :: [[Expr]]
-normBroken2 =
-   -- Herleid
-   let x = Var "x" in
-   let a = Var "a" in
-   let p = Var "p" in
-   [ [ (x^2+4*x-5)/(x^2+5*x-6), (x^2+2*x-8)/(x^2+10*x+24)
-     , (x^2-7*x+12)/(x^2+x-20), (x^2+7*x+12)/(x^2+5*x+6)
-     , (a^2-a-2)/(a^2+4*a-12), (a^2-3*a-10)/(a^2-a-20)
-     , (a^2-2*a-15)/(a^2-3*a-18), (a^2+a-2)/(a^2+3*a+2)
-     ]
-   , [ (x^2-16)/(x^2+x-12), (x^2-2*x+1)/(x^2-1), (x^2-9)/(x^2+6*x+9)
-     , (x^2-7*x+6)/(x^2-1), (2*p^2+8*p)/(p^2-16), (-(p^2)+5*p)/(p^2-10*p+25)
-     , (p^2-4)/(4*p^2+8*p), (p^2-12*p+36)/(p^2-6*p)
-     ]
-   , [ (x^3+3*x^2+2*x)/(x^2+4*x+4), (x^3+10*x^2+24*x)/(x^2+7*x+6)
-     , (x^2+5*x+6)/(x^3-x^2-6*x), (x^2+3*x-4)/(x^3-6*x^2+5*x)
-     , (a^3+7*a^2+12*a)/(a^2+6*a+9), (a^3+7*a^2+10*a)/(a^2-a-6)
-     , (a^2-9)/(a^3-4*a^2+3*a), (a^2-2*a-15)/(a^3-3*a^2-10*a)
-     ]
-   ]
-
-deelUit :: [[Expr]]
-deelUit =
-   let x = Var "x" in
-   let a = Var "a" in
-   let p = Var "p" in
-   let t = Var "t" in
-   [ -- laatste sommen van gebroken vorm herleiden (2), niveau 5
-     [ (-6*a^2-1)/a, -2*p^2+3/(7*p), (7*t^2+4)/(-4*t), (9*x^2+8)/(8*x)
-     ]
-   , -- sommen (2a)
-     [ (-7*a^2-4*a-6)/(-6*a), (3*p^2+6*p-8)/p, (2*t^2-9*t-8)/(-2*t)
-     , (x^2+5*x+5)/(2*x), (5*a^3-4*a+2)/(9*a), (5*p^3-7*p^2+9)/(2*p)
-     , (-3*t^3+6*t-4)/(3*t), (4*x^3-3*x^2+4)/(7*x)
-     ]
-   ]
-
--- Vervolg hoofdstuk 4, gebroken vorm herleiden (2 en 2a), vanaf niveau 4
-normBrokenCon :: [[Equation Expr]]
-normBrokenCon =
-   -- Herleid
-   let a = Var "a" in
-   let p = Var "p" in
-   let t = Var "t" in
-   let ca = symbol (newSymbol "A") in
-   let ct = symbol (newSymbol "T") in
-   let cn = symbol (newSymbol "N") in
-   [ [ ca :==: (p^2+2*p)/(p^2-4), ca :==: (6*p^2-18*p)/(p^2-9)
-     , ca :==: (p^2-1)/(-2*p^2+2*p), ca :==: (p^2-16)/(4*p^2+16*p)
-     , ct :==: (t^3-2*t^2)/(t^2-4), ct :==: (t^3+4*t^2)/(t^2-16)
-     , ct :==: (t^2-1)/(t^3+t^2), ct :==: (t^2-25)/(t^3-5*t^2)
-     ]
-   , [ cn :==: (a^4+4*a^2-5)/(a^4-1), cn :==: (a^4+5*a^2+6)/(a^4+4*a^2+3)
-     , cn :==: (a^4-5*a^2+6)/(a^4-7*a^2+10), cn :==: (a^4-8*a^2+16)/(a^4-5*a^2+4)
-     ]
-   ]
− src/Domain/Math/Polynomial/RationalExercises.hs 
@@ -1,273 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.RationalExercises
-   ( rationalEquationExercise
-   , simplifyRationalExercise, divisionRationalExercise
-   , eqSimplifyRational
-   ) where
-
-import Common.Library
-import Common.Utils (fst3)
-import Common.Utils.Uniplate
-import Control.Monad
-import Data.Maybe
-import Domain.Logic.Formula hiding (Var)
-import Domain.Logic.Views ((.&&.))
-import Domain.Math.CleanUp
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules
-import Domain.Math.Equation.Views
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.LeastCommonMultiple
-import Domain.Math.Polynomial.RationalExamples
-import Domain.Math.Polynomial.RationalRules
-import Domain.Math.Polynomial.Rules
-import Domain.Math.Polynomial.Strategies
-import Domain.Math.Polynomial.Views
-import Domain.Math.Power.OldViews (powerFactorViewWith)
-import Domain.Math.SquareRoot.Views
-import Prelude hiding ((^))
-import qualified Data.Foldable as F
-import qualified Data.Set as S
-import qualified Data.Traversable as T
-import qualified Domain.Logic as Logic
-import qualified Domain.Logic.Views as Logic
-
-rationalEquationExercise :: Exercise (OrList (Equation Expr))
-rationalEquationExercise = makeExercise
-   { exerciseId    = describe "solve a rational equation (with a variable in a divisor)" $
-                        newId "algebra.equations.rational"
-   , status        = Provisional
-   , parser        = parseOrsEqExpr
-   , suitable      = predicate (isJust . rationalEquations)
-   , ready         = predicateView relationsSolvedForm
-   , equivalence   = eqRationalEquation
-   , similarity    = withoutContext (viewEquivalent (traverseView (traverseView cleanUpView)))
-   , strategy      = rationalEquationStrategy
-   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder
-   , navigation    = termNavigator
-   , examples      = level Medium $ map singleton (concat brokenEquations)
-   }
-
-simplifyRationalExercise :: Exercise Expr
-simplifyRationalExercise = makeExercise
-   { exerciseId    = describe "simplify a rational expression (with a variable in a divisor)" $
-                        newId "algebra.manipulation.rational.simplify"
-   , status        = Alpha
-   , parser        = parseExpr
-   , ready         = predicate simplifiedRational
---   , equivalence   = withoutContext eqSimplifyRational
-   , similarity    = withoutContext (viewEquivalent cleanUpView)
-   , strategy      = simplifyRationalStrategy
-   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder
-   , navigation    = termNavigator
-   , examples      = level Medium $ concat (normBroken ++ normBroken2)
-   }
-
-divisionRationalExercise :: Exercise Expr
-divisionRationalExercise = simplifyRationalExercise
-   { exerciseId   = describe "divide a rational expression ('uitdelen')" $
-                       newId "math.divrational"
-   , strategy     = label "divide broken fraction" succeed
-   , examples     = level Medium $ concat deelUit
-   }
-
-rationalEquationStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))
-rationalEquationStrategy = cleanUpStrategy (applyTop (fmap (fmap cleaner))) $
-   label "Rational equation" $
-       brokenFormToPoly <*> higherDegreeStrategyG <*> checkSolutionStrategy
- where
-   -- a custom-made clean-up function. (Standard) cleanUpExpr function
-   -- has some strange interaction with the rules
-   cleaner = transform (simplify (powerFactorViewWith rationalView))
-           . cleanUpSimple . transform smart
-
-   brokenFormToPoly = label "rational form to polynomial" $ untilS allArePoly $
-      (  useC divisionIsZero <|> useC divisionIsOne
-     <|> useC sameDivisor <|> useC sameDividend
-     <|> use coverUpPlus <|> use coverUpMinusLeft <|> use coverUpMinusRight
-     <|> use coverUpNegate
-      ) |>
-      (  useC crossMultiply <|> useC multiplyOneDiv  )
-   checkSolutionStrategy = label "check solutions" $
-      try (multi (showId checkSolution) (somewhere checkSolution))
-
-allArePoly :: Context (OrList (Equation Expr)) -> Bool
-allArePoly =
-   let f a = a `belongsTo` polyView
-   in maybe False (all f . concatMap F.toList . F.toList) .  fromContext
-
-simplifyRationalStrategy :: LabeledStrategy (Context Expr)
-simplifyRationalStrategy = cleanUpStrategy (applyTop cleaner) $
-   label "Simplify rational expression" $
-      phaseOneDiv <*> phaseSimplerDiv
- where
-   -- a custom-made clean-up function. (Standard) cleanUpExpr function
-   -- has some strange interaction with the rules
-   cleaner = transform (simplify (powerFactorViewWith rationalView)) . cleanUpSimple
-
-   phaseOneDiv = label "Write as division" $
-      untilS isDivC $
-         use fractionPlus <|> use fractionScale <|> use turnIntoFraction
-   phaseSimplerDiv = label "Simplify division" $
-      repeatS $
-         (onlyLowerDiv findFactorsStrategyG <|> somewhere (useC cancelTermsDiv)
-            <|> commitS (onlyUpperDiv (repeatS findFactorsStrategyG) <*> useC cancelTermsDiv))
-         |> ( somewhere (use merge)
-         <|> multi (showId distributeTimes) (exceptLowerDiv (use distributeTimes))
-          )
-
-isDivC :: Context a -> Bool
-isDivC = maybe False (isJust . isDivide :: Term -> Bool) . currentT
-
--- First check that the whole strategy can be executed. Cleaning up is not
--- propagated correctly to predicate in check combinator, hence the use of
--- cleanUpStrategy (which is not desirable here).
-commitS :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr)
-commitS s =
-   let cs  = cleanUpStrategy (applyTop cleanUpExpr) (label "" s)
-       f a = fromMaybe a (do b <- top a; c <- current a; return (change (const c) b))
-   in check (applicable cs . f) <*> s
-
-exceptLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a)
-exceptLowerDiv = somewhereWith "except-lower-div" $ \a ->
-   if isDivC a then [1] else [0 .. arity a-1]
-
-onlyUpperDiv :: IsStrategy f => f (Context a) -> Strategy (Context a)
-onlyUpperDiv = onceWith "only-upper-div" $ \a -> [ 1 | isDivC a ]
-
-onlyLowerDiv :: IsStrategy f => f (Context a) -> Strategy (Context a)
-onlyLowerDiv = onceWith "only-lower-div" $ \a -> [ 2 | isDivC a ]
-
-simplifiedRational :: Expr -> Bool
-simplifiedRational expr =
-   case expr of
-      Negate a -> simplifiedRational a
-      _        -> f expr
- where
-   f (a :/: b) = inPolyForm a && noCommonFactor a b && inFactorForm b
-   f _ = False
-
-   inPolyForm :: Expr -> Bool
-   inPolyForm a =
-      a `belongsTo` polyNormalForm identity ||
-      S.size (varSet expr) > 1
-
-   inFactorForm :: Expr -> Bool
-   inFactorForm = flip belongsTo $
-      let v = first (polyNormalForm identity >>> second linearPolyView)
-      in powerProductView >>> second (listView v)
-
-rationalEquations :: OrList (Equation Expr) -> Maybe (OrList Expr)
-rationalEquations = fmap (F.foldMap id) . T.mapM rationalEquation
-
-rationalEquation :: Equation Expr -> Maybe (OrList Expr)
-rationalEquation eq = do
-   let (lhs :==: rhs) = coverUp eq
-       (a, b, c) = rationalExpr (lhs .-. rhs)
-   (_, as) <- match productView a
-   (_, bs) <- match productView b
-   let condition = foldr ((.&&.) . notZero) c bs
-   new1    <- match higherDegreeEquationsView $ toOrList $ map (:==: 0) as
-   return (restrictOrList condition new1)
-
-restrictOrList :: Logic (Relation Expr) -> OrList Expr -> OrList Expr
-restrictOrList p0 = catOrList . fmap f
- where
-   f a | p a       = singleton a
-       | otherwise = false
-   p zeroExpr =
-      case coverUp (zeroExpr :==: 0) of
-         Var x :==: a -> -- returns true if a contradiction was not found
-            substVar x (cleanUpExpr a) p0 /= F
-         _ -> True
-
-   substVar x a = Logic.simplify . catLogic . fmap (simpler . fmap (cleanUpExpr . subst))
-    where
-      subst (Var s) | x == s = a
-      subst expr = descend subst expr
-
-   simpler r = fromMaybe (Logic.Var r) $ do
-      a <- match (squareRootViewWith rationalView) (leftHandSide r)
-      b <- match (squareRootViewWith rationalView) (rightHandSide r)
-      case (a==b, relationType r) of
-         (True,  EqualTo)    -> return true
-         (False, EqualTo)    -> return false
-         (True,  NotEqualTo) -> return false
-         (False, NotEqualTo) -> return true
-         _ -> Nothing
-
-eqRationalEquation :: Context (OrList (Equation Expr)) -> Context (OrList (Equation Expr)) -> Bool
-eqRationalEquation ca cb = fromMaybe False $
-   liftM2 (==) (solve ca) (solve cb)
- where
-   solve ctx = do
-      let f = fromMaybe T . conditionOnClipboard
-      a  <- fromContext ctx
-      xs <- rationalEquations a
-      return $ simplify orSetView $ restrictOrList (f ctx) xs
-
-eqSimplifyRational :: Expr -> Expr -> Bool
-eqSimplifyRational a b = fromMaybe False $ do
-   let a1c = cleanUpExpr (fst3 (rationalExpr a))
-       b1c = cleanUpExpr (fst3 (rationalExpr b))
-       manyVars = S.size (varSet a `S.union` varSet b) > 1
-   if manyVars then return True else do
-   p1 <- match (polyViewWith rationalView) a1c
-   p2 <- match (polyViewWith rationalView) b1c
-   return (p1==p2)
-
-conditionOnClipboard :: Context a -> Maybe (Logic (Relation Expr))
-conditionOnClipboard = evalCM $ const $
-   lookupClipboardG "condition"
-
--- write expression as a/b, under certain conditions
-rationalExpr :: Expr -> (Expr, Expr, Logic (Relation Expr))
-rationalExpr expr =
-   case expr of
-      a :+: b  -> rationalExpr a `fPlus` rationalExpr b
-      a :-: b  -> rationalExpr (a :+: Negate b)
-      Negate a -> fNeg (rationalExpr a)
-      a :*: b  -> rationalExpr a `fTimes` rationalExpr b
-      a :/: b  -> rationalExpr a `fTimes` fRecip (rationalExpr b)
-      Sym s [a, b] | isPowerSymbol s ->
-         fPower (rationalExpr a) b
-      _ -> (expr, 1, T)
- where
-   fNeg   (a, b, p)   = (neg a, b, p)
-   fRecip (a, b, p)   = (b, a, notZero b .&&. p)
-   fPower (a, b, p) n = (a .^. n, b .^. n, p)
-   fTimes (a1, a2, p) (b1, b2, q) = (a1 .*. b1, a2 .*. b2, p .&&. q)
-   fPlus  (a1, a2, p) (b1, b2, q) =
-      case (divisionExpr c2 a2, divisionExpr c2 b2) of
-         (Just a3, Just b3)
-            | a1 == b1     -> (a1 .*. (a3 .+. b3), c2, pq)
-            | a1 == neg b1 -> (a1 .*. (a3 .-. b3), c2, pq)
-            | otherwise    -> (a1 .*. a3 .+. b1 .*. b3, c2, pq)
-         _ -> (a1 .*. b2 .+. b1 .*. a2, a2 .*. b2, pq)
-    where
-      c2 = lcmExpr a2 b2
-      pq = p .&&. q
-
-notZero :: Expr -> Logic (Relation Expr)
-notZero expr =
-   case match rationalView expr of
-      Just r | r /= 0    -> T
-             | otherwise -> F
-      _ -> Logic.Var (expr ./=. 0)
-
-{-
-q = checkExercise simplifyRationalExercise
-go = rationalExpr $ (a^2-2*a-15)/(a^3-3*a^2-10*a)
- where a = Var "a" -}
− src/Domain/Math/Polynomial/RationalRules.hs 
@@ -1,182 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.RationalRules
-   ( divisionIsZero, divisionIsOne, sameDivisor, sameDividend
-   , crossMultiply, multiplyOneDiv, fractionPlus, cancelTermsDiv
-   , fractionScale, turnIntoFraction, checkSolution
-   ) where
-
-import Common.Library
-import Control.Monad
-import Data.Maybe
-import Domain.Logic.Formula hiding (Var)
-import Domain.Logic.Views
-import Domain.Math.CleanUp
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.LeastCommonMultiple
-import Domain.Math.Polynomial.Views
-import Domain.Math.Power.Views
-import qualified Domain.Logic.Formula as Logic
-
-ratId :: Id
-ratId = newId "algebra.equations.rational"
-
----------------------------------------------------------------
--- Rules for rational expressions and rational equations
-
--- a/b = 0  iff  a=0 (and b/=0)
-divisionIsZero :: Rule (Context (Equation Expr))
-divisionIsZero = makeSimpleRule (ratId, "division-zero") $ withCM $ \(lhs :==: rhs) -> do
-   guard (rhs == 0)
-   (a, b) <- matchM divView lhs
-   conditionNotZero b
-   return (a :==: 0)
-
--- a/b = 1  iff  a=b (and b/=0)
-divisionIsOne :: Rule (Context (Equation Expr))
-divisionIsOne = makeSimpleRule (ratId, "division-one") $ withCM $ \(lhs :==: rhs) -> do
-   guard (rhs == 1)
-   (a, b) <- matchM divView lhs
-   conditionNotZero b
-   return (a :==: b)
-
--- a/c = b/c  iff  a=b (and c/=0)
-sameDivisor :: Rule (Context (Equation Expr))
-sameDivisor = makeSimpleRule (ratId, "same-divisor") $ withCM $ \(lhs :==: rhs) -> do
-   (a, c1) <- matchM divView lhs
-   (b, c2) <- matchM divView rhs
-   guard (c1==c2)
-   conditionNotZero c1
-   return (a :==: b)
-
--- a/b = a/c  iff  a=0 or b=c (and b/=0 and c/=0)
-sameDividend :: Rule (Context (OrList (Equation Expr)))
-sameDividend = makeSimpleRule (ratId, "same-dividend") $ withCM $ oneDisjunct $ \(lhs :==: rhs) -> do
-   (a1, b) <- matchM divView lhs
-   (a2, c) <- matchM divView rhs
-   guard (a1==a2)
-   conditionNotZero b
-   conditionNotZero c
-   return $ singleton (a1 :==: 0) <> singleton (b :==: c)
-
--- a/b = c/d  iff  a*d = b*c   (and b/=0 and d/=0)
-crossMultiply :: Rule (Context (Equation Expr))
-crossMultiply = makeSimpleRule (ratId, "cross-multiply") $ withCM $ \(lhs :==: rhs) -> do
-   (a, b) <- matchM divView lhs
-   (c, d) <- matchM divView rhs
-   conditionNotZero b
-   conditionNotZero d
-   return (a*d :==: b*c)
-
--- a/b = c  iff  a = b*c  (and b/=0)
-multiplyOneDiv :: Rule (Context (Equation Expr))
-multiplyOneDiv = makeSimpleRule (ratId, "multiply-one-div") $ withCM $ \(lhs :==: rhs) ->
-   f (:==:) lhs rhs `mplus` f (flip (:==:)) rhs lhs
- where
-   f eq ab c = do
-      guard (not (c `belongsTo` divView))
-      (a, b) <- matchM divView ab
-      conditionNotZero b
-      return (a `eq` (b*c))
-
--- a/c + b/c = a+b/c   (also see Numeric.Rules)
-fractionPlus :: Rule Expr -- also minus
-fractionPlus = makeSimpleRule (ratId, "rational-plus") $ \expr -> do
-   ((a, b), (c, d)) <- match myView expr
-   guard (b == d)
-   return (build divView (a+c, b))
- where
-   myView = plusView >>> (divView *** divView)
-
--- ab/ac  =>  b/c  (if a/=0)
--- Note that the common term can be squared (in one of the parts)
-cancelTermsDiv :: Rule (Context Expr)
-cancelTermsDiv = makeSimpleRule (ratId, "cancel-div") $ withCM $ \expr -> do
-   ((b, xs), (c, ys)) <- matchM myView expr
-   let (ps, qs, rs) = rec (map f xs) (map f ys)
-   guard (not (null rs))
-   conditionNotZero (build productView (False, map g rs))
-   return $ build myView ((b, map g ps), (c, map g qs))
- where
-   myView = divView >>> toView (productView *** productView)
-   powInt = powerView >>> second integerView
-   f a = fromMaybe (a, 1) (match powInt a)
-   g   = build powInt
-   rec ((_, 0):xs) ys = rec xs ys
-   rec (pair@(a, n):xs) ys =
-      case break ((==a) . fst) ys of
-         (ys1, (b, m):ys2)
-            | m == 0 ->
-                 rec (pair:xs) (ys1++ys2)
-            | otherwise ->
-                 let i = n `min` m
-                     (ps,qs,rs) = rec ((a, n-i):xs) (ys1++(b,m-i):ys2)
-                 in (ps, qs, (a,i):rs)
-         _ ->
-            let (ps,qs,rs) = rec xs ys
-            in (pair:ps, qs,rs)
-   rec xs ys = (xs, ys, [])
-
-fractionScale :: Rule Expr
-fractionScale = liftRule myView $
-   makeSimpleRule (ratId, "rational-scale") $ \((a, e1), (b, e2)) -> do
-      guard (e1 /= e2)
-      let e3 = lcmExpr e1 e2
-      ma <- divisionExpr e3 e1
-      mb <- divisionExpr e3 e2
-      guard (ma /= 1 || mb /= 1)
-      return ((ma*a, e3), (mb*b, e3))
- where
-   myView = plusView >>> (divView *** divView)
-
-turnIntoFraction :: Rule Expr
-turnIntoFraction = liftRule plusView $
-   makeSimpleRule (ratId, "to-rational") $ \(a, b) ->
-      liftM (\c -> (c, b)) (f a b) `mplus`
-      liftM (\c -> (a, c)) (f b a)
- where
-   f a b = do
-      guard (not (a `belongsTo` divView))
-      (_, e) <- match divView b
-      return $ build divView (a*e, e)
-
--- A simple implementation that considers the condition stored in the context
-checkSolution :: Rule (Context (OrList (Equation Expr)))
-checkSolution = makeSimpleRule (ratId, "check-solution") $
-   withCM $ oneDisjunct $ \(x :==: a) -> do
-      c  <- lookupClipboardG "condition"
-      xs <- matchM andView c
-      guard ((x ./=. a) `elem` xs)
-      return false
-
----------------------------------------------------------------
--- Helper-code
-
-condition :: Logic (Relation Expr) -> ContextMonad ()
-condition c = do
-   mp <- maybeOnClipboardG "condition"
-   let a = maybe id (.&&.) mp c
-   unless (a==T) (addToClipboardG "condition" a)
-
-conditionNotZero :: Expr -> ContextMonad ()
-conditionNotZero expr = condition (f xs)
- where
-   f  = pushNotWith (Logic.Var . notRelation) . Not
-   eq = expr :==: 0
-   xs = fmap (build equationView . fmap cleanUpExpr) $
-        case match higherDegreeEquationsView (singleton eq) of
-           Just ys -> build orListView (coverUpOrs (build higherDegreeEquationsView ys))
-           Nothing -> Logic.Var (coverUp eq)
− src/Domain/Math/Polynomial/Rules.hs 
@@ -1,610 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.Rules
-   ( sameConFactor, abcFormula, allPowerFactors, bringAToOne, cancelTerms
-   , commonFactorVar, commonFactorVarNew, defPowerNat
-   , distributeDivisionT, distributeDivisionMulti
-   , distributeTimes, distributionSquare, exposeSameFactor, factorLeftAsSquare
-   , factorVariablePower, flipEquation, higherSubst, merge, moveToLeft, mulZero
-   , niceFactors, niceFactorsNew, noDivisionConstant, noLinFormula, oneVar
-   , parentNotNegCheck, prepareSplitSquare, quadraticRuleOrder, removeDivision
-   , ruleApproximate, ruleNormalizeMixedFraction, ruleNormalizeRational
-   , ruleNormalizePolynomial
-   , sameFactor, simplerLinearFactor, simplerPolynomial, simplerSquareRootMulti
-   , squareBothSides, substBackVar, varToLeft, conditionVarsRHS, fractionProduct
-   ) where
-
-import Common.Library hiding (terms, simplify)
-import Common.Utils
-import Common.Utils.Uniplate (universe, descend)
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Data.Ord
-import Data.Ratio
-import Domain.Math.Approximation (precision)
-import Domain.Math.CleanUp
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Polynomial
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.BalanceRules
-import Domain.Math.Equation.CoverUpRules
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Views
-import Domain.Math.Power.OldViews (powerFactorView)
-import Domain.Math.Safe
-import Domain.Math.Simplification hiding (simplifyWith)
-import Domain.Math.SquareRoot.Views
-import Prelude hiding ( (^) )
-import qualified Prelude
-
-quadraticRuleOrder :: [Id]
-quadraticRuleOrder =
-   [ getId coverUpTimes, getId (coverUpMinusRightWith oneVar)
-   , getId (coverUpMinusLeftWith oneVar), getId (coverUpPlusWith oneVar)
-   , getId coverUpPower
-   , getId commonFactorVar, getId simplerPolynomial
-   , getId niceFactors, getId noLinFormula
-   , getId cancelTerms, getId sameConFactor, getId distributionSquare
-   , getId allPowerFactors
-   ]
-
-lineq, quadreq, polyeq :: String
-lineq   = "algebra.equations.linear"
-quadreq = "algebra.equations.quadratic"
-polyeq  = "algebra.equations.polynomial"
-
-------------------------------------------------------------
--- General form rules: ax^2 + bx + c = 0
-
-quadraticNF :: View Expr (String, (Rational, Rational, Rational))
-quadraticNF = polyNormalForm rationalView >>> second quadraticPolyView
-
--- ax^2 + bx = 0
-commonFactorVar :: Rule (Equation Expr)
-commonFactorVar = rhsIsZero commonFactorVarNew
-
--- Maybe to be replaced by more general factorVariablePower??
-commonFactorVarNew :: Rule Expr
-commonFactorVarNew = describe "Common factor variable" $
-   makeSimpleRule (quadreq, "common-factor") $ \expr -> do
-      (x, (a, b, c)) <- match quadraticNF expr
-      guard (a /= 0 && b /= 0 && c == 0)
-      -- also search for constant factor
-      let d = signum a * gcdFrac a b
-      return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d)))
-
-gcdFrac :: Rational -> Rational -> Rational
-gcdFrac r1 r2 =
-   if denominator r1 == 1 && denominator r2 == 1
-   then fromInteger (numerator r1 `gcd` numerator r2)
-   else 1
-
--- ax^2 + c = 0
-noLinFormula :: Rule (Equation Expr)
-noLinFormula = describe "No linear term ('b=0')" $ liftRule myView $
-   makeSimpleRule (quadreq, "no-lin") $ \((x, (a, b, c)), rhs) -> do
-      guard (rhs == 0 && b == 0 && c /= 0)
-      return $ if a>0 then ((x, (a, 0, 0)), -c)
-                      else ((x, (-a, 0, 0)), c)
- where
-   myView = constantRight quadraticNF
-
--- search for (X+A)*(X+B) decomposition
-niceFactors :: Rule (Equation Expr)
-niceFactors = rhsIsZero niceFactorsNew
-
--- search for (X+A)*(X+B) decomposition
-niceFactorsNew :: Rule Expr
-niceFactorsNew = describe "Find a nice decomposition" $
-   makeSimpleRuleList (quadreq, "nice-factors") $ \expr -> do
-   let sign t@(x, (a, b, c)) = if a== -1 then (x, (1, -b, -c)) else t
-   (x, (a, b, c)) <- liftM sign (matchM (polyNormalForm integerView >>> second quadraticPolyView) expr)
-   guard (a==1)
-   let ok (i, j) = i+j == b
-       f  (i, j)
-          | i == j = -- special case
-              (Var x + fromInteger i) ^ 2
-          | otherwise =
-              (Var x + fromInteger i) * (Var x + fromInteger j)
-   map f (filter ok (factors c))
- where
-   factors :: Integer -> [(Integer, Integer)]
-   factors n = [ pair
-               | let h = (floor :: Double -> Integer) (sqrt (abs (fromIntegral n)))
-               , a <- [1..h], let b = n `div` a, a*b == n
-               , pair <- [(a, b), (negate a, negate b)]
-               ]
-
--- Simplify polynomial by multiplying (or dividing) the terms:
--- 1) If a,b,c are ints, then find gcd
--- 2) If any of a,b,c is a fraction, find lcm of denominators
--- 3) If a<0, then also suggest to change sign (return two solutions)
-simplerPolynomial :: Rule (Equation Expr)
-simplerPolynomial = describe "simpler polynomial" $
-   rhsIsZero $ liftRuleIn (quadraticNF >>> toView swapView) $
-   makeSimpleRuleList (quadreq, "simpler-poly") $ \(a, b, c) -> do
-      r <- findFactor (filter (/=0) [a, b, c])
-      d <- if a >= 0 then [r] else [-r, r]
-      guard (d `notElem` [0, 1])
-      return (a*d, b*d, c*d)
-
--- Simplified variant of simplerPoly: just bring a to 1.
--- Needed for quadratic strategy without square formula
-bringAToOne :: Rule (Equation Expr)
-bringAToOne = rhsIsZero $ liftRuleIn (quadraticNF >>> toView swapView) $
-   describe "Bring 'a' to one" $
-   makeSimpleRule (quadreq, "scale") $ \(a, b, c) -> do
-   guard (a `notElem` [0, 1])
-   return (1, b/a, c/a)
-
-------------------------------------------------------------
--- General form rules: expr = 0
-
--- Rule must be symmetric in side of equation
-mulZero :: Rule (OrList (Equation Expr))
-mulZero = describe "multiplication is zero" $
-   makeSimpleRuleList (quadreq, "product-zero") $ oneDisjunct bothSides
- where
-   bothSides eq = oneSide eq `mplus` oneSide (flipSides eq)
-   oneSide (lhs :==: rhs) = do
-      guard (rhs == 0)
-      (_, xs) <- matchM productView lhs
-      guard (length xs > 1)
-      return $ toOrList $ flip map xs $ \e ->
-         case match (polyNormalForm rationalView >>> second linearPolyView) e of
-            -- special cases (simplify immediately, as in G&R)
-            Just (x, (a, b))
-               | a == 1 ->
-                    Var x :==: fromRational (-b)
-               | a == -1 ->
-                    Var x :==: fromRational b
-            _ -> e :==: 0
-
-------------------------------------------------------------
--- Constant form rules: expr = constant
-
--- Use this configuration for covering-up plus and minus symbols!
--- Prevent    (x^2+3x)+5 = 0   to be covered up
-oneVar :: ConfigCoverUp
-oneVar = configCoverUp
-   { configName        = "onevar"
-   , predicateCovered  = \a -> p1 a || p2 a
-   , predicateCombined = hasNoVar
-   , coverLHS          = True
-   , coverRHS          = True
-   }
- where
-   p1 = (==1) . length . vars
-   -- predicate p2 tests for cases such as 12*(x^2-3*x)+8 == 56
-   p2 a = fromMaybe False $ do
-      (x, y) <- match timesView a
-      return (hasSomeVar x /= hasSomeVar y)
-
-------------------------------------------------------------
--- Top form rules: expr1 = expr2
-
-simplerSquareRootMulti :: IsTerm a => Rule (Context a)
-simplerSquareRootMulti = describe "simpler square root" $
-   finalRule $ makeSimpleRuleList (quadreq, "simpler-sqrt") $ applyAll $
-   repeat1 (somewhere (use (makeSimpleRule () simplerSqrt)))
- where
-   -- Do not simplify (5+sqrt 53)/2
-   simplerSqrt :: Expr -> Maybe Expr
-   simplerSqrt e = do
-      xs <- f e
-      guard (not (null xs))
-      new <- canonical (squareRootViewWith rationalView) e
-      ys <- f new
-      guard (xs /= ys)
-      return new
-
-   -- return numbers under sqrt symbol
-   f :: Expr -> Maybe [Rational]
-   f e = liftM sort $ sequence [ match rationalView a | Sqrt a <- universe e ]
-
-cancelTerms :: Rule (Equation Expr)
-cancelTerms = describe "Cancel terms" $
-   makeSimpleRule (quadreq, "cancel") $ \(lhs :==: rhs) -> do
-   xs <- match sumView lhs
-   ys <- match sumView rhs
-   let zs = filter (`elem` ys) (nub xs)
-   guard (not (null zs))
-   let without as = build sumView (as \\ zs)
-   return (without xs :==: without ys)
-
--- "merkwaardige producten"
-distributionSquare :: Rule Expr
-distributionSquare = describe "distribution for special products" $
-   ruleList (quadreq, "distr-square")
-      [ \a b -> (a+b)^2 :~> a^2 + 2*a*b + b^2
-      , \a b -> (a-b)^2 :~> a^2 - 2*a*b + b^2
-      , \a b -> (a+b)*(a-b) :~> a^2 - b^2
-      , \a b -> (a-b)*(a+b) :~> a^2 - b^2
-      ]
-
--- a^2 == b^2
-squareBothSides :: Rule (OrList (Equation Expr))
-squareBothSides = describe "square both sides" $
-   rule (quadreq, "square-both") $ \a b ->
-   singleton (a^2 :==: b^2) :~> toOrList [a :==: b, a :==: -b]
-
--- prepare splitting a square; turn lhs into x^2+bx+c such that (b/2)^2 is c
-prepareSplitSquare :: Rule (Equation Expr)
-prepareSplitSquare = describe "prepare split square" $
-   liftRule myView $
-   makeSimpleRule (quadreq, "prepare-split") $ \((x, (a, b, c)), r) -> do
-      let newC   = (b/2)*(b/2)
-          newRHS = r + newC - c
-      guard (a==1 && b/=0 && c /= newC)
-      return ((x, (a, b, newC)), newRHS)
- where
-   myView = constantRight quadraticNF
-
--- factor left-hand side into (ax + c)^2
-factorLeftAsSquare :: Rule (Equation Expr)
-factorLeftAsSquare = describe "factor left as square" $
-   makeSimpleRule (quadreq, "left-square") $ \(lhs :==: rhs) -> do
-      guard (hasNoVar rhs)
-      (x, (a, b, c)) <- match quadraticNF lhs
-      let h = b/2
-      guard (a==1 && b/=0 && h*h == c)
-      return ((Var x + build rationalView h)^2 :==: rhs)
-
--- flip the two sides of an equation
-flipEquation :: Rule (Equation Expr)
-flipEquation = describe "flip equation" $
-   rule (lineq, "flip") $ \a b ->
-      (a :==: b) :~> (b :==: a)
-
-conditionVarsRHS :: Rule (Equation Expr)
-conditionVarsRHS = describe "All variables are in the right-hand side" $
-   checkRule $ \(lhs :==: rhs) ->
-      hasSomeVar rhs && hasNoVar lhs
-
--- Afterwards, merge and sort
-moveToLeft :: Rule (Equation Expr)
-moveToLeft = describe "Move to left" $
-   makeSimpleRule (quadreq, "move-left") $ \(lhs :==: rhs) -> do
-      guard (rhs /= 0 && hasSomeVar lhs && (hasSomeVar rhs || isComplex lhs))
-      return (collectLikeTerms (sorted (lhs - rhs)) :==: 0)
- where
-   isComplex = maybe False ((>= 2) . length . filter hasSomeVar)
-             . match sumView . applyD merge
-
-   -- high exponents first, non power-factor terms at the end
-   sorted = simplifyWith (sortBy (comparing toPF)) sumView
-   toPF   = fmap (negate . thd3) . match powerFactorView
-
-ruleApproximate :: Rule (Relation Expr)
-ruleApproximate = describe "Approximate irrational number" $
-   makeSimpleRule (quadreq, "approx") $ \relation -> do
-      lhs :==: rhs <- match equationView relation
-      guard (not (simplify rhs `belongsTo` rationalView))
-      x <- getVariable lhs
-      d <- match doubleView rhs
-      let new = fromDouble (precision 4 d)
-      return (Var x .~=. new)
-
-ruleNormalizeRational :: Rule Expr
-ruleNormalizeRational =
-   describe "normalize rational number" $
-   ruleFromView (lineq, "norm-rational") rationalView
-
-ruleNormalizeMixedFraction :: Rule Expr
-ruleNormalizeMixedFraction =
-   describe "normalize mixed fraction" $
-   ruleFromView (lineq, "norm-mixed") mixedFractionView
-
-ruleNormalizePolynomial :: Rule Expr
-ruleNormalizePolynomial =
-   describe "normalize polynomial" $
-   ruleFromView (polyeq, "norm-poly") (polyNormalForm rationalView)
-
------------------------------------------------------------
--------- Rules From HDE
-
--- X*A + X*B = X*C + X*D
--- New implementation, but slightly different than original
--- This one does not factor constants
-
-allPowerFactors :: Rule (OrList (Equation Expr))
-allPowerFactors = describe "all power factors" $
-   makeSimpleRule (polyeq, "power-factors") $ oneDisjunct $
-   \(lhs :==: rhs) -> do
-      let myView = polyNormalForm rationalView
-      (s1, p1) <- match myView lhs
-      (s2, p2) <- match myView rhs
-      let n | p1 == 0   = lowestDegree p2
-            | p2 == 0   = lowestDegree p1
-            | otherwise = lowestDegree p1 `min` lowestDegree p2
-          ts  = terms p1 ++ terms p2
-          f p = build myView (s1, raise (-n) p)
-      guard ((s1==s2 || p1==0 || p2==0) && n > 0 && length ts > 1)
-      return $ toOrList [Var s1 :==: 0, f p1 :==: f p2]
-
-factorVariablePower :: Rule Expr
-factorVariablePower = describe "factor variable power" $
-   makeSimpleRule (polyeq, "factor-varpower") $ \expr -> do
-   let myView = polyNormalForm rationalView
-   (s, p) <- match (polyNormalForm rationalView) expr
-   let n = lowestDegree p
-   guard (n > 0 && length (terms p) > 1)
-   new <- p `safeDiv` (var Prelude.^ n)
-   return $ Var s .^. fromIntegral n * build myView (s, new)
-
--- A*B = A*C  implies  A=0 or B=C
-sameFactor :: Rule (OrList (Equation Expr))
-sameFactor = describe "same factor" $
-   makeSimpleRule (quadreq, "same-factor") $ oneDisjunct $ \(lhs :==: rhs) -> do
-      (b1, xs) <- match productView lhs
-      (b2, ys) <- match productView rhs
-      (x, y) <- safeHead [ (x, y) | x <- xs, y <- ys, x==y, hasSomeVar x ] -- equality is too strong?
-      return $ toOrList [ x :==: 0, build productView (b1, xs\\[x]) :==: build productView (b2, ys\\[y]) ]
-
--- N*(A+B) = N*C + N*D   recognize a constant factor on both sides
--- Example: 3(x^2+1/2) = 6+6x
-sameConFactor :: Rule (Equation Expr)
-sameConFactor =
-   describe "same constant factor" $
-   liftRule myView $
-   makeSimpleRule (quadreq, "same-con-factor") $ \(ps1 :==: ps2) -> do
-      let (bs, zs) = unzip (ps1 ++ ps2)
-          (rs, es) = unzip (map (f 1 []) zs)
-          f r acc []     = (r, reverse acc)
-          f r acc (x:xs) = case match rationalView x of
-                              Just r2 -> f (r*r2) acc xs
-                              Nothing -> f r (x:acc) xs
-      c <- whichCon rs
-      guard (c /= 1)
-      let make b r e          = (b, fromRational (r/c):e)
-          (newLeft, newRight) = splitAt (length ps1) (zipWith3 make bs rs es)
-      return (newLeft :==: newRight)
- where
-   myView = bothSidesView (toView sumView >>> listView (toView productView))
-
-   whichCon :: [Rational] -> Maybe Rational
-   whichCon xs
-      | all (\x -> denominator x == 1 && x /= 0) xs =
-           Just (fromInteger (foldr1 gcd (map numerator xs)))
-      | otherwise = Nothing
-
-abcFormula :: Rule (Context (OrList (Equation Expr)))
-abcFormula = describe "quadratic formula (abc formule)" $
-   makeSimpleRule (quadreq, "abc") $ withCM $ oneDisjunct $ \(lhs :==: rhs) -> do
-   guard (rhs == 0)
-   (x, (a, b, c)) <- matchM quadraticNF lhs
-   addListToClipboard ["a", "b", "c"] (map fromRational [a, b, c])
-   let discr = b*b - 4 * a * c
-       sqD   = sqrt (fromRational discr)
-   addToClipboard "D" (fromRational discr)
-   case compare discr 0 of
-      LT -> return false
-      EQ -> return $ singleton $
-         Var x :==: (-fromRational b) / (2 * fromRational a)
-      GT -> return $ toOrList
-         [ Var x :==: (-fromRational b + sqD) / (2 * fromRational a)
-         , Var x :==: (-fromRational b - sqD) / (2 * fromRational a)
-         ]
-
-higherSubst :: Rule (Context (Equation Expr))
-higherSubst = describe "Substitute variable" $
-   makeSimpleRule (polyeq, "subst") $ withCM $ \(lhs :==: rhs) -> do
-   guard (rhs == 0)
-   let myView = polyView >>> second trinomialPolyView
-   (x, ((a, n1), (b, n2), (c, n3))) <- matchM myView lhs
-   guard (n1 == 0 && n2 > 1 && n3 `mod` n2 == 0 && x /= "p")
-   let new = build myView ("p", ((a, 0), (b, 1), (c, n3 `div` n2)))
-   addToClipboard "subst" (toExpr (Var "p" :==: Var x .^. fromIntegral n2))
-   return (new :==: 0)
-
-substBackVar :: Rule (Context Expr)
-substBackVar = describe "Substitute back a variable" $
-   makeSimpleRule (polyeq, "back-subst") $ withCM $ \a -> do
-   expr <- lookupClipboard "subst"
-   case fromExpr expr of
-      Just (Var p :==: rhs) -> do
-         guard (hasVar p a)
-         return (subst p rhs a)
-      _ -> fail "no subst in clipboard"
- where
-   subst a b (Var c) | a==c = b
-   subst a b expr = descend (subst a b) expr
-
-exposeSameFactor :: Rule (Equation Expr)
-exposeSameFactor = describe "expose same factor" $
-   liftRule (bothSidesView (toView productView)) $
-   makeSimpleRuleList (polyeq, "expose-factor") $ \((bx, xs) :==: (by, ys)) -> do
-      (nx, ny) <- [ (xs, new) | x <- xs, isOk x, new <- exposeList x ys ] ++
-                  [ (new, ys) | y <- ys, isOk y, new <- exposeList y xs ]
-      return ((bx, nx) :==: (by, ny))
- where
-   isOk p = fromMaybe False $ do
-      (_, _, b) <- match (linearViewWith rationalView) p
-      guard (b /= 0)
-      return True
-
-   exposeList _ [] = []
-   exposeList a (b:bs) = map (++bs) (expose a b) ++ map (b:) (exposeList a bs)
-
-   expose a b = do
-      (s1, p1) <- matchM (polyViewWith rationalView) a
-      (s2, p2) <- matchM (polyViewWith rationalView) b
-      guard (s1==s2 && p1/=p2)
-      case safeDiv p2 p1 of
-         Just p3 -> return $ map (\p -> build (polyViewWith rationalView) (s1,p)) [p1, p3]
-         Nothing -> []
-
----------------------------------------------------------
--- From LinearEquations
-
--- Only used for cleaning up
-distributeAll :: Expr -> Expr
-distributeAll expr =
-   case expr of
-      e1 :*: e2 -> let as = fromMaybe [e1] (match sumView e1)
-                       bs = fromMaybe [e2] (match sumView e2)
-                   in build sumView [ a .*. b | a <- as, b <- bs ]
-      _ -> expr
-
--- This rule should consider the associativity of multiplication
--- Combine bottom-up, for example:  5*(x-5)*(x+5)
--- However, in  -2x(2x+10)   (-2x) should be seen as "one term"
-distributionT :: Transformation Expr
-distributionT = makeTransList f
- where
-   f expr = do
-      (b, xs) <- matchM simpleProductView expr
-      ys      <- rec (combine xs)
-      return $ build simpleProductView (b, ys)
-
-   combine :: [Expr] -> [Expr]
-   combine (x:y:rest) | p x && p y = combine ((x*y):rest)
-    where p = maybe False ((==1) . length) . match sumView
-   combine []     = []
-   combine (x:xs) = x : combine xs
-
-   rec :: [Expr] -> [[Expr]]
-   rec (a:b:xs) = map (:xs) (g a b) ++ map (a:) (rec (b:xs))
-   rec _        = []
-
-   g :: Expr -> Expr -> [Expr]
-   g e1 e2 = do
-      as <- matchM sumView e1
-      bs <- matchM sumView e2
-      guard (length as > 1 || length bs > 1)
-      return $ build sumView [ a .*. b | a <- as, b <- bs ]
-
--------------------------------------------------------
--- Rewrite Rules
-
-varToLeft :: Rule (Relation Expr)
-varToLeft = doAfter (fmap collectLikeTerms) $
-   describe "variable to left" $
-   makeRule (lineq, "var-left") $ flip (supply1 "term") minusT $ \eq -> do
-      (x, a, _) <- match (linearViewWith rationalView) (rightHandSide eq)
-      guard (a/=0)
-      return (fromRational a * Var x)
-
--- factor is always positive due to lcm function
-removeDivision :: Rule (Relation Expr)
-removeDivision = doAfter (fmap (collectLikeTerms . distributeAll)) $
-   describe "remove division" $
-   makeRule (lineq, "remove-div") $ flip (supply1 "factor") timesT $ \eq -> do
-      xs <- match sumView (leftHandSide eq)
-      ys <- match sumView (rightHandSide eq)
-      -- also consider parts without variables
-      -- (but at least one participant should have a variable)
-      zs <- forM (xs ++ ys) $ \a -> do
-               (_, list) <- match productView a
-               return [ (hasSomeVar a, e) | e <- list ]
-      let f (b, e) = do
-             (_, this) <- match (divView >>> second integerView) e
-             return (b, this)
-          (bs, ns) = unzip (mapMaybe f (concat zs))
-      guard (or bs)
-      return (fromInteger (foldr1 lcm ns))
-
-distributeTimes :: Rule Expr
-distributeTimes = describe "distribution multiplication" $
-   makeSimpleRuleList (lineq, "distr-times") $
-      liftM collectLikeTerms . applyAll distributionT
-
-distributeDivisionMulti :: IsTerm a => Rule (Context a)
-distributeDivisionMulti = describe "distribution division" $
-   makeSimpleRule (quadreq, "distr-div") $ apply $ repeat1 $
-      somewhere (use (makeRule () distributeDivisionT))
-
-distributeDivisionT :: Transformation Expr
-distributeDivisionT = makeTrans $ \expr -> do
-   (xs, r) <- match (divView >>> (toView sumView *** rationalView)) expr
-   guard (length xs > 1)
-   let ys = map (/fromRational r) xs
-   return $ build sumView ys
-
-merge :: Rule Expr
-merge = describe "merge similar terms" $
-   makeSimpleRule (lineq, "merge") $ \old -> do
-      let norm = cleanUpSimple old -- don't use rule just for cleaning up
-          new  = collectLikeTerms norm
-          f    = maybe 0 length . match sumView
-      guard (f norm > f new)
-      return new
-
-simplerLinearFactor :: Rule Expr
-simplerLinearFactor = describe "simpler linear factor" $
-   makeSimpleRule (polyeq, "simpler-linfactor") $ \expr -> do
-   let myView = polyNormalForm rationalView >>> second linearPolyView
-   (x, (a, b)) <- match myView expr
-   let d = (if a<0 then negate else id) (gcdFrac a b)
-   guard (a /= 0 && b /= 0 && d `notElem` [1, -1])
-   return $ fromRational d * build myView (x, (a/d, b/d))
-
-ruleFromView :: (IsId n, Eq a) => n -> View a b -> Rule a
-ruleFromView s v = makeSimpleRule s $ \a -> do
-   b <- canonical v a
-   guard (a /= b)
-   return b
-
-rhsIsZero :: Rule Expr -> Rule (Equation Expr)
-rhsIsZero r = makeSimpleRuleList (showId r) $ \(lhs :==: rhs) -> do
-   guard (rhs == 0)
-   a <- applyAll r lhs
-   return (a :==: rhs)
-
-constantRight :: View Expr a -> View (Equation Expr) (a, Rational)
-constantRight v = makeView f g
- where
-   f (lhs :==: rhs) = liftM2 (,) (match v lhs) (match rationalView rhs)
-   g (a, r) = build v a :==: build rationalView r
-
-bothSidesView :: View a b -> View (Equation a) (Equation b)
-bothSidesView v = makeView f (fmap (build v))
- where
-   f (lhs :==: rhs) = liftM2 (:==:) (match v lhs) (match v rhs)
-
-findFactor :: Monad m => [Rational] -> m Rational
-findFactor rs
-   | null rs =
-        fail "no factor"
-   | all ((==1) . denominator) rs =
-        return $ Prelude.recip $ fromIntegral $ foldr1 gcd $ map numerator rs
-   | otherwise =
-        return $ fromIntegral $ foldr1 lcm $ map denominator rs
-
-parentNotNegCheck :: Rule (Context Expr)
-parentNotNegCheck = minorRule $ makeSimpleRule "parent not negate check" $ \c ->
-   case up c >>= current of
-      Just (Negate _) -> Nothing
-      _               -> Just c
-
-noDivisionConstant :: Rule Expr
-noDivisionConstant = makeSimpleRule (lineq, "no-div-con") f
- where
-   f (a :/: b) | hasNoVar b && hasSomeVar a =
-      return ((1/b) * a)
-   f _ = Nothing
-
--- (a/b) * (c/d) = (a*c)/(b*d)
-fractionProduct :: Rule Expr
-fractionProduct = makeSimpleRule (polyeq, "fraction-product") $ \expr -> do
-   ((a, b), (c, d)) <- match (timesView >>> divView *** divView) expr
-   return ((a .*. c) ./. (b .*. d))
-
-defPowerNat :: Rule Expr
-defPowerNat = makeSimpleRule (polyeq, "def-power-nat") f
- where
-   f (Sym _ [Var _, _]) = Nothing -- should not work on x^5
-   f (Sym s [a, Nat n]) | isPowerSymbol s =
-      return (build productView (False, replicate (fromInteger n) a))
-   f _ = Nothing
− src/Domain/Math/Polynomial/Strategies.hs 
@@ -1,194 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.Strategies
-   ( linearStrategy, linearMixedStrategy, linearStrategyG
-   , quadraticStrategy, quadraticStrategyG
-   , higherDegreeStrategy, higherDegreeStrategyG
-   , findFactorsStrategy, findFactorsStrategyG, expandStrategy
-   ) where
-
-import Common.Library
-import Common.Utils.Uniplate (transform)
-import Data.Maybe
-import Domain.Math.CleanUp
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus)
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Rules
-import Domain.Math.Polynomial.Views
-
-------------------------------------------------------------
--- Linear equations
-
-linearStrategy :: LabeledStrategy (Context (Equation Expr))
-linearStrategy = cleanUpStrategyAfter (applyTop (fmap cleanUpSimple)) linearStrategyG
-
-linearMixedStrategy :: LabeledStrategy (Context (Equation Expr))
-linearMixedStrategy =
-   let f   = applyTop (fmap (transform (simplify mixedFractionView) . cleanUpSimple))
-       cfg = [ (byName ruleNormalizeMixedFraction, Reinsert)
-             , (byName ruleNormalizeRational, Remove)
-             ]
-   in cleanUpStrategyAfter f (configureNow (configure cfg linearStrategyG))
-
-linearStrategyG :: IsTerm a => LabeledStrategy (Context a)
-linearStrategyG =
-   label "Linear Equation" $
-       label "Phase 1" (repeatS (
-               use removeDivision
-          <|>  multi (showId distributeTimes) (somewhere (useC parentNotNegCheck <*> use distributeTimes))
-          <|>  multi (showId merge) (once (use merge))))
-   <*> label "Phase 2" (repeatS (
-              (flipEquationS |> use varToLeft)
-          <|> use (coverUpPlusWith oneVar)
-          <|> use (coverUpMinusLeftWith oneVar)
-          <|> use (coverUpMinusRightWith oneVar)
-          <|> use coverUpTimes
-          <|> use coverUpNegate
-           ))
-   <*> repeatS (once
-          (  use ruleNormalizeRational
-         <|> remove (use ruleNormalizeMixedFraction)
-          ))
-
-------------------------------------------------------------
--- Quadratic equations
-
-quadraticStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))
-quadraticStrategy =
-   cleanUpStrategyAfter (applyTop cleanUpRelations) quadraticStrategyG
-
-quadraticStrategyG :: IsTerm a => LabeledStrategy (Context a)
-quadraticStrategyG =
-   label "Quadratic Equation Strategy" $ repeatS $
-   -- Relaxed strategy: even if there are "nice" factors, allow use of quadratic formula
-      somewhere (generalForm <|> generalABCForm)
-      |> somewhere zeroForm
-      |> somewhere constantForm
-      |> simplifyForm
-      |> topForm
- where
-   -- ax^2 + bx + c == 0, without quadratic formula
-   generalForm = label "general form" $
-          use commonFactorVar
-      <|> use noLinFormula
-      <|> use simplerPolynomial
-      <|> remove (use bringAToOne)
-      <|> use niceFactors
-      <|> use coverUpPower -- to deal with special case x^2=0
-
-   generalABCForm = label "abc form" $
-      useC abcFormula
-
-   zeroForm = label "zero form" $
-      use mulZero
-
-   -- expr == c
-   constantForm = label "constant form" $
-          use (coverUpPlusWith oneVar)
-      <|> use (coverUpMinusLeftWith oneVar)
-      <|> use (coverUpMinusRightWith oneVar)
-      <|> use coverUpTimes
-      <|> use coverUpNegate
-      <|> use coverUpNumerator
-      <|> use squareBothSides
-      <|> use factorLeftAsSquare
-
-   -- simplifies square roots, or do an approximation
-   simplifyForm =
-      label "square root simplification" simplerSquareRootMulti
-      <|>
-      remove (label "approximate result" (
-         multi (showId ruleApproximate) (somewhere (use ruleApproximate))))
-
-   topForm = label "top form" $
-        somewhere (use cancelTerms  <|> use sameFactor)
-      |> (  somewhere (use sameConFactor)
-        <|> multi (showId merge) (somewhere (use merge))
-        <|> somewhere (use distributionSquare)
-        <|> multi (showId distributeTimes) (somewhere
-               (useC parentNotNegCheck <*> use distributeTimes))
-        <|> finalRule distributeDivisionMulti
-        <|> somewhere flipEquationS
-         )
-      |> somewhere (use moveToLeft <|> remove (use prepareSplitSquare))
-
------------------------------------------------------------
--- Higher degree equations
-
-higherDegreeStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))
-higherDegreeStrategy =
-   cleanUpStrategyAfter (applyTop cleanUpRelations) higherDegreeStrategyG
-
-higherDegreeStrategyG :: IsTerm a => LabeledStrategy (Context a)
-higherDegreeStrategyG = label "higher degree" $
-   higherForm
-   <*> label "quadratic"  quadraticStrategyG
-   <*> afterSubst
- where
-   higherForm = label "higher degree form" $ repeatS $
-      somewhere (use allPowerFactors)
-      |> somewhere (
-              use coverUpPower
-          <|> use mulZero
-          <|> use sameFactor
-          <|> use coverUpTimes
-          <|> use exposeSameFactor
-          <|> use (coverUpPlusWith oneVar)
-          <|> use (coverUpMinusLeftWith oneVar)
-          <|> use (coverUpMinusRightWith oneVar)
-          <|> use sameConFactor
-          <|> useC higherSubst)
-      |> somewhere (use moveToLeft)
-
-   afterSubst = label "afterwards" $ try $
-      useC substBackVar  <*> repeatS (somewhere (use coverUpPower))
-
------------------------------------------------------------
--- Finding factors in an expression
-
-findFactorsStrategy :: LabeledStrategy (Context Expr)
-findFactorsStrategy = cleanUpStrategyAfter (applyTop cleanUpSimple) $
-   label "find factors" $ repeatS findFactorsStrategyG
-
-findFactorsStrategyG :: IsTerm a => LabeledStrategy (Context a)
-findFactorsStrategyG = label "find factor step" $
-   somewhereTimes $
-      use niceFactorsNew <|> use commonFactorVarNew
-      <|> use factorVariablePower <|> use simplerLinearFactor
-
-somewhereTimes :: IsStrategy f => f (Context a) -> Strategy (Context a)
-somewhereTimes = somewhereWith "SomewhereTimes" $ \c ->
-   if isTimesC c then [0 .. arity c-1] else []
-
-isTimesC :: Context a -> Bool
-isTimesC = maybe False (isJust . isTimes :: Term -> Bool) . currentT
-
-flipEquationS :: IsTerm a => Strategy (Context a)
-flipEquationS = use conditionVarsRHS <*> use flipEquation
-
------------------------------------------------------------
--- Expanding factors of an expression
-
-expandStrategy :: LabeledStrategy (Context Expr)
-expandStrategy = cleanUpStrategyAfter (applyTop f . change g) $
-   label "expand factors" $ repeatS (somewhere $
-      use distributionSquare <|> use merge <|> use distributeTimes <|>
-      use defPowerNat <|> use noDivisionConstant <|> use fractionProduct)
-   <*>
-      try (use ruleNormalizePolynomial)
- where -- mergeAlike
-   f = transform (simplify (listOfPowerFactors "x" rationalView))
-     -- . cleanUpSimple
-   g = simplify (polyRelaxedForm rationalView)
− src/Domain/Math/Polynomial/Tests.hs 
@@ -1,23 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.Tests (tests) where
-
-import Common.Algebra.Field
-import Common.Algebra.Law
-import Common.Utils.TestSuite
-import Control.Monad
-import Domain.Math.Data.Polynomial
-
-tests :: TestSuite
-tests = suite "Polynomial is a commutative ring" $
-   forM_ (commutativeRingLaws :: [Law (SafeNum (Polynomial Int))]) $ \p ->
-      addProperty (show p) p
− src/Domain/Math/Polynomial/Views.hs 
@@ -1,334 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Polynomial.Views
-   ( polyView, polyViewWith
-   , quadraticView, quadraticViewWith --, quadraticViewFor quadraticViewForWith
-   , linearView, linearViewWith -- linearViewFor linearViewForWith
-   , constantPolyView, linearPolyView, quadraticPolyView, cubicPolyView
-   , monomialPolyView, binomialPolyView, trinomialPolyView
-   , polyNormalForm, polyRelaxedForm
-   , linearEquationView, quadraticEquationView, quadraticEquationsView
-   , higherDegreeEquationsView, listOfPowerFactors
-   ) where
-
-import Common.Classes
-import Common.Rewriting
-import Common.Utils (distinct)
-import Common.Utils.Uniplate (transform, descend, children)
-import Common.View
-import Control.Monad
-import Data.Foldable (foldMap, toList)
-import Data.Maybe
-import Data.Traversable (mapM)
-import Domain.Math.CleanUp
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Polynomial
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Power.OldViews (powerFactorViewForWith)
-import Domain.Math.SquareRoot.Views
-import Prelude hiding ((^))
-import qualified Domain.Math.Data.SquareRoot as SQ
-import qualified Prelude
-
-polyViewWithNew :: View (String, Expr) (String, Polynomial Expr)
-polyViewWithNew = makeView matchPoly buildPoly
- where
-   matchPoly (s, expr) = liftM ((,) s) (matchPolyFor s expr)
-   buildPoly (s, p)    = (s, buildPolyFor s p)
-
-   matchPolyFor pv expr =
-      case expr of
-         Var s | pv == s -> Just var
-         Nat n    -> Just (fromIntegral n)
-         Negate a -> liftM negate (f a)
-         a :+: b  -> liftM2 (+) (f a) (f b)
-         a :-: b  -> liftM2 (-) (f a) (f b)
-         a :*: b  -> liftM2 (*) (f a) (f b)
-         a :/: b  -> do
-            guard (withoutVar pv b)
-            p <- f a
-            d <- match rationalView b
-            guard (d /= 0)
-            return (fmap (/fromRational d) p)
-         Sym s [a, n] | isPowerSymbol s ->
-           liftM2 (Prelude.^) (f a) (matchNat n)
-         _ -> do
-            guard (withoutVar pv expr)
-            return (con expr)
-    where
-      f = matchPolyFor pv
-
-   buildPolyFor pv =
-      let f (a, n) = a .*. (Var pv .^. fromIntegral n)
-      in build sumView . map f . reverse . terms
-
-   matchNat expr = do
-      n <- match integerView expr
-      guard (n >= 0)
-      return n
-
--------------------------------------------------------------------
--- Polynomial view
-
-polyView :: View Expr (String, Polynomial Expr)
-polyView = (f <-> snd) >>> polyViewWithNew
- where
-   f a = (fromMaybe "" (selectVar a), a)
-
-polyViewWith :: Fractional a => View Expr a -> View Expr (String, Polynomial a)
-polyViewWith v = polyView >>> second (traverseView v)
-
--------------------------------------------------------------------
--- Quadratic view
-
-quadraticView :: View Expr (String, Expr, Expr, Expr)
-quadraticView = quadraticViewWith identity
-
-quadraticViewWith :: Fractional a => View Expr a -> View Expr (String, a, a, a)
-quadraticViewWith v = polyViewWith v >>> second quadraticPolyView >>> (f <-> g)
- where
-   f (s, (a, b, c)) = (s, a, b, c)
-   g (s, a, b, c)   = (s, (a, b, c))
-
--------------------------------------------------------------------
--- Linear view
-
-linearView :: View Expr (String, Expr, Expr)
-linearView = linearViewWith identity
-
-linearViewWith :: Fractional a => View Expr a -> View Expr (String, a, a)
-linearViewWith v = polyViewWith v >>> second linearPolyView >>> (f <-> g)
- where
-   f (s, (a, b)) = (s, a, b)
-   g (s, a, b)   = (s, (a, b))
-
--------------------------------------------------------------------
--- Views on polynomials (degree)
-
-constantPolyView :: Num a => View (Polynomial a) a
-constantPolyView = makeView (isList1 . polynomialList) (buildList . list1)
-
-linearPolyView :: Num a => View (Polynomial a) (a, a)
-linearPolyView = makeView (isList2 . polynomialList) (buildList . list2)
-
-quadraticPolyView :: Num a => View (Polynomial a) (a, a, a)
-quadraticPolyView = makeView (isList3 . polynomialList) (buildList . list3)
-
-cubicPolyView :: Num a => View (Polynomial a) (a, a, a, a)
-cubicPolyView = makeView (isList4 . polynomialList) (buildList . list4)
-
--------------------------------------------------------------------
--- Views on polynomials (number of terms)
-
-monomialPolyView :: Num a => View (Polynomial a) (a, Int)
-monomialPolyView = makeView (isList1. terms) (buildPairs . list1)
-
-binomialPolyView :: Num a => View (Polynomial a) ((a, Int), (a, Int))
-binomialPolyView = makeView (isList2 . terms) (buildPairs . list2)
-
-trinomialPolyView :: Num a => View (Polynomial a) ((a, Int), (a, Int), (a, Int))
-trinomialPolyView = makeView (isList3 . terms) (buildPairs . list3)
-
--- helpers
-buildList :: Num a => [a] -> Polynomial a
-buildList = buildPairs . flip zip [0..] . reverse
-
-buildPairs :: Num a => [(a, Int)] -> Polynomial a
-buildPairs as
-   | null as   = 0
-   | otherwise = sum (map f as)
- where
-   f (a, n) = con a * var Prelude.^ n
-
-polynomialList :: Num a => Polynomial a -> [a]
-polynomialList p = map (`coefficient` p) [d, d-1 .. 0]
- where d = degree p
-
-list1 :: a -> [a]
-list1 a = [a]
-
-list2 :: (a, a) -> [a]
-list2 (a, b)     = [a, b]
-
-list3 :: (a, a, a) -> [a]
-list3 (a, b, c) = [a, b, c]
-
-list4 :: (a, a, a, a) -> [a]
-list4 (a, b, c, d) = [a, b, c, d]
-
-isList1 :: [a] -> Maybe a
-isList1 [a] = Just a
-isList1 _   = Nothing
-
-isList2 :: [a] -> Maybe (a, a)
-isList2 [a, b] = Just (a, b)
-isList2 _      = Nothing
-
-isList3 :: [a] -> Maybe (a, a, a)
-isList3 [a, b, c] = Just (a, b, c)
-isList3 _         = Nothing
-
-isList4 :: [a] -> Maybe (a, a, a, a)
-isList4 [a, b, c, d] = Just (a, b, c, d)
-isList4 _            = Nothing
-
--------------------------------------------------------------------
--- Normal form, and list of power factors
-
-listOfPowerFactors :: Num a => String -> View Expr a -> View Expr [(a, Int)]
-listOfPowerFactors pv v =
-   toView sumView >>> listView (powerFactorViewForWith pv v)
-
--- Generalization
-polyForm :: Num a => Bool -> View Expr a -> View Expr (String, Polynomial a)
-polyForm relaxed v = makeView f (uncurry g)
- where
-   f e = do
-      pv <- selectVar e
-      xs <- match (listOfPowerFactors pv v) e
-      guard (relaxed || distinct (map snd xs))
-      return (pv, buildPairs xs)
-   g pv = build (listOfPowerFactors pv v) . reverse . terms
-
-polyNormalForm :: Num a => View Expr a -> View Expr (String, Polynomial a)
-polyNormalForm = polyForm False
-
--- relaxes the condition that all powers should be distinct
-polyRelaxedForm :: Num a => View Expr a -> View Expr (String, Polynomial a)
-polyRelaxedForm = polyForm True
-
--------------------------------------------------------------------
--- Normal forms for equations
-
--- Excludes equations such as 1==1 or 0==1
-linearEquationViewWith :: Fractional a => View Expr a -> View (Equation Expr) (String, a)
-linearEquationViewWith v = makeView f g
- where
-   f (lhs :==: rhs) = do
-      (x, a, b) <- match (linearViewWith v) (lhs - rhs)
-      return (x, -b/a)
-   g (x, r) = Var x :==: build v r
-
-linearEquationView :: View (Equation Expr) (String, Rational)
-linearEquationView = linearEquationViewWith rationalView
-
-quadraticEquationsView:: View (OrList (Equation Expr)) (OrList (String, SQ.SquareRoot Rational))
-quadraticEquationsView = makeView f (fmap g)
- where
-   f = liftM (simplify orSetView . foldMap id)
-          . Data.Traversable.mapM (match quadraticEquationView)
-
-   g (x, a) = Var x :==: build (squareRootViewWith rationalView) a
-
-quadraticEquationView :: View (Equation Expr) (OrList (String, SQ.SquareRoot Rational))
-quadraticEquationView = makeView f g
- where
-   f (lhs :==: rhs) = do
-      (s, p) <- match (polyViewWith (squareRootViewWith rationalView)) (lhs - rhs)
-      guard (degree p <= 2)
-      liftM (fmap ((,) s)) $
-         case polynomialList p of
-            [a, b, c] -> do
-               discr <- SQ.fromSquareRoot (b*b - SQ.scale 4 (a*c))
-               let sdiscr = SQ.sqrtRational discr
-                   twoA   = SQ.scale 2 a
-               case compare discr 0 of
-                  LT   -> return false
-                  EQ   -> return $ singleton (-b/twoA)
-                  GT   -> return $ toOrList [(-b+sdiscr)/twoA, (-b-sdiscr)/twoA]
-            [a, b]     -> return $ singleton (-b/a)
-            [a] | a==0 -> return true
-            _          -> return false
-
-   g xs | isTrue xs = 0 :==: 0
-        | otherwise = build productView (False, map make (toList xs)) :==: 0
-    where
-      make (x, a) = Var x .-. build (squareRootViewWith rationalView) a
-
-higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr)
-higherDegreeEquationsView = f <-> fmap (:==: 0)
- where
-   f    = simplify orSetView . foldMap make . coverUpOrs
-   make = toOrList . filter (not . hasNegSqrt)
-        . map (cleanUpExpr . distr) . normHDE . sub
-   sub (a :==: b) = a-b
-
-   distr = transform g
-    where
-      g ((a :+: b) :/: c) = (a ./. c) .+. (b ./. c)
-      g ((a :-: b) :/: c) = (a ./. c) .-. (b ./. c)
-      g a = a
-
-hasNegSqrt :: Expr -> Bool
-hasNegSqrt (Sqrt a) =
-   case match rationalView a of
-      Just r | r < 0 -> True
-      _ -> hasNegSqrt a
-hasNegSqrt (Sym s [a, b]) | isRootSymbol s =
-   case (match rationalView a, match integerView b) of
-      (Just r, Just n) | r < 0 && even n -> True
-      _ -> hasNegSqrt a || hasNegSqrt b
-hasNegSqrt a =
-   any hasNegSqrt (children a)
-
-normHDE :: Expr -> [Expr]
-normHDE e =
-   case match (polyViewWith rationalView) e of
-      Just (x, p)  -> normPolynomial x p
-      Nothing -> fromMaybe [e] $ do
-         (x, a) <- match (linearEquationViewWith (squareRootViewWith rationalView)) (e :==: 0)
-         return [ Var x .+. build (squareRootViewWith rationalView) (-a) ]
-
-normPolynomial :: String -> Polynomial Rational -> [Expr]
-normPolynomial x p
-   | degree p == 0 =
-        []
-   | length (terms p) <= 1 =
-        [Var x]
-   | degree p == 1 =
-        [Var x .+. fromRational (coefficient 0 p / coefficient 1 p)]
-   | degree p == 2 =
-        let [a,b,c] = [ coefficient n p | n <- [2,1,0] ]
-            discr   = b*b - 4*a*c
-            sdiscr  = SQ.sqrtRational discr
-        in if discr < 0 then [] else
-           map ((Var x .+.) . build (squareRootViewWith rationalView))
-           [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr)
-           , SQ.scale (1/(2*a)) (SQ.con b - sdiscr)
-           ]
-   | otherwise =
-        case terms p of
-           [(c, 0), (b, e1), (a, e2)] | e1 > 1 && e2 `mod` e1 == 0 ->
-              let list = [(c, 0), (b, 1), (a, e2 `div` e1)]
-                  newp = sum (map (\(y, z) -> con y * (var Prelude.^ z)) list)
-                  sub  = map (substitute (x, Var x^fromIntegral e1))
-              in concatMap normHDE (sub (normPolynomial x newp))
-           [(c, 0), (a, n)]
-              | odd n  -> if c/a >= 0
-                          then [Var x + root (fromRational (c/a)) (fromIntegral n)]
-                          else [Var x - root (fromRational (abs (c/a))) (fromIntegral n)]
-              | even n -> if c/a > 0
-                          then []
-                          else [ Var x + root (fromRational (abs (c/a))) (fromIntegral n)
-                               , Var x - root (fromRational (abs (c/a))) (fromIntegral n)
-                               ]
-           _ ->
-              case factorize p of
-                 ps | length ps > 1 -> concatMap (normPolynomial x) ps
-                 _ -> [build (polyViewWith rationalView) (x, p)]
-
-substitute :: (String, Expr) -> Expr -> Expr
-substitute (s, a) (Var b) | s==b = a
-substitute pair expr = descend (substitute pair) expr
− src/Domain/Math/Power/Equation/Examples.hs 
@@ -1,356 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Example exercises from the Digital Mathematics Environment (DWO),
--- see: http://www.fi.uu.nl/dwo/gr/frameset.html.
---
------------------------------------------------------------------------------
-module Domain.Math.Power.Equation.Examples
-   ( powerEquations, expEquations, logEquations, higherPowerEquations
-   , rootEquations, rootEquations2, rootSubstEquations, expEquations2
-   ) where
-
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Prelude hiding ((^))
-
-----------------------------------------------------------
--- HAVO B applets
-
--- Hoofdstuk 7, vergelijkingen met machten algebraisch (6)
-powerEquations :: [[Equation Expr]]
-powerEquations =
-  -- los vergelijkingen algebraisch op
-  let x = Var "x" in
-  [ [ x^14 :==: 25
-    , x^(-7) :==: 110
-    , 2*x^3.5 :==: 70
-    , 8*x^(-9.2) :==: 1000
-    ]
-  , [ root x 5 :==: 2.9
-    , 5 * root x 3 :==: 7
-    , root (x^3) 4 :==: 720
-    , root (x^2) 5 :==: 5.5
-    ]
-  , [ 4*x^(-12) :==: 28
-    , 7*x^5.1 + 16 :==: 100
-    , 8*x^(-1.9) - 5 :==: 2
-    , 0.8 * x^0.7 + 7 :==: 12.5
-    ]
-  , [ 4*root x 7 + 7 :==: 11.8
-    , 9*x^3.2+17 :==: 37
-    , 6*x^(-3.1)-9 :==: 12
-    , 0.7 * x^(-1.1) + 17 :==: 40
-    ]
-  ]
-
--- Hoofdstuk 7, exponentiele vergelijkingen algebraisch (7)
-expEquations :: [[Equation Expr]]
-expEquations =
-  -- los exponentiele vergelijkingen algebraisch op
-  let x = Var "x" in
-  [ [ 2^x :==: 16 * sqrt 2
-    , 2^(x+2) :==: 1/4
-    , 3^(x-1) :==: 81
-    , 3^(x+5) :==: 243/sqrt 3
-    ]
-  , [ 5^(2-x) :==: 0.04
-    , 3^(2*x) :==: 1/9
-    , 3^(1-3*x) :==: 81
-    , 3^(3*x-2) :==: 3*sqrt 3
-    ]
-  , [ 5*2^(x-1) :==: 20*sqrt 2
-    , 6*5^(2-x) :==: 150
-    , 2*7^(4*x-1) :==: 98
-    , 8*3^(5-2*x) :==: 72*sqrt 3
-    ]
-  , [ 2^x-7 :==: 9
-    , 4^(3*x)+5 :==: 69
-    , 7*3^(2*x+1) :==: 189
-    , 5*2^(1-4*x)+11 :==: 51
-    ]
-  , [ 5^(x-4) :==: (1/5)^(2*x+1)
-    , 7^(1-2*x) :==: 1
-    , 4^(2*x-3) :==: 2*sqrt 2
-    , 2*9^(1-2*x) :==: 6*sqrt 3
-    ]
-  ]
-
--- Hoofdstuk 7, logaritmische vergelijkingen algebraisch (8)
-logEquations :: [[Equation Expr]]
-logEquations =
-  -- los algebraisch op
-  let x = Var "x" in
-  [ [ logBase 2 x :==: 7
-    , logBase 3 (x-2) :==: 2
-    , logBase 4 (x-3) :==: 1+(1/2)
-    , logBase 5 ((1/10)*x-3) :==: -1
-    , logBase x 7 :==: 1
-    , logBase x 4 :==: -1
-    , logBase 2 (x^2-1) :==: 3
-    , logBase (1/3) (1-5*x) :==: -1
-    ]
-  ]
-
-----------------------------------------------------------
--- VWO A/C applets
-
--- Hoofdstuk 5, hogeremachtswortels (1)
-higherPowerEquations :: [[Equation Expr]]
-higherPowerEquations =
-  -- bereken exacte oplossing
-  let x = Var "x" in
-  [ [ 2*x^3+9 :==: 19
-    , 4*x^5-17 :==: 27
-    , 3*x^7+8 :==: 62
-    , 5*x^3-1 :==: 9
-    , 6-5*x^3 :==: 76
-    , 11-7*x^5 :==: 53
-    , 4-(1/5)*x^7 :==: 9
-    , 18-11*x^7 :==: 62
-    ]
-  , [ (1/2)*x^4+5 :==: 12
-    , 5*x^6-37 :==: 68
-    , 4*x^8-19 :==: 9
-    , 5*x^6+7 :==: 97
-    , 18-7*x^4 :==: -38
-    , 3+(1/3)*x^6 :==: 7
-    , 1-(1/9)*x^8 :==: -4
-    , 47+15*x^8 :==: 77
-    ]
-  , [ 18*x^8-11 :==: 7
-    , (1/4)*x^6+14 :==: 30
-    , 5*x^4+67 :==: 472
-    , 5*x^4-1 :==: 4
-    , (1/8)*x^7+24 :==: 40
-    , (1/5)*x^3+27 :==: 52
-    , 32*x^3+18 :==: 22
-    , 4*x^3-8 :==: 100
-    ]
-  , [ 14-2*x^3 :==: 700
-    , 4-3*x^5 :==: 100
-    , 14-11*x^7 :==: 25
-    , 1-3*x^5 :==: 97
-    ]
-    -- Geef in twee decimalen nauwkeurig
-  , [ 3*x^5+7 :==: 15
-    , 0.7 * x^4 - 1.3 :==: 2
-    , (1/3)*x^7 :==: 720
-    ]
-  ]
-
--- Hoofdstuk 5, hogeremachtswortels (2)
-rootEquations :: [[Equation Expr]]
-rootEquations =
-  -- Bereken exacte oplossing
-  let x = Var "x" in
-  let y = Var "y" in
-  [ [ x^4 :==: 6
-    , root x 4 :==: 6
-    , sqrt x :==: 10
-    , root x 5 :==: 2
-    ]
-  , [ 3*x^5-1 :==: 20
-    , 3*root (x-1) 5 - 1 :==: 20
-    , (1/10)*sqrt x + 2 :==: 12
-    , (1/5)*x^7+8 :==: 26
-    ]
-  , [ 3*root x 4+2 :==: 14
-    , (1/2)*x^8-2 :==: 18
-    , 5-2*root x 3 :==: 3
-    ]
-  -- Maak x vrij
-  , [ y :==: x^5
-    , y :==: 2*x^5+4
-    , y :==: (1/10)*x^3-6
-    , y :==: root x 7
-    , y :==: 2*root x 3+8
-    , y :==: (1/10)*root x 5-6
-    ]
-  , [ y :==: 3*root x 7-6
-    , y :==: (1/4)*x^9-6
-    , y :==: 8+(1/2)*root x 3
-    ]
-  ]
-
-----------------------------------------------------------
--- VWO B applets
-
--- Hoofdstuk 1, wortelvergelijkingen
-rootEquations2 :: [[Equation Expr]]
-rootEquations2 =
-  let x = Var "x" in
-  -- los algebraisch op
-  [ [ 5-2*sqrt x :==: 1
-    , 7-3*sqrt x :==: 5
-    , 4-2*sqrt x :==: -3
-    , 6-3*sqrt x :==: 2
-    ]
-  , [ 2*sqrt x :==: x
-    , 2*sqrt x :==: 3*x
-    , x-3*sqrt x :==: 0
-    , 3*x-5*sqrt x :==: 0
-    ]
-  , [ x :==: sqrt (2*x+3)
-    , x :==: sqrt (3*x+10)
-    , x :==: sqrt (4*x+21)
-    , x :==: sqrt (3*x+4)
-    ]
-  , [ 5*x :==: sqrt (50*x+75)
-    , 2*x :==: sqrt (24*x+28)
-    , 3*x :==: sqrt (27*x-18)
-    , 2*x :==: sqrt (28*x-40)
-    , 3*x :==: sqrt (3*x+42)
-    , 5*x :==: sqrt (49*x+2)
-    , 3*x :==: sqrt (10*x-1)
-    , 5*x :==: sqrt (30*x-5)
-    ]
-  , [ x-sqrt x :==: 6
-    , x-4*sqrt x :==: 12
-    , x-sqrt x :==: 12
-    , x-sqrt x :==: 2
-    , 2*x+sqrt x :==: 3
-    , 3*x+4*sqrt x :==: 20
-    , 2*x+sqrt x :==: 15
-    , 2*x-3*sqrt x :==: 27
-    ]
-  ]
-
--- Hoofdstuk 1, wortelvergelijkingen
-rootSubstEquations :: [[Equation Expr]]
-rootSubstEquations =
-  let x = Var "x" in
-  -- los algebraisch op
-  [ [ 8*x^3+1 :==: 9*x*sqrt x
-    , 27*x^3 :==: 28*x*sqrt x-1
-    , x^3+3 :==: 4*x*sqrt x
-    , x^3 :==: 10*x*sqrt x-16
-    ]
-  , [ x^3 :==: 6*x*sqrt x+16
-    , x^3-24*x*sqrt x :==: 81
-    , x^3+x*sqrt x :==: 20
-    , x^3-15 :==: 2*x*sqrt x
-    ]
-  , [ x^5+32 :==: 33*x^2*sqrt x
-    , 243*x^5-244*x^2*sqrt x+1 :==: 0
-    , 32*x^5+31*x^2*sqrt x :==: 1
-    , x^5 :==: 242*x^2*sqrt x+243
-    ]
-  , [ x^5+8 :==: 6*x^2*sqrt x
-    , x^5 :==: 9*x^2*sqrt x-18
-    , x^5 :==: 5*x^2*sqrt x+24
-    , x^5+4*x^2*sqrt x :==:12
-    ]
-  ]
-
--- Hoofdstuk 5, exponentiele vergelijkingen exact oplossen (1, 2, 2a)
-expEquations2 :: [[Equation Expr]]
-expEquations2 =
-  let x = Var "x" in
-  -- los algebraisch op
-  -- 1
-  [ [ 2^(2*x-1) :==: 1/16
-    , 3^(1-x) :==: 81
-    , 5^(1-2*x) :==: 1/5
-    , (1/2)^(4*x-3) :==: 1/4
-    , (1/3)^(5*x+2) :==: 1/3
-    , 6^(3*x-2) :==: 1/216
-    ]
-  , [ 2^(3*x+2) :==: 2*sqrt 2
-    , 3^(2*x+1) :==: 9*sqrt 3
-    , 5^(4*x+3) :==: 625*sqrt 5
-    , (1/2)^(x+1) :==: 4
-    , (1/3)^(x-3) :==: 3
-    , 4^(x+2) :==: 64*root 4 3
-    ]
-  , [ 2^(x+3) :==: (1/2)*root 2 3
-    , 3^(4*x+1) :==: 27
-    , 5^(-x+2) :==: 1/25
-    , (1/2)^(1-x) :==: sqrt 2
-    , (1/3)^(x+1) :==: (1/9)*sqrt 3
-    , 2^(1-3*x) :==: (1/8)*sqrt 2
-    ]
-  , [ 3*2^x+1 :==: 25
-    , 4*3^x-9 :==: 27
-    , 2*5^x+4 :==: 14
-    , 5*(1/2)^x+11 :==: 51
-    , 8*(1/3)^x+27 :==: 99
-    , 3*(1/5)^x-35 :==: 40
-    ]
-  , [ 2^(4*x+3) :==: 1
-    , (1/2)^(2*x-1) :==: 1
-    , 3^(2*x+4) :==: 1
-    , (1/3)^(x-3) :==: 1
-    , 4^(4*x-7) :==: 1
-    , 5^(3*x-6) :==: 1
-    ]
-  -- 2
-  , [ 2^(2*x+1) :==: (1/2)^(x+2)
-    , 4^(2*x-1) :==: 2^(3*x+2)
-    , 2^(5*x-4) :==: 8^(x-3)
-    , (1/4)^(2*x+1) :==: 2^(6-2*x)
-    , (1/3)^(2*x-3) :==: 3^(4*x-3)
-    , 3^(3*x-2) :==: 9^(2-x)
-    , 27^(2*x+1) :==: 3^(2*x-5)
-    , 3^(5*x-1) :==: (1/9)^(2*x-1)
-    ]
-  , [ 6^(7*x-3) :==: 36^(2*x+3)
-    , (1/7)^(2*x-1) :==: 7^(2*x-7)
-    , 5^(5-2*x) :==: (1/5)^(x+2)
-    , 25^(4*x+1) :==: 5^(5*x-4)
-    , 3^(x^2) :==: (1/3)^(2*x)
-    , (1/2)^(x^2) :==: 2^(2*x)
-    , 5^(x^2) :==: 25^(3*x)
-    , 2^(x^2) :==: (1/8)^(-x)
-    ]
-  , [ (1/2)^(2-2*x) :==: 4^(3*x+5)
-    , 8^(x+1) :==: (1/2)^(x+7)
-    , (1/4)^(x+2) :==: 8^(2*x-1)
-    , 8^(2*x-3) :==: 16^(2*x+3)
-    , (1/3)^(x-2) :==: 9^(x+4)
-    , 9^(2*x-1) :==: 27^(2*x-1)
-    , (1/9)^(x+3) :==: 27^(2*x+2)
-    , 27^(3-2*x) :==: (1/3)^(4*x+3)
-    ]
-  , [ 4*2^x :==: 2^(3*x-2)
-    , 2^(5*x-9) :==: (1/8)*2^x
-    , 3^(4*x+6) :==: 27*3^x
-    , (1/9)*3^x :==: 3^(2-3*x)
-    , 3*3^x :==: (1/3)^(2*x+5)
-    , 4^(x+1) :==: 8*2^x
-    , (1/2)*2^x :==: (1/2)^x
-    , 9^(x+2) :==: (1/3)*3^x
-    ]
-  , [ (1/5)*5^(3*x-2) :==: 25^(x+1)
-    , 9*3^(2*x+1) :==: (1/3)^(4*x-3)
-    , 4^(3*x-5) :==: 8*2^(x+2)
-    , (1/2)^(3-2*x) :==: (1/4)*2^(3*x-4)
-    , 2^(x+2)+2^x :==: 40
-    , 2^(x+4) :==: 3/4+2^(x+2)
-    , 2^(x-2)+2^(x+1) :==: 9
-    , 2^(x+5)-2^(x+4) :==: 16
-    ]
-  -- 2a
-  , [ 3^(x+2) :==: 72+3^x
-    , 3^(x-1)+3^(x+1) :==: 10
-    , 3^(x+3)+3^(x+2) :==: 12
-    , 3^x-3^(x-1) :==: 54
-    ]
-  , [ 5^(x+1)+5^x :==: 150
-    , 5^(x+1) :==: 100+5^x
-    , 5^(x+2)+5^x :==:1+1/25
-    , 5^(x+1)+5^(x+2) :==: 30
-    ]
-  , [ 2^(x+4)-2^(x-2) :==: 63*sqrt 2
-    , 3^(x-1)+3^x :==: 12*sqrt 3
-    , 5^x-5^(x-1) :==: 4*sqrt 5
-    , 2^(x+2)+2^(x-3) :==: 66*sqrt 2
-    ]
-  ]
− src/Domain/Math/Power/Equation/Exercises.hs 
@@ -1,114 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Power.Equation.Exercises
-   ( powerEqExercise
-   , expEqExercise
-   , logEqExercise
-   , higherPowerEqExercise
-   , rootEqExercise
-   ) where
-
-import Prelude hiding ( (^) )
-
-import Common.Library
-import Data.Function (on)
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.Views
-import Domain.Math.Expr hiding (isPower)
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Views
-import Domain.Math.Power.Equation.Examples
-import Domain.Math.Power.Equation.NormViews
-import Domain.Math.Power.Equation.Strategies
-import Domain.Math.Power.Rules
-import Domain.Math.Power.Utils (sortOrList)
-
-------------------------------------------------------------
--- Exercises
-
-powerEqExercise :: Exercise (Relation Expr)
-powerEqExercise = let precision = 2 in makeExercise
-  { status         = Provisional
-  , parser         = parseRelExpr
-  , strategy       = powerEqApproxStrategy
-  , navigation     = termNavigator
-  , exerciseId     = describe "solve power equation algebraically with x > 0" $
-                       newId "algebra.manipulation.exponents.equation"
-  , examples       = level Medium $ concatMap (map $ build equationView) $
-                       powerEquations ++ [last higherPowerEquations]
-  , ready          = predicateView relationSolvedForm
-  , suitable       = predicateView (normPowerEqApproxView precision)
-  , equivalence    = withoutContext (viewEquivalent (normPowerEqApproxView precision))
-  }
-
-expEqExercise :: Exercise (Equation Expr)
-expEqExercise = makeExercise
-  { status         = Provisional
-  , parser         = parseEqExpr
-  , strategy       = expEqStrategy
-  , navigation     = termNavigator
-  , exerciseId     = describe "solve exponential equation algebraically" $
-                       newId "algebra.manipulation.exponential.equation"
-  , examples       = level Medium $ concat expEquations
-  , ready          = predicate $ \ rel -> isVariable (leftHandSide rel)
-                           && rightHandSide rel `belongsTo` rationalView
-  , suitable       = predicateView normExpEqView
-  , equivalence    = withoutContext (viewEquivalent normExpEqView)
-  , ruleOrdering   = ruleOrderingWithId [getId root2power]
-  }
-
-logEqExercise :: Exercise (OrList (Relation Expr))
-logEqExercise = makeExercise
-  { status         = Provisional
-  , parser         = parseOrsRelExpr
-  , strategy       = logEqStrategy
-  , navigation     = termNavigator
-  , exerciseId     = describe "solve logarithmic equation algebraically" $
-                       newId "algebra.manipulation.logarithmic.equation"
-  , examples       = level Medium $ map (singleton . build equationView) (concat logEquations)
-  , ready          = predicateView relationsSolvedForm
-  , suitable       = predicateView (traverseView equationView >>> normLogEqView)
-  , equivalence    = withoutContext (viewEquivalent (traverseView equationView >>> normLogEqView))
-  , ruleOrdering   = ruleOrderingWithId [getId calcPower]
-  }
-
-higherPowerEqExercise :: Exercise (OrList (Equation Expr))
-higherPowerEqExercise = makeExercise
-  { status         = Provisional
-  , parser         = parseOrsEqExpr
-  , strategy       = higherPowerEqStrategy
-  , navigation     = termNavigator
-  , exerciseId     = describe "solve higher power equation algebraically" $
-                       newId "algebra.manipulation.exponents.equation"
-  , examples       = level Medium $ map singleton $ concat $
-                       higherPowerEquations ++ take 3 rootEquations
-  , ready          = predicateView relationsSolvedForm
-  , suitable       = predicateView (traverseView normPowerEqView)
-  , equivalence    = withoutContext (viewEquivalent (normPowerEqView' hasSomeVar >>> higherDegreeEquationsView))
-  , ruleOrdering   = ruleOrderingWithId [getId calcPower]
-  }
-
-rootEqExercise :: Exercise (OrList (Equation Expr))
-rootEqExercise = makeExercise
-  { status         = Provisional
-  , parser         = parseOrsEqExpr
-  , strategy       = rootEqStrategy
-  , navigation     = termNavigator
-  , exerciseId     = describe "solve higher power equation algebraically" $
-                       newId "algebra.manipulation.exponents.equation"
-  , examples       = level Medium $ map singleton $ concat $ drop 3 rootEquations
-  , ready          = predicateView relationsSolvedForm
-  , suitable       = predicateView (traverseView normPowerEqView)
-  , equivalence    = withoutContext (on (==) (sortOrList . simplify (normPowerEqView' $ elem "x" . vars)))
-  , ruleOrdering   = ruleOrderingWithId [getId calcPower]
-  }
− src/Domain/Math/Power/Equation/NormViews.hs 
@@ -1,204 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Power.Equation.NormViews
-   ( normPowerEqApproxView, normExpEqView, normLogEqView
-   , normPowerEqView, normPowerEqView'
-   ) where
-
-import Common.Rewriting hiding (rewrite)
-import Common.Utils.Uniplate
-import Common.View
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Data.Ratio
-import Domain.Math.Approximation
-import Domain.Math.CleanUp
-import Domain.Math.Data.OrList
-import Domain.Math.Data.PrimeFactors
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.Views
-import Domain.Math.Power.NormViews
-import Domain.Math.Power.Utils
-import Domain.Math.Power.Views
-import Domain.Math.Simplification hiding (simplify, simplifyWith)
-import Prelude hiding ((^))
-import qualified Data.Traversable as T
-import qualified Prelude
-
-normPowerEqApproxView :: Int -> View (Relation Expr) (Expr, Expr)
-normPowerEqApproxView d = makeView f (uncurry (.~=.))
-   where
-     f rel = case relationType rel of
-      EqualTo       -> fmap (second (simplifyWith (precision d) doubleView))
-                     $ match (equationView >>> normPowerEqView) rel
-      Approximately -> return (leftHandSide rel, rightHandSide rel)
-      _             -> Nothing
-
-normPowerEqView :: View (Equation Expr) (Expr, Expr) -- with x>0!
-normPowerEqView = makeView f (uncurry (:==:))
-  where
-    f expr = do
-      -- selected var to the left, the rest to the right
-      (lhs :==: rhs) <- varLeft hasSomeVar expr >>= constRight hasSomeVar
-      -- match power
-      let simpl   = simplify normPowerView lhs
-          (c, ax) = fromMaybe (1, simpl) (match timesView simpl)
-          (a, x)  = fromMaybe (simpl, 1) $
-             match powerView ax
-           `mplus` do
-             (h, k) <- match rootView ax
-             return (h, 1 ./. k)
-      -- simplify, scale and take root
-      guard $ c /= 0 && x /= 0
-      let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x)
-      return (a, simplify rationalView y)
-
-normPowerEqView' :: (Expr -> Bool) -> View (OrList (Equation Expr)) (OrList (Equation Expr))
-normPowerEqView' isVar = makeView f id
-  where -- general clean up, write root as power, try to simplify powers
-    f = fmap ( fmap (fmap (cleanUpExpr . root2power . simplerPower))
-             . catOrList
-             )
-      . T.mapM takeRoot'   -- power to left and take root
-
-    root2power (Sym s [x, y])
-       | isRootSymbol s = x .^. (1 ./. y)
-    root2power expr = expr
-
-    takeRoot' expr = do
-      -- selected var to the left, the rest to the right
-      (lhs :==: rhs) <- varLeft isVar expr >>= constRight isVar
-      -- match power
-      (c, (a, x))    <- match unitPowerView lhs
-      -- simplify, scale and take root
-      let rhs' = simplify rationalView $ cleanUpExpr $ rhs ./. c
-      y <- maybe (Just [rhs' .^. (1 ./. x)]) (tr rhs') $ match integerView x
-      return $ toOrList $ map (a :==:) y
-
-tr :: Expr -> Integer -> Maybe [Expr]
-tr n x | odd x     = case n of
-                       Negate n' -> Just [neg (n' .^. (1 ./. x'))]
-                       _         -> Just [n .^. (1 ./. x')]
-       | otherwise = case n of
-                       Negate _ -> Nothing
-                       _        -> Just $ let e = n .^. (1 ./. x') in [e, neg e]
-  where x' = fromInteger x
-
-constRight :: (Expr -> Bool) -> Equation Expr -> Maybe (Equation Expr)
-constRight isVar (lhs :==: rhs) = do
-  (vs, cs) <- fmap (partition isVar) (match sumView lhs)
-  let rhs' = rhs .+. build sumView (map neg cs)
-  return $ negateEq $ build sumView vs :==: simplifyWith mergeAlikeSum sumView rhs'
-
-negateEq :: Equation Expr -> Equation Expr
-negateEq (lhs :==: rhs) =
-  case lhs of
-    Negate lhs' -> lhs' :==: neg rhs
-    _           -> lhs  :==: rhs
-
-varLeft :: (Expr -> Bool) -> Equation Expr -> Maybe (Equation Expr)
-varLeft isVar (lhs :==: rhs) = do
-  (vs, cs) <- fmap (partition isVar) (match sumView rhs)
-  return $ lhs .+. build sumView (map neg vs) :==: build sumView cs
-
-scaleLeft :: Equation Expr -> Maybe (Equation Expr)
-scaleLeft (lhs :==: rhs) =
-  match timesView lhs >>= \(c, x) -> return $
-    x :==: simplifyWith (second mergeAlikeProduct) productView (rhs ./. c)
-
-normExpEqView :: View (Equation Expr) (String, Rational)
-normExpEqView = makeView f id >>> linearEquationView
-  where
-    try g a = fromMaybe a $ g a
-    f e = do
-      let (l :==: r) = try scaleLeft $ try (constRight hasSomeVar) e
-      return $ case match powerView l of
-        Just (b, x) -> x :==: simplify normLogView (logBase b r)
-        Nothing     -> l :==: r
-
-normLogEqView :: View (OrList (Equation Expr)) (OrList (Equation Expr))
-normLogEqView = makeView (liftM g . T.mapM f) id
-  where
-    f expr@(lhs :==: rhs) = return $
-      case match logView lhs of
-        Just (b, x) -> x :==: b .^. rhs
-        Nothing     -> expr
-    g = simplify orSetView . fmap (fmap cleaner) . simplify (normPowerEqView' hasSomeVar)
-      . simplify higherDegreeEquationsView
-
-    -- Quick fix: 4^(3/2) should be simplified to sqrt (4^3), which is 8
-    cleaner = cleanUpExpr . transform h . cleanUpExpr
-    h expr@(Sym s [a, b]) | isPowerSymbol s =
-       case (match rationalView a, match rationalView b) of
-          (Just x, Just y) | denominator y /= 1 ->
-             root (fromRational (x Prelude.^ numerator y)) (fromInteger $ denominator y)
-          _ -> expr
-    h expr = expr
-
-normLogView :: View Expr Expr
-normLogView = makeView g id
-  where
-    g expr =
-      case expr of
-        Sym s [x, y]
-          | isLogSymbol s -> do
-              b <- match integerView x
-              let divExp (be, n) = return $ f be y ./. fromInteger n
-              maybe (Just $ f b y) divExp $ greatestPower b
-          | otherwise -> Nothing
-        _ -> Nothing
-    f b expr=
-      case expr of
-        Nat 1         -> 0
-        Nat n
-          | n == b    -> 1
-          | otherwise -> maybe (logBase (fromInteger b) (fromInteger n)) fromInteger
-                       $ lookup b (allPowers n)
-        e1 :*: e2 -> f b e1 .+. f b e2
-        e1 :/: e2 -> f b e1 .-. f b e2
-        Sqrt e    -> f b (e .^. (1 ./. 2))
-        Negate e  -> Negate $ f b e
-        Sym s [x,y]
-          | isPowerSymbol s -> y .*. f b x
-          | isRootSymbol  s -> f b (x .^. (1 ./. y))
-        _         -> expr
-
-simplerPower :: Expr -> Expr
-simplerPower expr =
-   case expr of
-     Sqrt x -> x ^ (1/2)
-     Sym s [x, y]
-       | isRootSymbol s  -> x ^ (1/y)
-       | isPowerSymbol s -> f x y
-     _ -> expr
- where
-   f x y
-      | y == 0 = 1
-      | y == 1 = x
-      | x == 0 = 0
-      | otherwise = fromMaybe expr $
-           -- geheel getal
-           liftM fromRational (match rationalView expr)
-         `mplus` do
-           -- breuk
-           ry <- match rationalView y
-           rx <- match rationalView x
-           guard $ denominator rx == 1 && denominator ry /= 1
-           fmap fromInteger $
-              takeRoot (numerator rx Prelude.^ numerator ry) (denominator ry)
-         `mplus` do
-           -- (a/b)^y -> a^y/b^y
-           (a, b) <- match divView x
-           return $ build divView (a .^. y, b .^. y)
− src/Domain/Math/Power/Equation/Rules.hs 
@@ -1,136 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Domain.Math.Power.Equation.Rules
-  -- ( -- * Power equation rules
-  --   commonPower, nthRoot, sameBase, equalsOne, greatestPower
-  -- , approxPower, reciprocalFor, coverUpRootWith, coverUpRoot
-  -- )
-  where
-
-import Common.Library hiding (simplify)
-import Control.Monad
---import Data.List (partition)
-import Domain.Math.Approximation (precision)
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import qualified Domain.Math.Data.PrimeFactors as PF
---import Domain.Math.CleanUp (collectLikeTerms)
-import Domain.Math.Polynomial.Rules (distributeTimes, distributeDivisionT)
-import Domain.Math.Power.Utils
-import Domain.Math.Power.Views
-import Domain.Math.Simplification (simplify)
-
--- | Identifier prefix --------------------------------------------------------
-
-powereq :: String
-powereq = "algebra.manipulation.exponents.equation"
-
--- | Power relation rules -----------------------------------------------------
-
--- | a^x = b^y  =>  a^(x/c) = b^(y/c)  where c = gcd x y
-commonPower :: Rule (Equation Expr)
-commonPower = makeSimpleRule (powereq, "common-power") $ \expr -> do
-  let v = eqView (powerView >>> second integerView)
-  ((a, x), (b, y)) <- match v expr
-  let c = gcd x y
-  guard $ c > 1
-  return $ build v ((a, x `div` c), (b, y `div` c))
-
--- | a^x = n  =>  a^x = b^e
-greatestPower :: Rule (Equation Expr)
-greatestPower = makeSimpleRule (powereq, "greatest-power") $ \(lhs :==: rhs) -> do
-  n      <- match integerView rhs
-  (_, x) <- match (powerView >>> second integerView) lhs
-  (b, e) <- PF.greatestPower n
-  guard $ gcd x e > 1
-  return $ lhs :==: fromInteger b .^. fromInteger e
-
--- a^x = c*b^y  =>  a = c*b^(y/x)
-nthRoot :: Rule (Equation Expr)
-nthRoot = makeSimpleRule (powereq, "nth-root") $ \(lhs :==: rhs) -> do
-  guard $ hasSomeVar lhs
-  (a, x)      <- match powerView lhs
-  (c, (b, y)) <- match unitPowerView rhs
-  return $ a :==: build unitPowerView (c, (b, simplify (y ./. x)))
-
--- x = a^x  =>  x ~= d
-approxPower :: Rule (Relation Expr)
-approxPower = makeRule (powereq, "approx-power") $ approxPowerT 2
-
--- x = a^x  =>  x ~= d
-approxPowerT :: Int -> Transformation (Relation Expr)
-approxPowerT n = makeTrans $ \ expr ->
-  match equationView expr >>= f
-  where
-    f (Var x :==: d) =
-      match doubleView d >>= Just . (Var x .~=.) . fromDouble . precision n
-    f (d :==: Var x) =
-      match doubleView d >>= Just . (.~=. Var x) . fromDouble . precision n
-    f _              = Nothing
-
--- a^x = a^y  =>  x = y
-sameBase :: Rule (Equation Expr)
-sameBase = makeSimpleRule (powereq, "same-base") $ \ expr -> do
-  ((a, x), (b, y)) <- match (eqView powerView) expr
-  guard $ a == b
-  return $ x :==: y
-
--- | c*a^x = d*(1/a)^y  => c*a^x = d*a^-y
-reciprocalFor :: Rule (Equation Expr)
-reciprocalFor = makeSimpleRule (powereq, "reciprocal-for-base") $
-  \ (lhs :==: rhs) -> do
-    (_, (a,  _)) <- match unitPowerView lhs
-    (one, _)     <- match divView rhs
-    (d, (a'', y)) <- match consPowerView rhs
-    guard $ one == 1 && a'' == a
-    return $ lhs :==: d .*. a'' .^. negate y
-
--- | a^x = 1  =>  x = 0
-equalsOne :: Rule (Equation Expr)
-equalsOne = makeSimpleRule (powereq, "equals-one") $ \ (lhs :==: rhs) -> do
-  guard $ rhs == 1
-  (_, x) <- match powerView lhs
-  return $ x :==: 0
-
------------------------ Move these funcs to right place ----------------------
-
--- add these two functions to coverUpRules?
-coverUpRootWith :: ConfigCoverUp -> Rule (Equation Expr)
-coverUpRootWith = coverUpBinaryRule "root" (isBinary rootSymbol) (.^.)
-
-coverUpRoot :: Rule (Equation Expr)
-coverUpRoot = coverUpRootWith configCoverUp
-
--- | Negations are pushed inside
-myCoverUpTimesWith :: ConfigCoverUp -> Rule (Equation Expr)
-myCoverUpTimesWith = doAfter f . coverUpTimesWith
- where
-   f (lhs :==: rhs) =
-      lhs :==: applyD distributeDivisionT (applyD distributeTimes rhs)
-
-condXisRight :: Rule (Equation Expr)
-condXisRight = describe "flip condition" $ checkRule $ \(lhs :==: rhs) ->
-   hasVar "x" rhs && withoutVar "x" lhs
-
---xToLeft = makeRule (powereq, "x -to-left") $  toLeftRightT $ elem "x" . vars
-
--- toLeftRightT :: (Expr -> Bool) -> Transformation (Equation Expr)
--- toLeftRightT p = makeTrans $
---   \ (lhs :==: rhs) -> do
---     (xs, cs) <- fmap (partition p) (match sumView lhs)
---     (ys, ds) <- fmap (partition p) (match sumView rhs)
---     guard $ length cs > 0 || length ys > 0
---     return $ fmap collectLikeTerms $
---       build sumView (xs ++ map neg ys) :==: build sumView (ds ++ map neg cs)
− src/Domain/Math/Power/Equation/Strategies.hs 
@@ -1,135 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Domain.Math.Power.Equation.Strategies
-   -- ( powerEqStrategy
-   -- , powerEqApproxStrategy
-   -- , expEqStrategy
-   -- , logEqStrategy
-   -- , higherPowerEqStrategy
-   -- )
-   where
-
-import Common.Library
-import Data.Maybe
-import Domain.Math.CleanUp
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules
-import Domain.Math.Expr
-import Domain.Math.Numeric.Rules
-import Domain.Math.Polynomial.Rules (flipEquation, conditionVarsRHS)
-import Domain.Math.Polynomial.Strategies (quadraticStrategy, linearStrategy)
-import Domain.Math.Power.Equation.Rules
-import Domain.Math.Power.Rules
-import Domain.Math.Power.Utils
-
--- | Strategies ---------------------------------------------------------------
-
-powerEqStrategy :: IsTerm a => LabeledStrategy (Context a)
-powerEqStrategy = cleanUpStrategy clean strat
-  where
-    strat =  label "Power equation" $ repeatS
-          $  myCoverUpStrategy
-         <*> option (use greatestPower <*> use commonPower)
-         <*> use nthRoot
-         <*> remove (label "useApprox" $ try $ use approxPower)
-
-    clean = applyD $ exhaustiveUse rules
-    rules = onePower : fractionPlus : naturalRules ++ rationalRules
-
-powerEqApproxStrategy :: LabeledStrategy (Context (Relation Expr))
-powerEqApproxStrategy = label "Power equation with approximation" $
-  configureNow (configure cfg powerEqStrategy)
-    where
-      cfg = [ (byName (newId "useApprox"), Reinsert) ]
-
-expEqStrategy :: LabeledStrategy (Context (Equation Expr))
-expEqStrategy = cleanUpStrategy cleanup strat
-  where
-    strat =  label "Exponential equation"
-          $  myCoverUpStrategy
-         <*> repeatS (somewhereNotInExp (use factorAsPower))
-         <*> repeatS (somewhereNotInExp (use reciprocal))
-         <*> powerS
-         <*> (use sameBase <|> use equalsOne)
-         <*> linearStrategy
-
-    cleanup = applyD (exhaustiveUse $ naturalRules ++ rationalRules)
-            . applyTop (fmap (mergeConstantsWith isIntRatio))
-
-    isIntRatio x = x `belongsTo` myIntegerView || x `belongsTo` v
-      where v = divView >>> first myIntegerView >>> second myIntegerView
-
-    powerS = exhaustiveUse [ root2power, addExponents, subExponents
-                           , mulExponents,  simpleAddExponents ]
-
-logEqStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))
-logEqStrategy = label "Logarithmic equation"
-              $  try (use logarithm)
-             <*> try (use conditionVarsRHS <*> use flipEquation)
-             <*> repeatS (somewhere $  use nthRoot
-                                   <|> use calcPower
-                                    <|> use calcPowerPlus
-                                   <|> use calcPowerMinus
-                                   <|> use calcPlainRoot
-                                   <|> use calcPowerRatio)
-             <*> quadraticStrategy
-
-higherPowerEqStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))
-higherPowerEqStrategy =  cleanUpStrategy cleanup coverUpStrategy'
-  where
-    cleanup = applyTop $ fmap $ fmap cleanUpExpr
-
-rootEqStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))
-rootEqStrategy =  cleanUpStrategy cleanup strat
-  where
-    strat =  label "Cover up"
-          $ try ( use condXisRight <*> use flipEquation )
-         <*> exhaustiveSomewhere myCoverUpRulesOr
-    cleanup = applyTop $ fmap $ fmap cleanUpExpr
-
--- | Help functions -----------------------------------------------------------
-
-myCoverUpStrategy :: IsTerm a => Strategy (Context a)
-myCoverUpStrategy = repeatS $ alternatives $ map use coverUpRules
-
-coverUpStrategy' :: LabeledStrategy (Context (OrList (Equation Expr)))
-coverUpStrategy' = cleanUpStrategy (applyTop $ fmap $ fmap cleanUpExpr) $
-   label "Cover-up" $
-   repeatS $ somewhere $ alternatives $ use coverUpRoot : coverUpRulesOr
-
-somewhereNotInExp :: IsStrategy f => f (Context a) -> Strategy (Context a)
-somewhereNotInExp = somewhereWith "somewhere but not in exponent" f
-  where
-    f a = if isPowC a then [1] else [0 .. arity a-1]
-    isPowC = maybe False (isJust . isPower :: Term -> Bool) . currentT
-
-myConfigCoverUp :: ConfigCoverUp
-myConfigCoverUp = configCoverUp
-   { configName        = ""
-   , predicateCovered  = elem "x" . vars
-   , predicateCombined = notElem "x" . vars
-   , coverLHS          = True
-   , coverRHS          = True
-   }
-
-myCoverUpRulesOr :: IsTerm a => [Rule (Context a)]
-myCoverUpRulesOr = use (coverUpPowerWith myConfigCoverUp)
-                 : map (\f -> use $ f myConfigCoverUp) coverUpRulesWith
-
-coverUpRulesWith :: [ConfigCoverUp -> Rule (Equation Expr)]
-coverUpRulesWith =
-   [ coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith
-   , coverUpNegateWith, {-myCoverUpTimesWith-} coverUpTimesWith, coverUpNumeratorWith
-   , coverUpDenominatorWith, coverUpSqrtWith, coverUpRootWith
-   ]
− src/Domain/Math/Power/Examples.hs 
@@ -1,482 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Example exercises from the Digital Mathematics Environment (DWO),
--- see: http://www.fi.uu.nl/dwo/gr/frameset.html.
---
------------------------------------------------------------------------------
-module Domain.Math.Power.Examples where
-
-import Common.Rewriting
-import Domain.Math.Expr
-import Prelude hiding ((^))
-
-----------------------------------------------------------
--- HAVO B, hfd 7 applets
-
-simplerPowers :: [[Expr]]
-simplerPowers = [level1, level2, level3, level4]
- where
-   a = variable "a"
-   b = variable "b"
-   level1 =
-      [ 4*a^3 * 5*a^2
-      , 14*a^6 / (-2*a^3)
-      , -21*a^7 / (3*a)
-      , 5*a * (-3)*a^2 * 2*a^3
-      ]
-
-   level2 =
-      [ a^2 * (-2*a)^3
-      , (2*a)^5 / (-4*a)^2
-      , (2*a)^4 * (-3)*a^2
-      , (-3*a)^4 / (9*a^2)
-      ]
-
-   level3 =
-      [ (a^2 * b^3)^7
-      , -a^3 * (2*b)^5 * a^2
-      , 3*a * (-2*b)^3 * (-a*b)^2
-      , (2*a*b^3)^2 * (-3*a^2*b)^3
-      ]
-
-   level4 =
-      [ ((1/2)*a)^3 - (4*a)^2 * (1/4)*a
-      , (2*a)^5 + ((1/3)*a)^2 * (-3*a)^3
-      , (2*a^3)^4 - 6*a^3 * (-a^3)^3
-      , (-2*a^3)^2 - 6*(3*a)^2 * (-4*a^4)
-      ]
-
-powersOfA :: [[Expr]]
-powersOfA = [level1, level2, level3, level4]
-  where
-    a = variable "a"
-    level1 =
-      [ a^3 * a^(-4)
-      , a^4 * (1/a^2)
-      , a^(-1) * a^5
-      , (1/a^3) * a
-      ]
-
-    level2 =
-      [ (a^(-2))^3
-      , (a^(-3))^4
-      , (1/a^6) * a^(-2)
-      , (1/a^2) * (1/a^4)
-      ]
-
-    level3 =
-      [ (a^(-2))^3 * (1/a^4)
-      , (1/a^3)^2
-      , (a^3)^2 * (1/a)
-      , (a^(-2))^(-3) * a^(-4)
-      ]
-
-    level4 =
-      [ (a^(-1))^2 / a^3
-      , (a^2)^(-3) / a^(-1)
-      , ((a^(-2))^4 / (a^2)^3) * a
-      , (1/a^(-3))^4 * (1/a)^3
-      ]
-
-nonNegExp :: [[Expr]]
-nonNegExp = [level1, level2]
-  where
-    a = variable "a"
-    b = variable "b"
-    level1 =
-      [ a * b^(-2)
-      , a^(-1) * b^2
-      , a^(-2) * b^(-3)
-      , (1/a^(-3)) * (b^(-2))^2
-      ]
-
-    level2 =
-      [ (1/(a*b)^(-2)) * a * b^(-1)
-      , (2*a)^(-1) / (4*b)^(-2)
-      , (4*a*b)^(-1) * (b^2)^(-3)
-      , (5*a)^(-2) * 10*b^(-1)
-      ]
-
--- schrijf als een macht van x
-powersOfX :: [[Expr]]
-powersOfX =
-   [ [root x 3, 1/root x 4, sqrt (1/x), (x^2) / root (x^2) 5]
-   , [sqrt x/(x^2), root (x/(x^3)) 3, x*root x 3, root x 3 * root (1/(x^2)) 4]
-   ]
- where
-   x = Var "x"
-
--- Schrijf zonder negatieve of gebroken exponenten
-nonNegExp2 :: [[Expr]]
-nonNegExp2 =
-   [ [ 4^(1/3), 5^(-(1/4)), 5*a^(1/2), 3*a^(-(1/4))]
-   , [ 4/(a^(-1)*b^(1/3)), a^(-1)/(8*b^(-(2/3)))
-     , 1/(3*a^(2/5)*b^(-1)), 3*a^(1/4)*b^(-(1/2))
-     ]
-   ]
- where
-   a = Var "a"
-   b = Var "b"
-
-----------------------------------------------------------
--- VWO A/C applets, hfd 5
-
--- herleid
-powers1 :: [[Expr]]
-powers1 =
-   [ [ 5*a^2*2*a^4, 3*a^4*9*a^2, a^5*7*a^3, 4*a^2*9*a^7
-     , 2*a^4*5*a^3, 3*a*3*a^4, 2*a^7*2*a^4, 7*a^6*4*a
-     ]
-   , [ 5*a^4*(1/a), 8*a^4*(1/2*a^2), 2*a^6*(6/a^4), a^2*(8/a)
-     , (4*a^3)/(a^5), a^7/a^3, (6*a^8)/(2*a^3), (6*a^5)/(2*a^3)
-     ]
-   , [ (3*a)^3, (4*a^5)^2, (6*a^3)^2, (2*a^7)^3
-     , (-a^6)^5, (-2*a^2)^5, (-4*a^3)^2, (-3*a^5)^4
-     ]
-   , [ 6*a^5+7*a^5-4*a^9, 8*a^2-4*a^2+2*a^4, 3*a^6+6*a^6+7*a^2
-     , 5*a-2*a-9*a^6, 5*a+8*a^2+4*a, 6*a^7-5*a^2+a^7
-     , 8*a^6+2*a^3-2*a^6, 2*a^3-8*a^5-a^3
-     ]
-   , [ (4*a^3)^2*2*a^4, (-a^5)^3*5*a^6, 4*a^3*(5*a^6)^2
-     , 6*a^7*(2*a^4)^3, a^17/((a^3)^5), a^9/((a^3)^2)
-     , a^14/((a^2)^4), a^16/((a^5)^3)
-     ]
-   ]
- where
-   a = Var "a"
-
--- herleid
-powers2 :: [[Expr]]
-powers2 =
-   [ [ 4*a^3*5*a^2, (14*a^6)/(-2*a^3), (-21*a^7)/(3*a)
-     , 5*a*(-3*a^2)*(2*a^3)
-     ]
-   , [ a^2*(-2*a)^3, (2*a)^5/(-4*a)^2
-     , (2*a)^4*(-3*(a^2)), (-3*a)^4/(9*a^2)
-     ]
-   , [ (a^2*b^3)^7, (-a)^3*(2*b)^5*a^2
-     , 3*a*(-2*b)^3*(-a*b)^2, (2*a*b^3)^2*(-3*a^2*b)^3
-     ]
-   , [ (2*a^3)^4-6*a^3*(-a^3)^3, (-2*a^3)^2-6*(3*a)^2*(-4*a^4)
-     ]
-   ]
- where
-   a = Var "a"
-   b = Var "b"
-
-negExp1 :: [[Expr]]
-negExp1 =
-   [ [ a^3/a^7, a^6/a^8, a^3/a^4, a^3/a^9, a/a^5
-     , (1/a^3)/a, a/a^7, (1/a^2)/a
-     ]
-   , [ (1/(a^4))/a^6, (1/(a^3))/a^5, (1/a^5)/a^2, 1/(a^4)/a^3
-     , 1/a^3, 1/a^5, 1/a^(-4), 1/a^(-6)
-     ]
-   , [ a^8/(1/a^2), a^4/(1/a^4), (a^6)/(1/a^5), a^3/(1/a^6)
-     , 1/(a^3)/a^(-2), (1/a^7)/a^(-5), (1/a^2)/a^(-9), (1/a^3)/a^(-8)
-     ]
-   ]
- where
-   a = Var "a"
-
-negExp2 :: [[Expr]]
-negExp2 =
-   [ [ a^3*a^(-4), a^4*(1/a^2), a^(-1)*a^5, (1/a^3)*a]
-   , [ (a^(-2))^3,(a^(-3))^4, (1/a^6)*a^(-2), (1/a^2)*(1/a^4)]
-   , [ (a^(-2))^3*(1/a^4), (1/a^3)^2, (a^3)^2*(1/a), (a^(-2))^(-3)*a^(-4)]
-   , [ (a^(-1))^2/a^3, (a^2)^(-3)/a^(-1), ((a^(-2))^4/(a^2)^3)*a
-     , (1/a^(-3))^4*(1/a)^3
-     ]
-   ]
- where
-   a = Var "a"
-
-negExp3 :: [[Expr]]
-negExp3 =
-   [ [ 4^(-2), 9^(-2), 3^(-3), 2^(-5)
-     , (1/4)^(-3), (1/7)^(-2), (1/2)^(-4), (1/3)^(-4)
-     ]
-   , [ (3/5)^(-1), (6/7)^(-1), (5/8)^(-1), (7/9)^(-1)
-     , 5*3^(-2), 7*2^(-5), 6*5^(-2), 4*7^(-2)
-     ]
-   , [ (1/3)/(6^(-2)), (1/2)/(8^(-2)), (1/8)/4^(-2), (1/10)/5^(-2) -- original in negExp5
-     , 5*10^(-2), 4*10^(-3), 8*10^(-4), 6*10^(-3)
-     ]
-   ]
-
-negExp4 :: [[Expr]]
-negExp4 =
-   [ [ a*b^(-2), a^(-1)*b^2, a^(-2)*b^(-3), (1/a^(-3))*(b^(-2))^2]
-   , [ (1/((a*b)^(-2)))*a*b^(-1), (2*a)^(-1)/(4*b)^(-2)
-     , (4*a*b)^(-1)*(b^2)^(-3), (5*a)^(-2) * 10*b^(-1)
-     ]
-   ]
- where
-   a = Var "a"
-   b = Var "b"
-
-negExp5 :: [[Expr]]
-negExp5 =
-   [ [ 2*a^(-2)*b^2, 4*a^(-5)*b^3, 3*a^2*b^(-1), 5*a*b^(-3)
-     , (1/7)*a^(-2), (1/3)*a^(-4), (1/5)*a^(-6), (1/2)*a^(-3)
-     ]
-   , [ 3*a^(-1), 4*a^(-4), 5*a^(-3), 2*a^(-7)
-     , ((2/3)*a)^(-3), ((3/4)*a)^(-2), ((2/5)*a)^(-3), ((5/6)*a)^(-2)
-     ]
-   , [ (2*a)^(-3)*b^(-4), 4*a^(-2)*(3*b)^(-2), (4*a)^(-3)*7*b^(-5)
-     , 9*a^(-7)*(2*b)^(-4), (a^5) / ((2*b)^(-2)), ((2*a)^(-3))/b^2
-     , a^(-3)/b^(-3), (4*a)^(-2)/b^(-4)
-     ]
-   ]
- where
-   a = Var "a"
-   b = Var "b"
-
-brokenExp1, brokenExp1' :: [[Expr]]
-brokenExp1 =
-  [ [ 5*a^(1/2), 7*a^(1/3), (2*a)^(1/4), (3*a)^(1/5)
-    , 4*a^(2/3), 2*a^(3/4), 3*a^(2/5), 4*a^(3/5)
-    ]
-  , [ 6*a^(-(1/2)), 4*a^(-(1/3)), 2*(3*a)^(-(1/4)), (3*a)^(-(1/5))
-    , 5*a^(-(2/3)), 7*a^(-(3/4)), 6*a^(-(2/5)), 2*a^(-(3/7))
-    ]
-  , [ (1/2)*a^(1/3)*b^(-(1/2)), (1/7)*a^(-(1/4))*b^(2/3), 4*a^(1/2)*b^(-(1/5))
-    , 3*a^(-(3/5))*b^(1/3), (2*a)^(-(2/3)), (6*a)^(-(2/5))
-    , (3*a)^(-(3/5)), (2*a)^(-(4/7))
-    ]
-  ]
- where
-   a = Var "a"
-   b = Var "b"
-
-brokenExp1' =
-  [ [ a*sqrt a, a^2*root a 3, a^5*root a 4, a^3*root a 7
-    , a*root (a^2) 3, a^3*root (a^2) 5, a^2*root (a^3) 5, a^4*root (a^5) 6
-    ]
-  , [ 1/sqrt a, a/root a 3, a^2/sqrt a, 1/root a 5, 1/(a*root a 3)
-    , a^2/(a*sqrt a), 1/(a^3*sqrt a), a^3/(a^2*root a 3)
-    ]
-  ]
- where
-   a = Var "a"
-
-brokenExp2 :: [[Expr]]
-brokenExp2 =
-   [ [ sqrt (1/a^2), root (1/a^5) 3, sqrt (1/a^5), root (1/a^3) 5
-     , sqrt (a^6), root (a^6) 3, sqrt (a^4), root (a^9) 3
-     ]
-   , [ (1/a^3)/sqrt a, (1/a^4)/root (a^2) 3, sqrt a/(1/a^2)
-     , root a 3/(1/a^5), (a^2*sqrt a)/(a*root a 3)
-     , (a^3*sqrt a)/(a^2*root (a^2) 3), (a^2*root a 5)/(a^3*root a 3)
-     , (a^4*root a 3)/(a^6*sqrt a)
-     ]
-   ]
- where
-   a = Var "a"
-
-brokenExp3 :: [[Expr]]
-brokenExp3 =
-   [ [root x 3, 1/root x 4, sqrt (1/x), x^2/root (x^2) 5]
-   , [sqrt x/x^2, root (x/x^3) 3, x*root x 3, root x 3*root (1/x^2) 4]
-   ]
- where
-   x = Var "x"
-
-----------------------------------------------------------
--- VWO B applets (hoofdstuk 4)
-
--- herleiden van wortelvormen
-normSqrt1 :: [[Expr]]
-normSqrt1 =
-   [ [ 9*sqrt 5 * 7*sqrt 3, 3*sqrt 2 * 2 * sqrt 5, 5*sqrt 2*6*sqrt 7
-     , 4*sqrt 6 * 2*sqrt 7, 6*a*sqrt 3*9*sqrt 2, 5*sqrt 5 * 2 * a * sqrt 7
-     , a*sqrt 6 * 7 * sqrt 5, 8*sqrt 7*a*sqrt 3
-     ]
-   , [ sqrt 15/(6*sqrt 3), (5*sqrt 30)/sqrt 5, (4*sqrt 10)/(5*sqrt 2)
-     , (5*sqrt 21)/(2*sqrt 7), (6*a*sqrt 35)/(3*sqrt 5), (5*a*sqrt 14)/(9*sqrt 2)
-     , (a*sqrt 6)/(7*sqrt 3), (3*a*sqrt 42)/(7*sqrt 7)
-     ]
-   , [ 5/(2*sqrt 2), 2/(5*sqrt 3), 3/(2*sqrt 5), 8/(7*sqrt 6), (2*a)/(3*sqrt 7)
-     , (6*a)/(7*sqrt 10), (5*a)/(3*sqrt 11), (6*a)/(5*sqrt 13)
-     ]
-   , [ sqrt (2/3), sqrt (5+1/3), sqrt (1+1/2), sqrt (3+4/7), sqrt (5*a^2)
-     , sqrt (7*a^2), sqrt (3*a^2), sqrt (6*a^2)
-     ]
-   , [ sqrt ((2/9)*a^2), sqrt ((5/16)*a^2), sqrt ((3/25)*a^2), sqrt ((7/16)*a^2)
-     , ((1/3)*sqrt 2)^2, ((1/2)*sqrt 3)^2, ((2/7)*sqrt 5)^2, ((2/3)*sqrt 7)^2
-     ]
-   ]
- where
-   a = Var "a"
-
-normSqrt2 :: [[Expr]]
-normSqrt2 =
-   [ [ ((1/7)*a*sqrt 2)^2, ((3/5)*a*sqrt 3)^2, ((1/3)*a*sqrt 5)^2
-     , ((4/7)*a*sqrt 6)^2, sqrt 8 + sqrt 2, sqrt 2 + sqrt 18
-     , sqrt 12 - sqrt 3, sqrt 7 - sqrt 28
-     ]
-   , [ sqrt 12 + sqrt 48, sqrt 18 - sqrt 8, sqrt 45 - sqrt 20, sqrt 80 + sqrt 45
-     , sqrt (50*a^2) - sqrt (32*a^2), sqrt (75*a^2) - sqrt (12*a^2)
-     , sqrt (27*a^2) + sqrt (3*a^2), sqrt (24*a^2) + sqrt (96*a^2)
-     ]
-   , [ sqrt 27 + 1/sqrt 3, sqrt 24 + 5/sqrt 6, sqrt 72 - 7/sqrt 2
-     , sqrt 98 - 5/sqrt 2, sqrt 24 + sqrt (1+1/2), sqrt 40 - sqrt (2+1/2)
-     , sqrt 75 - sqrt (1+1/3), sqrt (1+2/3) + sqrt 60
-     ]
-   ]
- where
-   a = Var "a"
-
-normSqrt3 :: [[Expr]]
-normSqrt3 =
-   [ [ (2*sqrt 7 + 7*sqrt 3)^2, (sqrt 2+6*sqrt 3)^2, (4*sqrt 3 + 3*sqrt 2)^2
-     , (2*sqrt 5 + sqrt 7)^2, (3*sqrt 6-4*sqrt 5)^2, (5*sqrt 3 - sqrt 2)^2
-     , (4*sqrt 6 - 2*sqrt 7)^2, (sqrt 5 - 2*sqrt 3)^2
-     ]
-   , [ (2*sqrt 3 - 2)^2, (5*sqrt 2-1)^2, (3+4*sqrt 3)^2, (2+3*sqrt 6)^2
-     , (4*sqrt 2 + 3)*(4*sqrt 2 - 3), (sqrt 7+sqrt 3)*(sqrt 7-sqrt 3)
-     , (2*sqrt 2 - sqrt 5)*(2*sqrt 2 + sqrt 5), (6-3*sqrt 3)*(6+3*sqrt 3)
-     ]
-   , [ (a-sqrt 3)^2, (2*sqrt 6+a)^2, (2*a+a*sqrt 5)^2, (a*sqrt 3 - 2*a*sqrt 2)^2
-     , (a-sqrt 7)*(a+sqrt 7), (3*a+2*sqrt 3)*(3*a-2*sqrt 3)
-     , (2*a+a*sqrt 2)*(2*a-a*sqrt 2), (3*a*sqrt 5 - a)*(3*a*sqrt 5 + a)
-     ]
-   , [ 4/ (sqrt 2 + 2), 3/(sqrt 5 + 1), 2 / (sqrt 3 - 3), 5/(sqrt 6-2)
-     , 6/(sqrt 7+sqrt 5), 4/(2*sqrt 3 + sqrt 6), 5/(3*sqrt 2 - sqrt 3)
-     , 2 / (sqrt 11 - sqrt 2)
-     ]
-   , [ (2*sqrt 3)/(sqrt 5 + sqrt 2), (6*sqrt 5)/(sqrt 7+sqrt 3)
-     , (4*sqrt 3)/(sqrt 5 - sqrt 3), (8*sqrt 7)/(sqrt 6 - sqrt 5)
-     ]
-   ]
- where
-   a = Var "a"
-
--- Machten herleiden
-normPower1 :: [[Expr]]
-normPower1 =
-  [ [ 5*a^2*2*a^4, 3*a^4*9*a^2, a^5*7*a^3, 4*a^2*9*a^7, 2*a^4*5*a^3
-    , 3*a*3*a^4, 2*a^7*2*a^4, 7*a^6*4*a
-    ]
-  , [ 5*a^4*(1/a), 8*a^4*(1/(2*a^2)), 2*a^6*(6/a^4), a^2*8/a
-    , (4*a^3)/a^5, a^7/a^3, (6*a^8)/(2*a^3), (6*a^5)/(2*a^3)
-    ]
-  , [ (3*a)^3, (4*a^5)^2, (6*a^3)^2, (2*a^7)^3, (-(a^6))^5
-    , (-2*a^2)^5, (-4*a^3)^2, (-3*a^5)^4
-    ]
-  , [ 6*a^5 + 7*a^5 - 4*a^9, 8*a^2 - 4*a^2+2*a^4, 3*a^6+6*a^6+7*a^2
-    , 5*a-2*a-9*a^6, 5*a+8*a^2+4*a, 6*a^7-5*a^2+a^7
-    , 8*a^6+2*a^3-2*a^6, 2*a^3-8*a^5-a^3
-    ]
-  , [ (4*a^3)^2*2*a^4, (-a^5)^3*5*a^6, 4*a^3*(5*a^6)^2, 6*a^7*(2*a^4)^3
-    , a^17/(a^3)^5, a^9/(a^3)^2, a^14/(a^2)^4, a^16/(a^5)^3
-    ]
-  ]
- where
-   a = Var "a"
-
-normPower2 :: [[Expr]]
-normPower2 =
-  [ -- one level only
-    [ (3*a)^3+4*a^3, (2*a^2)^3 +(4*a^3)^2, (-2*a^6)^2+(a^2)^6
-    , (-3*a^2)^3+(4*a^3)^2, (4*a*b^2)^2, (2*a^2*b^3)^3
-    , (3*a^2*b)^2, (-3*a^2*b^2)^4
-    ]
-  ]
- where
-   a = Var "a"
-   b = Var "b"
-
-normPower3, normPower3' :: [[Expr]]
-normPower3 =
-  [ [ a^3/a^7, a^6/a^8, a^3/a^4, a^3/a^9, a/a^5, (1/a^3)/a, a/a^7, (1/a^2)/a
-    ]
-  , [ (1/a^4)/a^6, (1/a^3)/a^5, (1/a^5)/a^2, (1/a^4)/a^3, 1/a^3, 1/a^5
-    , 1/a^(-4), 1/a^(-6)
-    ]
-  , [ a^8/(1/a^2), a^4/(1/a^4), a^6/(1/a^5), a^3/(1/a^6), (1/a^3)/a^(-2)
-    , (1/a^7)/a^(-5), (1/a^2)/a^(-9), (1/a^3)/a^(-8)
-    ]
-  ]
- where
-   a = Var "a"
-normPower3' = -- bereken zonder rekenmachine
-  [ [ 4^(-2), 9^(-2), 3^(-3), 2^(-5), (1/4)^(-3), (1/7)^(-2)
-    , (1/2)^(-4), (1/3)^(-4)
-    ]
-  , [ (3/5)^(-1), (6/7)^(-1), (5/8)^(-1), (7/9)^(-1), 5*3^(-2), 7*2^(-5)
-    , 6*5^(-2), 4*7^(-2)
-    ]
-  ]
-
-normPower4, normPower4' :: [[Expr]]
-normPower4 =
-  [  -- bereken zonder rekenmachine
-    [ (1/3)/6^(-2), (1/2)/8^(-2), (1/8)/4^(-2), (1/10)/5^(-2)
-    , 5*10^(-2), 4*10^(-3), 8*10^(-4), 6*10^(-3)
-    ]
-  ]
-normPower4' =    -- schrijf zonder negatieve exponenten
-  [ [ 2*a^(-2)*b^2, 4*a^(-5)*b^3, 3*a^2*b^(-1), 5*a*b^(-3)
-    , (1/7)*a^(-2), (1/3)*a^(-4), (1/5)*a^(-6), (1/2)*a^(-3)
-    ]
-  , [ 3*a^(-1), 4*a^(-4), 5*a^(-3), 2*a^(-7)
-    , ((2/3)*a)^(-3), ((3/4)*a)^(-2), ((2/5)*a)^(-3), ((5/6)*a)^(-2)
-    ]
-  , [ (2*a)^(-3)*b^(-4), 4*a^(-2)*(3*b)^(-2), (4*a)^(-3)*7*b^(-5)
-    , 9*a^(-7)*(2*b)^(-4), a^5/(2*b)^(-2), (2*a)^(-3)/b^2
-    , a^(-3)/b^(-3), (4*a)^(-2)/b^(-4)
-    ]
-  ]
- where
-   a = Var "a"
-   b = Var "b"
-
-normPower5, normPower5' :: [[Expr]]
-normPower5 =
-  [ -- schrijf zonder negatieve en gebroken exponent
-    [ 5*a^(1/2), 7*a^(1/3), (2*a)^(1/4), (3*a)^(1/5), (4*a)^(2/3)
-    , 2*a^(3/4), (3*a)^(2/5), 4*a^(3/5)
-    ]
-  , [ 6*a^(-1/2), 4*a^(-1/3), 2*(3*a)^(-1/4), (3*a)^(-1/5), 5*a^(-2/3)
-    , 7*a^(-3/4), 6*a^(-2/5), 2*a^(-3/7)
-    ]
-  , [ (1/2)*a^(1/3)*b^(-1/2), (1/7)*a^(-1/4)*b^(2/3), 4*a^(1/2)*b^(-1/5)
-    , 3*a^(-3/5)*b^(1/3), (2*a)^(-2/3), (6*a)^(-2/5), (3*a)^(-3/5), (2*a)^(-4/7)
-    ]
-  ]
- where
-   a = Var "a"
-   b = Var "b"
-normPower5' =    -- schrijf als macht van a
-  [ [ a*sqrt a, a^2*root a 3, a^5*root a 4, a^3*root a 7, a*root (a^2) 3
-    , a^3*root (a^2) 5, a^2*root (a^3) 5, a^4*root (a^5) 6
-    ]
-  , [ 1/sqrt a, a/root a 3, a^2/sqrt a, 1/root a 5, 1/(a*root a 3)
-    , a^2/(a*sqrt a), 1/(a^3*sqrt a), a^3/(a^2*root a 3)
-    ]
-  ]
- where
-   a = Var "a"
-
-normPower6 :: [[Expr]]
-normPower6 =
-  [ -- schrijf als macht van a
-    [ sqrt (1/a^2), root (1/a^5) 3, sqrt (1/a^5), root (1/a^3) 5, sqrt (a^6)
-    , root (a^6) 3, sqrt (a^4), root (a^9) 3
-    ]
-  , [ (1/a^3)/sqrt a, (1/a^4)/root (a^2) 3, sqrt a / (1/a^2), root a 3/(1/a^5)
-    , (a^2*sqrt a)/(a*root a 3), (a^3*sqrt a)/(a^2*root (a^2) 3)
-    , (a^2*root a 5)/(a^3*root a 3), (a^4*root a 3)/(a^6*sqrt a)
-    ]
-  ]
- where
-   a = Var "a"
− src/Domain/Math/Power/Exercises.hs 
@@ -1,159 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
---
------------------------------------------------------------------------------
-
-module Domain.Math.Power.Exercises
-   ( -- * Power exercises
-     simplifyPowerExercise
-   , powerOfExercise
-   , nonNegBrokenExpExercise
-   , calcPowerExercise
-   ) where
-
-import Prelude hiding ( (^) )
-
-import Common.Library
-import Common.Utils (distinct)
-import Domain.Math.Expr hiding (isPower)
-import Domain.Math.Numeric.Views
-import Domain.Math.Power.Examples
-import Domain.Math.Power.NormViews
-import Domain.Math.Power.Rules
-import Domain.Math.Power.Strategies
-import Domain.Math.Power.Views
-
--- Exercises
-
-powerExercise :: Exercise Expr
-powerExercise = makeExercise
-   { status        = Provisional
-   , parser        = parseExpr
-   , navigation    = navigator
-   }
-
--- | Simplify an expression containing powers as far as possible. This
--- exercise supports the following DWO-applets:
---
---  * HAVO B, hoofdstuk 7, activiteit 1
---
---  * VWO A/C, hoofdstuk 5, activiteit 3 t/m 6
---
---  * VWO B, hoofdstuk 4, activiteit 8, 9, part of 10
-simplifyPowerExercise :: Exercise Expr
-simplifyPowerExercise = powerExercise
-   { exerciseId   = describe "simplify expression (powers)" $
-                       newId "algebra.manipulation.exponents.simplify"
-   , strategy     = simplifyPowerStrategy
-   , ready        = predicate isPowerAdd
-   , suitable     = predicateView normPowerMapView
-   , equivalence  = withoutContext (viewEquivalent normPowerMapView)
-   , examples     = level Medium $ concat $
-                              simplerPowers
-                           ++ powers1 ++ powers2
-                           ++ negExp1 ++ negExp2
-                           ++ normPower1 ++ normPower2 ++ normPower3
-   , ruleOrdering = ruleOrderingWithId $ map getId
-                      [ root2power, subExponents, reciprocalVar, addExponents
-                      , mulExponents, distributePower ]
-   }
-
--- | The @powerOfExercise@ is more strict than the 'simplifyPowerExercise'.
--- It only allows one variable experssions. This exercise supports the
--- following DWO-applets:
---
---  * HAVO B, hoofdstuk 7, activiteit 2 and 4
---
---  * VWO A/C, hoofdstuk 5, activiteit part of 10 and 11 and 12
---
---  * VWO B, hoofdstuk 4, activiteit 12 partly, and 13
-powerOfExercise :: Exercise Expr
-powerOfExercise = powerExercise
-   { exerciseId   = describe "write as a power of a" $
-                       newId "algebra.manipulation.exponents.powerof"
-   , ready        = predicate isSimplePower
-   , strategy     = simplifyPowerStrategy
-   , suitable     = predicateView normPowerView
-   , equivalence  = withoutContext (viewEquivalent normPowerNonNegRatio)
-   , examples     = level Medium $ concat $  powersOfA ++ powersOfX
-                           ++ brokenExp1' ++ brokenExp2 ++ brokenExp3
-                           ++ normPower5' ++ normPower6
-   , ruleOrdering = ruleOrderingWithId $ map getId
-                      [ root2power, addExponents, subExponents, mulExponents
-                      ,  distributePower, reciprocalVar ]
-   }
-
--- | Rewrite power expressions so that they have any negative or broken
--- exponents. Supported DWO-applets:
---
---  * HAVO B, hoofdstuk 7, activiteit 3 and 5
---
---  * VWO A/C, hoofdstuk 5, activiteit 8,9  and part of 10
---
---  * VWO B, hoofdstuk 4, activiteit 11 partly, and 12 partly
-nonNegBrokenExpExercise :: Exercise Expr
-nonNegBrokenExpExercise = powerExercise
-   { exerciseId   = describe "write with a non-negative exponent" $
-                       newId "algebra.manipulation.exponents.nonnegative"
-   , strategy     = nonNegBrokenExpStrategy
-   , ready        = predicate (isPower plainNatView)
-   , suitable     = predicateView normPowerNonNegDouble
-   , equivalence  = withoutContext (viewEquivalent normPowerNonNegDouble)
-   , examples     = level Medium $ concat $  nonNegExp ++ nonNegExp2 ++ negExp4 ++ negExp5
-                           ++ brokenExp1
-                           ++ normPower4' ++ normPower5
-   , ruleOrdering = ruleOrderingWithId [ getId mulExponents
-                                       , getId reciprocalFrac
-                                       , getId reciprocalInv
-                                       , getId power2root
-                                       , getId distributePower ]
-   }
-
--- | Calculate the integer number for the given power expression. Supported
--- DWO-applets:
---
---  * VWO A/C, hoofdstuk 5, activiteit 7
---
---  * VWO B, hoofdstuk 4, activiteit 10 partly, 11 partly
-calcPowerExercise :: Exercise Expr
-calcPowerExercise = powerExercise
-   { exerciseId   = describe "simplify expression (powers)" $
-                       newId "arithmetic.exponents"
-   , strategy     = calcPowerStrategy
-   , ready        = predicate isPowerAdd
-   , suitable     = predicateView normPowerMapView
-   , equivalence  = withoutContext (viewEquivalent normPowerMapView)
-   , examples     = level Medium $ concat $ negExp3 ++ normPower3' ++ normPower4
-   }
-
--- Ready checks
-
-isSimplePower :: Expr -> Bool
-isSimplePower (Sym s [Var _, y])
-                 | isPowerSymbol s = y `belongsTo` rationalView
-isSimplePower _ = False
-
-isPower :: View Expr a -> Expr -> Bool
-isPower v expr =
-  let xs = snd (from productView expr)
-      f (Nat 1 :/: a) = g a
-      f a = g a
-      g (Sym s [Var _, a]) | isPowerSymbol s = a `belongsTo` v
-      g (Sym s [x, Nat _]) | isRootSymbol s = isPower v x
-      g (Sqrt x) = g x
-      g (Var _) = True
-      g a = a `belongsTo` rationalView
-  in distinct (concatMap vars xs) && all f xs
-
-isPowerAdd :: Expr -> Bool
-isPowerAdd expr =
-  let xs = from sumView expr
-  in all (isPower rationalView) xs && not (applicable calcPowerPlus expr)
− src/Domain/Math/Power/NormViews.hs 
@@ -1,146 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Domain.Math.Power.NormViews
-   ( -- * Normalising views
-     normPowerView, normPowerMapView, normPowerNonNegRatio
-   , normPowerNonNegDouble
-   ) where
-
-import Common.View
-import Control.Monad
-import Data.Function
-import Data.List
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Power.Utils
-import Prelude hiding ((^), recip)
-import qualified Data.Map as M
-import qualified Prelude
-
-type PowerMap = (M.Map String Rational, Rational)
-
-normPowerNonNegRatio :: View Expr (M.Map String Rational, Rational) -- (Rational, M.Map String Rational)
-normPowerNonNegRatio = makeView (liftM swap . f) (g . swap)
-  where
-    f expr =
-        case expr of
-           Sym s [a,b]
-              | isPowerSymbol s -> do
-                   (r, m) <- f a
-                   if r==1
-                     then do
-                       r2 <- match rationalView b
-                       return (1, M.map (*r2) m)
-                     else do
-                       n <- match integerView b
-                       if n >=0
-                         then return (r Prelude.^ n, M.map (*fromIntegral n) m)
-                         else return (1/(r Prelude.^ abs n), M.map (*fromIntegral n) m)
-              | isRootSymbol s ->
-                  f (Sym powerSymbol [a, 1/b])
-           Sqrt a ->
-              f (Sym rootSymbol [a,2])
-           a :*: b -> do
-             (r1, m1) <- f a
-             (r2, m2) <- f b
-             return (r1*r2, M.unionWith (+) m1 m2)
-           a :/: b -> do
-             (r1, m1) <- f a
-             (r2, m2) <- f b
-             guard (r2 /= 0)
-             return (r1/r2, M.unionWith (+) m1 (M.map negate m2))
-           Var s -> return (1, M.singleton s 1)
-           Nat n -> return (toRational n, M.empty)
-           Negate x -> do
-             (r, m) <- f x
-             return (negate r, m)
-           _ -> do
-             r <- match rationalView expr
-             return (fromRational r, M.empty)
-    g (r, m) =
-       let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ]
-       in build productView (False, fromRational r : xs)
-
--- | AG: todo: change double to norm view for rationals
-normPowerNonNegDouble :: View Expr (Double, M.Map String Rational)
-normPowerNonNegDouble = makeView (liftM (roundof 6) . f) g
-  where
-    roundof n (x, m) = (fromInteger (round (x * 10.0 ** n)) / 10.0 ** n, m)
-    f expr =
-      case expr of
-        Sym s [a,b]
-          | isPowerSymbol s -> do
-            (x, m) <- f a
-            y      <- match rationalView b
-            return (x ** fromRational y, M.map (*y) m)
-          | isRootSymbol s -> f (Sym powerSymbol [a, 1/b])
-        Sqrt a -> f (Sym rootSymbol [a,2])
-        a :*: b -> do
-          (r1, m1) <- f a
-          (r2, m2) <- f b
-          return (r1*r2, M.unionWith (+) m1 m2)
-        a :/: b -> do
-          (r1, m1) <- f a
-          (r2, m2) <- f b
-          guard (r2 /= 0)
-          return (r1/r2, M.unionWith (+) m1 (M.map negate m2))
-        Var s -> return (1, M.singleton s 1)
-        Negate x -> do
-          (r, m) <- f x
-          return (negate r, m)
-        _ -> do
-          d <- match doubleView expr
-          return (d, M.empty)
-    g (r, m) =
-      let xs = [ Var s .^. fromRational a | (s, a) <- M.toList m ]
-      in build productView (False, fromDouble r : xs)
-
-normPowerMapView :: View Expr [PowerMap]
-normPowerMapView = makeView (liftM h . f) g
-  where
-    f = (mapM (match normPowerNonNegRatio) =<<) . match sumView
-    g = build sumView . map (build normPowerNonNegRatio)
-    h :: [PowerMap] -> [PowerMap]
-    h = map (foldr1 (\(x,y) (_,q) -> (x,y+q))) . groupBy ((==) `on` fst) . sort
-
-normPowerView :: View Expr (String, Rational)
-normPowerView = makeView f g
- where
-   f expr =
-        case expr of
-           Sym s [x,y]
-              | isPowerSymbol s -> do
-                   (s2, r) <- f x
-                   r2 <- match rationalView y
-                   return (s2, r*r2)
-              | isRootSymbol s ->
-                   f (x^(1/y))
-           Sqrt x ->
-              f (Sym rootSymbol [x, 2])
-           Var s -> return (s, 1)
-           x :*: y -> do
-             (s1, r1) <- f x
-             (s2, r2) <- f y
-             guard (s1==s2)
-             return (s1, r1+r2)
-           Nat 1 :/: y -> do
-             (s, r) <- f y
-             return (s, -r)
-           x :/: y -> do
-             (s1, r1) <- f x
-             (s2, r2) <- f y
-             guard (s1==s2)
-             return (s1, r1-r2)
-           _ -> Nothing
-
-   g (s, r) = Var s .^. fromRational r
− src/Domain/Math/Power/OldViews.hs 
@@ -1,57 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Domain.Math.Power.OldViews
-   ( powerFactorView, powerFactorViewForWith, powerFactorViewWith
-   ) where
-
-import Common.Rewriting
-import Common.View
-import Control.Monad
-import Domain.Math.Expr hiding ( (^) )
-
-powerFactorView :: View Expr (String, Expr, Int)
-powerFactorView = powerFactorViewWith identity
-
-powerFactorViewWith :: Num a => View Expr a -> View Expr (String, a, Int)
-powerFactorViewWith v = makeView f g
- where
-   f expr = do
-      pv <- selectVar expr
-      (e, n) <- match (powerFactorViewForWith pv v) expr
-      return (pv, e, n)
-   g (pv, e, n) = build (powerFactorViewForWith pv v) (e, n)
-
-powerFactorViewForWith :: Num a => String -> View Expr a -> View Expr (a, Int)
-powerFactorViewForWith pv v = makeView f g
- where
-   f expr =
-      case expr of
-         Var s | pv == s -> Just (1, 1)
-         Negate e -> do
-            (a, b) <- f e
-            return (negate a, b)
-         e1 :*: e2 -> do
-            (a1, b1) <- f e1
-            (a2, b2) <- f e2
-            return (a1*a2, b1+b2)
-         Sym s [e1, Nat n]
-            | isPowerSymbol s -> do
-                 (a1, b1) <- f e1
-                 a <- match v (build v a1 ^ toInteger n)
-                 return (a, b1 * fromInteger n)
-         _ -> do
-            guard (withoutVar pv expr)
-            a <- match v expr
-            return (a, 0)
-
-   g (a, b) = build v a .*. (Var pv .^. fromIntegral b)
− src/Domain/Math/Power/Rules.hs 
@@ -1,310 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Domain.Math.Power.Rules
-  ( -- * Power rules
-    calcPower, calcPowerPlus, calcPowerMinus, addExponents, mulExponents
-  , subExponents, distributePower, distributePowerDiv, reciprocal
-  , reciprocalInv, reciprocalFrac, calcPowerRatio, simplifyPower
-  , onePower, powerOne, zeroPower, powerZero, divBase, reciprocalVar
-  , reciprocalPower, factorAsPower, calcPlainRoot, simpleAddExponents
-    -- * Root rules
-  , power2root, root2power
-    -- * Log rules
-  , logarithm
-    -- * Common rules
-  , myFractionTimes, pushNegOut
-  ) where
-
-import Common.Library hiding (root)
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.Power.Utils
-import Domain.Math.Power.Views
-import Prelude hiding ( (^) )
-import qualified Domain.Math.Data.PrimeFactors as PF
-import qualified Prelude
-
--- Identifier prefixes ------------------------------------------------------
-
-power, logarithmic :: String
-power       = "algebra.manipulation.exponents"
-logarithmic = "algebra.manipulation.logarithmic"
-
--- Power rules --------------------------------------------------------------
-
--- | n  =>  a^e  (with e /= 1)
-factorAsPower :: Rule Expr
-factorAsPower = makeSimpleRuleList (power, "factor-as-power") $ \ expr -> do
-  n      <- matchM myIntegerView expr
-  (a, x) <- PF.allPowers $ toInteger n
-  if n > 0
-    then return $ fromInteger a .^. fromInteger x
-    else if odd x
-      then return $ fromInteger (negate a) .^. fromInteger x
-      else fail "Could not factorise number."
-
--- | Calculate power, e.g., 2^2 => 4
-calcPower :: Rule Expr
-calcPower = makeSimpleRule "arithmetic.operation.rational.power" $ \ expr -> do
-  (a, x) <- match (powerViewWith rationalView plainNatView) expr
-  return $ fromRational $ a Prelude.^ x
-
--- | a^(x/y) => (a^x)^(1/y)
-calcPowerRatio :: Rule Expr
-calcPowerRatio = makeSimpleRule (power, "power-ratio") $ \ expr -> do
-  let v = powerView >>> second (rationalView >>> plainRationalView)
-  (a, (x, y)) <- match v expr
-  guard $ x /= 1 && y /= 1
-  return $ (a .^. fromInteger x) .^. (1 ./. fromInteger y)
-
--- | root n x
-calcPlainRoot :: Rule Expr
-calcPlainRoot = makeSimpleRule (power, "root") $ \expr -> do
-   (n, x) <- matchM (rootView >>> (integerView *** integerView)) expr
-   fmap fromInteger (takeRoot n x)
-
--- | [root n x, ... ]
--- BHR: not used. Better to turn this into OrList (Relation Expr)
-{-
-calcRoot :: Rule (OrList Expr)
-calcRoot = makeSimpleRule (power, "root") $
-   oneDisjunct $ \expr -> do
-      (n, x) <- match (rootView >>> (integerView *** integerView)) expr
-      y      <- liftM fromInteger $ lookup n $ map swap $ PF.allPowers (abs x)
-      let ys | x > 0 && even n = [y, negate y]
-             | x > 0 && odd  n = [y]
-             | x < 0 && odd  n = [negate y]
-             | otherwise       = []
-      roots  <- toMaybe (not. null) ys
-      return $ toOrList roots
--}
-
-calcPowerPlus :: Rule Expr
-calcPowerPlus =
-  makeCommutative sumView (.+.) $ calcBinPowerRule "plus" (.+.) isPlus
-
-calcPowerMinus :: Rule Expr
-calcPowerMinus =
-   makeCommutative sumView (.+.) $ calcBinPowerRule "minus" (.-.) isMinus
-
-addExponents :: Rule Expr
-addExponents = makeSimpleRuleList (power, "add-exponents") $ \ expr -> do
-  (sign, fs)     <- matchM (powerFactorView isPow) expr
-  ((x, y), fill) <- twoNonAdjacentHoles fs
-  prod           <- applyM addExponentsT $ x * y
-  return $ build productView (sign, fill prod)
-
-isPow :: Expr -> Expr -> Bool
-isPow x y = x `belongsTo` myIntegerView &&
-             (y `belongsTo` variableView || y `belongsTo` powerView)
-
--- | a*x^y * b*x^q = a*b * x^(y+q)
-addExponentsT :: Transformation Expr
-addExponentsT = makeTrans $ \ expr -> do
-  (e1, e2)     <- match timesView expr
-  (a, (x,  y)) <- match unitPowerView e1
-  (b, (x', q)) <- match unitPowerView e2
-  guard $ x == x'
-  return $ build unitPowerView (a .*. b, (x, y .+. q))
-
-simpleAddExponents :: Rule Expr
-simpleAddExponents = makeRule (power, "simple-add-exponents") addExponentsT
-
--- | a*x^y / b*x^q = a/b * x^(y-q)
-subExponents :: Rule Expr
-subExponents = makeSimpleRule (power, "sub-exponents") $ \ expr -> do
-  (e1, e2)     <- match divView expr
-  (a, (x,  y)) <- match unitPowerView e1
-  (b, (x', q)) <- match unitPowerView e2
-  guard $ x == x'
-  return $ build unitPowerView (a ./. b, (x, y .-. q))
-
--- | (a^x)^y = a^(x*y)
-mulExponents :: Rule Expr
-mulExponents = makeSimpleRule (power, "mul-exponents") $ \ expr -> do
-  ((a, x), y) <- match (strictPowerView >>> first powerView) expr
-  return $ build powerView (a, x .*. y)
-
--- | (a0 * a1 ... * an)^x = a0^x * a1^x ... * an^x
-distributePower :: Rule Expr
-distributePower = makeSimpleRule (power, "distr-power") $ \ expr -> do
-  ((sign, as), x) <- match (powerViewWith (toView productView) identity) expr
-  guard $ length as > 1
-  let y = build productView (False, map (\a -> build powerView (a, x)) as)
-  return $
-    maybe y (\n -> if odd n && sign then neg y else y) $ match integerView x
-
--- | (a/b)^y = (a^y / b^y)
-distributePowerDiv :: Rule Expr
-distributePowerDiv = makeSimpleRule (power, "distr-power-div") $ \ expr -> do
-  ((a, b), y) <- match (powerViewWith divView identity) expr
-  return $ build divView (build powerView (a, y), build powerView (b, y))
-
--- | a^0 = 1
-zeroPower :: Rule Expr
-zeroPower = makeSimpleRule (power, "power-zero") $ \ expr -> do
-  (_, x) <- match powerView expr
-  guard $ x == 0
-  return 1
-
--- a ^ 1 = a
-onePower :: Rule Expr
-onePower = makeSimpleRule (power, "power-one") $ \ expr -> do
-  (a, x) <- match powerView expr
-  guard $ x == 1
-  return a
-
--- 1 ^ x = 1
-powerOne :: Rule Expr
-powerOne = makeSimpleRule (power, "one-power") $ \ expr -> do
-  (a, _) <- match powerView expr
-  guard $ a == 1
-  return a
-
--- 0 ^ x = 0 with x > 0
-powerZero :: Rule Expr
-powerZero = makeSimpleRule (power, "one-power") $ \ expr -> do
-  (a, x) <- match (powerViewWith identity integerView) expr
-  guard $ x > 0 && a == 0
-  return 0
-
--- | all of the above simplification rules
-simplifyPower :: Rule Expr
-simplifyPower = makeSimpleRuleList (power, "simplify") $ \ expr ->
-  mapMaybe (`apply` expr) [zeroPower, onePower, powerOne, powerZero]
-
--- | e/a = e*a^(-1)  where a is an variable
-reciprocalVar :: Rule Expr
-reciprocalVar = makeSimpleRule (power, "reciprocal-var") $ \ expr -> do
-  (e, (c, (a, x))) <- match (divView >>> second unitPowerViewVar) expr
-  return $ (e .*. build unitPowerViewVar (1, (a, neg x))) ./. c
-
--- | c/a^x = c*a^x^(-1)
-reciprocalPower :: Rule Expr
-reciprocalPower = makeSimpleRule (power, "reciprocal-power") $ \ expr -> do
-  (e, (c, (a, x))) <- match (divView >>> second consPowerView) expr
-  return $ (e .*. build consPowerView (1, (a, neg x))) ./. c
-
--- | Use with care, will match any fraction!
-reciprocal :: Rule Expr
-reciprocal = makeSimpleRule (power, "reciprocal") $
-  apply (reciprocalForT identity)
-
--- | a/b = a*b^(-1)
-reciprocalForT :: View Expr a -> Transformation Expr
-reciprocalForT v = makeTrans $ \ expr -> do
-  (a, b) <- match divView expr
-  guard $ b `belongsTo` v
-  return $ a .*. build powerView (b, -1)
-
--- | a^x = 1/a^(-x)
-reciprocalInv ::  Rule Expr
-reciprocalInv = makeSimpleRule (power, "reciprocal-inverse") $ \ expr -> do
-  guard $ hasNegExp expr
-  (a, x) <- match strictPowerView expr
-  return $ 1 ./. build strictPowerView (a, neg x)
-
--- | c / d*a^(-x)*b^(-y)...p^r... = c*a^x*b^y.../d*p^r...
-reciprocalFrac :: Rule Expr
-reciprocalFrac = makeSimpleRule (power, "reciprocal-frac") $ \ expr -> do
-  (e1, e2) <- match divView expr
-  (s, xs)  <- match productView e2
-  let (ys, zs) = partition hasNegExp xs
-  guard (not $ null ys)
-  return $ e1 .*. build productView (s, map f ys) ./. build productView (False, zs)
-    where
-      f e = case match consPowerView e of
-              Just (c, (a, x)) -> build consPowerView (c, (a, neg x))
-              Nothing          -> e
-
--- | a^x / b^x = (a/b)^x
-divBase :: Rule Expr
-divBase = describe "divide base of root" $
-  makeSimpleRule (power, "divide-base") $ \ expr -> do
-  (e1, e2)      <- match divView expr
-  (c1, (a, x))  <- match consPowerView e1
-  (c2, (b, x')) <- match consPowerView e2
-  guard $ x == x' && b /= 0
-  return $ build consPowerView (c1 .*. c2, (a ./. b, x))
-
--- | (-a)^x = -(a^x)
-pushNegOut :: Rule Expr
-pushNegOut = makeSimpleRule (power, "push-negation-out") $ \ expr -> do
-  (a, x) <- match (powerViewWith identity integerView) expr
-  a'     <- isNegate a
-  return $ (if odd x then neg else id) $ build powerView (a', fromInteger x)
-
--- | Root rules ----------------------------------------------------------------
-
--- | a^(p/q) = root (a^p) q
-power2root :: Rule Expr
-power2root = makeSimpleRule (power, "write-as-root") $ \ expr -> do
-  (a, (p, q)) <- match (strictPowerView >>> second divView) expr
-  guard $ q /= 1
-  return $ root (a .^. p) q
-
--- | root a q = a^(1/q)
-root2power :: Rule Expr
-root2power = makeSimpleRule (power, "write-as-power") $ \ expr -> do
-  (a, q) <- match strictRootView expr
-  return $ a .^. (1 ./. q)
-
--- | Logarithmic relation rules -----------------------------------------------
-
-logarithm :: Rule (Equation Expr)
-logarithm = makeSimpleRule (logarithmic, "logarithm") $ \(lhs :==: rhs) -> do
-    (b, x) <- match logView lhs
-    return $ x :==: build powerView (b, rhs)
-
--- | Common rules --------------------------------------------------------------
-
--- | a/b * c/d = a*c / b*d  (b or d may be one)
-myFractionTimes :: Rule Expr
-myFractionTimes = smartRule $ makeSimpleRule (power, "fraction-times") $ \ expr -> do
-  (e1, e2) <- match timesView expr
-  guard $ e1 `belongsTo` divView || e2 `belongsTo` divView
-  let f e    = fromMaybe (e, 1) (match divView e)
-      (a, b) = f e1
-      (c, d) = f e2
-  return $ build divView (a .*. c, b .*. d)
-
--- | Help functions -----------------------------------------------------------
-
-calcBinPowerRule :: String -> (Expr -> Expr -> Expr) -> (Expr -> Maybe (Expr, Expr)) -> Rule Expr
-calcBinPowerRule opName op m =
-  makeSimpleRule (power, "calc-power", opName) $ \e -> do
-    (e1, e2)     <- m e
-    (c1, (a, x)) <- match unitPowerViewVar e1
-    (c2, (b, y)) <- match unitPowerViewVar e2
-    guard $ a == b && x == y
-    return $ build unitPowerViewVar (op c1 c2, (a, x))
-
--- use twoNonAdHoles instead of split ???
-makeCommutative :: IsView f => f Expr [Expr] -> (Expr -> Expr -> Expr) -> Rule Expr -> Rule Expr
-makeCommutative view op r =
-  makeSimpleRuleList (getId r) $ \ expr ->
-    case match view expr of
-      Just factors -> do
-        (e, es) <- split op factors
-        case apply r e of
-          Just e' -> return $ build view (e' : es)
-          Nothing -> []
-      Nothing -> []
-
-hasNegExp :: Expr -> Bool
-hasNegExp expr = fromMaybe False $
-  fmap ((< 0) . snd . snd) (match consPowerView expr)
− src/Domain/Math/Power/Strategies.hs 
@@ -1,71 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Domain.Math.Power.Strategies
-   ( -- * Power strategies
-     simplifyPowerStrategy
-   , calcPowerStrategy
-   , nonNegBrokenExpStrategy
-   ) where
-
-import Common.Library hiding (simplifyWith)
-import Domain.Math.Expr
-import Domain.Math.Numeric.Rules (divisionNumerator, divisionDenominator)
-import Domain.Math.Power.Rules
-import Domain.Math.Power.Utils
-import Domain.Math.Simplification
-
--- Strategies ---------------------------------------------------------------
-
--- | Simplify an expression containing powers as far as possible
-simplifyPowerStrategy :: LabeledStrategy (Context Expr)
-simplifyPowerStrategy = cleanUpStrategyRules "Simplify" powerRules
-
-nonNegBrokenExpStrategy :: LabeledStrategy (Context Expr)
-nonNegBrokenExpStrategy = cleanUpStrategy (change cleanup . applyTop cleanup) $
-   label "Write with non-negative exponent" $ exhaustiveStrategy rs
-  where
-    rs = [ addExponents, subExponents, mulExponents, reciprocalInv
-         , distributePower, distributePowerDiv, power2root, zeroPower
-         , calcPowerPlus, calcPowerMinus
-         ]
-    cleanup = applyD divisionNumerator
-            . applyD myFractionTimes
-            . mergeConstants
-            . simplifyWith simplifyConfig {withMergeAlike = False}
-
-calcPowerStrategy :: LabeledStrategy (Context Expr)
-calcPowerStrategy = cleanUpStrategy cleanup $
-   label "Calculate power" $ exhaustiveStrategy rules
-  where
-    rules = calcPower : divisionDenominator : reciprocalInv : divBase : rationalRules
-    cleanup = applyTop (applyD myFractionTimes)
-            . applyD (exhaustiveStrategy $ myFractionTimes : naturalRules)
-
--- Rule collections ---------------------------------------------------------
-
-powerRules :: [Rule Expr]
-powerRules =
-  [ addExponents, subExponents, mulExponents, distributePower, zeroPower
-  , reciprocalVar, root2power, calcPower, calcPowerPlus, calcPowerMinus
-  , pushNegOut
-  ]
-
--- | Help functions -----------------------------------------------------------
-
-cleanUpStrategyRules :: IsId n => n -> [Rule Expr] -> LabeledStrategy (Context Expr)
-cleanUpStrategyRules l =
-  cleanUpStrategy (change cleanUp. applyTop cleanUp) . label l . exhaustiveStrategy
-
-cleanUp :: Expr -> Expr
-cleanUp = mergeConstants
-        . simplifyWith simplifyConfig {withMergeAlike = False}
− src/Domain/Math/Power/Utils.hs 
@@ -1,227 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- some of these help functions may have a broader scope and could be
--- moved to other parts of the framework (eg. Common)
---
------------------------------------------------------------------------------
-module Domain.Math.Power.Utils where
-
-import Common.Library
-import Common.Utils.Uniplate
-import Data.Foldable (toList)
-import Data.Function (on)
-import Data.List
-import Data.Ratio
-import Domain.Math.CleanUp
-import Domain.Math.Data.OrList
-import Domain.Math.Data.Relation
-import Domain.Math.Equation.CoverUpRules
-import Domain.Math.Expr
-import Domain.Math.Numeric.Rules
-import Domain.Math.Numeric.Views
-
--- | Strategy functions -------------------------------------------------------
-
-exhaustiveStrategy :: IsTerm a => [Rule a] -> Strategy (Context a)
-exhaustiveStrategy = exhaustiveSomewhere . map liftToContext
-
-exhaustiveUse :: (IsTerm a, IsTerm b) => [Rule a] -> Strategy (Context b)
-exhaustiveUse = exhaustiveSomewhere . map use
-
-exhaustiveSomewhere :: IsStrategy f => [f (Context a)] -> Strategy (Context a)
-exhaustiveSomewhere = repeatS . somewhere . alternatives
-
--- | Rule functions -----------------------------------------------------------
-
-smartRule :: Rule Expr -> Rule Expr
-smartRule = doAfter f
-  where
-    f (a :*: b) = a .*. b
-    f (a :/: b) = a ./. b
-    f (Negate a) = neg a
-    f (a :+: b) = a .+. b
-    f (a :-: b) = a .-. b
-    f e = e
-
-mergeConstantsWith :: (Expr -> Bool) -> Expr -> Expr
-mergeConstantsWith p = simplifyWith f productView
-  where
-    f (sign, xs) =
-      let (cs, ys) = partition p xs
-          c = simplify rationalView $ build productView (False, cs)
-      in if maybe False (> 1) (match rationalView c)
-           then (sign, c:ys)
-           else (sign, xs)
-
-mergeConstants :: Expr -> Expr
-mergeConstants = mergeConstantsWith (`belongsTo` rationalView)
-
--- | View functions -----------------------------------------------------------
-
-plainNatView :: View Expr Integer
-plainNatView = makeView f Nat
-  where
-    f (Nat n) = Just n
-    f _       = Nothing
-
-myIntegerView :: View Expr Integer
-myIntegerView = makeView f fromInteger
-  where
-    f (Nat n)          = Just n
-    f (Negate (Nat n)) = Just $ negate n
-    f _                = Nothing
-
-plainRationalView :: View Rational (Integer, Integer)
-plainRationalView =
-  makeView (\x -> return (numerator x, denominator x)) (uncurry (%))
-
-eqView :: View a b -> View (Equation a) (b, b)
-eqView v = eqv >>> v *** v
-  where
-    eqv = makeView (\(lhs :==: rhs) -> Just (lhs, rhs)) (uncurry (:==:))
-
-relationView :: View (Equation a) (Relation a)
-relationView = makeView f g
- where
-   f (x :==: y) = return $ x .==. y
-   g r | relationType r == EqualTo = leftHandSide r :==: rightHandSide r
-       | otherwise                 = error "Not an equality"
-
--- | Rule collections ---------------------------------------------------------
-
-naturalRules :: [Rule Expr]
-naturalRules =
-   [ calcPlusWith "nat" plainNatView, calcMinusWith "nat" plainNatView
-   , calcTimesWith "nat" plainNatView, calcDivisionWith "nat" plainNatView
-   , doubleNegate, negateZero , plusNegateLeft, plusNegateRight
---   , minusNegateLeft
-   , minusNegateRight, timesNegateLeft, timesNegateRight, divisionNegateLeft
-   , divisionNegateRight
-   ]
-
-rationalRules :: [Rule Expr]
-rationalRules =
-   [ calcPlusWith "rational" rationalRelaxedForm
-   , calcMinusWith "rational" rationalRelaxedForm
-   , calcTimesWith "rational" rationalRelaxedForm
-   , calcDivisionWith "integer" integerNF
-   , doubleNegate, negateZero, divisionDenominator, divisionNumerator
-   , simplerFraction
-   ]
-
-coverUpRulesX :: [Rule (Equation Expr)]
-coverUpRulesX = map (\r -> r cfg)
-   [ coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith, coverUpNegateWith
-   , coverUpTimesWith, coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith
-   ]
-   where
-     cfg = configCoverUp { predicateCovered = elem "x" . vars
-                         , predicateCombined = notElem "x" . vars
-                         , coverLHS = False}
-
--- | Common functions ---------------------------------------------------------
-
-sortExpr :: Expr -> Expr
-sortExpr = transform $ simplifyWith (sort . map sortProd) sumView
-  where sortProd = simplifyWith (fmap sort) productView
-
-sortEquation :: Equation Expr -> Equation Expr
-sortEquation (x :==: y) = if x < y then eq else flipSides eq
-  where eq = sortExpr x :==: sortExpr y
-
-sortOrList :: OrList (Equation Expr) -> OrList (Equation Expr)
-sortOrList = toOrList . sort . map sortEquation . toList
-
--- Semantic equivalence
-class SemEq a where
-    (===), (=/=) :: a -> a -> Bool
-    x =/= y = not (x === y)
---    x === y = not (x =/= y)
-
-infix 4 ===, =/=
-
-instance SemEq a => SemEq (Equation a) where
-  (a :==: b) === (c :==: d) = a === c && b === d || a === d && b === c
-
-instance SemEq Expr where
-  (===) = on (==) cleanUpExpr
-
-instance SemEq a => SemEq (OrList a) where
-  a === b = let as = toList a ; bs = toList b
-            in length (intersectBy (===) as bs) == length as
-
--- y = root n x
-takeRoot :: Integer -> Integer -> Maybe Integer
-takeRoot n x
-   | n >= 0 && x >0 && a Prelude.^ x == n = Just a
-   | otherwise = Nothing
- where
-   a = round (fromInteger n ** (1/fromInteger x) :: Double)
-{-
-| n == 0    = [0]
-             | n == 1    = if x > 0 && odd x then [1] else [1, -1]
-             | n == (-1) = [-1 | x > 0 && odd x]
-             | x == 1    = [n]
-             | x > 0     = maybe [] roots $ lookup x $ map swap $ PF.allPowers (abs n)
-             | otherwise = []
-  where
-    roots r | n > 0 && even x = [r, negate r]
-            | n > 0 && odd  x = [r]
-            | n < 0 && odd  x = [negate r]
-            | otherwise       = [] -}
-
--- prop_takeRoot n = traceShow n f
---   where
---     f n x | x > 0 = n `elem` (takeRoot (n Prelude.^ x) x)
---           | otherwise = True
-
-swap :: (a, b) -> (b, a)
-swap (a, b) = (b, a)
-
-split :: (Eq a) => (a -> a -> t) -> [a] -> [(t, [a])]
-split op xs = f xs
-      where
-        f (y:ys) | not (null ys) = [(y `op` z, xs \\ [y, z]) | z <- ys] ++ f ys
-                 | otherwise     = []
-        f [] = []
-
-toMaybe :: (a -> Bool) -> a -> Maybe a
-toMaybe p x = if p x then Just x else Nothing
-
-joinBy :: Eq a => (a -> a -> Bool) -> [a] -> [[a]]
-joinBy _  [] = []
-joinBy eq xs = ys : joinBy eq (xs \\ ys)
-  where
-    ys = dropUntil eq xs
-
-dropUntil :: (a -> a -> Bool) -> [a] -> [a]
-dropUntil _ []       = []
-dropUntil _ [x]      = [x]
-dropUntil p (x:y:ys) | p x y     = x : dropUntil p (y:ys)
-                     | otherwise = [x]
-
-holes :: [a] -> [(a, [a], a -> [a])]
-holes xs = map f [0 .. length xs - 1]
-  where
-    f i = let (ys, z:zs) = splitAt i xs
-          in (z, ys ++ zs, \x -> ys ++ x:zs)
-
-twoNonAdjacentHoles :: [a] -> [((a, a), a -> [a])]
-twoNonAdjacentHoles xs = concatMap g pairs
-  where
-    pairs = [(x, y) | x <- [0 .. length xs - 1], y <- [x + 1 .. length xs - 1]]
-    g (x, y) = let (ys, z:zs) = splitAt x xs
-                   (ps, q:qs) = splitAt (y - x - 1) zs
-               in if null ps
-                 then [ ((z, q), \a -> ys ++ a:ps ++ qs) ]
-                 else [ ((z, q), \a -> ys ++ a:ps ++ qs)
-                      , ((z, q), \a -> ys ++ ps ++ a:qs) ]
− src/Domain/Math/Power/Views.hs 
@@ -1,132 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-
-module Domain.Math.Power.Views
-   ( -- * Power views
-     -- ** Simple power views
-     powerView, powerViewWith, powerViewFor, powerFactorView
-     -- ** Views for power expressions with a constant factor
-   , consPowerView
-     -- ** Power views that allow constants
-   , unitPowerView, unitPowerViewVar, strictPowerView
-     -- Root views
-   , rootView, strictRootView
-     -- * Log view
-   , logView
-     -- * Other views
-   , plainNatView, plainRationalView
-   ) where
-
-import Common.Library hiding (root)
-import Control.Monad
-import Domain.Math.Expr
-import Domain.Math.Power.Utils
-
--- Power views with constant factor -----------------------------------------
-
-consPowerView :: View Expr (Expr, (Expr, Expr))
-consPowerView = makeView f g
- where
-   f (Negate a) = fmap (first Negate) (f a)
-   f (a :*: b)  = fmap ((,) a) (match powerView b)
-   f expr       = f (1 :*: expr)
-   g = build (timesView >>> second powerView)
-
-unitPowerViewWith :: View Expr a -> View Expr (Expr, (a, Expr))
-unitPowerViewWith v = makeView f g
- where
-   mv = powerViewWith v identity
-   f (Negate a) = fmap (first Negate) (f a)
-   f (a :*: b)  = do
-         x <- match mv b
-         return (a, x)
-       `mplus` do
-         x <- match v b
-         return (a, (x, 1))
-   f expr = f (1 :*: expr)
-   g = build (timesView >>> second mv)
-
-unitPowerViewVar :: View Expr (Expr, (String, Expr))
-unitPowerViewVar = unitPowerViewWith variableView
-
--- | Careful! This view will match anything, so use it wise and with care.
-unitPowerView :: View Expr (Expr, (Expr, Expr))
-unitPowerView = unitPowerViewWith identity
-
--- | A root view
-rootView :: View Expr (Expr, Expr)
-rootView = makeView f (uncurry root)
-  where
-    f expr = do
-      (a, (x, y)) <- match (powerView >>> second divView) expr
-      guard (x `elem` [1, -1])
-      return $ if x == 1 then (a, y) else (a, negate y)
-
--- | only matches sqrt and root
-strictRootView :: View Expr (Expr, Expr)
-strictRootView = makeView f g
-  where
-    f expr =
-      case expr of
-        Sym s [a, b] | isRootSymbol s -> return (a, b)
-        Sqrt e                       -> return (e, 2)
-        _ -> Nothing
-
-    g (a, b) = if b == 2 then Sqrt a else root a b
-
--- Power views --------------------------------------------------------------
-
-strictPowerView :: View Expr (Expr, Expr)
-strictPowerView = makeView f (uncurry (.^.))
-  where
-    f expr =
-      case expr of
-        Sym s [a, b] | isPowerSymbol s -> return (a, b)
-        _ -> Nothing
-
-powerView :: View Expr (Expr, Expr)
-powerView = matcherView f g
-  where
-    f = matcher (strictRootView >>> second (arr (1 ./.)))
-        <+> matcher strictPowerView
-    g (a, b) =
-       case b of
-         (Nat 1 :/: b') -> build strictRootView (a, b')
-         _              -> build strictPowerView (a, b)
-
-powerViewWith :: View Expr a -> View Expr b -> View Expr (a, b)
-powerViewWith va vb = powerView >>> (va *** vb)
-
-powerViewForWith :: Eq a => View Expr a -> View Expr b -> a -> View Expr b
-powerViewForWith va vb a = makeView f ((build va a .^.) .  build vb)
-  where
-    f expr = do
-      (a', b) <- match (powerViewWith va vb) expr
-      guard $ a == a'
-      return b
-
-powerViewFor :: Expr -> View Expr Expr
-powerViewFor = powerViewForWith identity identity
-
-powerFactorView :: (Expr -> Expr -> Bool) -> Isomorphism Expr (Bool, [Expr])
-powerFactorView p = productView >>> second (f <-> id)
-  where
-    f = map (build productView . (,) False) . joinBy p
-
--- Log views ----------------------------------------------------------------
-
-logView :: View Expr (Expr, Expr)
-logView = makeView f (uncurry logBase)
-  where
-    f expr = case expr of
-        Sym s [a, b] | isLogSymbol s -> return (a, b)
-        _ -> Nothing
− src/Domain/Math/Safe.hs 
@@ -1,78 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Safe
-   ( -- * Safe division
-     SafeDiv(..), safeDivFractional
-   , -- * Safe power and root
-     SafePower(..)
-   ) where
-
-import Data.Ratio
-
--------------------------------------------------------------------
--- Safe division
-
-class Num a => SafeDiv a where
-   safeDiv   :: a -> a -> Maybe a
-   safeRecip :: a -> Maybe a
-   -- default definitions
-   safeRecip = safeDiv 1
-
-instance SafeDiv Integer where
-   safeDiv x y
-      | y /= 0 && m == 0 = Just d
-      | otherwise        = Nothing
-    where (d, m) = x `divMod` y
-
-instance SafeDiv Double where
-   safeDiv = safeDivFractional
-
-instance Integral a => SafeDiv (Ratio a) where
-   safeDiv = safeDivFractional
-
-safeDivFractional :: Fractional a => a -> a -> Maybe a
-safeDivFractional x y
-   | y /= 0    = Just (x / y)
-   | otherwise = Nothing
-
--------------------------------------------------------------------
--- Safe power and root
-
-class Num a => SafePower a where
-   safePower :: a -> a -> Maybe a
-   safeSqrt  :: a -> Maybe a
-   safeRoot  :: a -> a -> Maybe a
-   -- default definitions
-   safeSqrt = (`safeRoot` 2)
-
-instance SafePower Integer where
-   safeRoot _ _ = Nothing
-   safePower x y
-      | y >= 0    = Just (x ^ y)
-      | otherwise = Nothing
-
-instance Integral a => SafePower (Ratio a) where
-   safeRoot _ _ = Nothing
-   safePower x y
-      | denominator y /= 1 = Nothing
-      | numerator y >= 0   = Just a
-      | otherwise          = Just (1/a)
-    where
-      a = x ^ abs (numerator y)
-
-instance SafePower Double where
-   safePower x y
-      | x==0 && y<0 = Nothing
-      | otherwise   = Just (x**y)
-   safeRoot x y
-      | x >= 0 && y >= 1 = Just (x ** (1/y))
-      | otherwise        = Nothing
− src/Domain/Math/Simplification.hs 
@@ -1,209 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.Simplification
-   ( Simplify(..), SimplifyConfig(..)
-   , simplifyConfig
-   , Simplified, simplified, liftS, liftS2
-   , simplifyRule
-   , collectLikeTerms, mergeAlike, distribution, constantFolding
-   , mergeAlikeSum, mergeAlikeProduct
-   ) where
-
-import Common.Library hiding (simplify, simplifyWith)
-import Common.Utils.Uniplate
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Domain.Math.CleanUp (smart)
-import Domain.Math.Data.Relation
-import Domain.Math.Expr
-import Domain.Math.Numeric.Views
-import Domain.Math.SquareRoot.Views
-import qualified Common.View as View
-
-data SimplifyConfig = SimplifyConfig
-  { withSmartConstructors  :: Bool
-  , withMergeAlike         :: Bool
-  , withDistribution       :: Bool
-  , withSimplifySquareRoot :: Bool
-  , withConstantFolding    :: Bool
-  }
-
-class Simplify a where
-   simplifyWith :: SimplifyConfig -> a -> a
-   simplify :: a -> a
-   simplify = simplifyWith simplifyConfig
-
-simplifyConfig :: SimplifyConfig
-simplifyConfig = SimplifyConfig True True True True True
-
-instance Simplify a => Simplify (Context a) where
-   simplifyWith cfg = change $ simplifyWith cfg
-
-instance Simplify a => Simplify (Equation a) where
-   simplifyWith cfg = fmap $ simplifyWith cfg
-
-instance Simplify a => Simplify (Relation a) where
-   simplifyWith cfg = fmap $ simplifyWith cfg
-
-instance Simplify a => Simplify [a] where
-   simplifyWith cfg = fmap $ simplifyWith cfg
-
-instance Simplify Expr where
-   simplifyWith cfg = let optional p f = if p then f else id in
-       optional (withSmartConstructors cfg)  (transform smart)
-     . optional (withMergeAlike cfg)         mergeAlike
-     . optional (withDistribution cfg)       distribution
-     . optional (withSimplifySquareRoot cfg) (View.simplify
-                                               (squareRootViewWith rationalView))
-     . optional (withConstantFolding cfg)    constantFolding
-
-instance Simplify a => Simplify (Rule a) where
-   simplifyWith cfg = doAfter (simplifyWith cfg) -- by default, simplify afterwards
-
-data Simplified a = S a deriving (Eq, Ord)
-
-instance Show a => Show (Simplified a) where
-   show (S x) = show x
-
-instance (Num a, Simplify a) => Num (Simplified a) where
-   (+)         = liftS2 (+)
-   (*)         = liftS2 (*)
-   (-)         = liftS2 (-)
-   negate      = liftS negate
-   abs         = liftS abs
-   signum      = liftS signum
-   fromInteger = simplified . fromInteger
-
-instance (Fractional a, Simplify a) => Fractional (Simplified a) where
-   (/)          = liftS2 (/)
-   recip        = liftS recip
-   fromRational = simplified . fromRational
-
-instance (Floating a, Simplify a) => Floating (Simplified a) where
-   pi      = simplified pi
-   sqrt    = liftS  sqrt
-   (**)    = liftS2 (**)
-   logBase = liftS2 logBase
-   exp     = liftS exp
-   log     = liftS log
-   sin     = liftS sin
-   tan     = liftS tan
-   cos     = liftS cos
-   asin    = liftS asin
-   atan    = liftS atan
-   acos    = liftS acos
-   sinh    = liftS sinh
-   tanh    = liftS tanh
-   cosh    = liftS cosh
-   asinh   = liftS asinh
-   atanh   = liftS atanh
-   acosh   = liftS acosh
-
-instance (Simplify a, IsTerm a) => IsTerm (Simplified a) where
-   toTerm (S x) = toTerm x
-   fromTerm     = liftM simplified . fromTerm
-
-simplified :: Simplify a => a -> Simplified a
-simplified = S . simplify
-
-liftS :: Simplify a => (a -> a) -> Simplified a -> Simplified a
-liftS f (S x) = simplified (f x)
-
-liftS2 :: Simplify a => (a -> a -> a) -> Simplified a -> Simplified a -> Simplified a
-liftS2 f (S x) (S y) = simplified (f x y)
-
-simplifyRule :: Simplify a => Rule a
-simplifyRule = simplify idRule
-
--------------------------------------------------------------
--- Distribution of constants
-
-distribution :: Expr -> Expr
-distribution = descend distribution . f
- where
-  f expr =
-   fromMaybe expr $
-   case expr of
-      a :*: b -> do
-         (x, y) <- match plusView a
-         r      <- match rationalView b
-         return $ (fromRational r .*. x) .+. (fromRational r .*. y)
-       `mplus` do
-         r      <- match rationalView a
-         (x, y) <- match plusView b
-         return $ (fromRational r .*. x) .+. (fromRational r .*. y)
-      a :/: b -> do
-         xs <- match sumView a
-         guard (length xs > 1)
-         return $ build sumView $ map (./. b) xs
-      _ -> Nothing
-
--------------------------------------------------------------
--- Constant folding
-
--- Not an efficient implementation: could be improved if necessary
-constantFolding :: Expr -> Expr
-constantFolding expr =
-   case match rationalView expr of
-      Just r  -> fromRational r
-      Nothing -> descend constantFolding expr
-
-----------------------------------------------------------------------
--- merge alike for sums and products
-
--- Todo: combine with mergeAlike (subtle differences)
-collectLikeTerms :: Expr -> Expr
-collectLikeTerms = View.simplifyWith f sumView
- where
-   f = mergeAlikeSum . map (View.simplifyWith (second mergeAlikeProduct) productView)
-
-mergeAlike :: Expr -> Expr
-mergeAlike a =
-   case (match sumView a, match productView a) of
-      (Just xs, _) | length xs > 1 ->
-         build sumView (sort $ mergeAlikeSum $ map mergeAlike xs)
-      (_, Just (b, ys)) | length (filter (/= 1) ys) > 1 ->
-         build productView (b, sort $ mergeAlikeProduct $ map mergeAlike ys)
-      _ -> a
-
-mergeAlikeProduct :: [Expr] -> [Expr]
-mergeAlikeProduct ys = f [ (match rationalView y, y) | y <- ys ]
- where
-   f []                    = []
-   f ((Nothing  , e):xs)   = e:f xs
-   f ((Just r   , _):xs)   =
-      let cs   = r : [ c | (Just c, _) <- xs ]
-          rest = [ x | (Nothing, x) <- xs ]
-      in build rationalView (product cs):rest
-
-mergeAlikeSum :: [Expr] -> [Expr]
-mergeAlikeSum xs = rec [ (Just $ pm 1 x, x) | x <- xs ]
- where
-   pm :: Rational -> Expr -> (Rational, Expr)
-   pm r (e1 :*: e2) = case (match rationalView e1, match rationalView e2) of
-                         (Just r1, _) -> pm (r*r1) e2
-                         (_, Just r1) -> pm (r*r1) e1
-                         _           -> (r, e1 .*. e2)
-   pm r (Negate e) = pm (negate r) e
-   pm r e = case match rationalView e of
-               Just r1 -> (r*r1, Nat 1)
-               Nothing -> (r, e)
-
-   rec [] = []
-   rec ((Nothing, e):ys) = e:rec ys
-   rec ((Just (r, a), e):ys) = new:rec rest
-    where
-      (js, rest) = partition (maybe False ((==a) . snd) . fst) ys
-      rs  = r:map fst (mapMaybe fst js)
-      new | null js   = e
-          | otherwise = build rationalView (sum rs) .*. a
− src/Domain/Math/SquareRoot/Tests.hs 
@@ -1,29 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.SquareRoot.Tests (tests) where
-
-import Common.Algebra.Field
-import Common.Algebra.Group
-import Common.Algebra.Law
-import Common.Utils.TestSuite
-import Domain.Math.Data.SquareRoot
-
--------------------------------------------------------------------
--- Testing
-
-tests :: TestSuite
-tests = mapM_ f $ commutativeRingLaws ++
-                  distributiveSubtractionLaws ++
-                  map fromAdditiveLaw appendInverseLaws
- where
-   f :: Law (SafeNum (SquareRoot Rational)) -> TestSuite
-   f p = addProperty (show p) p
− src/Domain/Math/SquareRoot/Views.hs 
@@ -1,50 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Math.SquareRoot.Views
-   ( squareRootView, squareRootViewWith
-   ) where
-
-import Common.View
-import Control.Monad
-import Domain.Math.Data.SquareRoot
-import Domain.Math.Expr hiding ((^))
-import Domain.Math.Numeric.Views
-import Domain.Math.Safe
-
-squareRootView :: View Expr (SquareRoot Expr)
-squareRootView = squareRootViewWith identity
-
-squareRootViewWith :: Fractional a => View Expr a -> View Expr (SquareRoot a)
-squareRootViewWith v = makeView f g
- where
-   f expr =
-      case expr of
-         Nat a    -> Just (fromIntegral a)
-         a :+: b  -> liftM2 (+) (f a) (f b)
-         a :-: b  -> liftM2 (-) (f a) (f b)
-         Negate a -> fmap negate (f a)
-         a :*: b  -> liftM2 (*) (f a) (f b)
-         a :/: b  -> join $ liftM2 safeDiv (f a) (f b)
-         Sqrt a   -> fmap sqrtRational (match rationalView a)
-         Sym s [a, b] | isPowerSymbol s ->
-            liftM2 power (f a) (match integerView b)
-         _ -> fmap con (match v expr)
-
-   power a n
-      | n >= 0    = a ^ n
-      | otherwise = 1 / (a ^ abs n)
-
-   g = to sumView . map h . toList
-   h (a, n)
-      | n == 0    = 0
-      | n == 1    = build v a
-      | otherwise = build v a .*. Sqrt (fromIntegral n)
− src/Domain/RelationAlgebra.hs 
@@ -1,70 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.RelationAlgebra (module Export) where
-
-import Domain.RelationAlgebra.Exercises as Export
-import Domain.RelationAlgebra.Formula as Export
-import Domain.RelationAlgebra.Generator as Export
-import Domain.RelationAlgebra.Parser as Export
-import Domain.RelationAlgebra.Rules as Export
-import Domain.RelationAlgebra.Strategies as Export
--- import Domain.RelationAlgebra.Equivalence
-
-{-
-import Common.Classes
-import Common.Context
-import Control.Monad
-import Data.List
-import System.Random
-import Test.QuickCheck
-
-nrpairs = 2000 -- 20000
-
-repeatM :: Monad m => m a -> m [a]
-repeatM m = liftM2 (:) m (repeatM m)
-
-pairs :: [(RelAlg, RelAlg)]
-pairs = take nrpairs $ generate 100 (mkStdGen 280578) (repeatM arbitrary)
-
-precision :: IO ()
-precision = do
-   let f (x, y) = probablyEqualWithG (mkStdGen 28) x y
-       ms   = map f pairs
-       freq = map g $ group $ sort ms
-       is   = [ n | (Just n, _)  <- freq ]
-       g xs@(x:_) = (x, length xs)
-       h n = let score = sum [ i | (Just m, i) <- freq, m <= n ]
-             in putStrLn $ show n ++ ": " ++ showPerc (nrpairs - score - dif)
-       troubles = [ (norm p, norm q) | (Nothing, (p, q)) <- zip ms pairs ]
-       len = length unknown
-       dif = length troubles - len
-       unknown  = -- map (\(a,b) -> (a, b, isEquivalent a b)) $
-                  filter (\(a,b) -> a /= b) troubles
-   putStrLn $ map (maybe '!' (const '.')) ms
-   mapM_ h is
-
-   putStrLn $ unlines $ map show unknown
-   putStrLn $ "(" ++ show len ++ " unknown)"
-
-showPerc :: Int -> String
-showPerc n = show (fromIntegral (100*n)/fromIntegral nrpairs) ++ "%"
-
-norm :: RelAlg -> RelAlg
-norm = fromContext . applyD toCNF . inContext
-
-pair1 = ((Not (Inv (Var "q")) :&&: Not (Inv (Var "s"))) :&&: Inv (Var "s") :.: Inv (Var "q"),E)
-pair2 = ((Var "s" :&&: (E :+: Not (Var "r")) :.: Inv (Var "r") :&&: ((Not (Var "s") :.: Var "q") :||: (Not (Var "s") :.: Var "s"))) :.: (Var "s" :+: Inv (Var "r") :.: (Inv (Var "s") :+: Inv (Var "r")) :&&: Inv (Var "q")),E)
-pair3 = ((Not (Var "q") :||: Not (Var "s")) :||: ((Inv (Var "r") :+: E :.: Inv (Var "q")) :||: (Not (Var "q") :||: Var "s")),U)
-
-test1 = uncurry isEquivalent pair1
-test2 = uncurry isEquivalent pair2
-test3 = uncurry isEquivalent pair3 -}
− src/Domain/RelationAlgebra/Exercises.hs 
@@ -1,55 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.RelationAlgebra.Exercises (cnfExercise) where
-
-import Common.Library
-import Data.Maybe
-import Domain.RelationAlgebra.Formula
-import Domain.RelationAlgebra.Generator
-import Domain.RelationAlgebra.Parser
-import Domain.RelationAlgebra.Rules
-import Domain.RelationAlgebra.Strategies
-import Prelude hiding (repeat)
-import Test.QuickCheck
-
-cnfExercise :: Exercise RelAlg
-cnfExercise = makeExercise
-   { exerciseId     = describe "To conjunctive normal form" $
-                         newId "relationalgebra.cnf"
-   , status         = Alpha
-   , parser         = parseRelAlg
-   , prettyPrinter  = ppRelAlg
-   , equivalence    = withoutContext probablyEqual -- isEquivalent
-   , extraRules     = map liftToContext (relAlgRules ++ buggyRelAlgRules)
-   , strategy       = toCNF
-   , navigation     = navigator
-   , ready          = predicate (myReady cnfExercise)
-   , randomExercise = let ok p = let n = fromMaybe maxBound (stepsRemaining 4 p)
-                                 in n >= 2 && n <= 4
-                      in useGenerator ok (\_ -> templateGenerator 1)
-   , testGenerator  = Just arbitrary
-   }
-
-stepsRemaining :: Int -> RelAlg -> Maybe Int
-stepsRemaining i =
-   lengthMax i . derivationTree toCNF . inContext cnfExercise
-
-{- cnfExerciseSimple :: Exercise RelAlg
-cnfExerciseSimple = cnfExercise
-   { identifier  = "cnf-simple"
-   , description = description cnfExercise ++ " (simple)"
-   , strategy    = label "Apply rules exhaustively" $ repeat $ somewhere $ alternatives $ ruleset cnfExercise
-   } -}
-
-myReady :: Exercise a -> a -> Bool
-myReady ex = null . applyAll (alternatives $ filter (not . isBuggyRule) (ruleset ex))
-         . inContext ex
− src/Domain/RelationAlgebra/Formula.hs 
@@ -1,212 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.RelationAlgebra.Formula where
-
-import Common.Rewriting
-import Common.Utils
-import Common.Utils.Uniplate
-import Control.Monad
-import Data.List
-import System.Random (StdGen, mkStdGen, split, randomR)
-import Test.QuickCheck
-import Test.QuickCheck.Gen
-import qualified Data.Set as S
-
-infixr 2 :.:
-infixr 3 :+:
-infixr 4 :||:
-infixr 5 :&&:
-
--- | The data type RelAlg is the abstract syntax for the domain
--- | of logic expressions.
-data RelAlg = Var String
-            | RelAlg :.:  RelAlg           -- composition
-            | RelAlg :+: RelAlg            -- relative addition
-            | RelAlg :&&:  RelAlg          -- and (conjunction)
-            | RelAlg :||:  RelAlg          -- or (disjunction)
-            | Not RelAlg                   -- not
-            | Inv RelAlg                   -- inverse
-            | V                            -- universe
-            | I                            -- identity relation
- deriving (Show, Eq, Ord)
-
--- The empty relation is a smart-constructor: it has no (longer an) actual constructor
--- in the RelAlg datatype
-empty :: RelAlg
-empty = Not V
-
--------------------------------------
-
-isAtom :: RelAlg -> Bool
-isAtom  r =
-    case r of
-      Var _             -> True
-      Not I             -> True
-      Not V             -> True
-      Not (Var _)       -> True
-      Inv (Var _)       -> True
-      Not (Inv (Var _)) -> True
-      V                 -> True
-      I                 -> True
-      _                 -> False
-
-isMolecule :: RelAlg -> Bool
-isMolecule (r :.: s) = isMolecule r && isMolecule s
-isMolecule (r :+: s) = isMolecule r && isMolecule s
-isMolecule r = isAtom r
-
-isDisj :: RelAlg -> Bool
-isDisj (r :||: s) = isDisj r && isDisj s
-isDisj r = isMolecule r
-
-isCNF :: RelAlg -> Bool
-isCNF (r :&&: s) = isCNF r && isCNF s
-isCNF r = isDisj r
-
--- | The type RelAlgAlgebra is the algebra for the data type RelAlg
--- | Used in the fold for RelAlg.
-type RelAlgAlgebra a = (String -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a -> a, a -> a, a -> a, a, a)
-
--- | foldRelAlg is the standard folfd for RelAlg.
-foldRelAlg :: RelAlgAlgebra a -> RelAlg -> a
-foldRelAlg (var, comp, add, conj, disj, neg, inv, univ, ident) = rec
- where
-   rec term =
-      case term of
-         Var x     -> var x
-         p :.: q   -> rec p `comp` rec q
-         p :+: q   -> rec p `add`  rec q
-         p :&&: q  -> rec p `conj` rec q
-         p :||: q  -> rec p `disj` rec q
-         Not p     -> neg (rec p)
-         Inv p     -> inv (rec p)
-         V         -> univ
-         I         -> ident
-
-type Relation a = S.Set (a, a)
-
-evalRelAlg :: Ord a => (String -> Relation a) -> [a] -> RelAlg -> Relation a
-evalRelAlg var as = foldRelAlg (var, comp, add, conj, disj, neg, inv, univ, ident)
- where
-   pairs = cartesian as as
-
-   comp p q = let f (a1, a2) c = (a1, c) `S.member` p && (c, a2) `S.member` q
-              in S.fromAscList [ x | x <- pairs, any (f x) as ]
-   add p q  = let f (a1, a2) c = (a1, c) `S.member` p || (c, a2) `S.member` q
-              in S.fromAscList [ x | x <- pairs, all (f x) as ]
-   conj     = S.intersection
-   disj     = S.union
-   neg p    = S.fromAscList [ x | x <- pairs, x `S.notMember` p ]
-   inv      = S.map (\(x, y) -> (y, x))
-   univ     = S.fromAscList pairs
-   ident    = S.fromAscList [ (x, x) | x <- as ]
-
--- | Try to find a counter-example showing that the two formulas are not equivalent.
-probablyEqual :: RelAlg -> RelAlg -> Bool
-probablyEqual = probablyEqualWith (mkStdGen 28)
-
-probablyEqualWith :: StdGen -> RelAlg -> RelAlg -> Bool
-probablyEqualWith rng p q = all (\i -> eval i p == eval i q) (makeRngs 50 rng)
- where
-   -- size of (co-)domain
-   as :: [Int]
-   as = [0..1]
-   -- number of attemps (with different randomly generated relations)
-   makeRngs :: Int -> StdGen -> [StdGen]
-   makeRngs n g
-      | n == 0    = []
-      | otherwise = let (g1, g2) = split g in g1 : makeRngs (n-1) g2
-   eval g =
-      let MkGen f   = arbRelations as
-          (size, a) = randomR (0, 100) g
-      in evalRelAlg (f a size) as
-
-arbRelations :: Eq a => [a] -> Gen (String -> Relation a)
-arbRelations as = promote (\s -> coarbitrary s (arbRelation as))
-
--- Suitable for small domains (e.g., with just 2 elements)
-arbRelation :: Eq a => [a] -> Gen (Relation a)
-arbRelation as = do
-   let f _ = elements [True, False]
-   xs <- filterM f (cartesian as as)
-   return (S.fromAscList xs)
-
--- Alternative relation generator, which works best for slightly
--- larger domains (for instance, with 4 elements or more)
-arbRelationAlt:: Eq a => [a] -> Gen (Relation a)
-arbRelationAlt as = do
-   n  <- choose (0, 100)
-   let f x = do
-          m <- choose (1::Int, 100)
-          return [ x | n < m ]
-   xs <- mapM f $ cartesian as as
-   return $ S.fromAscList $ concat xs
-
--- Test on a limited domain whether two relation algebra terms are equivalent
-(===) :: RelAlg -> RelAlg -> Property
-p === q = forAll arbitrary $ \n -> probablyEqualWith (mkStdGen n) p q
-
--- | Function varsRelAlg returns the variables that appear in a RelAlg expression.
-varsRelAlg :: RelAlg -> [String]
-varsRelAlg = foldRelAlg (return, union, union, union, union, id, id, [], [])
-
-instance Uniplate RelAlg where
-   uniplate term =
-      case term of
-         s :.:  t  -> plate (:.:)  |* s |* t
-         s :+:  t  -> plate (:+:)  |* s |* t
-         s :&&: t  -> plate (:&&:) |* s |* t
-         s :||: t  -> plate (:||:) |* s |* t
-         Not s     -> plate Not    |* s
-         Inv s     -> plate Inv    |* s
-         _         -> plate term
-
-instance Different RelAlg where
-   different = (V, I)
-
-instance IsTerm RelAlg where
-   toTerm = foldRelAlg
-      ( variable, binary compSymbol, binary addSymbol
-      , binary conjSymbol
-      , binary disjSymbol, unary notSymbol, unary invSymbol
-      , symbol universeSymbol, symbol identSymbol
-      )
-
-   fromTerm a =
-      fromTermWith f a `mplus` liftM Var (getVariable a)
-    where
-      f s []
-         | s == universeSymbol  = return V
-         | s == identSymbol     = return I
-      f s [x]
-         | s == notSymbol       = return (Not x)
-         | s == invSymbol       = return (Inv x)
-      f s [x, y]
-         | s == compSymbol      = return (x :.:  y)
-         | s == addSymbol       = return (x :+:  y)
-         | s == conjSymbol      = return (x :&&: y)
-         | s == disjSymbol      = return (x :||: y)
-      f _ _ = fail "fromTerm"
-
-compSymbol, addSymbol, conjSymbol, disjSymbol,
-   notSymbol, invSymbol, universeSymbol, identSymbol :: Symbol
-compSymbol     = relalgSymbol "comp"
-addSymbol      = relalgSymbol "add"
-conjSymbol     = relalgSymbol "conj"
-disjSymbol     = relalgSymbol "disj"
-notSymbol      = relalgSymbol "not"
-invSymbol      = relalgSymbol "inv"
-universeSymbol = relalgSymbol "universe"
-identSymbol    = relalgSymbol "ident"
-
-relalgSymbol :: String -> Symbol
-relalgSymbol a = newSymbol ["relalg", a]
− src/Domain/RelationAlgebra/Generator.hs 
@@ -1,95 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.RelationAlgebra.Generator (templateGenerator) where
-
-import Control.Monad
-import Domain.RelationAlgebra.Formula
-import Test.QuickCheck
-
-instance Arbitrary RelAlg where
-   arbitrary = sized (arbRelAlg . min 8)
-
-arbRelAlg :: Int -> Gen RelAlg
-arbRelAlg 0 = frequency [(8, liftM Var (elements relAlgVars)), (1, return V), (1, return empty), (1, return I)]
-arbRelAlg n = oneof [ arbRelAlg 0, binop (:.:), binop (:+:), binop (:&&:), binop (:||:)
-                    , unop Not, unop Inv
-                    ]
- where
-   binop op = liftM2 op rec rec
-   unop op  = liftM op rec
-   rec      = arbRelAlg (n `div` 2)
-
-relAlgVars :: [String]
-relAlgVars = ["q", "r", "s"]
-
--------------------------------------------------------------------
--- Templates
-
-template1, template2, template3, template4, template7, template8 ::
-   RelAlg -> RelAlg -> RelAlg -> RelAlg
-
-template5 :: RelAlg -> RelAlg -> RelAlg -> RelAlg -> RelAlg
-template6 :: Maybe RelAlg -> RelAlg -> RelAlg -> Maybe RelAlg -> RelAlg
-
-template1 x y z = x :||: (y :&&: z)
-template2 x y z = Not(x :&&: (y :||: z))
-template3 x y z = Inv(x :||: (y :&&: z))
-template4 x y z = Inv (Not(x :&&: (y :||: z)))
-template5 x y z v = Inv (Not((x :||: v) :&&: (y :||: z)))
-template6 mp a b mq = f1 (f2 (a :&&: b))
- where f1 x = maybe x (:.: x) mp
-       f2 x = maybe x (x :.:) mq
-template7 x y z = x :.: (y :||:z)
-template8 x y z = x :||: Not (Inv (y :.: z) :&&: Not (Inv y :.: Inv z))
-
--------------------------------------------------------------------
--- Template generators
-
-templateGenerator :: Int -> Gen RelAlg
-templateGenerator n = oneof (map ($ n) [gen1,gen2,gen3,gen4,gen5,gen6,gen7,gen8,gen9])
-
-gen1, gen2, gen3, gen4, gen5, gen6, gen7, gen8, gen9 :: Int -> Gen RelAlg
-gen1 = use3 template1 arbInvNotMol arbInvNotMol arbInvNotMol
-gen2 = use3 template2 arbInvNotMol arbInvNotMol arbInvNotMol
-gen3 = use3 template3 arbInvNotMol arbInvNotMol arbInvNotMol
-gen4 = use3 template4 arbInvNotMol arbInvNotMol arbInvNotMol
-gen5 = use4 template5 arbInvNotMol arbInvNotMol arbInvNotMol arbInvNotMol
-gen6 = use3 template1 hulpgen1 arbInvNotMol arbInvNotMol
-gen7 = use3 template1 arbInvNotMol hulpgen1 arbInvNotMol
-gen8 = use3 template2 arbInvNotMol hulpgen1 arbInvNotMol
-gen9 = use3 template8 hulpgen2 arbInvNotMol arbInvNotMol
-
-use3 :: (a -> b -> c -> d) -> (t -> Gen a) -> (t -> Gen b) -> (t -> Gen c) -> t -> Gen d
-use3 temp f g h   n = liftM3 temp (f n) (g n) (h n)
-
-use4 :: (a -> b -> c -> d -> e) -> (t -> Gen a) -> (t -> Gen b) -> (t -> Gen c) -> (t -> Gen d) -> t -> Gen e
-use4 temp f g h k n = liftM4 temp (f n) (g n) (h n) (k n)
-
-hulpgen1 :: Int -> Gen RelAlg
-hulpgen1 n = liftM4 template6 (arbMaybeInvNotMol n) arbVar arbVar (arbMaybeInvNotMol n)
-
-hulpgen2 :: Int -> Gen RelAlg
-hulpgen2 n = liftM3 template7 (arbInvNotMol 1) (arbRelAlg n) (arbRelAlg n)
-
-arbInvNotMol :: Int -> Gen RelAlg
-arbInvNotMol 0 = frequency [(10, liftM Var (elements relAlgVars)), (1, return V), (1, return empty), (1, return I)]
-arbInvNotMol n = frequency [ (10, arbInvNotMol 0), (4, binop (:.:)), (4, binop (:+:)), (2, unop Not), (2, unop Inv) ]
- where
-   binop op = liftM2 op rec rec
-   unop op  = liftM op rec
-   rec      = arbInvNotMol (n `div` 2)
-
-arbMaybeInvNotMol :: Int -> Gen (Maybe RelAlg)
-arbMaybeInvNotMol n = frequency [(3, liftM Just (arbInvNotMol n)), (1, return Nothing)]
-
-arbVar :: Gen RelAlg
-arbVar = liftM Var (elements relAlgVars)
− src/Domain/RelationAlgebra/Parser.hs 
@@ -1,82 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.RelationAlgebra.Parser (parseRelAlg, ppRelAlg) where
-
-import Domain.RelationAlgebra.Formula
-import Text.Parsing
-import qualified Text.ParserCombinators.Parsec.Token as P
-
------------------------------------------------------------
---- Parser
-
-parseRelAlg  :: String -> Either String RelAlg
-parseRelAlg = parseSimple relalg
- where
-   relalg = buildExpressionParser table term
-
-   term = foldl (flip ($)) <$> atom <*> many pUn
-
-   pUn = choice
-      [ Inv <$ reservedOp "~"
-      , Not <$ reservedOp "-"
-      ]
-
-   atom = choice
-      [ V     <$  P.reserved lexer "V"
-      , empty <$  P.reserved lexer "E"
-      , I     <$  P.reserved lexer "I"
-      , Var   <$> P.identifier lexer
-      , P.parens lexer relalg
-      ]
-
-   table =
-      [ [ Infix ((:.:) <$ reservedOp ";") AssocRight -- or none-associative?
-        , Infix ((:+:) <$ reservedOp "!") AssocRight -- or none-associative?
-        ]
-      , [ Infix ((:&&:) <$ reservedOp "/\\") AssocRight ]
-      , [ Infix ((:||:) <$ reservedOp "\\/") AssocRight ]
-      ]
-
------------------------------------------------------------
---- Lexer
-
-lexer :: P.TokenParser a
-lexer = P.makeTokenParser $ emptyDef
-   { reservedNames   = ["V", "E", "I"]
-   , reservedOpNames = ["~", "-", ";", "!", "\\/", "/\\"]
-   , identStart      = letter
-   , identLetter     = letter
-   , opStart         = fail ""
-   , opLetter        = fail ""
-   }
-
-reservedOp :: String -> Parser ()
-reservedOp = P.reservedOp lexer
-
------------------------------------------------------------
---- Pretty-Printer
-
-ppRelAlg :: RelAlg -> String
-ppRelAlg = ppRelAlgPrio (0, "")
-
-ppRelAlgPrio :: (Int, String) -> RelAlg -> String
-ppRelAlgPrio = (\f n -> f n "") . flip (foldRelAlg alg)
- where
-   alg = (var, binop 4 ";", binop 4 "!", binop 3 "/\\", binop 2 "\\/"
-         , nott, inv, var "V", var "I"
-         )
-   binop prio op p q (n, parent) =
-      parIf (n > prio || (prio==4 && n==4 && op/=parent)) (p (prio+1, op) . ((" "++op++" ")++) . q (prio, op))
-   var       = const . (++)
-   nott p _  = p (6, "") . ("-"++)
-   inv  p _  = p (6, "") . ("~"++)
-   parIf b f = if b then ("("++) . f . (")"++) else f
− src/Domain/RelationAlgebra/Rules.hs 
@@ -1,320 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.RelationAlgebra.Rules where
-
-import Common.Id
-import Common.Rewriting
-import Common.Transformation (Rule, buggyRule)
-import Domain.RelationAlgebra.Formula
-import Domain.RelationAlgebra.Generator()
-import qualified Common.Transformation as Rule
-
-invRules :: [Rule RelAlg]
-invRules = [ ruleInvOverUnion, ruleInvOverIntersec, ruleInvOverComp
-           , ruleInvOverAdd, ruleInvOverNot, ruleDoubleInv
-           ]
-compAddRules :: [Rule RelAlg]
-compAddRules = [ ruleCompOverUnion {- , ruleCompOverIntersec  -}
-               , {- ruleAddOverUnion,-} ruleAddOverIntersec
-               ]
-relAlgRules :: [Rule RelAlg]
-relAlgRules = invRules ++ compAddRules ++
-              [ ruleUnionOverIntersec, ruleDeMorganOr, ruleDeMorganAnd, ruleIdempOr, ruleIdempAnd
-              , ruleRemCompl, ruleDoubleNegation, ruleAbsorpCompl
-              , ruleAbsorp, ruleRemRedunExprs, ruleNotOverComp
-              , ruleNotOverAdd
-              ]
-
-buggyRelAlgRules ::[Rule RelAlg]
-buggyRelAlgRules = [buggyRuleIdemComp, buggyRuleIdemAdd, buggyRuleDeMorgan
-                   , buggyRuleNotOverAdd, buggyRuleNotOverComp, buggyRuleParenth
-                   , buggyRuleAssoc, buggyRuleInvOverComp, buggyRuleInvOverAdd
-                   , buggyRuleCompOverIntersec, buggyRuleAddOverUnion, buggyRuleRemCompl
-                   ]
-
-relalg :: IsId a => a -> Id
-relalg = ( # ) "relationalgebra"
-
-rule :: RuleBuilder f a => String -> f -> Rule a
-rule = Rule.rule . relalg
-
-ruleList :: RuleBuilder f a => String -> [f] -> Rule a
-ruleList = Rule.ruleList . relalg
-
--- | 1. Alle ~ operatoren naar binnen verplaatsen
-
-ruleInvOverUnion :: Rule RelAlg
-ruleInvOverUnion = rule "InvOverUnion" $
-   \r s -> Inv (r :||: s) :~> Inv r :||: Inv s
-
-ruleInvOverIntersec :: Rule RelAlg
-ruleInvOverIntersec = rule "InvOverIntersect" $
-   \r s -> Inv (r :&&: s) :~> Inv r :&&: Inv s --- !!!!!!! ALLEEN VOOR FUNCTIES
-
-ruleInvOverComp :: Rule RelAlg
-ruleInvOverComp = rule "InvOverComp" $
-   \r s -> Inv (r :.: s) :~> Inv s :.: Inv r
-
-ruleInvOverAdd :: Rule RelAlg
-ruleInvOverAdd = rule "InvOverAdd" $
-   \r s -> Inv (r :+: s) :~> Inv s :+: Inv r
-
-ruleInvOverNot :: Rule RelAlg
-ruleInvOverNot = rule "InvOverNot" $
-   \r -> Inv (Not r) :~> Not (Inv r)
-
-ruleDoubleInv :: Rule RelAlg
-ruleDoubleInv = rule "DoubleInv" $
-   \r -> Inv (Inv r) :~> r
-
--- | 2. Alle ; en + operatoren zoveel mogelijk naar binnen verplaatsen
-
-ruleCompOverUnion :: Rule RelAlg
-ruleCompOverUnion = ruleList "CompOverUnion"
-   [ \q r s -> q :.: (r :||: s) :~>  (q :.: r) :||: (q :.: s)
-   , \q r s -> (q :||: r) :.: s :~>  (q :.: s) :||: (r :.: s)
-   ]
-
-ruleCompOverIntersec :: Rule RelAlg
-ruleCompOverIntersec = ruleList "CompOverIntersec"
-   [ \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: (q :.: s)  --alleen toegestaan als q een functie is!
-   , \q r s -> (q :&&: r) :.: s :~> (q :.: s) :&&: (r :.: s)  --idem
-   ]
-ruleAddOverUnion :: Rule RelAlg
-ruleAddOverUnion = ruleList "AddOverUnion"
-   [ \q r s -> q :+: (r :||: s) :~>  (q :+: r) :||: (q :+: s) --alleen toegestaan als q een functie is!
-   , \q r s -> (q :||: r) :+: s :~>  (q :+: s) :||: (r :+: s) --idem
-   ]
-
-ruleAddOverIntersec :: Rule RelAlg
-ruleAddOverIntersec = ruleList "AddOverIntersec"
-   [ \q r s -> q :+: (r :&&: s) :~>  (q :+: r) :&&: (q :+: s)
-   , \q r s -> (q :&&: r) :+: s :~>  (q :+: s) :&&: (r :+: s)
-   ]
--- | 3. Distribute union over intersection
-
-ruleUnionOverIntersec :: Rule RelAlg
-ruleUnionOverIntersec = ruleList "UnionOverIntersec"
-   [ \q r s -> q :||: (r :&&: s) :~> (q :||: r) :&&: (q :||: s)
-   , \q r s -> (q :&&: r) :||: s :~> (q :||: s) :&&: (r :||: s)
-   ]
-
--- | 4. De Morgan rules
-
-ruleDeMorganOr :: Rule RelAlg
-ruleDeMorganOr = rule "DeMorganOr" $
-   \r s -> Not (r :||: s) :~> Not r :&&: Not s
-
-ruleDeMorganAnd :: Rule RelAlg
-ruleDeMorganAnd = rule "DeMorganAnd" $
-   \r s -> Not (r :&&: s) :~> Not r :||: Not s
-
--- | 5. Idempotency
-
-ruleIdempOr :: Rule RelAlg
-ruleIdempOr = rule "IdempotencyOr" $
-   \r -> r :||: r :~>  r
-
-ruleIdempAnd :: Rule RelAlg
-ruleIdempAnd = rule "IdempotencyAnd" $
-   \r -> r :&&: r :~>  r
-
--- | 6. Complement
-
-ruleDoubleNegation :: Rule RelAlg
-ruleDoubleNegation = rule "DoubleNegation" $
-   \r -> Not (Not r) :~> r
-
-ruleRemCompl :: Rule RelAlg
-ruleRemCompl = ruleList "RemCompl"
-   [ \r -> r :||: Not r :~>  V
-   , \r -> Not r :||: r :~>  V
-   , \r -> r :&&: Not r :~>  empty
-   , \r -> Not r :&&: r :~>  empty
-   ]
-
--- Distribute Not over . and +
-
-ruleNotOverComp :: Rule RelAlg
-ruleNotOverComp = rule "NotOverComp" $
-   \r s -> Not (r :.: s) :~> Not r :+: Not s
-
-ruleNotOverAdd :: Rule RelAlg
-ruleNotOverAdd = rule "NotOverAdd" $
-   \r s -> Not (r :+: s) :~> Not r :.: Not s
-
--- | 7. Absorption complement
-
-ruleAbsorpCompl :: Rule RelAlg
-ruleAbsorpCompl = ruleList "AbsorpCompl"
-   [ \r s -> r :&&: (Not r :||: s) :~> r :&&: s
-   , \r s -> r :&&: (s :||: Not r) :~> r :&&: s
-   , \r s -> (Not r :||: s) :&&: r :~> r :&&: s
-   , \r s -> (s :||: Not r) :&&: r :~> r :&&: s
-   , \r s -> r :||: (Not r :&&: s) :~> r :||: s
-   , \r s -> r :||: (s :&&: Not r) :~> r :||: s
-   , \r s -> (Not r :&&: s) :||: r :~> r :||: s
-   , \r s -> (s :&&: Not r) :||: r :~> r :||: s
-   ]
-
-ruleAbsorp :: Rule RelAlg
-ruleAbsorp = ruleList "Absorp"
-   [ \r s -> r :&&: (r :||: s)  :~> r
-   , \r s -> r :&&: (s :||: r)  :~> r
-   , \r s -> (r :||: s) :&&: r  :~> r
-   , \r s -> (s :||: r) :&&: r  :~> r
-   , \r s -> r  :||: (r :&&: s) :~> r
-   , \r s -> r  :||: (s :&&: r) :~> r
-   , \r s -> (r :&&: s) :||: r  :~> r
-   , \r s -> (s :&&: r) :||: r  :~> r
-   ]
-
--- | 8. Remove redundant expressions
-
-ruleRemRedunExprs :: Rule RelAlg
-ruleRemRedunExprs = ruleList "RemRedunExprs"
-   [ \r -> r :||: V :~> V
-   , \r -> V :||: r :~> V
-   , \r -> r :&&: V :~> r
-   , \r -> V :&&: r :~> r
---   , (r :.: U)  :~> r
---   , (U :.: r)  :~> r
-   , \_ -> V :.: V :~> V
-   , \r -> r :+: V :~> V
-   , \r -> V :+: r :~> V
---   , (r :+: E)  :~> r
---   , (E :+: r)  :~> r
-   , \_ -> Inv V :~> V
-   -- rules involving the empty relation
-   , \_ -> Inv empty    :~> empty
-   , \r -> r :||: empty :~> r
-   , \r -> empty :||: r :~> r
-   , \r -> r :&&: empty :~> empty
-   , \r -> empty :&&: r :~> empty
-   , \r -> r :.: empty  :~> empty
-   , \r -> empty :.: r  :~> empty
-   , \_ -> empty :+: empty :~> empty
--- new identity rules: CHECK!
-   , \_ -> Inv I :~> I
-   , \r -> I :.: r :~> r
-   , \r -> r :.: I :~> r
-   ]
-
--- Buggy rules:
-
-buggyGroup :: RuleBuilder f a => String -> [f] -> Rule a
-buggyGroup s =
-   buggyRule . Rule.ruleList ("relationalgebra.buggy." ++ s)
-
-buggyRuleIdemComp :: Rule RelAlg
-buggyRuleIdemComp = buggyGroup "IdemComp"
-   [ \q -> q :.: q :~> q
-   ]
-
-buggyRuleIdemAdd :: Rule RelAlg
-buggyRuleIdemAdd = buggyGroup "IdemAdd"
-   [ \q -> q :+: q :~>  q
-   ]
-
-buggyRuleDeMorgan :: Rule RelAlg
-buggyRuleDeMorgan = buggyGroup "DeMorgan"
-    [ \q r -> Not (q :&&: r) :~> Not q :||: r
-    , \q r -> Not (q :&&: r) :~> q :||: Not r
-    , \q r -> Not (q :&&: r) :~> Not (Not q :||: Not r)
-    , \q r -> Not (q :||: r) :~> Not q :&&: r
-    , \q r -> Not (q :||: r) :~> q :&&: Not r
-    , \q r -> Not (q :||: r) :~> Not (Not q :&&: Not r) --note the firstNot in both formulas!
-    ]
-
-buggyRuleNotOverAdd :: Rule RelAlg
-buggyRuleNotOverAdd = buggyGroup "NotOverAdd"
-     [ \q r -> Not (q :+: r) :~> Not q :+: Not r
-     , \q r -> Not (q :+: r) :~> Not q :.: r
-     , \q r -> Not (q :+: r) :~> Not q :+: r
-     , \q r -> Not (q :+: r) :~> Not (Not q :.: Not r) --note the firstNot in both formulas!
-     ]
-
-buggyRuleNotOverComp :: Rule RelAlg
-buggyRuleNotOverComp = buggyGroup "NotOverComp"
-     [ \q r -> Not (q :.: r) :~> Not q :.: Not r
-     , \q r -> Not (q :.: r) :~> Not q :.: r
-     , \q r -> Not (q :.: r) :~> Not q :+: r
-     , \q r -> Not (q :.: r) :~> Not (Not q :.: Not r) --note the firstNot in both formulas!
-     ]
-
-buggyRuleParenth :: Rule RelAlg
-buggyRuleParenth = buggyGroup "Parenth"
-    [ \q r -> Not (q :&&: r)     :~> Not q :&&: r
-    , \q r -> Not (q :||: r)     :~> Not q :||: r
-    , \q r -> Not (Not q :&&: r) :~> q :&&: r
-    , \q r -> Not (Not q :||: r) :~> q :||: r
-    , \q r -> Not (Not q :.: r)  :~> q :.: r
-    , \q r -> Not (Not q :+: r)  :~> q :+: r
-    , \q r -> Inv (q :&&: r)     :~> Inv q :&&: r
-    , \q r -> Inv (q :||: r)     :~> Inv q :||: r
-    , \q r -> Inv (Inv q :&&: r) :~> q :&&: r
-    , \q r -> Inv (Inv q :||: r) :~> q :||: r
-    , \q r -> Inv (Inv q :.: r)  :~> q :.: r
-    , \q r -> Inv (Inv q :+: r)  :~> q :+: r
-    ]
-
-buggyRuleAssoc :: Rule RelAlg
-buggyRuleAssoc = buggyGroup "Assoc"
-    [ \q r s -> q :||: (r :&&: s) :~> (q :||: r) :&&: s
-    , \q r s -> (q :||: r) :&&: s :~> q :||: (r :&&: s)
-    , \q r s -> (q :&&: r) :||: s :~> q :&&: (r :||: s)
-    , \q r s -> q :&&: (r :||: s) :~> (q :&&: r) :||: s
-    , \q r s -> q :.: (r :||: s)  :~> (q :.: r) :||: s
-    , \q r s -> (q :||: r) :.: s  :~> q :||: (r :.: s)
-    , \q r s -> q :.: (r :&&: s)  :~> (q :.: r) :&&: s
-    , \q r s -> (q :&&: r) :.: s  :~> q :&&: (r :.: s)
-    , \q r s -> q :+: (r :||: s)  :~> (q :+: r) :||: s
-    , \q r s -> (q :||: r) :+: s  :~> q :||: (r :+: s)
-    , \q r s -> q :+: (r :&&: s)  :~> (q :+: r) :&&: s
-    , \q r s -> (q :&&: r) :+: s  :~> q :&&: (r :+: s)
-    ]
-
-buggyRuleInvOverComp :: Rule RelAlg
-buggyRuleInvOverComp = buggyGroup "InvOverComp"
-   [ \r s -> Inv (r :.: s) :~> Inv r :.: Inv s
-   ]
-
-buggyRuleInvOverAdd :: Rule RelAlg
-buggyRuleInvOverAdd = buggyGroup "InvOverAdd"
-   [ \r s -> Inv (r :+: s) :~> Inv r :+: Inv s
-   ]
-
-buggyRuleCompOverIntersec :: Rule RelAlg
-buggyRuleCompOverIntersec = buggyGroup "CompOverIntersec"
-   [ \q r s -> q :.: (r :&&: s) :~> (q :.: r) :&&: (q :.: s)  --alleen toegestaan als q een functie is!
-   , \q r s -> (q :&&: r) :.: s :~> (q :.: s) :&&: (r :.: s)  --idem
-   ]
-buggyRuleAddOverUnion :: Rule RelAlg
-buggyRuleAddOverUnion = buggyGroup "AddOverUnion"
-   [ \q r s -> q :+: (r :||: s) :~> (q :+: r) :||: (q :+: s) --alleen toegestaan als q een functie is!
-   , \q r s -> (q :||: r) :+: s :~> (q :+: s) :||: (r :+: s) --idem
-   ]
-
-buggyRuleRemCompl :: Rule RelAlg
-buggyRuleRemCompl = buggyGroup "RemCompl"
-   [ \r -> r :&&: Not r :~> V
-   , \r -> Not r :&&: r :~> V
-   , \r -> r :||: Not r :~> empty
-   , \r -> Not r :||: r :~> empty
-   ]
-
--- Older rules involving the empty relation
-{-
-  -- RemRedunExprs
-   \_ -> (Not V)    :~> E
-   \_ -> (Not E)    :~> V
--}
− src/Domain/RelationAlgebra/Strategies.hs 
@@ -1,40 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.RelationAlgebra.Strategies (toCNF) where
-
-import Common.Context
-import Common.Strategy
-import Common.Transformation
-import Domain.RelationAlgebra.Formula
-import Domain.RelationAlgebra.Rules
-import Prelude hiding (repeat)
-
-toCNF :: LabeledStrategy (Context RelAlg)
-toCNF = label "To CNF" $
-   repeat $  label "step1" step1
-          |> label "step2" step2
-          |> label "step3" step3
- where
-   step1 = topDown $ useRules $
-      [ ruleRemCompl, ruleRemRedunExprs, ruleDoubleNegation
-      , ruleIdempOr, ruleIdempAnd, ruleAbsorp, ruleAbsorpCompl
-      ] ++ invRules
-   step2 = topDown $ useRules
-      [ ruleCompOverUnion, ruleAddOverIntersec, ruleDeMorganOr, ruleDeMorganAnd
-      , ruleNotOverComp, ruleNotOverAdd
-      ]
-   step3 = somewhere $ liftToContext
-      ruleUnionOverIntersec
-
--- local helper-function
-useRules :: [Rule RelAlg] -> Strategy (Context RelAlg)
-useRules = alternatives . map liftToContext
+ src/Ideas/Common/Algebra/Boolean.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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
+ src/Ideas/Common/Algebra/BooleanLaws.hs view
@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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])
+ src/Ideas/Common/Algebra/Field.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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
+
+--------------------------------------------------------
+-- 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 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
+ src/Ideas/Common/Algebra/FieldLaws.hs view
@@ -0,0 +1,110 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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)])
+ src/Ideas/Common/Algebra/Group.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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.Foldable (Foldable)
+import Data.Maybe
+import Data.Monoid
+import Data.Traversable (Traversable)
+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, Traversable, 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
+
+--------------------------------------------------------
+-- 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
+ src/Ideas/Common/Algebra/GroupLaws.hs view
@@ -0,0 +1,149 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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 Data.Monoid
+import Ideas.Common.Algebra.Group
+import Ideas.Common.Algebra.Law
+
+--------------------------------------------------------
+-- 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)
+ src/Ideas/Common/Algebra/Law.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Algebra.Law
+   ( Law, LawSpec((:==:)), law, 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 = Abs (a -> LawSpec a) | a :==: a
+
+law :: LawBuilder l a => String -> l -> Law a
+law s l = Law s (lawSpec l)
+
+class LawBuilder l a | l -> a where
+   lawSpec :: l -> LawSpec a
+
+instance LawBuilder (LawSpec a) a where
+   lawSpec = id
+
+instance LawBuilder b a => LawBuilder (a -> b) a where
+   lawSpec f = Abs (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 (Abs f)    = Abs (rec . f . to)
+   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 (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 (Abs f)    = buildRuleSpec i f
+
+getLawSpec :: Law a -> LawSpec a
+getLawSpec (Law _ l) = l
+ src/Ideas/Common/Algebra/SmartGroup.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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 hiding ((<*>))
+import Ideas.Common.Algebra.Group
+import qualified Ideas.Common.Algebra.Field as Field
+
+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 Field.<*> b)
+      | Just x <- isNegate b = plusInverse (a Field.<*> x)
+      | isZero a || isZero b = zero
+      | isOne a = b
+      | isOne b = a
+      | Just (x, y) <- isTimes b = (a Field.<*> x) Field.<*> y
+      | Just (x, y) <- isDivision b = (a Field.<*> x) </> y
+      | otherwise = liftA2 (Field.<*>) 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 Field.<*> 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 Field.<*> 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
+ src/Ideas/Common/Classes.hs view
@@ -0,0 +1,130 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Type classes and instances.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Classes
+   ( -- * Type class Apply
+     Apply, apply, applyAll, applicable, applyD, applyM, applyList
+     -- * Type class Container
+   , Container, singleton, getSingleton
+     -- * Type class BiArrow
+   , BiArrow(..)
+     -- * Type class BiFunctor
+   , BiFunctor, biMap, mapFirst, mapSecond, mapBoth
+     -- * Buggy and Minor properties
+   , Buggy(..), Minor(..)
+   ) where
+
+import Control.Arrow
+import Data.Maybe
+import qualified Data.Set as S
+
+-----------------------------------------------------------
+-- Type class Apply
+
+-- | A type class for functors that can be applied to a value. Transformation,
+-- Rule, and Strategy are all instances of this type class.
+class Apply t where
+   applyAll :: t a -> a -> [a]  -- ^ Returns zero or more results
+
+-- | Returns zero or one results
+apply :: Apply t => t a -> a -> Maybe a
+apply ta = listToMaybe . applyAll ta
+
+-- | Checks whether the functor is applicable (at least one result)
+applicable :: Apply t => t a -> a -> Bool
+applicable ta = isJust . apply ta
+
+-- | If not applicable, return the current value (as default)
+applyD :: Apply t => t a -> a -> a
+applyD ta a = fromMaybe a (apply ta a)
+
+-- | Same as apply, except that the result (at most one) is returned in some monad
+applyM :: (Apply t, Monad m) => t a -> a -> m a
+applyM ta = maybe (fail "applyM") return . apply ta
+
+applyList :: Apply t => [t a] -> a -> Maybe a
+applyList xs a = foldl (\m r -> m >>= applyM r) (Just a) xs
+
+-----------------------------------------------------------
+-- Type class Container
+
+-- | Instances should satisfy the following law: @getSingleton . singleton == Just@
+class Container f where
+   singleton    :: a   -> f a
+   getSingleton :: f a -> Maybe a
+
+instance Container [] where
+   singleton        = return
+   getSingleton [a] = Just a
+   getSingleton _   = Nothing
+
+instance Container S.Set where
+   singleton    = S.singleton
+   getSingleton = getSingleton . S.toList
+
+-----------------------------------------------------------
+-- Type class BiArrow
+
+infix 1 <->
+
+-- |Type class for bi-directional arrows. @<->@ should be used instead of
+-- @arr@ from the arrow interface. Minimal complete definition: @<->@.
+class Arrow arr => BiArrow arr where
+   (<->) :: (a -> b) -> (b -> a) -> arr a b
+   (!->) :: (a -> b) -> arr a b
+   (<-!) :: (b -> a) -> arr a b
+   -- default definitions
+   (!->) f = f <-> errBiArrow
+   (<-!) f = errBiArrow <-> f
+
+errBiArrow :: a
+errBiArrow = error "BiArrow: not bi-directional"
+
+-----------------------------------------------------------
+-- Type class BiFunctor
+
+class BiFunctor f where
+   biMap     :: (a -> c) -> (b -> d) -> f a b -> f c d
+   mapFirst  :: (a -> b) -> f a c -> f b c
+   mapSecond :: (b -> c) -> f a b -> f a c
+   -- default definitions
+   mapFirst  = flip biMap id
+   mapSecond = biMap id
+
+instance BiFunctor Either where
+   biMap f g = either (Left . f) (Right . g)
+
+instance BiFunctor (,) where
+  biMap f g (a, b) = (f a, g b)
+
+mapBoth :: BiFunctor f => (a -> b) -> f a a -> f b b
+mapBoth f = biMap f f
+
+-----------------------------------------------------------
+-- Buggy and Minor properties
+
+class Buggy a where
+   buggy    :: a -> a
+   setBuggy :: Bool -> a -> a
+   isBuggy  :: a -> Bool
+   -- default definition
+   buggy = setBuggy True
+
+class Minor a where
+   minor    :: a -> a
+   setMinor :: Bool -> a -> a
+   isMinor  :: a -> Bool
+   isMajor  :: a -> Bool
+   -- default definition
+   minor   = setMinor True
+   isMajor = not . isMinor
+ src/Ideas/Common/Context.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE GADTs, RankNTypes #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A context for a term that maintains an environment of
+-- key-value pairs. A context is both showable and parsable.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Context
+   ( -- * Abstract data type
+     Context, newContext
+   , fromContext, fromContextWith, fromContextWith2
+   , Location, location
+     -- * Context navigator
+   , ContextNavigator, noNavigator, navigator, termNavigator
+     -- * Lifting
+   , liftToContext, contextView
+   , use, useC, applyTop
+   , 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)
+
+----------------------------------------------------------
+-- Abstract data type
+
+-- | Abstract data type for a context: a context stores an envrionent
+-- (key-value pairs) and a value
+data Context a = C
+   { getEnvironment :: Environment        -- ^ Returns the environment
+   , getNavigator   :: ContextNavigator a -- ^ Value with focus
+   }
+
+fromContext :: Monad m => Context a -> m a
+fromContext = maybe (fail "fromContext") return .
+   currentNavigator . getNavigator . top
+
+fromContextWith :: Monad m => (a -> b) -> Context a -> m b
+fromContextWith f = liftM f . fromContext
+
+fromContextWith2 :: Monad m => (a -> b -> c) -> Context a -> Context b -> m c
+fromContextWith2 f a b = liftM2 f (fromContext a) (fromContext b)
+
+instance Eq a => Eq (Context a) where
+   x == y = fromMaybe False $ liftM2 (==) (fromContext x) (fromContext y)
+
+instance Show a => Show (Context a) where
+   show c@(C env a) =
+      let rest | noBindings env = ""
+               | otherwise      = "  {" ++ show env ++ "}"
+      in maybe "??" show (currentNavigator a) ++
+         " @ " ++ show (location c) ++ rest
+
+instance Navigator (Context a) where
+   up       = liftCN up
+   down     = liftCN down
+   downLast = liftCN downLast
+   left     = liftCN left
+   right    = liftCN right
+   location = navLocation . getNavigator
+
+instance HasEnvironment (Context a) where
+   environment = getEnvironment
+   setEnvironment e c = c {getEnvironment = e}
+
+-- | Construct a context
+newContext :: Environment -> ContextNavigator a -> Context a
+newContext = C
+
+----------------------------------------------------------
+-- Context navigator
+
+noNavigator :: a -> ContextNavigator a
+noNavigator = NoNav
+
+navigator :: Uniplate a => a -> ContextNavigator a
+navigator = Simple . focus
+
+termNavigator :: IsTerm a => a -> ContextNavigator a
+termNavigator = TermNav . focus . toTerm
+
+data ContextNavigator a where
+   TermNav :: IsTerm a   => UniplateNavigator Term -> ContextNavigator a
+   Simple  :: Uniplate a => UniplateNavigator a -> ContextNavigator a
+   NoNav   :: a -> ContextNavigator a
+
+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 _ (C _   (NoNav _))   = fail "noNavigator"
+
+navLocation :: ContextNavigator a -> Location
+navLocation (TermNav a) = location a
+navLocation (Simple a)  = location a
+navLocation (NoNav _)   = mempty
+
+currentNavigator :: ContextNavigator a -> Maybe a
+currentNavigator (TermNav a) = matchM termView (current a)
+currentNavigator (Simple a)  = Just (current a)
+currentNavigator (NoNav a)   = Just a
+
+changeNavigator :: (a -> a) -> ContextNavigator a -> ContextNavigator a
+changeNavigator f (TermNav a) = TermNav (change (simplifyWith f termView) a)
+changeNavigator f (Simple a)  = Simple (change f a)
+changeNavigator f (NoNav a)   = NoNav (f a)
+
+currentT :: ContextNavigator a -> Maybe Term
+currentT (TermNav a) = Just (current a)
+currentT _           = Nothing
+
+changeT :: (Term -> Maybe Term) -> ContextNavigator a -> Maybe (ContextNavigator a)
+changeT f (TermNav a) = fmap TermNav (changeM f a)
+changeT _ _           = Nothing
+
+castT :: IsTerm b => ContextNavigator a -> Maybe (ContextNavigator b)
+castT (TermNav a) = Just (TermNav a)
+castT _           = Nothing
+
+----------------------------------------------------------
+-- Lifting rules
+
+contextView :: View (Context a) (a, Context a)
+contextView = "views.contextView" @> makeView f g
+ where
+   f ctx = currentInContext ctx >>= \a -> Just (a, ctx)
+   g     = uncurry replaceInContext
+
+-- | Lift a rule to operate on a term in a context
+liftToContext :: LiftView f => f a -> f (Context a)
+liftToContext = liftViewIn contextView
+
+-- | Apply a function at top-level. Afterwards, try to return the focus
+-- to the old position
+applyTop :: (a -> a) -> Context a -> Context a
+applyTop f c =
+   navigateTowards (location c) (changeInContext f (top c))
+
+use :: (LiftView f, IsTerm a, IsTerm b) => f a -> f (Context b)
+use = useC . liftToContext
+
+useC :: (LiftView f, IsTerm a, IsTerm b) => f (Context a) -> f (Context b)
+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))
+
+currentTerm :: Context a -> Maybe Term
+currentTerm = currentT . getNavigator
+
+changeTerm :: (Term -> Maybe Term) -> Context a -> Maybe (Context a)
+changeTerm f c = do
+   new <- changeT f (getNavigator c)
+   return c {getNavigator = new}
+
+currentInContext :: Context a -> Maybe a
+currentInContext (C _   a) = currentNavigator a
+
+changeInContext :: (a -> a) -> Context a -> Context a
+changeInContext f (C env a) = C env (changeNavigator f a)
+
+replaceInContext :: a -> Context a -> Context a
+replaceInContext = changeInContext . const
+ src/Ideas/Common/Derivation.hs view
@@ -0,0 +1,105 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Datatype for representing a derivation (parameterized both in the terms
+-- and the steps)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Derivation
+   ( -- * Data type
+     Derivation
+     -- * Constructing a derivation
+   , emptyDerivation, prepend, extend
+     -- * Querying a derivation
+   , isEmpty, derivationLength, terms, steps, triples
+   , firstTerm, lastTerm, lastStep, withoutLast
+   , updateSteps, derivationM
+   ) where
+
+import Data.Maybe
+import Ideas.Common.Classes
+import qualified Data.Foldable as F
+import qualified Data.Sequence as S
+
+-----------------------------------------------------------------------------
+-- Data type definition and instances
+
+data Derivation s a = D a (S.Seq (s, a))
+
+instance (Show s, Show a) => Show (Derivation s a) where
+   show (D a xs) = unlines $
+      show a : concatMap (\(r, b) -> ["   => " ++ show r, show b]) (F.toList xs)
+
+instance Functor (Derivation s) where
+   fmap = mapSecond
+
+instance BiFunctor Derivation where
+   biMap f g (D a xs) = D (g a) (fmap (biMap f g) xs)
+
+-----------------------------------------------------------------------------
+-- Constructing a derivation
+
+emptyDerivation :: a -> Derivation s a
+emptyDerivation a = D a S.empty
+
+prepend :: (a, s) -> Derivation s a -> Derivation s a
+prepend (a, s) (D b xs) = D a ((s, b) S.<| xs)
+
+extend :: Derivation s a -> (s, a) -> Derivation s a
+extend (D a xs) p = D a (xs S.|> p)
+
+-----------------------------------------------------------------------------
+-- Querying a derivation
+
+-- | Tests whether the derivation is empty
+isEmpty :: Derivation s a -> Bool
+isEmpty (D _ xs) = S.null xs
+
+-- | Returns the number of steps in a derivation
+derivationLength :: Derivation s a -> Int
+derivationLength (D _ xs) = S.length xs
+
+-- | All terms in a derivation
+terms :: Derivation s a -> [a]
+terms (D a xs) = a:map snd (F.toList xs)
+
+-- | All steps in a derivation
+steps :: Derivation s a -> [s]
+steps (D _ xs) = map fst (F.toList xs)
+
+-- | The triples of a derivation, consisting of the before term, the
+-- step, and the after term.
+triples :: Derivation s a -> [(a, s, a)]
+triples d = zip3 (terms d) (steps d) (tail (terms d))
+
+firstTerm :: Derivation s a -> a
+firstTerm = head . terms
+
+lastTerm :: Derivation s a -> a
+lastTerm = last . terms
+
+lastStep:: Derivation s a -> Maybe s
+lastStep = listToMaybe . reverse . steps
+
+withoutLast :: Derivation s a -> Derivation s a
+withoutLast d@(D a xs) =
+   case S.viewr xs of
+      S.EmptyR  -> d
+      ys S.:> _ -> D a ys
+
+updateSteps :: (a -> s -> a -> t) -> Derivation s a -> Derivation t a
+updateSteps f d =
+   let ts   = [ f a b c | (a, b, c) <- triples d ]
+       x:xs = terms d
+   in D x (S.fromList (zip ts xs))
+
+-- | Apply a monadic function to each term, and to each step
+derivationM :: Monad m => (s -> m ()) -> (a -> m ()) -> Derivation s a -> m ()
+derivationM f g (D a xs) = g a >> mapM_ (\(s, b) -> f s >> g b) (F.toList xs)
+ src/Ideas/Common/DerivationTree.hs view
@@ -0,0 +1,192 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Datatype for representing derivations as a tree. The datatype stores all
+-- intermediate results as well as annotations for the steps.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.DerivationTree
+   ( -- * Data types
+     DerivationTree
+     -- * Constructors
+   , singleNode, addBranches, makeTree
+     -- * Query
+   , root, endpoint, branches, subtrees
+   , leafs, lengthMax
+     -- * Adapters
+   , restrictHeight, restrictWidth, updateAnnotations
+   , cutOnStep, mergeMaybeSteps, sortTree, cutOnTerm
+     -- * Conversions
+   , derivation, randomDerivation, derivations
+   ) where
+
+import Control.Arrow
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Ideas.Common.Classes
+import Ideas.Common.Derivation
+import System.Random
+
+-----------------------------------------------------------------------------
+-- Data type definitions for derivation trees and derivation lists
+
+data DerivationTree s a = DT
+   { root     :: a                           -- ^ The root of the tree
+   , endpoint :: Bool                        -- ^ Is this node an endpoint?
+   , branches :: [(s, DerivationTree s a)]   -- ^ All branches
+   }
+ deriving Show
+
+instance Functor (DerivationTree s) where
+   fmap = mapSecond
+
+instance BiFunctor DerivationTree where
+   biMap f g (DT a b xs) = DT (g a) b (map (biMap f (biMap f g)) xs)
+
+-----------------------------------------------------------------------------
+-- Constructors for a derivation tree
+
+-- | Constructs a node without branches; the boolean indicates whether the
+-- node is an endpoint or not
+singleNode :: a -> Bool -> DerivationTree s a
+singleNode a b = DT a b []
+
+-- | Branches are attached after the existing ones (order matters)
+addBranches :: [(s, DerivationTree s a)] -> DerivationTree s a -> DerivationTree s a
+addBranches new (DT a b xs) = DT a b (xs ++ new)
+
+makeTree :: (a -> (Bool, [(s, a)])) -> a -> DerivationTree s a
+makeTree f = rec
+ where
+   rec a = let (b, xs) = f a
+           in addBranches (map (mapSecond rec) xs) (singleNode a b)
+
+-----------------------------------------------------------------------------
+-- Inspecting a derivation tree
+
+-- | Returns the annotations at a given node
+annotations :: DerivationTree s a -> [s]
+annotations = map fst . branches
+
+-- | Returns all subtrees at a given node
+subtrees :: DerivationTree s a -> [DerivationTree s a]
+subtrees = map snd . branches
+
+-- | Returns all leafs, i.e., final results in derivation. Be careful:
+-- the returned list may be very long
+leafs :: DerivationTree s a -> [a]
+leafs t = [ root t | endpoint t ] ++ concatMap leafs (subtrees t)
+
+-- | The argument supplied is the maximum number of steps; if more steps are
+-- needed, Nothing is returned
+lengthMax :: Int -> DerivationTree s a -> Maybe Int
+lengthMax n = join . fmap (f . derivationLength) . derivation
+            . commit . restrictHeight (n+1)
+ where
+    f i = if i<=n then Just i else Nothing
+
+updateAnnotations :: (a -> s -> a -> t) -> DerivationTree s a -> DerivationTree t a
+updateAnnotations f = rec
+ where
+   rec (DT a b xs) =
+      let g (s, t) = (f a s (root t), rec t)
+      in DT a b (map g xs)
+
+-----------------------------------------------------------------------------
+-- Changing a derivation tree
+
+-- | Restrict the height of the tree (by cutting off branches at a certain depth).
+-- Nodes at this particular depth are turned into endpoints
+restrictHeight :: Int -> DerivationTree s a -> DerivationTree s a
+restrictHeight n t
+   | n == 0    = singleNode (root t) True
+   | otherwise = t {branches = map f (branches t)}
+ where
+   f = mapSecond (restrictHeight (n-1))
+
+-- | Restrict the width of the tree (by cutting off branches).
+restrictWidth :: Int -> DerivationTree s a -> DerivationTree s a
+restrictWidth n = rec
+ where
+   rec t = t {branches = map (mapSecond rec) (take n (branches t))}
+
+-- | Commit to the left-most derivation (even if this path is unsuccessful)
+commit :: DerivationTree s a -> DerivationTree s a
+commit = restrictWidth 1
+
+-- | Filter out intermediate steps, and merge its branches (and endpoints) with
+-- the rest of the derivation tree
+mergeSteps :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a
+mergeSteps p = rec
+ where
+   rec t = addBranches (concat list) (singleNode (root t) isEnd)
+    where
+      new = map rec (subtrees t)
+      (bools, list) = unzip (zipWith f (annotations t) new)
+      isEnd = endpoint t || or bools
+      f s st
+         | p s       = (False, [(s, st)])
+         | otherwise = (endpoint st, branches st)
+
+sortTree :: (l -> l -> Ordering) -> DerivationTree l a -> DerivationTree l a
+sortTree f t = t {branches = change (branches t) }
+ where
+   change = map (mapSecond (sortTree f)) . sortBy cmp
+   cmp (l1, _) (l2, _) = f l1 l2
+
+mergeMaybeSteps :: DerivationTree (Maybe s) a -> DerivationTree s a
+mergeMaybeSteps = mapFirst fromJust . mergeSteps isJust
+
+cutOnStep :: (s -> Bool) -> DerivationTree s a -> DerivationTree s a
+cutOnStep p = rec
+ where
+   rec t = t {branches = map f (branches t)}
+   f (s, t)
+      | p s       = (s, singleNode (root t) True)
+      | otherwise = (s, rec t)
+
+cutOnTerm :: (a -> Bool) -> DerivationTree s a -> DerivationTree s a
+cutOnTerm p (DT r e bs) =
+    DT r e (map (second (cutOnTerm p)) $ filter (not . p . root . snd) bs)
+
+-----------------------------------------------------------------------------
+-- Conversions from a derivation tree
+
+-- | All possible derivations (returned in a list)
+derivations :: DerivationTree s a -> [Derivation s a]
+derivations t =
+   [ emptyDerivation (root t) | endpoint t ] ++
+   [ (root t, r) `prepend` d | (r, st) <- branches t, d <- derivations st ]
+
+-- | The first derivation (if any)
+derivation :: DerivationTree s a -> Maybe (Derivation s a)
+derivation = listToMaybe . derivations
+
+-- | Return  a random derivation (if any exists at all)
+randomDerivation :: RandomGen g => g -> DerivationTree s a -> Maybe (Derivation s a)
+randomDerivation g t = msum xs
+ where
+   (xs, g0) = shuffle g list
+   list     = [ Just (emptyDerivation (root t)) | endpoint t ] ++
+              map make (branches t)
+   make (r, st) = do
+      d <- randomDerivation g0 st
+      return ((root t, r) `prepend` d)
+
+shuffle :: RandomGen g => g -> [a] -> ([a], g)
+shuffle g0 xs = rec g0 [] (length xs) xs
+ where
+   rec g acc n ys =
+      case splitAt i ys of
+         (as, b:bs) -> rec g1 (b:acc) (n-1) (as++bs)
+         _ -> (acc, g)
+    where
+      (i, g1) = randomR (0, n-1) g
+ src/Ideas/Common/Environment.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE ExistentialQuantification #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- References, bindings, and heterogenous environments
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Environment
+   ( -- * Reference
+     Ref, Reference(..)
+     -- * Binding
+   , Binding, makeBinding
+   , fromBinding, showValue, getTermValue
+     -- * Heterogeneous environment
+   , Environment, makeEnvironment, singleBinding
+   , HasEnvironment(..), HasRefs(..)
+   , bindings, noBindings, (?)
+   ) where
+
+import Control.Monad
+import Data.Function
+import Data.List
+import Data.Monoid
+import Data.Typeable
+import Ideas.Common.Id
+import Ideas.Common.Rewriting.Term
+import Ideas.Common.Utils
+import Ideas.Common.View
+import qualified Data.Map as M
+
+-----------------------------------------------------------
+-- Reference
+
+-- | 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
+   }
+
+instance Show (Ref a) where
+   show = showId
+
+instance Eq (Ref a) where
+   (==) = (==) `on` getId
+
+instance HasId (Ref a) where
+   getId = identifier
+   changeId f d = d {identifier = f (identifier d)}
+
+-- | 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
+
+instance Reference Int
+
+instance Reference Term
+
+instance Reference Char where
+   makeRefList n = Ref (newId n) id Just variableView
+
+instance Reference a => Reference [a] where
+   makeRef = makeRefList
+
+instance (Reference a, Reference b) => Reference (a, b)
+
+-----------------------------------------------------------
+-- Binding
+
+data Binding = forall a . Typeable 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)
+          in (==) `on` f
+
+instance HasId Binding where
+   getId (Binding ref _ ) = getId ref
+   changeId f (Binding ref a) = Binding (changeId f ref) a
+
+makeBinding :: Typeable a => Ref a -> a -> Binding
+makeBinding = Binding
+
+fromBinding :: Typeable a => Binding -> Maybe (Ref a, a)
+fromBinding (Binding ref a) = liftM2 (,) (gcast ref) (cast a)
+
+showValue :: Binding -> String
+showValue (Binding ref a) = printer ref a
+
+getTermValue :: Binding -> Term
+getTermValue (Binding ref a) = build (refView ref) a
+
+-----------------------------------------------------------
+-- Heterogeneous environment
+
+newtype Environment = Env { envMap :: M.Map Id Binding }
+   deriving Eq
+
+instance Show Environment where
+   show = intercalate ", " . map show . bindings
+
+instance Monoid Environment where
+   mempty = Env mempty
+   mappend a b = Env (envMap a `mappend` envMap b) -- left has presedence
+
+instance HasRefs Environment where
+   allRefs env = [ Some ref | Binding ref _ <- bindings env ]
+
+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
+
+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
+   -- default definitions
+   deleteRef a = changeEnv (Env . M.delete (getId a) . envMap)
+   insertRef ref =
+      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
+
+-- local helper
+changeEnv :: HasEnvironment env => (Environment -> Environment) -> env -> env
+changeEnv f env = setEnvironment (f (environment env)) env
+
+class HasRefs a where
+   getRefs   :: a -> [Some Ref]
+   allRefs   :: a -> [Some Ref] -- with duplicates
+   getRefIds :: a -> [Id]
+   -- default implementation
+   getRefIds a = [ getId r | Some r <- getRefs a]
+   getRefs = sortBy cmp . nubBy eq . allRefs
+    where
+      cmp :: Some Ref -> Some Ref -> Ordering
+      cmp (Some x) (Some y) = compareId (getId x) (getId y)
+      eq a b = cmp a b == EQ
+
+instance HasEnvironment Environment where
+   environment    = id
+   setEnvironment = const
+
+bindings :: HasEnvironment env => env -> [Binding]
+bindings = sortBy compareId . M.elems . envMap . environment
+
+noBindings :: HasEnvironment env => env -> Bool
+noBindings = M.null . envMap . environment
+
+(?) :: (HasEnvironment env, Typeable a) => 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
+        ]
+ src/Ideas/Common/Exercise.hs view
@@ -0,0 +1,516 @@+{-# LANGUAGE Rank2Types #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- This module defines the concept of an exercise
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Exercise
+   ( -- * Exercises
+     Exercise, makeExercise, emptyExercise
+   , exerciseId, status, parser, prettyPrinter
+   , equivalence, similarity, ready, suitable, isReady, isSuitable
+   , hasTermView
+   , strategy, navigation, canBeRestarted, extraRules, ruleOrdering
+   , difference, differenceEqual
+   , testGenerator, randomExercise, examples, getRule
+   , simpleGenerator, useGenerator
+   , randomTerm, randomTermWith, ruleset
+   , makeContext, inContext, recognizeRule
+   , ruleOrderingWith, ruleOrderingWithId
+   , Examples, mapExamples, examplesContext
+   , Difficulty(..), readDifficulty, level
+   , hasTypeable, useTypeable, castFrom, castTo
+     -- * Exercise status
+   , Status(..), isPublic, isPrivate
+     -- * Miscellaneous
+   , withoutContext, simpleSimilarity, simpleEquivalence
+   , prettyPrinterContext, restrictGenerator
+   , showDerivation, printDerivation
+   , ExerciseDerivation, defaultDerivation
+   , derivationDiffEnv
+   , checkExercise, checkParserPretty
+   , checkExamples, exerciseTestSuite
+   ) where
+
+import Control.Monad.Error
+import Data.Char
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Ord
+import Data.Typeable
+import Ideas.Common.Classes
+import Ideas.Common.Context
+import Ideas.Common.Derivation
+import Ideas.Common.DerivationTree
+import Ideas.Common.Environment
+import Ideas.Common.Id
+import Ideas.Common.Predicate
+import Ideas.Common.Rewriting
+import Ideas.Common.Rule
+import Ideas.Common.Strategy hiding (not, fail, repeat, replicate)
+import Ideas.Common.Traversal.Navigator (top, downs)
+import Ideas.Common.Utils (ShowString(..))
+import Ideas.Common.Utils.TestSuite
+import Ideas.Common.View
+import System.Random
+import Test.QuickCheck hiding (label)
+import Test.QuickCheck.Gen
+import qualified Ideas.Common.Rewriting.Difference as Diff
+import qualified Ideas.Common.Strategy as S
+
+data Exercise a = Exercise
+   { -- identification and meta-information
+     exerciseId     :: Id -- identifier that uniquely determines the exercise
+   , status         :: Status
+     -- parsing and pretty-printing
+   , parser         :: String -> Either String a
+   , prettyPrinter  :: a -> String
+     -- syntactic and semantic checks
+   , equivalence    :: Context a -> Context a -> Bool
+   , similarity     :: Context a -> Context a -> Bool -- possibly more liberal than syntactic equality
+   , ready          :: Predicate a
+   , suitable       :: Predicate a
+   , hasTermView    :: Maybe (View Term a)
+   , hasTypeable    :: Maybe (IsTypeable a)
+     -- strategies and rules
+   , strategy       :: LabeledStrategy (Context a)
+   , navigation     :: a -> ContextNavigator a
+   , canBeRestarted :: Bool                -- By default, assumed to be the case
+   , extraRules     :: [Rule (Context a)]  -- Extra rules (possibly buggy) not appearing in strategy
+   , ruleOrdering   :: Rule (Context a) -> Rule (Context a) -> Ordering -- Ordering on rules (for onefirst)
+     -- testing and exercise generation
+   , testGenerator  :: Maybe (Gen a)
+   , randomExercise :: Maybe (StdGen -> Maybe Difficulty -> a)
+   , examples       :: [(Difficulty, a)]
+   }
+
+instance Eq (Exercise a) where
+   e1 == e2 = getId e1 == getId e2
+
+instance Ord (Exercise a) where
+   compare = comparing getId
+
+instance Apply Exercise where
+   applyAll ex = mapMaybe fromContext . applyAll (strategy ex) . inContext ex
+
+instance HasId (Exercise a) where
+   getId = exerciseId
+   changeId f ex = ex { exerciseId = f (exerciseId ex) }
+
+makeExercise :: (Show a, Eq a, IsTerm a) => Exercise a
+makeExercise = emptyExercise
+   { prettyPrinter = show
+   , similarity    = (==)
+   , hasTermView   = Just termView
+   }
+
+emptyExercise :: Exercise a
+emptyExercise = Exercise
+   { -- identification and meta-information
+     exerciseId     = mempty
+   , status         = Experimental
+     -- parsing and pretty-printing
+   , parser         = const (Left "<<no parser>>")
+   , prettyPrinter  = const "<<no pretty-printer>>"
+     -- syntactic and semantic checks
+   , equivalence    = \_ _ -> True
+   , similarity     = \_ _ -> True
+   , ready          = true
+   , suitable       = true
+   , hasTermView    = Nothing
+   , hasTypeable    = Nothing
+     -- strategies and rules
+   , strategy       = label "Fail" S.fail
+   , navigation     = noNavigator
+   , canBeRestarted = True
+   , extraRules     = []
+   , ruleOrdering   = compareId
+     -- testing and exercise generation
+   , testGenerator  = Nothing
+   , randomExercise = Nothing
+   , examples       = []
+   }
+
+makeContext :: Exercise a -> Environment -> a -> Context a
+makeContext ex env = newContext env . navigation ex
+
+-- | Put a value into an empty environment
+inContext :: Exercise a -> a -> Context a
+inContext = flip makeContext mempty
+
+---------------------------------------------------------------
+-- Difficulty levels
+
+type Examples a = [(Difficulty, a)]
+
+mapExamples :: (a -> b) -> Examples a -> Examples b
+mapExamples f = map (second f)
+
+examplesContext :: Exercise a -> Examples (Context a)
+examplesContext ex = mapExamples (inContext ex) (examples ex)
+
+data Difficulty = VeryEasy | Easy | Medium | Difficult | VeryDifficult
+   deriving (Eq, Ord, Enum)
+
+instance Show Difficulty where
+   show = (xs !!) . fromEnum
+    where
+      xs = ["very_easy", "easy", "medium", "difficult", "very_difficult"]
+
+readDifficulty :: String -> Maybe Difficulty
+readDifficulty s =
+   case filter p [VeryEasy .. VeryDifficult] of
+            [a] -> Just a
+            _   -> Nothing
+ where
+   normal = filter isAlpha . map toLower
+   p = (== normal s) . normal . show
+
+level :: Difficulty -> [a] -> Examples a
+level = zip . repeat
+
+---------------------------------------------------------------
+-- Exercise generators
+
+-- returns a sorted list of rules (no duplicates)
+ruleset :: Exercise a -> [Rule (Context a)]
+ruleset ex = nub (sortBy compareId list)
+ where
+   list = extraRules ex ++ rulesInStrategy (strategy ex)
+
+simpleGenerator :: Gen a -> Maybe (StdGen -> Maybe Difficulty -> a)
+simpleGenerator = useGenerator (const True) . const
+
+useGenerator :: (a -> Bool) -> (Maybe Difficulty -> Gen a) -> Maybe (StdGen -> Maybe Difficulty -> a)
+useGenerator p makeGen = Just (\rng -> rec rng . makeGen)
+ where
+   rec rng gen@(MkGen f)
+      | p a       = a
+      | otherwise = rec (snd (next rng)) gen
+    where
+      (size, r) = randomR (0, 100) rng
+      a         = f r size
+
+restrictGenerator :: (a -> Bool) -> Gen a -> Gen a
+restrictGenerator p g = do
+   a <- g
+   if p a then return a
+          else restrictGenerator p g
+
+randomTerm :: Exercise a -> Maybe Difficulty -> IO a
+randomTerm ex mdif = do
+   rng <- newStdGen
+   maybe (fail "no random term") return $ randomTermWith rng ex mdif
+
+randomTermWith :: StdGen -> Exercise a -> Maybe Difficulty -> Maybe a
+randomTermWith rng ex mdif =
+   case randomExercise ex of
+      Just f  -> return (f rng mdif)
+      Nothing
+         | null xs   -> Nothing
+         | otherwise -> Just $
+              snd $ xs !! fst (randomR (0, length xs - 1) rng)
+       where
+         xs = filter p (examples ex)
+         p (d, _) = maybe True (==d) mdif
+
+difference :: Exercise a -> a -> a -> Maybe (a, a)
+difference ex a b = do
+   v <- hasTermView ex
+   Diff.differenceWith v a b
+
+differenceEqual :: Exercise a -> a -> a -> Maybe (a, a)
+differenceEqual ex a b = do
+   v <- hasTermView ex
+   Diff.differenceEqualWith v (simpleEquivalence ex) a b
+
+-- Recognize a rule at (possibly multiple) locations
+recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [(Location, Environment)]
+recognizeRule ex r ca cb = rec (top ca)
+ where
+   final = addTransRecognizer (similarity ex) r
+   rec x = do
+      -- here
+      as <- recognizeAll final x cb
+      return (location x, as)
+    `mplus` -- or there
+      concatMap rec (downs x)
+
+ruleOrderingWith :: [Rule a] -> Rule a -> Rule a -> Ordering
+ruleOrderingWith = ruleOrderingWithId . map getId
+
+ruleOrderingWithId :: HasId b => [b] -> Rule a -> Rule a -> Ordering
+ruleOrderingWithId bs r1 r2 =
+   let xs = map getId bs in
+   case (elemIndex (getId r1) xs, elemIndex (getId r2) xs) of
+      (Just i,  Just j ) -> i `compare` j
+      (Just _,  Nothing) -> LT
+      (Nothing, Just _ ) -> GT
+      (Nothing, Nothing) -> compareId r1 r2
+
+---------------------------------------------------------------
+-- Using type representations for casts
+
+data IsTypeable a = IT (forall b . Typeable b => a -> Maybe b)
+                       (forall b . Typeable b => b -> Maybe a)
+
+useTypeable :: Typeable a => Maybe (IsTypeable a)
+useTypeable = Just (IT cast cast)
+
+castFrom :: Typeable b => Exercise a -> a -> Maybe b
+castFrom ex a = do
+   IT f _ <- hasTypeable ex
+   f a
+
+castTo :: Typeable b => Exercise a -> b -> Maybe a
+castTo ex a = do
+   IT _ g <- hasTypeable ex
+   g a
+
+---------------------------------------------------------------
+-- Exercise status
+
+data Status
+   = Stable       -- ^ A released exercise that has undergone some thorough testing
+   | Provisional  -- ^ A released exercise, possibly with some deficiencies
+   | Alpha        -- ^ An exercise that is under development
+   | Experimental -- ^ An exercise for experimentation purposes only
+   deriving (Show, Eq)
+
+-- | An exercise with the status @Stable@ or @Provisional@
+isPublic :: Exercise a -> Bool
+isPublic ex = status ex `elem` [Stable, Provisional]
+
+-- | An exercise that is not public
+isPrivate :: Exercise a -> Bool
+isPrivate = not . isPublic
+
+---------------------------------------------------------------
+-- Rest
+
+-- | Function for defining equivalence or similarity without taking
+-- the context into account.
+withoutContext :: (a -> a -> Bool) -> Context a -> Context a -> Bool
+withoutContext f a b = fromMaybe False (fromContextWith2 f a b)
+
+isReady :: Exercise a -> a -> Bool
+isReady = evalPredicate . ready
+
+isSuitable :: Exercise a -> a -> Bool
+isSuitable = evalPredicate . suitable
+
+-- | Similarity on terms without a context
+simpleSimilarity :: Exercise a -> a -> a -> Bool
+simpleSimilarity ex = similarity ex `on` inContext ex
+
+-- | Equivalence on terms without a context
+simpleEquivalence :: Exercise a -> a -> a -> Bool
+simpleEquivalence ex = equivalence ex `on` inContext ex
+
+prettyPrinterContext :: Exercise a -> Context a -> String
+prettyPrinterContext ex =
+   maybe "<<invalid term>>" (prettyPrinter ex) . fromContext
+
+getRule :: Monad m => Exercise a -> Id -> m (Rule (Context a))
+getRule ex a =
+   case filter ((a ==) . getId) (ruleset ex) of
+      [hd] -> return hd
+      []   -> fail $ "Could not find ruleid " ++ showId a
+      _    -> fail $ "Ambiguous ruleid " ++ showId a
+
+-- |Shows a derivation for a given start term. The specified rule ordering
+-- is used for selection.
+showDerivation :: Exercise a -> a -> String
+showDerivation ex a = show (present der) ++ extra
+ where
+   der   = derivationDiffEnv (defaultDerivation ex a)
+   extra =
+      case fromContext (lastTerm der) of
+         Nothing               -> "<<invalid term>>"
+         Just b | isReady ex b -> ""
+                | otherwise    -> "<<not ready>>"
+   present = biMap (ShowString . f) (ShowString . prettyPrinterContext ex)
+   f ((r, local), global) = showId r ++ part1 ++ part2
+    where
+      newl  = "\n      "
+      part1 = newl ++ show local
+      part2 | noBindings global = ""
+            | otherwise         = newl ++ show global
+
+type ExerciseDerivation a = Derivation (Rule (Context a), Environment) (Context a)
+
+defaultDerivation :: Exercise a -> a -> ExerciseDerivation a
+defaultDerivation ex a =
+   let ca     = inContext ex a
+       tree   = sortTree (ruleOrdering ex `on` fst) (derivationTree False (strategy ex) ca)
+       single = emptyDerivation ca
+   in fromMaybe single (derivation tree)
+
+derivationDiffEnv :: Derivation s (Context a) -> Derivation (s, Environment) (Context a)
+derivationDiffEnv = updateSteps $ \old a new ->
+   let keep x = not (getId x `sameId` "location" || x `elem` list)
+       list = bindings old
+   in (a, makeEnvironment $ filter keep $ bindings new)
+
+printDerivation :: Exercise a -> a -> IO ()
+printDerivation ex = putStrLn . showDerivation ex
+
+---------------------------------------------------------------
+-- Checks for an exercise
+
+checkExercise :: Exercise a -> IO ()
+checkExercise = runTestSuite . exerciseTestSuite
+
+exerciseTestSuite :: Exercise a -> TestSuite
+exerciseTestSuite ex = suite ("Exercise " ++ show (exerciseId ex)) $ do
+   -- get some exercises
+   xs <- if isJust (randomExercise ex)
+         then liftIO $ replicateM 10 (randomTerm ex Nothing)
+         else return (map snd (examples ex))
+   -- do tests
+   assertTrue "Exercise terms defined" (not (null xs))
+   assertTrue "Equivalence implemented" $
+      let eq a b = equivalence ex (inContext ex a) (inContext ex b)
+      in length (nubBy eq xs) > 1
+   assertTrue "Similarity implemented" $
+      let sim a b = similarity ex (inContext ex a) (inContext ex b)
+      in length (nubBy sim xs) > 1
+   checkExamples ex
+   case testGenerator ex of
+      Nothing  -> return ()
+      Just gen -> do
+         let showAsGen = showAs (prettyPrinter ex) gen
+         addProperty "parser/pretty printer" $ forAll showAsGen $
+            checkParserPrettyEx ex . inContext ex . fromS
+
+         {-
+         suite "Soundness non-buggy rules" $
+            forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r ->
+               let eq a b = equivalence ex (fromS a) (fromS b)
+                   myGen  = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen)
+                   myView = makeView (return . fromS) (S (prettyPrinterContext ex))
+                   args   = stdArgs {maxSize = 10, maxSuccess = 10, maxDiscard = 100}
+               in addPropertyWith (showId r) args $
+                     propRuleSmart eq (liftView myView r) myGen -}
+
+         addProperty "soundness strategy/generator" $
+            forAll showAsGen $
+               maybe False (isReady ex) . fromContext
+               . applyD (strategy ex) . inContext ex . fromS
+
+data ShowAs a = S {showS :: a -> String, fromS :: a}
+
+instance Show (ShowAs a) where
+   show a = showS a (fromS a)
+
+showAs :: (a -> String) -> Gen a -> Gen (ShowAs a)
+showAs f = liftM (S f)
+
+-- check combination of parser and pretty-printer
+checkParserPretty :: (a -> a -> Bool) -> (String -> Either String a) -> (a -> String) -> a -> Bool
+checkParserPretty eq p pretty a =
+   either (const False) (eq a) (p (pretty a))
+
+checkParserPrettyEx :: Exercise a -> Context a -> Bool
+checkParserPrettyEx ex ca =
+   let f    = mapSecond make . parser ex
+       make = newContext (environment ca) . navigation ex
+   in checkParserPretty (similarity ex) f (prettyPrinterContext ex) ca
+
+{-
+propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property
+propRule eq r gen =
+   forAll gen $ \a ->
+   let xs = applyAll r a in
+   not (null xs) ==>
+   forAll (elements xs) $ \b ->
+   a `eq` b -}
+
+checkExamples :: Exercise a -> TestSuite
+checkExamples ex = do
+   let xs = map snd (examples ex)
+   unless (null xs) $ suite "Examples" $
+      mapM_ (checksForTerm True ex) xs
+
+checksForTerm :: Bool -> Exercise a -> a -> TestSuite
+checksForTerm leftMost ex a = do
+   let tree = derivationTree False (strategy ex) (inContext ex a)
+   -- Left-most derivation
+   when leftMost $
+      case derivation tree of
+         Just d  -> checksForDerivation ex d
+         Nothing ->
+            fail $ "no derivation for " ++ prettyPrinter ex a
+   -- Random derivation
+   g <- liftIO getStdGen
+   case randomDerivation g tree of
+      Just d  -> checksForDerivation ex d
+      Nothing -> return ()
+
+checksForDerivation :: Exercise a -> Derivation (Rule (Context a), Environment) (Context a) -> TestSuite
+checksForDerivation ex d = do
+   -- Conditions on starting term
+   let start = firstTerm d
+   assertTrue
+      ("start term not suitable: " ++ prettyPrinterContext ex start) $
+      maybe False (isSuitable ex) (fromContext start)
+
+   {-
+   b2 <- do let b = False -- maybe True (isReady ex) (fromContext start)
+            when b $ report $
+               "start term is ready: " ++ prettyPrinterContext ex start
+            return b-}
+   -- Conditions on final term
+   let final = lastTerm d
+   {-
+   b3 <- do let b = False -- maybe True (isSuitable ex) (fromContext final)
+            when b $ report $
+               "final term is suitable: " ++ prettyPrinterContext ex start
+               ++ "  =>  " ++ prettyPrinterContext ex final
+            return b -}
+   assertTrue
+      ("final term not ready: " ++ prettyPrinterContext ex start
+               ++ "  =>  " ++ prettyPrinterContext ex final) $
+      maybe False (isReady ex) (fromContext final)
+
+   -- Parser/pretty printer on terms
+   let ts  = terms d
+       p1  = not . checkParserPrettyEx ex
+   assertNull "parser/pretty-printer" $ take 1 $ flip map (filter p1 ts) $ \hd ->
+      let s = prettyPrinterContext ex hd
+      in "parse error for " ++ s ++ ": parsed as "
+         ++ either show (prettyPrinter ex) (parser ex s)
+
+   -- Equivalences between terms
+   let pairs    = [ (x, y) | x <- ts, y <- ts ]
+       p2 (x, y) = not (equivalence ex x y)
+   assertNull "equivalences" $ take 1 $ flip map (filter p2 pairs) $ \(x, y) ->
+      "not equivalent: " ++ prettyPrinterContext ex x
+      ++ "  with  " ++ prettyPrinterContext ex y
+
+   -- Similarity of terms
+   let p3 (x, (_, _), y) = similarity ex x y &&
+                           on (==) (maybe False (isReady ex) . fromContext) x y
+   assertNull  "similars" $ take 1 $ flip map (filter p3 (triples d)) $ \(x, r, y) ->
+      "similar subsequent terms: " ++ prettyPrinterContext ex x
+      ++ "  with  " ++ prettyPrinterContext ex y
+      ++ "  using  " ++ show r
+
+   assertNull "self similarity" $ take 1 $ do
+      x <- terms d
+      guard (not (similarity ex x x))
+      return $ "term not similar to itself: " ++ prettyPrinterContext ex x
+
+   -- Parameters
+   assertNull "parameters" $ take 1 $ do
+      (r, env) <- steps d
+      maybeToList (checkReferences r env)
+ src/Ideas/Common/Id.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Identification of entities
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Id
+   ( Id, IsId(..), HasId(..), Identify(..), ( # ), sameId
+   , unqualified, qualifiers, qualification
+   , describe, description, showId, compareId
+   , mempty, isEmptyId, listQualify
+   ) where
+
+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 Test.QuickCheck
+
+---------------------------------------------------------------------
+-- Abstract data type and its instances
+
+data Id = Id
+   { idList        :: [String]
+   , idDescription :: String
+   , idRef         :: !StringRef
+   }
+ deriving (Data, Typeable)
+
+instance Show Id where
+   show = intercalate "." . idList
+
+instance Read Id where
+   readsPrec _ =
+      return . mapFirst stringId . span isIdChar . dropWhile isSpace
+
+instance Eq Id where
+   a == b = idRef a == idRef b
+
+instance Ord Id where
+   compare = comparing idRef
+
+instance Monoid Id where
+   mempty  = emptyId
+   mappend = ( # )
+
+instance Arbitrary Id where
+   arbitrary = frequency
+      [ (4, do n  <- choose (0, 8)
+               xs <- replicateM n (elements ['a' .. 'z'])
+               return $ newId xs)
+      , (1, liftM2 mappend arbitrary arbitrary)
+      ]
+
+---------------------------------------------------------------------
+-- Type class for constructing identifiers
+
+class IsId a where
+   newId    :: a   -> Id
+   concatId :: [a] -> Id -- for String instance
+   -- default definition
+   concatId = mconcat . map newId
+
+instance IsId Id where
+   newId = id
+
+instance IsId Char where
+   newId c  = stringId [c]
+   concatId = stringId
+
+instance IsId a => IsId [a] where
+   newId    = concatId
+   concatId = mconcat . map newId
+
+instance IsId () where
+   newId = const emptyId
+
+instance (IsId a, IsId b) => IsId (a, b) where
+   newId (a, b) = newId a # newId b
+
+instance (IsId a, IsId b, IsId c) => IsId (a, b, c) where
+   newId (a, b, c) = newId a # newId b # newId c
+
+instance IsId a => IsId (Maybe a) where
+   newId = maybe emptyId newId
+
+instance (IsId a, IsId b) => IsId (Either a b) where
+   newId = either newId newId
+
+-----------------------------------------------------
+-- Type class for structures containing an identifier
+
+class HasId a where
+   getId    :: a -> Id
+   changeId :: (Id -> Id) -> a -> a
+
+instance HasId Id where
+   getId    = id
+   changeId = id
+
+instance (HasId a, HasId b) => HasId (Either a b) where
+   getId      = either getId getId
+   changeId f = biMap (changeId f) (changeId f)
+
+class HasId a => Identify a where
+   (@>) :: IsId n => n -> a -> a
+
+---------------------------------------------------------------------
+-- Private constructors
+
+appendId :: Id -> Id -> Id
+appendId a b
+   | null (idList a) = b
+   | null (idList b) = a
+   | otherwise       = Id (idList a ++ idList b) "" ref
+ where
+   ref = stringRef (show a ++ "." ++ show b)
+
+-- Only allow alphanum and '-' ('.' has a special meaning)
+stringId :: String -> Id
+stringId txt = Id (make s) "" (stringRef s)
+ where
+   s    = norm txt
+   make = filter (not . null) . splitsWithElem '.'
+   norm = filter isIdChar . map toLower
+
+isIdChar :: Char -> Bool
+isIdChar c = isAlphaNum c || c `elem` ".-_"
+
+emptyId :: Id
+emptyId = Id [] "" (stringRef "")
+
+---------------------------------------------------------------------
+-- Additional functionality (overloaded)
+
+infixr 8 #
+
+( # ) :: (IsId a, IsId b) => a -> b -> Id
+a # b = appendId (newId a) (newId b)
+
+sameId :: (IsId a, IsId b) => a -> b -> Bool
+sameId a b = newId a == newId b
+
+unqualified :: HasId a => a -> String
+unqualified a
+   | null xs   = ""
+   | otherwise = last xs
+ where
+   xs = idList (getId a)
+
+qualifiers :: HasId a => a -> [String]
+qualifiers a
+   | null xs   = []
+   | otherwise = init xs
+ where
+   xs = idList (getId a)
+
+qualification :: HasId a => a -> String
+qualification = intercalate "." . qualifiers
+
+description :: HasId a => a -> String
+description = idDescription . getId
+
+showId :: HasId a => a -> String
+showId = show . getId
+
+compareId :: HasId a => a -> a -> Ordering
+compareId = comparing showId
+
+isEmptyId :: Id -> Bool
+isEmptyId = (== emptyId)
+
+describe :: HasId a => String -> a -> a
+describe = changeId . describeId
+ where
+   describeId s a
+      | null (idDescription a) =
+           a {idDescription = s}
+      | otherwise =
+           a {idDescription = s ++ " " ++ idDescription a}
+
+listQualify :: (IsId a, IsId b) => [a] -> b -> Id -- TODO: clean me up
+listQualify ls h = foldr (appendId . newId) (newId h) ls
+ src/Ideas/Common/Library.hs view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Exports most from package Common
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Library
+   ( module Export
+   , failS, notS, repeatS, replicateS, sequenceS, untilS
+   ) where
+
+import Ideas.Common.Classes as Export
+import Ideas.Common.Context as Export
+import Ideas.Common.Derivation as Export
+import Ideas.Common.DerivationTree as Export
+import Ideas.Common.Environment as Export
+import Ideas.Common.Exercise as Export
+import Ideas.Common.Id as Export
+import Ideas.Common.Predicate as Export
+import Ideas.Common.Rewriting as Export
+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, toLocation, fromLocation, arity, top)
+import Ideas.Common.View as Export
+
+import qualified Ideas.Common.Strategy as S
+
+-- | Alias for strategy combinator @fail@
+failS :: Strategy a
+failS = S.fail
+
+-- | Alias for strategy combinator @not@
+notS :: IsStrategy f => f a -> Strategy a
+notS = S.not
+
+-- | Alias for strategy combinator @repeat@
+repeatS :: IsStrategy f => f a -> Strategy a
+repeatS = S.repeat
+
+-- | Alias for strategy combinator @replicate@
+replicateS :: IsStrategy f => Int -> f a -> Strategy a
+replicateS = S.replicate
+
+-- | Alias for strategy combinator @sequence@
+sequenceS :: IsStrategy f => [f a] -> Strategy a
+sequenceS = S.sequence
+
+-- | Alias for strategy combinator @until@
+untilS :: IsStrategy f => (a -> Bool) -> f a -> Strategy a
+untilS = S.until
+ src/Ideas/Common/Predicate.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ExistentialQuantification #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Representation for predicates
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Predicate
+   ( -- * Predicate representation
+     Predicate, predicate, predicateView
+   , evalPredicate
+     -- * Exports from Boolean algebra
+   , BoolValue(..), Boolean(..)
+   , ands, ors, implies, equivalent
+   ) where
+
+import Ideas.Common.Algebra.Boolean
+import Ideas.Common.Id
+import Ideas.Common.View
+
+data Predicate a
+   = Const Bool
+   | Prim (a -> Bool)
+   | forall b . PView (View a b)
+   | Compl (Predicate a)
+   | Predicate a :&&: Predicate a
+   | Predicate a :||: Predicate a
+   | Id :@ Predicate a
+
+instance BoolValue (Predicate a) where
+   fromBool = Const
+   isTrue  (Const b) = b
+   isTrue  _         = False
+   isFalse (Const b) = not b
+   isFalse _         = False
+
+instance Boolean (Predicate a) where
+   Const b <&&> y       = if b then y else false
+   x       <&&> Const b = if b then x else false
+   x       <&&> y       = x :&&: y
+   Const b <||> y       = if b then true else y
+   x       <||> Const b = if b then true else x
+   x       <||> y       = x :||: y
+   complement (Const b) = Const (not b)
+   complement x         = Compl x
+
+instance HasId (Predicate a) where
+   getId (n :@ _)  = n
+   getId (PView v) = getId v
+   getId _         = mempty
+   changeId f (n :@ a) = f n :@ a
+   changeId f a        = f mempty :@ a
+
+instance Identify (Predicate a) where
+   n @> v | isEmptyId a = v
+          | otherwise   = a :@ v
+    where
+      a = newId n
+
+predicate :: (a -> Bool) -> Predicate a
+predicate = Prim
+
+predicateView :: View a b -> Predicate a
+predicateView = PView
+
+evalPredicate :: Predicate a -> a -> Bool
+evalPredicate p a = rec p
+ where
+   rec (Const b)  = b
+   rec (Prim f)   = f a
+   rec (PView v)  = a `belongsTo` v
+   rec (Compl x)  = not (rec x)
+   rec (x :&&: y) = rec x && rec y
+   rec (x :||: y) = rec x || rec y
+   rec (_ :@ x)   = rec x
+ src/Ideas/Common/Rewriting.hs view
@@ -0,0 +1,15 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rewriting (module Export) where
+
+import Ideas.Common.Rewriting.RewriteRule as Export
+import Ideas.Common.Rewriting.Term as Export
+ src/Ideas/Common/Rewriting/AC.hs view
@@ -0,0 +1,133 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rewriting.AC
+   ( -- * Types
+     Pairings, PairingsList, PairingsPair
+--   , pairings, pairingsMatch
+     -- * Primitive pairings functions
+   , pairingsNone, pairingsA, pairingsMatchA
+   , pairingsC, pairingsAC
+   ) where
+
+import Data.List
+import Ideas.Common.Classes
+
+type Pairings     a   = a -> a -> [[(a, a)]]
+type PairingsList a b = [a] -> [b] -> [[([a], [b])]]
+type PairingsPair a b = (a, a) -> (b, b) -> [[(a, b)]]
+
+-----------------------------------------------------------
+-- Pairing terms with an AC theory
+-- matchMode: the left-hand sides cannot have the operator at top-level
+
+{-
+pairings, pairingsMatch :: IsMagma m => m a -> Pairings a
+pairings      = pairingsMode False
+pairingsMatch = pairingsMode True
+
+pairingsMode :: IsMagma m => Bool -> m a -> Pairings a
+pairingsMode matchMode op =
+   case (isAssociative op, isCommutative op) of
+      (True , True ) -> operatorPairings op (pairingsAC matchMode)
+      (True , False) -> operatorPairings op (pairingsA matchMode)
+      (False, True ) -> opPairings op pairingsC
+      (False, False) -> opPairings op pairingsNone
+-}
+
+-- non-associative, non-commutative pairings
+pairingsNone :: PairingsPair a b
+pairingsNone (a1, a2) (b1, b2) =
+   [[(a1, b1), (a2, b2)]]
+
+-- commutative pairings
+pairingsC :: PairingsPair a b
+pairingsC (a1, a2) (b1, b2) =
+   [[(a1, b1), (a2, b2)], [(a1, b2), (a2, b1)]]
+
+-- associative pairings
+pairingsA :: Bool -> PairingsList a b
+pairingsA matchMode
+   | matchMode = pairingsMatchA (\a bs -> ([a], bs))
+   | otherwise = rec
+ where
+   rec [] [] = [[]]
+   rec as bs =
+      [ (as1, bs1):ps
+      | i <- [1 .. length as]
+      , j <- [1 .. length bs]
+      , i==1 || j==1
+      , let (as1, as2) = splitAt i as
+      , let (bs1, bs2) = splitAt j bs
+      , ps <- rec as2 bs2
+      ]
+
+pairingsMatchA :: (a -> [b] -> c) -> [a] -> [b] -> [[c]]
+pairingsMatchA f = rec
+ where
+   rec [] [] = [[]]
+   rec [] _  = []
+   rec (a:as) bs =
+      [ p:ps
+      | (xs, ys) <- take (length bs - length as) $ tail $ splits bs
+      , let p = f a xs
+      , ps <- rec as ys
+      ]
+
+-- go _ = length $ pairingsMatchA [1::Int ..10] [1::Int ..20] -- 92378
+
+-- associative/commutative pairings
+pairingsAC :: Bool -> PairingsList a b
+pairingsAC matchMode = rec
+ where
+   rec [] [] = [[]]
+   rec [] _  = []
+   rec (a:as) bs =
+      [ (as1, bs1):ps
+      | (asr, as2) <- if matchMode then [([], as)] else divide as
+      , let as1 = a:asr
+      , (bs1, bs2) <- divide bs
+      , not (null bs1)
+      , length as1==1 || length bs1==1
+      , ps <- rec as2 bs2
+      ]
+
+----------------------------------------------------------
+-- Helper functions
+{-
+opPairings :: IsMagma m => m a -> PairingsPair a a -> Pairings a
+opPairings op f a b = fromMaybe [] $
+   liftM2 f (match (magmaView op) a) (match (magmaView op) b)
+
+operatorPairings :: IsMagma m => m a -> PairingsList a a -> Pairings a
+operatorPairings op g = curry $
+   let f a = fromMaybe [a] $ match (magmaListView op) a
+       h = build (magmaListView op)
+   in map (map (onBoth h)) . uncurry g . onBoth f
+-}
+divide :: [a] -> [([a], [a])]
+divide = foldr op [([], [])]
+ where
+   op a ps = map (mapFirst (a:)) ps ++ map (mapSecond (a:)) ps
+
+splits :: [a] -> [([a], [a])]
+splits xs = zip (inits xs) (tails xs)
+
+{-
+onBoth :: (a -> b) -> (a, a) -> (b, b)
+onBoth f (x, y) = (f x, f y)
+
+permutations :: [a] -> [[a]]
+permutations = foldr (concatMap . insert) [[]]
+ where
+   insert a []     = [[a]]
+   insert a (x:xs) = (a:x:xs) : map (x:) (insert a xs)
+-}
+ src/Ideas/Common/Rewriting/Confluence.hs view
@@ -0,0 +1,156 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rewriting.Confluence
+   ( isConfluent, checkConfluence, checkConfluenceWith
+   , somewhereM
+   , Config, defaultConfig, showTerm, complexity, termEquality
+   ) where
+
+import Data.Maybe
+import Ideas.Common.Id
+import Ideas.Common.Rewriting.RewriteRule
+import Ideas.Common.Rewriting.Substitution
+import Ideas.Common.Rewriting.Term
+import Ideas.Common.Rewriting.Unification
+import Ideas.Common.Traversal.Navigator
+import Ideas.Common.Traversal.Utils
+import Ideas.Common.Utils.Uniplate hiding (rewriteM)
+
+normalForm :: [RewriteRule a] -> Term -> Term
+normalForm rs = run []
+ where
+   run hist a =
+      case [ b | r <- rs, b <- somewhereM (rewriteTerm r) a ] of
+         []   -> a
+         hd:_ -> if hd `elem` hist
+                 then error "cyclic"
+                 else run (a:hist) hd
+
+rewriteTerm :: RewriteRule a -> Term -> [Term]
+rewriteTerm r t = do
+   let lhs :~> rhs = ruleSpecTerm $
+          renumberRewriteRule (nextMetaVar t) r
+   sub <- match lhs t
+   return (sub |-> rhs)
+
+-- uniplate-like helper-functions
+somewhereM :: Uniplate a => (a -> [a]) -> a -> [a]
+somewhereM f = map unfocus . rec . uniplateNav
+ where
+   rec ca = changeG f ca ++ concatMap rec (downs ca)
+
+uniplateNav :: Uniplate a => a -> UniplateNavigator a
+uniplateNav = focus
+
+----------------------------------------------------
+
+type Pair   a = (RewriteRule a, Term)
+type Triple a = (RewriteRule a, Term, Term)
+
+superImpose :: RewriteRule a -> RewriteRule a -> [UniplateNavigator Term]
+superImpose r1 r2 = rec (uniplateNav lhs1)
+ where
+    lhs1 :~> _ = ruleSpecTerm r1
+    lhs2 :~> _ = ruleSpecTerm (renumber r1 r2)
+
+    rec ca = case current ca of
+                TMeta _ -> []
+                a       -> maybe [] (return . (`subTop` ca)) (unify a lhs2) ++
+                           concatMap rec (downs ca)
+
+    subTop :: Substitution -> UniplateNavigator Term -> UniplateNavigator Term
+    subTop s ca = fromMaybe ca $
+       navigateTo (location ca) (change (s |->) (top ca))
+
+    renumber r = case metaInRewriteRule r of
+                    [] -> id
+                    xs -> renumberRewriteRule (maximum xs + 1)
+
+criticalPairs :: [RewriteRule a] -> [(Term, Pair a, Pair a)]
+criticalPairs rs =
+   [ (a, (r1, b1), (r2, b2))
+   | r1       <- rs
+   , r2       <- rs
+   , na <- superImpose r1 r2
+   , compareId r1 r2 == LT || not (null (fromLocation (location na)))
+   , let a = unfocus na
+   , b1 <- rewriteTerm r1 a
+   , b2 <- map unfocus (changeG (rewriteTerm r2) na)
+   ]
+
+noDiamondPairs :: Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)]
+noDiamondPairs cfg rs = noDiamondPairsWith (normalForm rs) cfg rs
+
+noDiamondPairsWith :: (Term -> Term) -> Config -> [RewriteRule a] -> [(Term, Triple a, Triple a)]
+noDiamondPairsWith f cfg rs =
+   [ (a, (r1, e1, nf1), (r2, e2, nf2))
+   | (a, (r1, e1), (r2, e2)) <- criticalPairs rs
+   , let (nf1, nf2) = (f e1, f e2)
+   , not (termEquality cfg nf1 nf2)
+   ]
+
+reportPairs :: Config -> [(Term, Triple a, Triple a)] -> IO ()
+reportPairs cfg = putStrLn . unlines . zipWith report [1::Int ..]
+ where
+   f = showTerm cfg
+   report i (a, (r1, e1, nf1), (r2, e2, nf2)) = unlines
+      [ show i ++ ") " ++ f a
+      , "  "   ++ showId r1
+      , "    " ++ f e1 ++ if e1==nf1 then "" else "   -->   " ++ f nf1
+      , "  "   ++ showId r2
+      , "    " ++ f e2 ++ if e2==nf2 then "" else "   -->   " ++ f nf2
+      ]
+
+----------------------------------------------------
+
+isConfluent :: [RewriteRule a] -> Bool
+isConfluent = null . noDiamondPairs defaultConfig
+
+checkConfluence :: [RewriteRule a] -> IO ()
+checkConfluence = checkConfluenceWith defaultConfig
+
+checkConfluenceWith :: Config -> [RewriteRule a] -> IO ()
+checkConfluenceWith cfg = reportPairs cfg . noDiamondPairs cfg
+
+data Config = Config
+   { showTerm     :: Term -> String
+   , complexity   :: Term -> Int
+   , termEquality :: Term -> Term -> Bool
+   }
+
+defaultConfig :: Config
+defaultConfig = Config show (const 0) (==)
+
+----------------------------------------------------
+-- Example
+{-
+r1, r2, r3, r4, r5 :: RewriteRule SLogic
+r1 = rewriteRule "R1" $ \p q r -> p :||: (q :||: r) :~> (p :||: q) :||: r
+r2 = rewriteRule "R2" $ \p q   -> p :||: q :~> q :||: p
+r3 = rewriteRule "R3" $ \p     -> p :||: p :~> p
+r4 = rewriteRule "R4" $ \p     -> p :||: T :~> T
+r5 = rewriteRule "R5" $ \p     -> p :||: F :~> p
+
+this = [r1, r2, r3, r4, r5, r6]
+go = reportPairs $ noDiamondPairs this
+
+r6 :: RewriteRule SLogic
+r6 = rewriteRule "R6" $ \p -> p :||: T :~> F
+
+r1, r2, r3 :: RewriteRule Expr
+r1 = rewriteRule "a1" $ \a -> 0+a :~> a
+r2 = rewriteRule "a3" $ \a b c -> a+(b+c) :~> (a+b)+c
+r3 = rewriteRule "a2" $ \a -> a+0 :~> a
+
+go = do -- putStrLn $ unlines $ map show $ criticalPairs [r1,r2]
+        checkConfluence [r1,r2,r3]
+-}
+ src/Ideas/Common/Rewriting/Difference.hs view
@@ -0,0 +1,86 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Compute the difference of two terms generically, taking associativity
+-- into account.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rewriting.Difference
+   ( difference, differenceEqual
+   , differenceWith, differenceEqualWith
+   ) where
+
+import Control.Monad
+import Data.Function
+import Data.Maybe
+import Ideas.Common.Rewriting.Term
+import Ideas.Common.View
+
+differenceWith :: View Term a -> a -> a -> Maybe (a, a)
+differenceWith = diff (\_ _ -> True)
+
+differenceEqualWith :: View Term a -> (a -> a -> Bool) -> a -> a -> Maybe (a, a)
+differenceEqualWith v eq p q = guard (eq p q) >> diff eq v p q
+
+difference :: IsTerm a => a -> a -> Maybe (a, a)
+difference = diff (\_ _ -> True) termView
+
+-- | This function returns the difference, except that the
+-- returned terms should be logically equivalent. Nothing can signal that
+-- there is no difference, or that the terms to start with are not equivalent.
+differenceEqual :: IsTerm a => (a -> a -> Bool) -> a -> a -> Maybe (a, a)
+differenceEqual eq p q = do
+   guard (eq p q)
+   diff eq termView p q
+
+collectSym :: Symbol -> Term -> [Term]
+collectSym s a = maybe [a] (uncurry ((++) `on` collectSym s)) (isBinary s a)
+
+-- local implementation function
+diff :: (a -> a -> Bool) -> View Term a -> a -> a -> Maybe (a, a)
+diff eq v a b = do
+   let eqT x y = fromMaybe False $ liftM2 eq (match v x) (match v y)
+   (t1, t2) <- diffTerm eqT (build v a) (build v b)
+   liftM2 (,) (match v t1) (match v t2)
+
+diffTerm :: (Term -> Term -> Bool) -> Term -> Term -> Maybe (Term, Term)
+diffTerm eq = rec
+ where
+   rec p q =
+      case (getFunction p, getFunction q) of
+         (Just (s1, ps), Just (s2, qs))
+            | s1 /= s2         -> Just (p, q)
+            | isAssociative s1 -> (diffA s1 `on` collectSym s1) p q
+            | otherwise        -> diffList ps qs
+         _  | p == q           -> Nothing
+            | otherwise        -> Just (p, q)
+
+   diffList xs ys
+      | length xs /= length ys = Nothing
+      | otherwise =
+           case catMaybes (zipWith rec xs ys) of
+              [p] -> Just p
+              _   -> Nothing
+
+   diffA s = curry (make . rev . f . rev . f)
+    where
+      f (p:ps, q:qs) | not (null ps || null qs) &&
+                       isNothing (rec p q) &&
+                       equal ps qs =
+         f (ps, qs)
+      f pair = pair
+
+      equal     = eq `on` builder
+      rev       = reverse *** reverse
+      builder   = foldr1 (binary s)
+      make pair =
+         case pair of
+            ([p], [q]) -> rec p q
+            (ps, qs)   -> Just (builder ps, builder qs)
+ src/Ideas/Common/Rewriting/RewriteRule.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses,
+       FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rewriting.RewriteRule
+   ( -- * Supporting type class
+     Different(..)
+     -- * Rewrite rules and specs
+   , RewriteRule, ruleSpecTerm, RuleSpec(..)
+     -- * Compiling rewrite rules
+   , makeRewriteRule, RuleBuilder(..)
+     -- * Using rewrite rules
+   , showRewriteRule
+   , metaInRewriteRule, renumberRewriteRule
+   , symbolMatcher, symbolBuilder
+   ) where
+
+import Data.Maybe
+import Data.Monoid
+import Ideas.Common.Classes
+import Ideas.Common.Environment
+import Ideas.Common.Id
+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 qualified Data.IntSet as IS
+import qualified Data.Map as M
+
+------------------------------------------------------
+-- Rewrite rules and specs
+
+infixl 1 :~>
+
+data RuleSpec a = a :~> a deriving Show
+
+instance Functor RuleSpec where
+   fmap f (a :~> b) = f a :~> f b
+
+data RewriteRule a = R
+   { ruleId         :: Id
+   , ruleSpecTerm   :: RuleSpec Term
+   , ruleShow       :: a -> String
+   , ruleTermView   :: View Term a
+   , ruleMatchers   :: M.Map Symbol SymbolMatch
+   , ruleBuilders   :: M.Map Symbol ([Term] -> Term)
+   }
+
+instance Show (RewriteRule a) where
+   show = showId
+
+instance HasId (RewriteRule a) where
+   getId = ruleId
+   changeId f r = r {ruleId = f (ruleId r)}
+
+------------------------------------------------------
+-- Compiling a rewrite rule
+
+class Different a where
+   different :: (a, a)
+
+instance Different a => Different [a] where
+   different = ([], [fst different])
+
+instance Different Char where
+   different = ('a', 'b')
+
+class (IsTerm a, Show a) => RuleBuilder t a | t -> a where
+   buildRuleSpec  :: Int -> t -> RuleSpec Term
+
+instance (IsTerm a, Show a) => RuleBuilder (RuleSpec a) a where
+   buildRuleSpec  = const $ fmap toTerm
+
+instance (Different a, RuleBuilder t b) => RuleBuilder (a -> t) b where
+   buildRuleSpec i f = buildFunction i (buildRuleSpec (i+1) . f)
+
+buildFunction :: Different a => Int -> (a -> RuleSpec Term) -> RuleSpec Term
+buildFunction n f = fzip (fill n) ((f *** f) different)
+ where
+   fzip g (a :~> b, c :~> d) = g a c :~> g b d
+
+fill :: Int -> Term -> Term -> Term
+fill i = rec
+ where
+   rec (TCon s xs) (TCon t ys) | s == t && length xs == length ys =
+      TCon s (zipWith rec xs ys)
+   rec (TList xs) (TList ys) | length xs == length ys =
+      TList (zipWith rec xs ys)
+   rec a b
+      | a == b    = a
+      | otherwise = TMeta i
+
+buildSpec :: M.Map Symbol SymbolMatch
+          -> M.Map Symbol ([Term] -> Term)
+          -> RuleSpec Term -> Term -> [(Term, [Term])]
+buildSpec sm sb (lhs :~> rhs) a = do
+   (sub, ml, mr) <- matchExtended sm lhs a
+   let sym = maybe (error "buildSpec") fst (getFunction lhs)
+       extLeft  = maybe id (binary sym) ml
+       extRight = maybe id (flip (binary sym)) mr
+       new  = useBuilders $ extLeft $ extRight $ sub |-> rhs
+       args = mapMaybe (`lookupVar` sub) $ IS.toList $ dom sub
+   return (new, args)
+ where
+   useBuilders
+      | M.null sb = id
+      | otherwise = rec
+    where
+      rec (TCon s xs) =
+         fromMaybe (TCon s) (M.lookup s sb) (map rec xs)
+      rec term = term
+
+makeRewriteRule :: (IsId n, RuleBuilder f a) => n -> f -> RewriteRule a
+makeRewriteRule s f =
+   R (newId s) (buildRuleSpec 0 f) show termView M.empty M.empty
+
+symbolMatcher :: Symbol -> SymbolMatch -> RewriteRule a -> RewriteRule a
+symbolMatcher s f r = r {ruleMatchers = M.insert s f (ruleMatchers r)}
+
+symbolBuilder :: Symbol -> ([Term] -> Term) -> RewriteRule a -> RewriteRule a
+symbolBuilder s f r = r {ruleBuilders = M.insert s f (ruleBuilders r)}
+
+------------------------------------------------------
+-- Using a rewrite rule
+
+instance Apply RewriteRule where
+   applyAll r = map fst . applyRewriteRule r
+
+applyRewriteRule :: RewriteRule a -> a -> [(a, Environment)]
+applyRewriteRule r a = do
+   let builder = buildSpec (ruleMatchers r) (ruleBuilders r) (ruleSpecTerm r)
+       term    = toTermRR r a
+   (out, xs) <- builder term
+   let env    = mconcat (zipWith make xs [1::Int ..])
+       make t = flip singleBinding t . makeRef . show
+   b <- fromTermRR r out
+   return (b, env)
+
+-----------------------------------------------------------
+-- Pretty-print a rewriteRule
+
+showRewriteRule :: Bool -> RewriteRule a -> Maybe String
+showRewriteRule sound r = do
+   x <- fromTermRR r (sub |-> a)
+   y <- fromTermRR r (sub |-> b)
+   let op = if sound then "~>" else "/~>"
+   return (ruleShow r x ++ " " ++ op ++ " " ++ ruleShow r y)
+ where
+   a :~> b = ruleSpecTerm r
+   vs  = IS.toList (metaVarSet a `IS.union` metaVarSet b)
+   sub = listToSubst $ zip vs [ TVar [c] | c <- ['a' ..] ]
+
+------------------------------------------------------
+
+-- some helpers
+metaInRewriteRule :: RewriteRule a -> [Int]
+metaInRewriteRule r = metaVars a ++ metaVars b
+ where a :~> b = ruleSpecTerm r
+
+renumberRewriteRule :: Int -> RewriteRule a -> RewriteRule a
+renumberRewriteRule n r = r {ruleSpecTerm = fmap f (ruleSpecTerm r)}
+ where
+   f (TMeta i) = TMeta (i+n)
+   f term      = descend f term
+
+toTermRR :: RewriteRule a -> a -> Term
+toTermRR = build . ruleTermView
+
+fromTermRR :: Monad m => RewriteRule a -> Term -> m a
+fromTermRR = matchM . ruleTermView
+ src/Ideas/Common/Rewriting/Substitution.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Substitutions on terms. Substitutions are idempotent, and non-cyclic.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rewriting.Substitution
+   ( Substitution, emptySubst, singletonSubst, dom, lookupVar
+   , (@@), (|->), listToSubst, composable, (@+@)
+   , tests
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Ideas.Common.Rewriting.Term
+import Ideas.Common.Utils.TestSuite
+import Ideas.Common.Utils.Uniplate
+import Test.QuickCheck
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+
+-----------------------------------------------------------
+--- * Substitution
+
+-- | Abstract data type for substitutions
+newtype Substitution = S { unS :: IM.IntMap Term }
+   deriving Eq
+
+instance Monoid Substitution where
+   mempty  = emptySubst
+   mappend = (@@)
+
+infixr 5 |->
+infixr 6 @@
+
+instance Show Substitution where
+   show = show . unS
+
+-- | Returns the empty substitution
+emptySubst :: Substitution
+emptySubst = S IM.empty
+
+-- | Returns a singleton substitution
+singletonSubst :: Int -> Term -> Substitution
+singletonSubst i a
+   | a == TMeta i        = emptySubst
+   | i `elem` metaVars a = error "Substitution: cyclic"
+   | otherwise           = S (IM.singleton i a)
+
+-- | Turns a list into a substitution
+listToSubst :: [(Int, Term)] -> Substitution
+listToSubst = mconcat . map (uncurry singletonSubst)
+
+-- | Combines two substitutions. The left-hand side substitution is first applied to
+-- the co-domain of the right-hand side substitution
+(@@) :: Substitution -> Substitution -> Substitution
+s1 @@ s2
+   | composable s1 s2 = S $ IM.map (s1 |->) (unS s2) `IM.union` unS s1
+   | otherwise        = error "Substitution: cyclic"
+
+composable :: Substitution -> Substitution -> Bool
+composable s1 s2 =
+   let f = IS.unions . map metaVarSet . IM.elems . unS
+   in IS.null (IS.intersection (f s1) (dom s2))
+
+-- | Lookups a variable in a substitution. Nothing indicates that the variable is
+-- not in the domain of the substitution
+lookupVar :: Int -> Substitution -> Maybe Term
+lookupVar s = IM.lookup s . unS
+
+-- | Returns the domain of a substitution (as a set)
+dom :: Substitution -> IS.IntSet
+dom = IM.keysSet . unS
+
+-- | Apply the substitution
+(|->) :: Substitution -> Term -> Term
+s |-> term =
+   case term of
+      TMeta i -> fromMaybe term (lookupVar i s)
+      _       -> descend (s |->) term
+
+infix 6 @+@
+
+(@+@) :: Substitution -> Substitution -> Maybe Substitution
+s1 @+@ s2 = liftM S $ foldM op (unS s1) $ IM.toList $ unS s2
+ where
+   op m (i, a) =
+      case IM.lookup i m of
+         Just b
+            | a == b    -> Just m
+            | otherwise -> Nothing
+         Nothing        -> Just (IM.insert i a m)
+
+-----------------------------------------------------------
+--- * Test substitution properties
+
+instance Arbitrary Substitution where
+   arbitrary = do
+      n  <- choose (1, 10)
+      ts <- vector n
+      let is = [0..] \\ concatMap metaVars ts
+      return (listToSubst (zip is ts))
+
+tests :: TestSuite
+tests = suite "Substitution" $ do
+   addProperty "left unit" $ \s ->
+      mempty @@ s == s
+   addProperty "right unit" $ \s ->
+      s @@ mempty == s
+   addProperty "associative" $ \s1 s2 s3 ->
+      composable s1 s2 && composable (s1 @@ s2) s3
+      && composable s2 s3 && composable s1 (s2 @@ s3)
+      ==> (s1 @@ s2) @@ s3 == s1 @@ (s2 @@ s3)
+   addProperty "idempotence" $ \s ->
+      s @@ s == s
+   addProperty "idempotence/application" $ \s a ->
+      s |-> a == s |-> (s |-> a)
+   addProperty "composition" $ \s1 s2 a ->
+      composable s1 s2
+      ==> s1 |-> (s2 |-> a) == (s1 @@ s2) |-> a
+ src/Ideas/Common/Rewriting/Term.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS -fno-warn-orphans #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A simple data type for term rewriting
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rewriting.Term
+   ( -- * Symbols
+     Symbol, newSymbol
+   , isAssociative, makeAssociative
+     -- * Terms
+   , Term(..), IsTerm(..), termView
+   , fromTermM, fromTermWith
+     -- * Functions and symbols
+   , WithFunctions(..), isSymbol, isFunction
+   , unary, binary, isUnary, isBinary
+     -- * Variables
+   , WithVars(..), isVariable
+   , vars, varSet, hasVar, withoutVar
+   , hasSomeVar, hasNoVar, variableView
+     -- * Meta variables
+   , WithMetaVars(..), isMetaVar
+   , metaVars, metaVarSet, hasMetaVar, nextMetaVar
+   ) 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 qualified Data.IntSet as IS
+import qualified Data.Set as S
+
+-----------------------------------------------------------
+-- Symbols
+
+data Symbol = S { isAssociative :: Bool, symbolId :: Id }
+
+instance Eq Symbol where
+   (==) = (==) `on` getId -- without associativity property
+
+instance Ord Symbol where
+   compare = compareId    -- without associativity property
+
+instance Show Symbol where
+   show = showId
+
+instance Read Symbol where
+   readsPrec n = map f . readsPrec n
+    where
+      f :: (Id, String) -> (Symbol, String)
+      f (a, s) = (newSymbol a, s)
+
+instance HasId Symbol where
+   getId = symbolId
+   changeId f (S b a) = S b (f a)
+
+newSymbol :: IsId a => a -> Symbol
+newSymbol = S False . newId
+
+makeAssociative :: Symbol -> Symbol
+makeAssociative (S _ a) = S True a
+
+-----------------------------------------------------------
+-- * Data type for terms
+
+data Term = TVar   String
+          | TCon   Symbol [Term]
+          | TList  [Term]
+          | TNum   Integer
+          | TFloat Double
+          | TMeta  Int
+ deriving (Show, Read, Eq, Ord, Typeable)
+
+instance Uniplate Term where
+   uniplate (TCon x xs)   = plate (function x) ||* xs
+   uniplate (TList xs)    = plate TList ||* xs
+   uniplate term          = plate term
+
+-----------------------------------------------------------
+-- * Type class for conversion to/from terms
+
+class IsTerm a where
+   toTerm   :: a -> Term
+   fromTerm :: MonadPlus m => Term -> m a
+
+termView :: IsTerm a => View Term a
+termView = makeView fromTerm toTerm
+
+instance IsTerm Term where
+   toTerm   = id
+   fromTerm = return
+
+instance IsTerm ShowString where
+   toTerm = TVar . fromShowString
+   fromTerm (TVar s) = return (ShowString s)
+   fromTerm _        = fail "fromTerm"
+
+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 _              = 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)
+
+instance IsTerm Int where
+   toTerm = TNum . fromIntegral
+   fromTerm = liftM fromInteger . fromTerm
+
+instance IsTerm Integer where
+   toTerm = TNum
+   fromTerm (TNum a) = return a
+   fromTerm _        = fail "fromTerm"
+
+instance IsTerm Double where
+   toTerm = TFloat
+   fromTerm (TFloat a) = return a
+   fromTerm _          = fail "fromTerm"
+
+instance IsTerm Char where
+   toTerm c = TVar [c]
+   fromTerm (TVar [c]) = return c
+   fromTerm _          = fail "fromTerm"
+
+instance IsTerm a => IsTerm [a] where
+   toTerm = TList . map toTerm
+   fromTerm (TList xs) = mapM fromTerm xs
+   fromTerm _ = fail "fromTerm"
+
+fromTermM :: (Monad m, IsTerm a) => Term -> m a
+fromTermM = maybe (fail "fromTermM") return . fromTerm
+
+fromTermWith :: (Monad m, IsTerm a) => (Symbol -> [a] -> m a) -> Term -> m a
+fromTermWith f a = do
+   (s, xs) <- getFunction a
+   ys      <- mapM fromTermM xs
+   f s ys
+
+-----------------------------------------------------------
+-- * Functions and symbols
+
+class WithFunctions a where
+   -- constructing
+   symbol   :: Symbol -> a
+   function :: Symbol -> [a] -> a
+   -- matching
+   getSymbol   :: Monad m => a -> m Symbol
+   getFunction :: Monad m => a -> m (Symbol, [a])
+   -- default definition
+   symbol s = function s []
+   getSymbol a =
+      case getFunction a of
+         Just (t, []) -> return t
+         _            -> fail "Ideas.Common.Term.getSymbol"
+
+instance WithFunctions Term where
+   function = TCon
+   getFunction (TCon s xs) = return (s, xs)
+   getFunction _           = fail "Ideas.Common.Rewriting.getFunction"
+
+isSymbol :: WithFunctions a => Symbol -> a -> Bool
+isSymbol s = maybe False (==s) . getSymbol
+
+isFunction :: (WithFunctions a, Monad m) => Symbol -> a -> m [a]
+isFunction s a =
+   case getFunction a of
+      Just (t, as) | s == t -> return as
+      _                     -> fail "Ideas.Common.Term.isFunction"
+
+unary :: WithFunctions a => Symbol -> a -> a
+unary s a = function s [a]
+
+binary :: WithFunctions a => Symbol -> a -> a -> a
+binary s a b = function s [a, b]
+
+isUnary :: (WithFunctions a, Monad m) => Symbol -> a -> m a
+isUnary s a =
+   case isFunction s a of
+      Just [x] -> return x
+      _        -> fail "Ideas.Common.Term.isUnary"
+
+isBinary :: (WithFunctions a, Monad m) => Symbol -> a -> m (a, a)
+isBinary s a =
+   case isFunction s a of
+      Just [x, y] -> return (x, y)
+      _           -> fail "Ideas.Common.Term.isBinary"
+
+-----------------------------------------------------------
+-- * Variables
+
+class WithVars a where
+   variable     :: String -> a
+   getVariable  :: Monad m => a -> m String
+
+instance WithVars Term where
+   variable = TVar
+   getVariable (TVar s) = return s
+   getVariable _        = fail "Ideas.Common.Rewriting.getVariable"
+
+isVariable :: WithVars a => a -> Bool
+isVariable = isJust . getVariable
+
+vars :: (Uniplate a, WithVars a) => a -> [String]
+vars = concatMap getVariable . universe
+
+varSet :: (Uniplate a, WithVars a) => a -> S.Set String
+varSet = S.fromList . vars
+
+hasVar :: (Uniplate a, WithVars a) => String -> a -> Bool
+hasVar i = (i `elem`) . vars
+
+withoutVar :: (Uniplate a, WithVars a) => String -> a -> Bool
+withoutVar i = not . hasVar i
+
+hasSomeVar :: (Uniplate a, WithVars a) => a -> Bool
+hasSomeVar = not . hasNoVar
+
+hasNoVar :: (Uniplate a, WithVars a) => a -> Bool
+hasNoVar = null . vars
+
+variableView :: WithVars a => View a String
+variableView = makeView getVariable variable
+
+-----------------------------------------------------------
+-- * Meta variables
+
+class WithMetaVars a where
+   metaVar    :: Int -> a
+   getMetaVar :: Monad m => a -> m Int
+
+instance WithMetaVars Term where
+   metaVar = TMeta
+   getMetaVar (TMeta i) = return i
+   getMetaVar _         = fail "Ideas.Common.Rewriting.getMetaVar"
+
+isMetaVar :: WithMetaVars a => a -> Bool
+isMetaVar = isJust . getMetaVar
+
+metaVars :: (Uniplate a, WithMetaVars a) => a -> [Int]
+metaVars = concatMap getMetaVar . universe
+
+metaVarSet :: (Uniplate a, WithMetaVars a) => a -> IS.IntSet
+metaVarSet = IS.fromList . metaVars
+
+hasMetaVar :: (Uniplate a, WithMetaVars a) => Int -> a -> Bool
+hasMetaVar i = (i `elem`) . metaVars
+
+nextMetaVar :: (Uniplate a, WithMetaVars a) => a -> Int
+nextMetaVar a
+   | null is   = 0
+   | otherwise = maximum is + 1
+ where
+   is = metaVars a
+
+-----------------------------------------------------------
+-- * Arbitrary term generator
+
+instance Arbitrary Term where
+   arbitrary = generators
+      [ constGens $ map TVar ["x", "y", "z"]
+      , arbGen TNum, arbGen TFloat, arbGen TMeta
+      , constGens $ map (symbol . newSymbol) ["a", "b"]
+      , unaryGens $ map (unary . newSymbol) ["h", "k"]
+      , binaryGens $ map (binary . newSymbol) ["f", "g"]
+      ]
+ src/Ideas/Common/Rewriting/Unification.hs view
@@ -0,0 +1,189 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rewriting.Unification
+   ( unify, match, matchExtended, matchList
+   , Match, SymbolMatch
+   , unificationTests
+   ) where
+
+import Control.Monad
+import Data.Maybe
+import Ideas.Common.Rewriting.AC (pairingsMatchA)
+import Ideas.Common.Rewriting.Substitution
+import Ideas.Common.Rewriting.Term
+import Ideas.Common.Utils.TestSuite
+import qualified Data.Map as M
+
+-----------------------------------------------------------
+-- Unification (in both ways)
+
+unify :: Term -> Term -> Maybe Substitution
+unify term1 term2 =
+   case (term1, term2) of
+      (TMeta i, TMeta j) | i == j ->
+         return emptySubst
+      (TMeta i, _) | not (i `hasMetaVar` term2) ->
+         return (singletonSubst i term2)
+      (_, TMeta j) | not (j `hasMetaVar` term1) ->
+         return (singletonSubst j term1)
+      (TCon s xs, TCon t ys) | s == t ->
+         rec xs ys
+      (TList xs, TList ys) ->
+         rec xs ys
+      _ | term1 == term2 ->
+         return emptySubst
+      _ -> Nothing
+ where
+   rec [] [] = return emptySubst
+   rec (x:xs) (y:ys) = do
+      s1 <- unify x y
+      s2 <- rec (map (s1 |->) xs) (map (s1 |->) ys)
+      return (s2 @@ s1)
+   rec _ _ = fail "match: no unifier"
+
+match :: MonadPlus m => Term -> Term -> m Substitution
+match term1 term2 =
+   case (term1, term2) of
+      (TMeta i, TMeta j) | i == j ->
+         return emptySubst
+      (TMeta i, _) | not (i `hasMetaVar` term2) ->
+         return (singletonSubst i term2)
+      (_, TMeta _) ->
+         fail "match: no unifier"
+      (TCon s xs, TCon t ys) | s == t ->
+         rec xs ys
+      (TList xs, TList ys) ->
+         rec xs ys
+      _ | term1 == term2 ->
+         return emptySubst
+      _ -> fail "match: no unifier"
+ where
+   rec [] [] = return emptySubst
+   rec (x:xs) (y:ys) = do
+      s1 <- match x y
+      s2 <- rec (map (s1 |->) xs) ys
+      guard (composable s1 s2)
+      return (s1 @@ s2)
+   rec _ _ = fail "match: no unifier"
+
+-----------------------------------------------------------
+-- Matching (or: one-way unification)
+
+type Match a = a -> a -> [Substitution]
+type SymbolMatch = Match Term -> [Term] -> Term -> [Substitution]
+
+-- If the top-level symbol (of the left-hand side) is an associative binary
+-- operator, extend both sides optionally with a meta-variable.
+matchExtended :: M.Map Symbol SymbolMatch -> Term -> Term -> [(Substitution, Maybe Term, Maybe Term)]
+matchExtended sm x y =
+   [ (sub, lookupVar mvLeft sub, lookupVar mvRight sub)
+   | f   <- extensions
+   , sub <- matchA sm (f x) y
+   ]
+ where
+   mvLeft     = nextMetaVar x
+   mvRight    = mvLeft + 1
+   extensions =
+      case x of
+         TCon s [_, _] | isAssociative s ->
+            let extLeft  = binary s (TMeta mvLeft)
+                extRight = flip (binary s) (TMeta mvRight)
+            in [ f . g | f <- [id, extLeft], g <- [id, extRight] ]
+         _ -> [id]
+
+-- second term should not have meta variables
+matchA :: M.Map Symbol SymbolMatch -> Match Term
+matchA sm = rec
+ where
+   rec (TMeta i) y =
+      return (singletonSubst i y)
+   rec (TList xs) (TList ys) =
+      matchList rec xs ys
+   rec x y =
+      case getFunction x of
+         Just (s, as) ->
+            case M.lookup s sm of
+               Just f -> f rec as y
+               Nothing
+                  | isAssociative s -> associativeMatch s rec as y
+                  | otherwise       -> defaultMatch rec x y
+         _ -> defaultMatch rec x y
+
+defaultMatch :: Match Term -> Match Term
+defaultMatch f x y =
+   case (x, y) of
+      (TCon s xs, TCon t ys) -> do
+         guard (s == t)
+         matchList f xs ys
+      (TList xs, TList ys) ->
+         matchList f xs ys
+      _ -> do
+         guard (x == y)
+         return emptySubst
+
+matchList :: Match Term -> Match [Term]
+matchList f as bs =
+   case safeZipWith f as bs of
+      Just ms -> products ms
+      Nothing -> fail "matchList: lengths differ"
+
+safeZipWith :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
+safeZipWith f = rec
+ where
+   rec []     []     = Just []
+   rec (a:as) (b:bs) = liftM (f a b:) (rec as bs)
+   rec _      _      = Nothing
+
+products :: [[Substitution]] -> [Substitution]
+products = foldr op [emptySubst]
+ where
+   op xs ys = catMaybes [ x @+@ y | x <- xs, y <- ys ]
+
+associativeMatch :: Symbol -> SymbolMatch
+associativeMatch s f as b =
+   pairingsMatchA make (collects as []) (collect b []) >>= products
+ where
+   make :: Term -> [Term] -> [Substitution]
+   make (TMeta i) xs = [singletonSubst i (construct xs)]
+   make x [y]        = f x y
+   make _ _          = []
+
+   collects     = foldr ((.) . collect) id
+   collect term = maybe (term:) collects (isFunction s term)
+
+   construct xs
+      | null xs   = error "associativeMatch: empty list"
+      | otherwise = foldr1 (binary s) xs
+
+-----------------------------------------------------------
+--- * Test unification properties
+
+unificationTests :: TestSuite
+unificationTests = suite "Unification" $ do
+   addProperty "unify" $ \a b ->
+      case unify a b of
+         Just s  -> (s |-> a) == (s |-> b)
+         Nothing -> True
+   addProperty "unify-succeed" $ \a s ->
+      let b = s |-> a in
+      case unify a b of
+         Just s2 -> (s2 |-> a) == (s2 |-> b)
+         Nothing -> False
+   addProperty "match" $ \a b ->
+      case match a b of
+         Just s  -> (s |-> a) == b
+         Nothing -> True
+   addProperty "match-succeed" $ \a s ->
+      let b = s |-> a in
+      case match a (s |-> a) of
+         Just s2 -> (s2 |-> a) == b
+         Nothing -> True
+ src/Ideas/Common/Rule.hs view
@@ -0,0 +1,18 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+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
+ src/Ideas/Common/Rule/Abstract.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE MultiParamTypeClasses #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A rule is just a transformation with some meta-information, such as a name
+-- (which should be unique) and properties such as "buggy" or "minor". Rules
+-- can be lifted with a view using the LiftView type class.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rule.Abstract
+   ( -- * Rule data type and accessors
+     Rule, transformation, recognizer, checkReferences
+     -- * Constructor functions
+   , makeRule, ruleMaybe, ruleList, ruleTrans, ruleRewrite
+   , buggyRule, minorRule, rewriteRule, rewriteRules
+     -- * Special minor rules
+   , idRule, checkRule, emptyRule
+     -- * Rule properties
+   , ruleSiblings, siblingOf
+   , isRewriteRule, isRecognizer, doAfter
+     -- * Recognizer
+   , addRecognizer, addRecognizerBool
+   , addTransRecognizer, addRecognizerEnvMonad
+   ) where
+
+import Control.Arrow
+import Control.Monad
+import Data.Monoid
+import Ideas.Common.Classes
+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
+import Test.QuickCheck
+
+-----------------------------------------------------------
+--- Rule data type and accessors
+
+-- | Abstract data type for representing rules
+data Rule a = Rule
+   { ruleId        :: Id  -- ^ Unique identifier of the rule
+   , getTrans      :: Transformation a
+   , getRecognizer :: Recognizer a
+   , isBuggyRule   :: Bool -- ^ Inspect whether or not the rule is buggy (unsound)
+   , isMinorRule   :: Bool -- ^ Returns whether or not the rule is minor (i.e., an administrative step that is automatically performed by the system)
+   , ruleSiblings  :: [Id]
+   }
+
+instance Show (Rule a) where
+   show = showId
+
+instance Eq (Rule a) where
+   r1 == r2 = ruleId r1 == ruleId r2
+
+instance Ord (Rule a) where
+   compare = compareId
+
+instance Apply Rule where
+   applyAll r = map fst . transApply (transformation r)
+
+instance HasId (Rule a) where
+   getId        = ruleId
+   changeId f r = r { ruleId = f (ruleId r) }
+
+instance LiftView Rule where
+   liftViewIn v r = r
+      { getTrans      = transLiftViewIn v (getTrans r)
+      , getRecognizer = liftViewIn v (getRecognizer r)
+      }
+
+instance Recognizable Rule where
+   recognizer = getRecognizer
+
+instance Buggy (Rule a) where
+   setBuggy b r = r {isBuggyRule = b}
+   isBuggy = isBuggyRule
+
+instance Minor (Rule a) where
+   setMinor b r = r {isMinorRule = b}
+   isMinor = isMinorRule
+
+instance (Arbitrary a, CoArbitrary a) => Arbitrary (Rule a) where
+   arbitrary = liftM3 make arbitrary arbitrary arbitrary
+    where
+      make :: Bool -> Id -> (a -> Maybe a) -> Rule a
+      make b n f = setMinor b $ makeRule n f
+
+instance HasRefs (Rule a) where
+   allRefs r = allRefs (transformation r) ++ allRefs (recognizer r)
+
+transformation :: Rule a -> Transformation a
+transformation = getTrans
+
+checkReferences :: Rule a -> Environment -> Maybe String
+checkReferences r env = do
+   let xs = getRefIds r
+       ys = getRefIds env
+   guard (xs /= ys)
+   return $ show r ++ " has " ++ show xs ++ " but produces " ++ show ys
+
+-----------------------------------------------------------
+--- Constructor functions
+
+makeRule :: (IsId n, MakeTrans f) => n -> (a -> f a) -> Rule a
+makeRule n = ruleTrans n . makeTrans
+
+ruleMaybe :: IsId n => n -> (a -> Maybe a) -> Rule a
+ruleMaybe = makeRule
+
+ruleList :: IsId n => n -> (a -> [a]) -> Rule a
+ruleList = makeRule
+
+ruleTrans :: IsId n => n -> Transformation a -> Rule a
+ruleTrans n f = Rule (newId n) f mempty False False []
+
+ruleRewrite :: RewriteRule a -> Rule a
+ruleRewrite r = ruleTrans (getId r) (transRewrite r)
+
+rewriteRule :: (IsId n, RuleBuilder f a) => n -> f -> Rule a
+rewriteRule n = rewriteRules n . return
+
+rewriteRules :: (IsId n, RuleBuilder f a) => n -> [f] -> Rule a
+rewriteRules n =
+   let a = newId n
+   in ruleTrans a . mconcat . map (transRewrite . makeRewriteRule a)
+
+buggyRule :: (IsId n, MakeTrans f) => n -> (a -> f a) -> Rule a
+buggyRule n = buggy . makeRule n
+
+minorRule :: (IsId n, MakeTrans f) => n -> (a -> f a) -> Rule a
+minorRule n = minor . makeRule n
+
+-----------------------------------------------------------
+--- Special minor rules
+
+-- | A special (minor) rule that is never applicable (i.e., this rule always fails)
+emptyRule :: IsId n => n -> Rule a
+emptyRule n = minor $ ruleTrans n zeroArrow
+
+-- | A special (minor) rule that always returns the identity
+idRule :: IsId n => n -> Rule a
+idRule n = minor $ ruleTrans n identity
+
+-- | A special (minor) rule that checks a predicate (and returns the identity
+-- if the predicate holds)
+checkRule :: IsId n => n -> (a -> Bool) -> Rule a
+checkRule n p = minorRule n $ \a -> [ a | p a ]
+
+-----------------------------------------------------------
+--- Rule properties
+
+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 }
+
+-- | Perform the function after the rule has been fired
+doAfter :: (a -> a) -> Rule a -> Rule a
+doAfter f r = r {getTrans = getTrans r >>^ f }
+
+-----------------------------------------------------------
+--- Recognizer
+
+addRecognizer :: Recognizer a -> Rule a -> Rule a
+addRecognizer a r = r {getRecognizer = a `mappend` getRecognizer r}
+
+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 $
+   let t = first (transformation r) >>> transList (uncurry p)
+       p x y = [ () | eq x y ]
+   in makeRecognizerTrans t
+ src/Ideas/Common/Rule/EnvironmentMonad.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE GADTs #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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.Monad.State
+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 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 = runStateT . rec
+ where
+   rec :: EnvMonad a -> StateT Environment [] a
+   rec monad =
+      case monad of
+         Return a   -> return a
+         Bind m f   -> rec m >>= rec . f
+         Then m n   -> rec m >> rec n
+         Fail s     -> fail s
+         Zero       -> mzero
+         Plus m n   -> rec m `mplus` rec n
+         ref := a   -> modify (insertRef ref a)
+         ref :~ f   -> modify (changeRef ref f)
+         ref :? a   -> gets (fromMaybe a . (ref ?))
+         GetRef ref -> gets (ref ?) >>= maybe (fail "getRef") return
+
+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 []
+ src/Ideas/Common/Rule/Parameter.hs view
@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- This module defines transformations. Given a term, a transformation returns
+-- a list of results (often a singleton list or the empty list). A
+-- transformation can be parameterized with one or more Bindables.
+-- Transformations rules can be lifted to work on more complex domains with
+-- the LiftView type class.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rule.Parameter
+   ( ParamTrans
+   , supplyParameters, supplyContextParameters
+   , parameter1, parameter2, parameter3
+   ) where
+
+import Control.Arrow
+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
+
+type ParamTrans a b = Trans (a, b) b
+
+supplyParameters :: ParamTrans b a -> (a -> Maybe b) -> Transformation a
+supplyParameters f g = transMaybe g &&& identity >>> f
+
+supplyContextParameters :: ParamTrans b a -> (a -> EnvMonad b) -> Transformation (Context a)
+supplyContextParameters f g = transLiftContextIn $
+   transUseEnvironment (transEnvMonad g &&& identity) >>> first f
+
+parameter1 :: (IsId n1, Reference a) => n1 -> (a -> Transformation b) -> ParamTrans a b
+parameter1 n1 f = first (bindValue n1 >>> arr f) >>> app
+
+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
+
+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
+
+bindValue :: (IsId n, Reference a) => n -> Trans a a
+bindValue = transRef . makeRef
+ src/Ideas/Common/Rule/Recognizer.hs view
@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rule.Recognizer
+   ( -- * data type and type class
+     Recognizable(..), Recognizer
+     -- * Constructor functions
+   , makeRecognizer, makeRecognizerEnvMonad, makeRecognizerTrans
+   ) where
+
+import Control.Monad
+import Data.Maybe
+import Data.Monoid
+import Ideas.Common.Environment
+import Ideas.Common.Rule.EnvironmentMonad
+import Ideas.Common.Rule.Transformation
+import Ideas.Common.View
+
+-----------------------------------------------------------
+--- Data type and type class
+
+class Recognizable f where
+   recognizer     :: f a -> Recognizer a
+   recognizeAll   :: f a -> a -> a -> [Environment]
+   recognize      :: f a -> a -> a -> Maybe Environment
+   recognizeTrans :: f a -> Trans (a, a) ()
+   -- default definitions
+   recognizeAll r a b = map snd $ transApply (recognizeTrans r) (a, b)
+   recognize    r a b = listToMaybe $ recognizeAll r a b
+   recognizeTrans     = unR . recognizer
+
+newtype Recognizer a = R { unR :: Trans (a, a) () }
+
+instance LiftView Recognizer where
+   liftViewIn v r =
+      let f = fmap fst . match v
+      in R $ makeTrans f *** makeTrans f >>> unR r
+
+instance Monoid (Recognizer a) where
+   mempty      = R mempty
+   mappend f g = R $ unR f `mappend` unR g
+
+instance Recognizable Recognizer where
+   recognizer = id
+
+instance HasRefs (Recognizer a) where
+   allRefs = allRefs . unR
+
+-----------------------------------------------------------
+--- 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
+
+makeRecognizerTrans :: Trans (a, a) () -> Recognizer a
+makeRecognizerTrans = R
+ src/Ideas/Common/Rule/Transformation.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE GADTs, Rank2Types #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- This module defines transformations. Given a term, a transformation returns
+-- a list of results (often a singleton list or the empty list).
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Rule.Transformation
+   ( -- * Trans data type
+     Transformation, Trans
+     -- * Constructor functions
+   , MakeTrans(..)
+   , transPure, transMaybe, transList, transEnvMonad
+   , transRewrite, transRef
+     -- * Lifting transformations
+   , transUseEnvironment
+   , transLiftView, transLiftViewIn
+   , transLiftContext, transLiftContextIn
+   , makeTransLiftContext, makeTransLiftContext_
+     -- * Using transformations
+   , transApply, transApplyWith
+   , getRewriteRules, isZeroTrans
+   ) where
+
+import Control.Arrow
+import Data.Maybe
+import Data.Monoid
+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 qualified Control.Category as C
+
+-----------------------------------------------------------
+--- Trans data type and instances
+
+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
+
+instance C.Category Trans where
+   id  = arr id
+   (.) = flip (:>>:)
+
+instance Arrow Trans where
+   arr      = transPure
+   (***)    = (:**:)
+   first  f = f :**: identity
+   second f = identity :**: f
+
+instance ArrowZero Trans where
+   zeroArrow = Zero
+
+instance ArrowPlus Trans where
+   (<+>) = Append
+
+instance ArrowChoice Trans where
+   (+++)   = (:++:)
+   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
+
+-----------------------------------------------------------
+--- Constructor functions
+
+-- | A type class for constructing a transformation. If possible, @makeTrans@
+-- should be used. Use specialized constructor functions for disambiguation.
+class MakeTrans f where
+   makeTrans :: (a -> f b) -> Trans a b
+
+instance MakeTrans Maybe where
+   makeTrans = transMaybe
+
+instance MakeTrans [] where
+   makeTrans = transList
+
+instance MakeTrans EnvMonad where
+   makeTrans = transEnvMonad
+
+transPure :: (a -> b) -> Trans a b
+transPure f = transList (return . f)
+
+transMaybe :: (a -> Maybe b) -> Trans a b
+transMaybe f = transList (maybeToList . f)
+
+transList :: (a -> [b]) -> Trans a b
+transList = List
+
+transEnvMonad :: (a -> EnvMonad b) -> Trans a b
+transEnvMonad = EnvMonad
+
+transRewrite :: RewriteRule a -> Trans a a
+transRewrite = Rewrite
+
+transRef :: Typeable a => Ref a -> Trans a a
+transRef = Ref
+
+-----------------------------------------------------------
+--- Lifting transformations
+
+transUseEnvironment :: Trans a b -> Trans (a, Environment) (b, Environment)
+transUseEnvironment = UseEnv
+
+transLiftView :: View a b -> Transformation b -> Transformation a
+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)
+
+transLiftContext :: Transformation a -> Transformation (Context a)
+transLiftContext = transLiftContextIn . transUseEnvironment
+
+transLiftContextIn :: Transformation (a, Environment) -> Transformation (Context a)
+transLiftContextIn = transLiftViewIn (contextView >>> (f <-> g))
+ where
+   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
+
+transApply :: Trans a b -> a -> [(b, Environment)]
+transApply = transApplyWith mempty
+
+transApplyWith :: Environment -> Trans a b -> a -> [(b, Environment)]
+transApplyWith env trans a =
+   case trans of
+      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)
+      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
+ where
+   make :: (b -> c) -> Trans a b -> a -> [(c, Environment)]
+   make f g = map (mapFirst f) . transApplyWith env g
+
+getRewriteRules :: Trans a b -> [Some RewriteRule]
+getRewriteRules trans =
+   case trans of
+      Rewrite r -> [Some r]
+      _         -> descendTrans getRewriteRules trans
+
+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
+
+-- 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
+ src/Ideas/Common/Strategy.hs view
@@ -0,0 +1,54 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A strategy is a context-free grammar with rules as symbols. Strategies can be
+-- labeled with strings. A type class is introduced to lift all the combinators
+-- that work on strategies, only to prevent that you have to insert these lifting
+-- functions yourself.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Strategy
+   ( -- * Data types and type classes
+     Strategy, LabeledStrategy
+   , IsStrategy(..)
+     -- * Running strategies
+   , fullDerivationTree, derivationTree
+     -- * Strategy combinators
+     -- ** Basic combinators
+   , (<*>), (<|>), (<%>), succeed, fail, atomic, label
+   , sequence, alternatives, interleave, permute, fix
+     -- ** EBNF combinators
+   , many, many1, replicate, option
+     -- ** Negation and greedy combinators
+   , check, not, repeat, repeat1, try, (|>), exhaustive
+   , while, until, multi
+     -- ** Traversal combinators
+   , module Ideas.Common.Strategy.Traversal
+     -- * Configuration combinators
+   , module Ideas.Common.Strategy.Configuration
+     -- * Strategy locations
+   , strategyLocations, subStrategy
+   , subTaskLocation, nextTaskLocation
+     -- * Prefixes
+   , Prefix, emptyPrefix, makePrefix, prefixTree, Step(..)
+   , prefixToSteps, stepsToRules, lastStepInPrefix
+     -- * Misc
+   , cleanUpStrategy, cleanUpStrategyAfter
+   , rulesInStrategy
+   ) where
+
+import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.Combinators
+import Ideas.Common.Strategy.Configuration
+import Ideas.Common.Strategy.Location
+import Ideas.Common.Strategy.Parsing
+import Ideas.Common.Strategy.Prefix
+import Ideas.Common.Strategy.Traversal hiding (full, spine, stop, once)
+import Prelude ()
+ src/Ideas/Common/Strategy/Abstract.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Strategy.Abstract
+   ( Strategy, IsStrategy(..)
+   , LabeledStrategy, label, unlabel
+   , fullDerivationTree, derivationTree, rulesInStrategy
+   , mapRules, mapRulesS
+   , cleanUpStrategy, cleanUpStrategyAfter
+     -- Accessors to the underlying representation
+   , toCore, fromCore, liftCore, liftCore2, makeLabeledStrategy
+   , toLabeledStrategy
+   , LabelInfo, processLabelInfo, changeInfo, makeInfo
+   , removed, collapsed, hidden, IsLabeled(..), noInterleaving
+   ) where
+
+import Control.Monad
+import Data.List
+import Ideas.Common.Classes
+import Ideas.Common.DerivationTree
+import Ideas.Common.Environment
+import Ideas.Common.Id
+import Ideas.Common.Rewriting (RewriteRule)
+import Ideas.Common.Rule
+import Ideas.Common.Strategy.Core
+import Ideas.Common.Strategy.Parsing
+import Ideas.Common.Utils.Uniplate hiding (rewriteM)
+import Ideas.Common.View
+import Test.QuickCheck hiding (label)
+
+-----------------------------------------------------------
+--- Strategy data-type
+
+-- | Abstract data type for strategies
+newtype Strategy a = S { toCore :: Core LabelInfo a }
+
+instance Show (Strategy a) where
+   show = show . toCore
+
+instance Apply Strategy where
+   applyAll = runCore . toCore
+
+instance (Arbitrary a, CoArbitrary a) => Arbitrary (Strategy a) where
+   arbitrary = liftM fromCore arbitrary
+
+-----------------------------------------------------------
+--- The information used as label in a strategy
+
+data LabelInfo = Info
+   { labelId   :: Id
+   , removed   :: Bool
+   , collapsed :: Bool
+   , hidden    :: Bool
+   }
+ deriving (Eq, Ord)
+
+instance Show LabelInfo where
+   show info =
+      let ps = ["removed"   | removed   info] ++
+               ["collapsed" | collapsed info] ++
+               ["hidden"    | hidden    info]
+          extra = " (" ++ intercalate ", " ps ++ ")"
+      in showId info ++ if null ps then "" else extra
+
+instance HasId LabelInfo where
+   getId = labelId
+   changeId f info = info { labelId = f (labelId info) }
+
+instance Arbitrary LabelInfo where
+   arbitrary = liftM (makeInfo :: Id -> LabelInfo) arbitrary
+
+makeInfo :: IsId a => a -> LabelInfo
+makeInfo s = Info (newId s) False False False
+
+-----------------------------------------------------------
+--- Type class
+
+-- | Type class to turn values into strategies
+class IsStrategy f where
+   toStrategy :: f a -> Strategy a
+
+instance IsStrategy Strategy where
+   toStrategy = id
+
+instance IsStrategy (LabeledStrategy) where
+  toStrategy (LS info (S core)) = S (Label info core)
+
+instance IsStrategy Rule where
+   toStrategy r
+      | isMajor r = toStrategy (toLabeled r)
+      | otherwise = S (Rule r)
+
+instance IsStrategy RewriteRule where
+   toStrategy = toStrategy . ruleRewrite
+
+-----------------------------------------------------------
+--- Labeled Strategy data-type
+
+-- | A strategy which is labeled with a string
+data LabeledStrategy a = LS
+   { labelInfo :: LabelInfo  -- ^ Returns information associated with this label
+   , unlabel   :: Strategy a -- ^ Removes the label from a strategy
+   }
+
+makeLabeledStrategy :: IsStrategy f => LabelInfo -> f a -> LabeledStrategy a
+makeLabeledStrategy info = LS info . toStrategy
+
+toLabeledStrategy :: Monad m => Strategy a -> m (LabeledStrategy a)
+toLabeledStrategy s =
+   case toCore s of
+      Label l c -> return (makeLabeledStrategy l (fromCore c))
+      _         -> fail "Strategy without label"
+
+instance Show (LabeledStrategy a) where
+   show s = show (labelInfo s) ++ ": " ++ show (unlabel s)
+
+instance Apply LabeledStrategy where
+   applyAll = applyAll . toStrategy
+
+instance HasId (LabeledStrategy a) where
+   getId = getId . labelInfo
+   changeId = changeInfo . changeId
+
+class IsLabeled f where
+   toLabeled :: f a -> LabeledStrategy a
+
+instance IsLabeled LabeledStrategy where
+   toLabeled = id
+
+instance IsLabeled Rule where
+   toLabeled r = LS (makeInfo (getId r)) (S (Rule r))
+
+instance IsLabeled RewriteRule where
+   toLabeled = toLabeled . ruleRewrite
+
+-- | Labels a strategy with a string
+label :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a
+label l = LS (makeInfo l) . toStrategy
+
+changeInfo :: IsLabeled f => (LabelInfo -> LabelInfo) -> f a -> LabeledStrategy a
+changeInfo f a = LS (f info) s
+ where LS info s = toLabeled a
+
+-----------------------------------------------------------
+--- Process Label Information
+
+processLabelInfo :: (l -> LabelInfo) -> Core l a -> Core l a
+processLabelInfo getInfo = rec []
+ where
+   rec env core =
+      case core of
+         Rec n a   -> Rec n (rec ((n, core):env) a)
+         Label l a -> forLabel env l (rec env a)
+         _ -> descend (rec env) core
+
+   forLabel env l c
+      | removed info   = Fail
+      | collapsed info = Label l (Rule asRule) -- !!
+      | otherwise      = new
+    where
+      new | hidden info = fmap minor (Label l c)
+          | otherwise   = Label l c
+      info   = getInfo l
+      asRule = makeRule (getId info) (runCore (subst new))
+      subst  = flip (foldl (flip (uncurry substCoreVar))) env
+
+-----------------------------------------------------------
+--- Remaining functions
+
+-- | Returns the derivation tree for a strategy and a term, including all
+-- minor rules
+fullDerivationTree :: IsStrategy f => Bool -> f a -> a -> DerivationTree (Step LabelInfo a) a
+fullDerivationTree search = make . processLabelInfo id . toCore . toStrategy
+ where
+   make core = fmap value . parseDerivationTree search . makeState core
+
+-- | Returns the derivation tree for a strategy and a term with only major rules
+derivationTree :: IsStrategy f => Bool -> f a -> a -> DerivationTree (Rule a, Environment) a
+derivationTree search s = mergeMaybeSteps . mapFirst f . fullDerivationTree search s
+ where
+   f (RuleStep env r) | isMajor r = Just (r, env)
+   f _ = Nothing
+
+-- | Returns a list of all major rules that are part of a labeled strategy
+rulesInStrategy :: IsStrategy f => f a -> [Rule a]
+rulesInStrategy f = [ r | Rule r <- universe (toCore (toStrategy f)), isMajor r ]
+
+instance LiftView LabeledStrategy where
+   liftViewIn = mapRules . liftViewIn
+
+instance LiftView Strategy where
+   liftViewIn = mapRulesS . liftViewIn
+
+-- | Apply a function to all the rules that make up a labeled strategy
+mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b
+mapRules f (LS n s) = LS n (mapRulesS f s)
+
+mapRulesS :: (Rule a -> Rule b) -> Strategy a -> Strategy b
+mapRulesS f = S . fmap f . toCore
+{-
+mapRulesM :: Monad m => (Rule a -> m (Rule a)) -> Strategy a -> m (Strategy a)
+mapRulesM f = liftM S . T.mapM f . toCore
+-}
+-- | Use a function as do-after hook for all rules in a labeled strategy, but
+-- also use the function beforehand
+cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a
+cleanUpStrategy f (LS n s) = cleanUpStrategyAfter f (LS n (make s))
+ where
+   make = liftCore2 (.*.) (doAfter f (idRule ()))
+
+-- | Use a function as do-after hook for all rules in a labeled strategy
+cleanUpStrategyAfter :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a
+cleanUpStrategyAfter f = mapRules $ \r ->
+   if isMajor r then doAfter f r else r
+
+noInterleaving :: IsStrategy f => f a -> Strategy a
+noInterleaving = liftCore $ transform f
+   where
+      f (a :%:  b) = a :*: b
+      f (a :!%: b) = a :*: b
+      f (Atomic a) = a
+      f s          = s
+
+-----------------------------------------------------------
+--- Functions to lift the core combinators
+
+fromCore :: Core LabelInfo a -> Strategy a
+fromCore = S
+
+liftCore :: IsStrategy f => (Core LabelInfo a -> Core LabelInfo a) -> f a -> Strategy a
+liftCore f = fromCore . f . toCore . toStrategy
+
+liftCore2 :: (IsStrategy f, IsStrategy g) => (Core LabelInfo a -> Core LabelInfo a -> Core LabelInfo a) -> f a -> g a -> Strategy a
+liftCore2 f = liftCore . f . toCore . toStrategy
+ src/Ideas/Common/Strategy/Combinators.hs view
@@ -0,0 +1,141 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A collection of strategy combinators: all lifted to work on different
+-- data types
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Strategy.Combinators where
+
+import Ideas.Common.Id
+import Ideas.Common.Rule
+import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.Configuration
+import Ideas.Common.Strategy.Core
+import Prelude hiding (not, repeat, fail, sequence)
+import qualified Prelude
+
+-----------------------------------------------------------
+--- Strategy combinators
+
+-- Basic combinators --------------------------------------
+
+infixr 2 <%>
+infixr 3 <|>
+infixr 4  |>
+infixr 5 <*>
+
+-- | Put two strategies in sequence (first do this, then do that)
+(<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+(<*>) = liftCore2 (.*.)
+
+-- | Choose between the two strategies (either do this or do that)
+(<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+(<|>) = liftCore2 (.|.)
+
+-- | Interleave two strategies
+(<%>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+(<%>) = liftCore2 (.%.)
+
+-- | The strategy that always succeeds (without doing anything)
+succeed :: Strategy a
+succeed = fromCore Succeed
+
+-- | The strategy that always fails
+fail :: Strategy a
+fail = fromCore Fail
+
+-- | Makes a strategy atomic (w.r.t. parallel composition)
+atomic :: IsStrategy f => f a -> Strategy a
+atomic = liftCore Atomic
+
+-- | Puts a list of strategies into a sequence
+sequence :: IsStrategy f => [f a] -> Strategy a
+sequence = foldr ((<*>) . toStrategy) succeed
+
+-- | Combines a list of alternative strategies
+alternatives :: IsStrategy f => [f a] -> Strategy a
+alternatives = foldr ((<|>) . toStrategy) fail
+
+-- | Merges a list of strategies (in parallel)
+interleave :: IsStrategy f => [f a] -> Strategy a
+interleave = foldr ((<%>) . toStrategy) succeed
+
+-- | Allows all permutations of the list
+permute :: IsStrategy f => [f a] -> Strategy a
+permute = foldr ((<%>) . atomic) succeed
+
+-- EBNF combinators --------------------------------------
+
+-- | Repeat a strategy zero or more times (non-greedy)
+many :: IsStrategy f => f a -> Strategy a
+many = liftCore Many
+
+-- | Apply a certain strategy at least once (non-greedy)
+many1 :: IsStrategy f => f a -> Strategy a
+many1 s = s <*> many s
+
+-- | Apply a strategy a certain number of times
+replicate :: IsStrategy f => Int -> f a -> Strategy a
+replicate n = sequence . Prelude.replicate n
+
+-- | Apply a certain strategy or do nothing (non-greedy)
+option :: IsStrategy f => f a -> Strategy a
+option s = s <|> succeed
+
+-- Negation and greedy combinators ----------------------
+
+-- | Checks whether a predicate holds for the current term. The
+--   check is considered to be a minor step.
+check :: (a -> Bool) -> Strategy a
+check = toStrategy . checkRule "check"
+
+-- | Check whether or not the argument strategy cannot be applied: the result
+--   strategy only succeeds if this is not the case (otherwise it fails).
+not :: IsStrategy f => f a -> Strategy a
+not = liftCore (Not . noLabels)
+
+-- | Repeat a strategy zero or more times (greedy version of 'many')
+repeat :: IsStrategy f => f a -> Strategy a
+repeat = liftCore Repeat
+
+-- | Apply a certain strategy at least once (greedy version of 'many1')
+repeat1 :: IsStrategy f => f a -> Strategy a
+repeat1 s = s <*> repeat s
+
+-- | Apply a certain strategy if this is possible (greedy version of 'option')
+try :: IsStrategy f => f a -> Strategy a
+try s = s |> succeed
+
+-- | Left-biased choice: if the left-operand strategy can be applied, do so. Otherwise,
+--   try the right-operand strategy
+(|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+(|>) = liftCore2 (:|>:)
+
+-- | Repeat the strategy as long as the predicate holds
+while :: IsStrategy f => (a -> Bool) -> f a -> Strategy a
+while p s = repeat (check p <*> s)
+
+-- | Repeat the strategy until the predicate holds
+until :: IsStrategy f => (a -> Bool) -> f a -> Strategy a
+until p = while (Prelude.not . p)
+
+-- | Apply a strategy at least once, but collapse into a single step
+multi :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a
+multi s = collapse . label s . repeat1
+
+-- | Apply the strategies from the list exhaustively (until this is no longer possible)
+exhaustive :: IsStrategy f => [f a] -> Strategy a
+exhaustive = repeat . alternatives
+
+-- | A fix-point combinator on strategies (to model recursion). Powerful
+-- (but dangerous) combinator
+fix :: (Strategy a -> Strategy a) -> Strategy a
+fix f = fromCore (coreFix (toCore . f . fromCore))
+ src/Ideas/Common/Strategy/Configuration.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Strategy.Configuration
+   ( -- Types and constructors
+     StrategyConfiguration, makeStrategyConfiguration
+   , ConfigItem, ConfigLocation, byName, byGroup
+   , ConfigAction(..), configActions
+     --  Configure
+  ,  configure, configureNow
+     -- Combinators
+   , remove, reinsert, collapse, expand, hide, reveal
+   ) where
+
+import Data.Maybe
+import Ideas.Common.Classes
+import Ideas.Common.Id
+import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.Core
+
+---------------------------------------------------------------------
+-- Types and constructors
+
+newtype StrategyConfiguration = SC { configItems :: [ConfigItem] }
+   deriving Show
+
+makeStrategyConfiguration :: [ConfigItem] -> StrategyConfiguration
+makeStrategyConfiguration = SC
+
+type ConfigItem = (ConfigLocation, ConfigAction)
+
+data ConfigLocation
+   = ByName  Id
+   | ByGroup Id
+ deriving Show
+
+data ConfigAction = Remove | Reinsert | Collapse | Expand | Hide | Reveal
+   deriving (Show, Enum)
+
+configActions :: [ConfigAction]
+configActions = [Remove .. ]
+
+byName :: HasId a => a -> ConfigLocation
+byName = ByName . getId
+
+byGroup :: HasId a => a -> ConfigLocation
+byGroup = ByGroup . getId
+
+---------------------------------------------------------------------
+-- Configure
+
+configureNow :: LabeledStrategy a -> LabeledStrategy a
+configureNow =
+   let lsToCore = toCore . toStrategy
+       coreToLS = fromMaybe err . toLabeledStrategy . fromCore
+       err      = error "configureNow: label disappeared"
+   in coreToLS . processLabelInfo id . lsToCore
+
+configure :: StrategyConfiguration -> LabeledStrategy a -> LabeledStrategy a
+configure cfg ls =
+   label (getId ls) (fromCore (configureCore cfg (toCore (unlabel ls))))
+
+configureCore :: StrategyConfiguration -> Core LabelInfo a -> Core LabelInfo a
+configureCore cfg = mapFirst (change [])
+ where
+   change groups info =
+      let actions = getActions info groups cfg
+      in foldr doAction info actions
+
+getActions :: LabelInfo -> [String]
+           -> StrategyConfiguration -> [ConfigAction]
+getActions info groups = map snd . filter (select . fst) . configItems
+ where
+   select (ByName a)  = getId info == a
+   select (ByGroup s) = showId s `elem` groups
+
+doAction :: ConfigAction -> LabelInfo -> LabelInfo
+doAction action =
+   case action of
+      Remove   -> setRemoved True
+      Reinsert -> setRemoved False
+      Collapse -> setCollapsed True
+      Expand   -> setCollapsed False
+      Hide     -> setHidden True
+      Reveal   -> setHidden False
+
+---------------------------------------------------------------------
+-- Configuration combinators
+
+remove, reinsert :: IsLabeled f => f a -> LabeledStrategy a
+remove   = changeInfo (doAction Remove)
+reinsert = changeInfo (doAction Reinsert)
+
+collapse, expand :: IsLabeled f => f a -> LabeledStrategy a
+collapse = changeInfo (doAction Collapse)
+expand   = changeInfo (doAction Expand)
+
+hide, reveal :: IsLabeled f => f a -> LabeledStrategy a
+hide   = changeInfo (doAction Hide)
+reveal = changeInfo (doAction Reveal)
+
+-- helpers
+setRemoved, setCollapsed, setHidden :: Bool -> LabelInfo -> LabelInfo
+setRemoved   b info = info {removed   = b}
+setCollapsed b info = info {collapsed = b}
+setHidden    b info = info {hidden    = b}
+ src/Ideas/Common/Strategy/Core.hs view
@@ -0,0 +1,199 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- The core strategy combinators. This module defines the interal data
+-- structure of a strategy, and some utility functions that operate
+-- directly on it.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Strategy.Core
+   ( GCore(..), Core
+   , (.|.), (.*.), (.%.)
+   , coreMany, coreRepeat, coreOrElse, coreFix
+   , noLabels, substCoreVar
+   ) where
+
+import Control.Applicative
+import Ideas.Common.Classes
+import Ideas.Common.Rule
+import Ideas.Common.Utils.QuickCheck
+import Ideas.Common.Utils.Uniplate
+import qualified Data.Foldable as F
+import qualified Data.Traversable as T
+
+-----------------------------------------------------------------
+-- Strategy (internal) data structure, containing a selection
+-- of combinators
+
+infixr 2 :%:, :!%:, .%.
+infixr 3 :|:, :|>:, .|.
+infixr 5 :*:, .*.
+
+-- | Core expression, with rules
+type Core l a = GCore l (Rule a)
+
+-- | A generalized Core expression, not restricted to rules. This makes GCore
+-- a (traversable and foldable) functor.
+data GCore l a
+   = GCore l a :*:  GCore l a
+   | GCore l a :|:  GCore l a
+   | GCore l a :|>: GCore l a
+   | GCore l a :%:  GCore l a -- interleave
+   | GCore l a :!%: GCore l a -- interleave-first-from-left
+   | Many    (GCore l a)
+   | Repeat  (GCore l a)
+   | Not     (GCore l a)
+   | Label l (GCore l a)
+   | Atomic  (GCore l a)
+   | Succeed
+   | Fail
+   | Rule a -- ^ Generalized constructor (not restricted to rules)
+   | Var Int
+   | Rec Int (GCore l a)
+ deriving Show
+
+-----------------------------------------------------------------
+-- Useful instances
+
+instance Functor (GCore l) where
+   fmap = mapSecond
+
+instance Uniplate (GCore l a) where
+   uniplate core =
+      case core of
+         a :*: b   -> plate (:*:)  |* a |* b
+         a :|: b   -> plate (:|:)  |* a |* b
+         a :|>: b  -> plate (:|>:) |* a |* b
+         a :%: b   -> plate (:%:)  |* a |* b
+         a :!%: b  -> plate (:!%:) |* a |* b
+         Many a    -> plate Many   |* a
+         Repeat a  -> plate Repeat |* a
+         Label l a -> plate Label  |- l |* a
+         Atomic a  -> plate Atomic |* a
+         Rec n a   -> plate Rec    |- n |* a
+         Not a     -> plate Not    |* a
+         _         -> plate core
+
+instance BiFunctor GCore where
+   biMap f g = rec
+    where
+      rec core =
+         case core of
+            a :*: b   -> rec a :*:  rec b
+            a :|: b   -> rec a :|:  rec b
+            a :|>: b  -> rec a :|>: rec b
+            a :%: b   -> rec a :%:  rec b
+            a :!%: b  -> rec a :!%: rec b
+            Many a    -> Many   (rec a)
+            Repeat a  -> Repeat (rec a)
+            Not a     -> Not    (rec a)
+            Atomic a  -> Atomic (rec a)
+            Rec n a   -> Rec n  (rec a)
+            Label l a -> Label (f l) (rec a)
+            Rule a    -> Rule (g a)
+            Var n     -> Var n
+            Succeed   -> Succeed
+            Fail      -> Fail
+
+instance T.Traversable (GCore l) where
+   traverse f core =
+      case core of
+         a :*: b   -> (:*:)   <$> T.traverse f a <*> T.traverse f b
+         a :|: b   -> (:|:)   <$> T.traverse f a <*> T.traverse f b
+         a :|>: b  -> (:|>:)  <$> T.traverse f a <*> T.traverse f b
+         a :%: b   -> (:%:)   <$> T.traverse f a <*> T.traverse f b
+         a :!%: b  -> (:!%:)  <$> T.traverse f a <*> T.traverse f b
+         Many a    -> Many    <$> T.traverse f a
+         Repeat a  -> Repeat  <$> T.traverse f a
+         Label l a -> Label l <$> T.traverse f a
+         Atomic a  -> Atomic  <$> T.traverse f a
+         Rec n a   -> Rec n   <$> T.traverse f a
+         Not a     -> Not     <$> T.traverse f a
+         Rule r    -> Rule    <$> f r
+         Succeed   -> pure Succeed
+         Fail      -> pure Fail
+         Var n     -> pure $ Var n
+
+instance F.Foldable (GCore l) where
+   foldMap = T.foldMapDefault
+
+instance (Arbitrary l, Arbitrary a) => Arbitrary (GCore l a) where
+   arbitrary = generators
+      [ constGens [Succeed, Fail]
+      , unaryGen Atomic, arbGen Rule, unaryArbGen Label
+      , binaryGens [(:*:), (:|:), (:%:)]
+      ]
+
+-----------------------------------------------------------------
+-- Smart constructors
+
+(.|.) :: GCore l a -> GCore l a -> GCore l a
+Fail .|. b    = b
+a    .|. Fail = a
+a    .|. b    = a :|: b
+
+(.*.) :: GCore l a -> GCore l a -> GCore l a
+Fail    .*. _       = Fail
+Succeed .*. b       = b
+_       .*. Fail    = Fail
+a       .*. Succeed = a
+a       .*. b       = a :*: b
+
+(.%.) :: GCore l a -> GCore l a -> GCore l a
+Fail    .%. _       = Fail
+Succeed .%. b       = b
+_       .%. Fail    = Fail
+a       .%. Succeed = a
+a       .%. b       = a :%: b
+
+-----------------------------------------------------------------
+-- Definitions
+
+coreMany :: GCore l a -> GCore l a
+coreMany a = Rec n (Succeed :|: (a :*: Var n))
+ where n = nextVar a
+
+coreRepeat :: GCore l a -> GCore l a
+coreRepeat a = Many a :*: Not a
+
+coreOrElse :: GCore l a -> GCore l a -> GCore l a
+coreOrElse a b = a :|: (Not a :*: b)
+
+coreFix :: (GCore l a -> GCore l a) -> GCore l a
+coreFix f = -- disadvantage: function f is applied twice
+   let i = nextVar (f (Var (-1)))
+   in Rec i (f (Var i))
+
+-----------------------------------------------------------------
+-- Utility functions
+
+substCoreVar :: Int -> GCore l a -> GCore l a -> GCore l a
+substCoreVar i a core =
+   case core of
+      Var j   | i==j -> a
+      Rec j _ | i==j -> core
+      _              -> descend (substCoreVar i a) core
+
+nextVar :: GCore l a -> Int
+nextVar p
+   | null xs   = 0
+   | otherwise = maximum xs + 1
+ where xs = coreVars p
+
+coreVars :: GCore l a -> [Int]
+coreVars core =
+   case core of
+      Var n   -> [n]
+      Rec n a -> n : coreVars a
+      _       -> concatMap coreVars (children core)
+
+noLabels :: GCore l a -> GCore l a
+noLabels (Label _ a) = noLabels a
+noLabels core        = descend noLabels core
+ src/Ideas/Common/Strategy/Location.hs view
@@ -0,0 +1,79 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Locations in a strategy
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Strategy.Location
+   ( subTaskLocation, nextTaskLocation
+   , strategyLocations, subStrategy
+   ) where
+
+import Data.Maybe
+import Ideas.Common.Id
+import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.Core
+import Ideas.Common.Utils.Uniplate
+
+-----------------------------------------------------------
+--- Strategy locations
+
+-- old (current) and actual (next major rule) location
+subTaskLocation :: LabeledStrategy a -> Id -> Id -> Id
+subTaskLocation s xs ys = g (rec (f xs) (f ys))
+ where
+   f = fromMaybe [] . toLoc s
+   g = fromMaybe (getId s) . fromLoc s
+   rec (i:is) (j:js)
+      | i == j    = i : rec is js
+      | otherwise = []
+   rec _ (j:_)    = [j]
+   rec _ _        = []
+
+-- old (current) and actual (next major rule) location
+nextTaskLocation :: LabeledStrategy a -> Id -> Id -> Id
+nextTaskLocation s xs ys = g (rec (f xs) (f ys))
+ where
+   f = fromMaybe [] . toLoc s
+   g = fromMaybe (getId s) . fromLoc s
+   rec (i:is) (j:js)
+      | i == j    = i : rec is js
+      | otherwise = [j]
+   rec _ _        = []
+
+-- | Returns a list of all strategy locations, paired with the labeled
+-- substrategy at that location
+strategyLocations :: LabeledStrategy a -> [([Int], LabeledStrategy a)]
+strategyLocations s = ([], s) : rec [] (toCore (unlabel s))
+ where
+   rec is = concat . zipWith make (map (:is) [0..]) . collect
+
+   make is (l, core) =
+      let ls  = makeLabeledStrategy l (fromCore core)
+      in (is, ls) : rec is core
+
+   collect core =
+      case core of
+         Label l t -> [(l, t)]
+         Not _     -> []
+         _         -> concatMap collect (children core)
+
+-- | Returns the substrategy or rule at a strategy location. Nothing
+-- indicates that the location is invalid
+subStrategy :: Id -> LabeledStrategy a -> Maybe (LabeledStrategy a)
+subStrategy loc =
+   fmap snd . listToMaybe . filter ((==loc) . getId . snd) . strategyLocations
+
+fromLoc :: LabeledStrategy a -> [Int] -> Maybe Id
+fromLoc s loc = fmap getId (lookup loc (strategyLocations s))
+
+toLoc :: LabeledStrategy a -> Id -> Maybe [Int]
+toLoc s i =
+   fmap fst (listToMaybe (filter ((==i) . getId . snd) (strategyLocations s)))
+ src/Ideas/Common/Strategy/Parsing.hs view
@@ -0,0 +1,305 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Basic machinery for executing a core strategy expression.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Strategy.Parsing
+   ( Step(..)
+   , State, makeState, stack, choices, trace, value
+   , parseDerivationTree, replay, runCore
+   , firsts, Result(..), isReady
+   ) where
+
+import Control.Arrow
+import Control.Monad
+import Data.Monoid
+import Ideas.Common.Classes
+import Ideas.Common.DerivationTree
+import Ideas.Common.Environment
+import Ideas.Common.Rule
+import Ideas.Common.Strategy.Core
+import Ideas.Common.Utils.Uniplate
+
+----------------------------------------------------------------------
+-- Step data type
+
+data Step l a = Enter l | Exit l | RuleStep Environment (Rule a)
+   deriving (Show, Eq)
+
+-- A core expression where the symbols are steps instead of "only" rules
+type StepCore l a = GCore l (Step l a)
+
+instance Apply (Step l) where
+   applyAll (RuleStep _ r) = applyAll r
+   applyAll _              = return
+
+instance Minor (Step l a) where
+   setMinor b (RuleStep env r) = RuleStep env (setMinor b r)
+   setMinor _ step = step
+
+   isMinor (RuleStep _ r) = isMinor r
+   isMinor _ = True
+
+----------------------------------------------------------------------
+-- State data type
+
+data State l a = S
+   { stack   :: Stack l a
+   , choices :: [Bool]
+   , trace   :: [Step l a]
+   , timeout :: !Int
+   , value   :: a
+   } deriving Show
+
+data Stack l a = Stack
+   { active    :: [StepCore l a] -- the active items, performed in sequence
+   , suspended :: [StepCore l a] -- suspended items, performed after a step from active
+   , remainder :: [StepCore l a] -- remaining items: must be empty if there are no suspended items
+   } deriving Show
+
+makeState :: Core l a -> a -> State l a
+makeState = newState . fmap (RuleStep mempty)
+
+newState :: StepCore l a -> a -> State l a
+newState core a = push core (S emptyStack [] [] 0 a)
+
+----------------------------------------------------------------------
+-- Parse derivation tree
+
+parseDerivationTree :: Bool -> State l a -> DerivationTree (Step l a) (State l a)
+parseDerivationTree search
+    | search     = mapSecond (changeStack removeRecAnnotations) . tree
+    | otherwise  = tree
+  where
+    tree = makeTree $ \state ->
+      let xs = firsts search state
+      in ( any (isReady . fst) xs , [ (step, s) | (Result step, s) <- xs ] )
+
+    removeRecAnnotations (Stack as ss rs) =
+        Stack (map f as) (map f ss) (map f rs)
+      where
+        f (Rec (-666) Fail) = Succeed
+        f core              = descend f core
+
+firsts :: Bool -> State l a -> [(Result (Step l a), State l a)]
+firsts search st =
+   case pop st of
+      Nothing        -> [(Ready, st)]
+      Just (core, s) -> firstsStep core s
+ where
+   firstsStep core state =
+      case core of
+         a :*: b   -> firstsStep a (push b state)
+         a :|: b   -> chooseFor True a ++ chooseFor False b
+         a :%: b   -> firstsStep (coreInterleave search a b) state
+         a :!%: b  -> firstsStep a (suspend b state)
+         Rec i a   -> incrTimer state >>= firstsStep (substCoreVar i core a)
+         Var _     -> freeCoreVar "firsts"
+         Rule r    -> hasStep r
+         Label l a -> firstsStep (coreLabel l a) state
+         Atomic a  -> firstsStep a (useAtomic state)
+         Not a     -> guard (checkNot a state) >> firsts search state
+         a :|>: b  -> firstsStep (coreOrElse a b) state
+         Many a    -> firstsStep (coreMany a) state
+         Repeat a  -> firstsStep (coreRepeat a) state
+         Fail      -> []
+         Succeed   -> firsts search state
+    where
+      chooseFor b  = flip firstsStep (makeChoice b state)
+      hasStep step = [ (Result (head (trace s)), s) | s <- useRule step state ]
+      -- hasStep step = [ (Result step, s) | s <- useRule step (traceStep step state) ]
+
+-- helper datatype
+data Result a = Result a | Ready deriving  Show
+
+instance Functor Result where
+   fmap f (Result a) = Result (f a)
+   fmap _ Ready      = Ready
+
+isReady :: Result a -> Bool
+isReady Ready = True
+isReady _     = False
+
+----------------------------------------------------------------------
+-- Running the parser
+
+runCore :: Core l a -> a -> [a]
+runCore core = runState . makeState core
+
+runState :: State l a -> [a]
+runState st =
+   case pop st of
+      Nothing        -> [value st]
+      Just (core, s) -> runStep core s
+ where
+   runStep core state =
+      case core of
+         a :*: b   -> runStep a (push b state)
+         a :|: b   -> runStep a state ++ runStep b state
+         a :%: b   -> runStep (coreInterleave False a b) state
+         a :!%: b  -> runStep a (suspend b state)
+         Rec i a   -> incrTimer state >>= runStep (substCoreVar i core a)
+         Var _     -> freeCoreVar "runState"
+         Rule  r   -> concatMap runState (useRule r (interleave r state))
+         Label _ a -> runStep a state
+         Atomic a  -> runStep a (useAtomic state)
+         Not a     -> guard (checkNot a state) >> runState state
+         a :|>: b  -> let xs = runStep a state
+                      in if null xs then runStep b state else xs
+         Many a    -> runStep (coreMany a) state
+         Repeat a  -> runStep (coreRepeat a) state
+         Fail      -> []
+         Succeed   -> runState state
+
+----------------------------------------------------------------------
+-- Replay a parse run
+
+replay :: Monad m => Int -> [Bool] -> Core l a -> m (State l a)
+replay n0 bs0 = replayState n0 bs0 . flip makeState noValue
+ where
+   noValue = error "no value in replay"
+
+   replayState n bs state =
+      case pop state of
+         _ | n==0       -> return state
+         Nothing        -> return state
+         Just (core, s) -> replayStep n bs core s
+
+   replayStep n bs core state =
+      case core of
+         _ | n==0  -> return state
+         a :*: b   -> replayStep n bs a (push b state)
+         a :|: b   -> case bs of
+                        []   -> fail "replay failed"
+                        x:xs -> let new = if x then a else b
+                                in replayStep n xs new (makeChoice x state)
+         a :%: b   -> replayStep n bs (coreInterleave False a b) state
+         a :!%: b  -> replayStep n bs a (suspend b state)
+         Rec i a   -> replayStep n bs (substCoreVar i core a) state
+         Var _     -> freeCoreVar "replay"
+         Rule r    -> replayState (n-1) bs (traceStep r state)
+         Label l a -> replayStep n bs (coreLabel l a) state
+         Atomic a  -> replayStep n bs a (useAtomic state)
+         Not _     -> replayState n bs state
+         a :|>: b  -> replayStep n bs (coreOrElse a b) state
+         Many a    -> replayStep n bs (coreMany a) state
+         Repeat a  -> replayStep n bs (coreRepeat a) state
+         Fail      -> fail "replay failed"
+         Succeed   -> replayState n bs state
+
+----------------------------------------------------------------------
+-- Core translations
+
+coreLabel :: l -> StepCore l a -> StepCore l a
+coreLabel l a = Rule (Enter l) :*: a :*: Rule (Exit l)
+
+coreInterleave :: Bool -> StepCore l a -> StepCore l a -> StepCore l a
+coreInterleave search a b = (a :!%: b) :|: (b :!%: a') :|: emptyOnly (a :*: b)
+  where
+    a' = if search then Rec (-666) Fail :*: a else a
+    emptyOnly core =
+      case core of
+         Rec (-666) Fail :*: y -> emptyOnly y
+         Rule step | interleaveAfter step -> Fail
+         Not _    -> core
+         x :|>: y -> emptyOnly x .|. (Not x :*: emptyOnly y)
+         Repeat x -> emptyOnly (coreRepeat x)
+         x :|: y  -> emptyOnly x .|. emptyOnly y
+         x :*: y  -> emptyOnly x .*. emptyOnly y
+         x :%: y  -> emptyOnly x .*. emptyOnly y -- no more interleaving
+         x :!%: y -> emptyOnly x .*. emptyOnly y -- no more interleaving
+         _        -> descend emptyOnly core
+
+----------------------------------------------------------------------
+-- State functions
+
+push :: StepCore l a -> State l a -> State l a
+push = changeStack . pushStack
+
+suspend :: StepCore l a -> State l a -> State l a
+suspend = changeStack . suspendStack
+
+useAtomic :: State l a -> State l a
+useAtomic = changeStack interleaveStack
+
+pop :: State l a -> Maybe (StepCore l a, State l a)
+pop s = fmap (second f) (popStack (stack s))
+ where f new = s {stack = new}
+
+makeChoice :: Bool -> State l a -> State l a
+makeChoice b s = s {choices = b : choices s}
+
+checkNot :: StepCore l a -> State l a -> Bool
+checkNot core = null . runState . newState core . value
+
+useRule :: Step l a -> State l a -> [State l a]
+useRule step state = map resetTimer $
+   case step of
+      RuleStep _ r -> do
+         (a, env) <- transApply (transformation r) (value state)
+         return $ traceStep (RuleStep env r) state {value = a}
+      _ -> [traceStep step state]
+
+traceStep :: Step l a -> State l a -> State l a
+traceStep step s = interleave step s {trace = step : trace s}
+
+freeCoreVar :: String -> a
+freeCoreVar caller = error $ "Free var in core expression: " ++ caller
+
+incrTimer :: Monad m => State l a -> m (State l a)
+incrTimer s
+   | timeout s >= 20 = fail "timeout after 20 fixpoints"
+   | otherwise       = return (s {timeout = timeout s + 1})
+
+resetTimer :: State l a -> State l a
+resetTimer s = s {timeout = 0}
+
+interleaveAfter :: Step l a -> Bool
+interleaveAfter (RuleStep _ _) = True
+interleaveAfter _              = False
+
+interleave :: Step l a -> State l a -> State l a
+interleave step = if interleaveAfter step then useAtomic else id
+
+changeStack :: (Stack l a -> Stack l a) -> State l a -> State l a
+changeStack f s = s {stack = f (stack s)}
+
+----------------------------------------------------------------------
+-- Stack functions
+
+emptyStack :: Stack l a
+emptyStack = Stack [] [] []
+
+pushStack :: StepCore l a -> Stack l a -> Stack l a
+pushStack core s = s {active = core : active s}
+
+suspendStack :: StepCore l a -> Stack l a -> Stack l a
+suspendStack core s
+   | null (active s) = s {suspended = core : suspended s}
+   | otherwise = emptyStack {suspended = [core], remainder = combineStack s}
+
+popStack :: Stack l a -> Maybe (StepCore l a, Stack l a)
+popStack s =
+   case active s of
+      x:xs -> Just (x, s {active = xs})
+      [] | null (suspended s) -> Nothing
+         | otherwise          -> Just (Fail, s)
+
+interleaveStack :: Stack l a -> Stack l a
+interleaveStack s = emptyStack {active = combineStack s}
+
+combineStack :: Stack l a -> [StepCore l a]
+combineStack s
+   | null (suspended s) = active s
+   | otherwise = front : remainder s
+ where
+   actives = foldr (.*.) Succeed (active s)
+   front   = foldr (.%.) Succeed (actives:suspended s)
+ src/Ideas/Common/Strategy/Prefix.hs view
@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A prefix encodes a sequence of steps already performed (a so-called trace),
+-- and allows to continue the derivation at that particular point.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Strategy.Prefix
+   ( Prefix, emptyPrefix, makePrefix
+   , prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix, activeLabels
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Ideas.Common.DerivationTree
+import Ideas.Common.Rule
+import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.Parsing
+
+-----------------------------------------------------------
+--- Prefixes
+
+-- | Abstract data type for a (labeled) strategy with a prefix (a sequence of
+-- executed rules). A prefix is still "aware" of the labels that appear in the
+-- strategy. A prefix is encoded as a list of integers (and can be reconstructed
+-- from such a list: see @makePrefix@). The list is stored in reversed order.
+data Prefix a = P (State LabelInfo a)
+
+prefixPair :: Prefix a -> (Int, [Bool])
+prefixPair (P s) = (length (trace s), reverse (choices s))
+
+prefixIntList :: Prefix a -> [Int]
+prefixIntList = f . prefixPair
+ where
+   f (0, []) = []
+   f (n, bs) = n : map (\b -> if b then 0 else 1) bs
+
+instance Show (Prefix a) where
+   show = show . prefixIntList
+
+instance Eq (Prefix a) where
+   a == b = prefixPair a == prefixPair b
+
+-- | Construct the empty prefix for a labeled strategy
+emptyPrefix :: LabeledStrategy a -> Prefix a
+emptyPrefix = fromMaybe (error "emptyPrefix") . makePrefix []
+
+-- | Construct a prefix for a given list of integers and a labeled strategy.
+makePrefix :: Monad m => [Int] -> LabeledStrategy a -> m (Prefix a)
+makePrefix []     ls = makePrefix [0] ls
+makePrefix (i:is) ls = liftM P $
+   replay i (map (==0) is) (mkCore ls)
+ where
+   mkCore = processLabelInfo id . toCore . toStrategy
+
+-- | Create a derivation tree with a "prefix" as annotation.
+prefixTree :: Bool -> Prefix a -> a -> DerivationTree (Prefix a) a
+prefixTree search (P s) a = fmap value $ updateAnnotations (\_ _ -> P) $
+   parseDerivationTree search s {value = a}
+
+prefixToSteps :: Prefix a -> [Step LabelInfo a]
+prefixToSteps (P t) = reverse (trace t)
+
+-- | Retrieves the rules from a list of steps
+stepsToRules :: [Step l a] -> [Rule a]
+stepsToRules xs = [ r | RuleStep _ r <- xs ]
+
+-- | Returns the last rule of a prefix (if such a rule exists)
+lastStepInPrefix :: Prefix a -> Maybe (Step LabelInfo a)
+lastStepInPrefix (P t) = listToMaybe (trace t)
+
+-- | Calculate the active labels
+activeLabels :: Prefix a -> [LabelInfo]
+activeLabels p = nub [l | Enter l <- steps] \\ [l | Exit l <- steps]
+   where
+      steps = prefixToSteps p
+ src/Ideas/Common/Strategy/Tests.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Testing strategy combinator properties
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Strategy.Tests (tests) where
+
+import Data.Function
+import Data.List
+import Data.Ord
+import Ideas.Common.Algebra.Group
+import Ideas.Common.Algebra.GroupLaws
+import Ideas.Common.Algebra.Law
+import Ideas.Common.Classes
+import Ideas.Common.Strategy
+import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.Parsing
+import Ideas.Common.Utils.QuickCheck hiding (label, Result)
+import Ideas.Common.Utils.TestSuite
+import Prelude hiding (fail)
+import qualified Ideas.Common.Algebra.Field as F
+import qualified Ideas.Common.Algebra.FieldLaws as F
+
+---------------------------------------------------------
+-- Properties
+
+tests :: TestSuite
+tests = suite "Strategy combinator properties" $ do
+   -- monoids and semi-rings
+   fs (commutative : idempotent : monoidLaws :: [Law Choice])
+   fs (monoidZeroLaws :: [Law Sequence])
+   fs (commutative : monoidZeroLaws :: [Law Interleave])
+   fs (F.distributiveLaws :: [Law Sequence])
+   fs (F.distributiveLaws :: [Law Interleave])
+
+   -- properties of atomic
+   addProperty "atomic-twice" $ \a ->
+      atomic (atomic a) === atomic (idS a)
+   assertTrue  "atomic-succeed" $
+      atomic succeed === succeed
+   assertTrue  "atomic-fail" $
+      atomic fail === fail
+   addProperty "atomic-choice" $ \a b ->
+      atomic (idS a <|> idS b) === atomic a <|> atomic b
+
+   -- splits theorm parallel/atomic
+   addProperty "atomic-split"  $ \x y a b ->
+      (atomic x <*> a) <%> (atomic y <*> b)
+      ===
+      (idS x <*> (a <%> (atomic y <*> b)))
+        <|>
+      (idS y <*> ((atomic x <*> idS a) <%> idS b))
+ where
+   fs :: (Arbitrary a, Show a, Eq a) => [Law a] -> TestSuite
+   fs = mapM_ (\p -> addProperty (show p) p)
+
+---------------------------------------------------------
+-- Algebraic instances
+
+newtype Choice     = Choice     (Strategy Int) deriving (Show, Arbitrary)
+newtype Sequence   = Sequence   (Strategy Int) deriving (Show, Arbitrary)
+newtype Interleave = Interleave (Strategy Int) deriving (Show, Arbitrary)
+
+instance Eq Choice     where     Choice a == Choice b     = a === b
+instance Eq Sequence   where   Sequence a == Sequence b   = a === b
+instance Eq Interleave where Interleave a == Interleave b = a === b
+
+instance Monoid Choice where
+   mempty = Choice fail
+   mappend (Choice a) (Choice b) = Choice (a <|> b)
+
+instance Monoid Sequence where
+   mempty = Sequence succeed
+   mappend (Sequence a) (Sequence b) = Sequence (a <*> b)
+
+instance MonoidZero Sequence where
+   mzero = Sequence fail
+
+instance Monoid Interleave where
+   mempty = Interleave succeed
+   mappend (Interleave a) (Interleave b) = Interleave (a <%> b)
+
+instance MonoidZero Interleave where
+   mzero = Interleave fail
+
+instance F.SemiRing Sequence where
+   Sequence a <+> Sequence b = Sequence (a <|> b)
+   zero  = Sequence fail
+   (<*>) = mappend
+   one   = mempty
+
+instance F.SemiRing Interleave where
+   Interleave a <+> Interleave b = Interleave (a <|> b)
+   zero  = Interleave fail
+   (<*>) = mappend
+   one   = mempty
+
+---------------------------------------------------------
+-- Helper functions for equality
+
+idS :: Strategy Int -> Strategy Int
+idS = id
+
+infix 1 ===
+
+(===) :: Strategy Int -> Strategy Int -> Bool
+s1 === s2 = rec 100 [(start s1, start s2)]
+ where
+   start = return . flip makeState 0 . toCore
+
+   rec :: Int -> [([State LabelInfo Int], [State LabelInfo Int])] -> Bool
+   rec _ [] = True
+   rec n (pair:rest)
+      | n == 0    = True
+      | otherwise = testReady xs ys
+                 && testValue xs ys
+                 && testFirsts gxs gys
+                 && rec (n-1) (rest ++ new)
+
+    where
+      p@(xs, ys)    = mapBoth (concatMap myFirsts) pair
+      gp@(gxs, gys) = mapBoth f p
+      new           = uncurry zip (mapBoth (map snd) gp)
+
+      testReady  = (==) `on` any (isReady . fst)
+      testValue  = (==) `on` (nub . sort . map (value . snd))
+      testFirsts = (==) `on` map fst
+
+      f          = map merge . groupBy eqFst . sortBy cmpFst . results
+      merge   as = (fst (head as), map snd as)
+      results as = [ (a, b) | (Result a, b) <- as ]
+
+      cmpFst = comparing (show . fst)
+      eqFst  = (==) `on` fst
+
+myFirsts :: State l a -> [(Result (Step l a), State l a)]
+myFirsts = concatMap f . firsts False
+ where
+   f pair@(result, a) =
+      case result of
+         Result (Enter _) -> myFirsts a
+         Result (Exit _)  -> myFirsts a
+         _                -> [pair]
+
+{-
+debug :: Show a => Strategy a -> a -> IO ()
+debug s = rec . makeState (toCore s)
+ where
+   rec st = do
+      print st
+      putStrLn $ "\nReady: " ++ show (any (isReady . fst) xs)
+      putStrLn $ unlines $
+         zipWith (\i y -> show i ++ ". " ++ show (fst y)) [1::Int ..] ys
+      if (null xs) then print "(no choices)" else do
+      n <- ask
+      rec (snd (ys !! n))
+    where
+      xs = firsts st
+      ys = [ (a, b) | (Result a, b) <- xs ]
+
+      ask = do
+         putStr "? "
+         input <- getLine
+         case readInt input of
+            Just n | n > 0 && n <= length ys ->
+               return (n-1)
+            _ -> if input == "q" then error "QUIT" else ask -}
+ src/Ideas/Common/Strategy/Traversal.hs view
@@ -0,0 +1,172 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Strategy.Traversal
+   ( layer, traverse, Option
+     -- * Options
+   , topdown, bottomup, leftToRight, rightToLeft
+   , full, spine, stop, once, traversalFilter, parentFilter
+     -- * One-pass traversals
+   , fulltd, fullbu, oncetd, oncebu, somewhere
+     -- * Fixpoint traversals
+   , innermost, outermost
+   ) where
+
+import Data.Monoid
+import Ideas.Common.Rule
+import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.Combinators
+import Ideas.Common.Traversal.Navigator
+import Prelude hiding (repeat, not)
+
+----------------------------------------------------------------------
+-- One-layer combinators
+
+data Visit = VisitFirst | VisitOne | VisitSome | VisitAll | VisitMany
+
+visit :: (IsStrategy f, IsStrategy g) => Visit -> f a -> g a -> Strategy a
+visit v next s = fix $ \a ->
+   case v of
+      VisitFirst -> s  |> next <*> a
+      VisitOne   -> s <|> next <*> a
+      VisitSome  -> s <*> try (next <*> visit VisitMany next s) <|> next <*> a
+      VisitAll   -> s <*> (not next |> (next <*> a))
+      VisitMany  -> try s <*> (not next |> (next <*> a))
+
+----------------------------------------------------------------------
+-- Parameterized traversals
+
+layer :: (IsStrategy f, Navigator a) => [Option a] -> f a -> Strategy a
+layer = layerWith . fromOptions
+
+layerWith :: (IsStrategy f, Navigator a) => Info a -> f a -> Strategy a
+layerWith tr s =
+   goDown <*> findOk <*> visit (getVisit tr) (next <*> findOk) s <*> try ruleUp
+ where
+   (next, goDown)
+      | getReversed tr = (ruleLeft, ruleDownLast)
+      | otherwise      = (ruleRight, ruleDown)
+
+   findOk =
+      case getFilters tr of
+         [] -> succeed
+         ps -> fix $ \a -> check (\x -> all ($ x) ps) |> (next <*> a)
+
+traverse :: (IsStrategy f, Navigator a) => [Option a] -> f a -> Strategy a
+traverse = traverseWith . fromOptions
+
+traverseWith :: (IsStrategy f, Navigator a) => Info a -> f a -> Strategy a
+traverseWith tr s =
+   fix $ \a ->
+   case getCombinator tr of
+      Sequence
+         | getTopDown tr -> s <*> (descend a <|> check isLeaf)
+         | otherwise     -> (descend a <|> check isLeaf) <*> s
+      OrElse
+         | getTopDown tr -> s |> descend a
+         | otherwise     -> descend a |> s
+      Choice             -> s <|> descend a
+ where
+   descend = layerWith tr
+
+-----------------------------------------------------------------------
+
+data Combinator = Sequence | OrElse | Choice
+
+data Info a = Info
+   { getVisit      :: Visit
+   , getCombinator :: Combinator
+   , getFilters    :: [a -> Bool]
+   , getTopDown    :: Bool
+   , getReversed   :: Bool
+   }
+
+newtype Option a = O { unO :: Info a -> Info a }
+
+instance Monoid (Option a) where
+   mempty            = O id
+   O f `mappend` O g = O (f . g)
+
+fromOptions :: [Option a] -> Info a
+fromOptions xs = unO (mconcat xs) (Info VisitOne Choice [] True False)
+
+topdown, bottomup :: Option a
+topdown  = O $ \t -> t {getTopDown = True}
+bottomup = O $ \t -> t {getTopDown = False}
+
+leftToRight, rightToLeft :: Option a
+leftToRight = O $ \t -> t {getReversed = False}
+rightToLeft = O $ \t -> t {getReversed = True}
+
+full, spine, stop, once :: Option a
+full  = setCombinator Sequence `mappend` setVisit VisitAll
+spine = setCombinator Sequence `mappend` setVisit VisitOne
+stop  = setCombinator OrElse   `mappend` setVisit VisitAll
+once  = setCombinator OrElse   `mappend` setVisit VisitOne
+
+setVisit :: Visit -> Option a
+setVisit v = O $ \t -> t {getVisit = v}
+
+setCombinator :: Combinator -> Option a
+setCombinator c = O $ \t -> t {getCombinator = c}
+
+traversalFilter :: (a -> Bool) -> Option a
+traversalFilter ok = O $ \t -> t {getFilters = ok:getFilters t}
+
+parentFilter :: Navigator a => (a -> [Int]) -> Option a
+parentFilter p = O $ \t -> t {getFilters = ok:getFilters t}
+ where
+   ok a = maybe True (\x -> childnr a `elem` p x) (up a)
+
+----------------------------------------------------------------------
+-- One-pass traverses
+
+fulltd :: (IsStrategy f, Navigator a) => f a -> Strategy a
+fulltd = traverse [full, topdown]
+
+fullbu :: (IsStrategy f, Navigator a) => f a -> Strategy a
+fullbu = traverse [full, bottomup]
+
+oncetd :: (IsStrategy f, Navigator a) => f a -> Strategy a
+oncetd = traverse [once, topdown]
+
+oncebu :: (IsStrategy f, Navigator a) => f a -> Strategy a
+oncebu = traverse [once, bottomup]
+
+somewhere :: (IsStrategy f, Navigator a) => f a -> Strategy a
+somewhere = traverse []
+
+----------------------------------------------------------------------
+-- fixpoint traverses
+
+innermost :: (IsStrategy f, Navigator a) => f a -> Strategy a
+innermost = repeat . oncebu
+
+outermost :: (IsStrategy f, Navigator a) => f a -> Strategy a
+outermost = repeat . oncetd
+
+----------------------------------------------------------------------
+-- Navigator rules
+
+ruleUp :: Navigator a => Rule a
+ruleUp = minorRule "navigator.up" up
+
+ruleDown :: Navigator a => Rule a
+ruleDown = minorRule "navigator.down" down
+
+ruleDownLast :: Navigator a => Rule a
+ruleDownLast = minorRule "navigator.downlast" downLast
+
+ruleLeft :: Navigator a => Rule a
+ruleLeft = minorRule "navigator.left" left
+
+ruleRight :: Navigator a => Rule a
+ruleRight = minorRule "navigator.right" right
+ src/Ideas/Common/Traversal/Iterator.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Traversal.Iterator
+   ( -- * Iterator type class
+     Iterator(..), isFirst, isFinal, hasNext, hasPrevious
+   , searchForward, searchBackward, searchNext, searchPrevious, searchWith
+     -- * List iterator
+   , ListIterator
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Ideas.Common.Traversal.Utils
+import Test.QuickCheck
+
+---------------------------------------------------------------
+-- Iterator type class
+
+class Iterator a where
+   next     :: a -> Maybe a
+   previous :: a -> Maybe a
+   first    :: a -> a
+   final    :: a -> a
+   position :: a -> Int
+   -- default implementations
+   first    = fixp previous
+   final    = fixp next
+   position = pred . length . fixpl previous
+
+instance Iterator a => Iterator (Mirror a) where
+   next     = liftWrapper previous
+   previous = liftWrapper next
+   first    = mapWrapper  final
+   final    = mapWrapper  first
+
+isFirst :: Iterator a => a -> Bool
+isFirst = not . hasPrevious
+
+isFinal :: Iterator a => a -> Bool
+isFinal = not . hasNext
+
+hasNext :: Iterator a => a -> Bool
+hasNext = isJust . next
+
+hasPrevious :: Iterator a => a -> Bool
+hasPrevious = isJust . previous
+
+searchForward :: Iterator a => (a -> Bool) -> a -> Maybe a
+searchForward = searchWith next
+
+searchBackward :: Iterator a => (a -> Bool) -> a -> Maybe a
+searchBackward = searchWith previous
+
+searchNext :: Iterator a => (a -> Bool) -> a -> Maybe a
+searchNext p = next >=> searchForward p
+
+searchPrevious :: Iterator a => (a -> Bool) -> a -> Maybe a
+searchPrevious p = previous >=> searchBackward p
+
+searchWith :: (a -> Maybe a) -> (a -> Bool) -> a -> Maybe a
+searchWith f p = rec
+ where
+   rec a | p a       = Just a
+         | otherwise = f a >>= rec
+
+---------------------------------------------------------------
+-- List iterator
+
+data ListIterator a = LI [a] a [a]
+   deriving Eq
+
+instance Show a => Show (ListIterator a) where
+   show (LI xs y ys) =
+      let listLike   = brackets . intercalate ","
+          brackets s = "[" ++ s ++ "]"
+          focusOn  s = "<<" ++ s ++ ">>"
+      in listLike (map show (reverse xs) ++ focusOn (show y) : map show ys)
+
+instance Iterator (ListIterator a) where
+   previous (LI (x:xs) y ys) = Just (LI xs x (y:ys))
+   previous _                = Nothing
+
+   next     (LI xs x (y:ys)) = Just (LI (x:xs) y ys)
+   next     _                = Nothing
+
+   position (LI xs _ _) = length xs
+
+instance Focus (ListIterator a) where
+   type Unfocus (ListIterator a) = [a]
+
+   focusM []     = Nothing
+   focusM (x:xs) = Just (LI [] x xs)
+
+   unfocus (LI xs y ys) = reverse xs ++ y : ys
+
+instance Update ListIterator where
+   update (LI xs a ys) = (a, \b -> LI xs b ys)
+
+instance Arbitrary a => Arbitrary (ListIterator a) where
+   arbitrary = liftM3 LI arbitrary arbitrary arbitrary
+ src/Ideas/Common/Traversal/Navigator.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Traversal.Navigator
+   ( -- * Location information
+     Location, toLocation, fromLocation
+     -- * Navigator type class
+   , Navigator(..)
+   , isTop, isLeaf
+   , hasLeft, hasRight, hasUp, hasDown
+   , top, leftMost, rightMost, leftMostLeaf, rightMostLeaf
+   , depth, level, levelNext, levelPrevious, leftMostAt, rightMostAt
+   , downs, downTo, arity, navigateTo, navigateTowards
+     -- * Tree walks
+   , PreOrder, makePreOrder
+   , PostOrder, makePostOrder
+   , LevelOrder, makeLevelOrder
+   , Horizontal, makeHorizontal
+   , Leafs, makeLeafs
+     -- * Uniplate navigator
+   , UniplateNavigator
+   ) where
+
+import Control.Monad
+import Data.Function
+import Data.Generics.Str
+import Data.Maybe
+import Ideas.Common.Algebra.Group
+import Ideas.Common.Traversal.Iterator
+import Ideas.Common.Traversal.Utils
+import Ideas.Common.Utils.Uniplate
+import Test.QuickCheck hiding (Str)
+
+---------------------------------------------------------------
+-- Navigator type class
+
+newtype Location = L { fromLocation :: [Int] }
+ deriving (Eq, Ord)
+
+instance Show Location where
+   show = show . fromLocation
+
+instance Monoid Location where
+   mempty = L []
+   L xs `mappend` L ys = L (xs ++ ys)
+
+toLocation :: [Int] -> Location
+toLocation = L
+
+-- | For a minimal complete definition, provide an implemention for downs or
+-- allDowns. All other functions need an implementation as well, except for
+-- change. Note that a constructor (a -> f a) is not included in the type class
+-- to allow additional type class constraints on type a.
+class Navigator a where
+   up       :: a -> Maybe a
+   down     :: a -> Maybe a
+   downLast :: a -> Maybe a
+   left     :: a -> Maybe a
+   right    :: a -> Maybe a
+   childnr  :: a -> Int
+   location :: a -> Location
+   -- default definitions
+   downLast = liftM (fixp right) . down
+   childnr  = pred . length . fixpl left
+   location = toLocation . map childnr . drop 1 . reverse . fixpl up
+
+instance Navigator a => Navigator (Mirror a) where
+   up       = liftWrapper up
+   down     = liftWrapper downLast
+   downLast = liftWrapper down
+   left     = liftWrapper right
+   right    = liftWrapper left
+
+isTop, isLeaf :: Navigator a => a -> Bool
+isTop  = not . hasUp
+isLeaf = not . hasDown
+
+hasLeft, hasRight, hasUp, hasDown :: Navigator a => a -> Bool
+hasLeft  = isJust . left
+hasRight = isJust . right
+hasUp    = isJust . up
+hasDown  = isJust . down
+
+top, leftMost, rightMost :: Navigator a => a -> a
+top       = fixp up
+leftMost  = fixp left
+rightMost = fixp right
+
+leftMostLeaf, rightMostLeaf :: Navigator a => a -> a
+leftMostLeaf  = fixp down
+rightMostLeaf = fixp downLast
+
+downs :: Navigator a => a -> [a]
+downs = maybe [] (fixpl right) . down
+
+downTo :: Navigator a => Int -> a -> Maybe a
+downTo n
+   | n < 0     = const Nothing
+   | otherwise = listToMaybe . drop n . downs
+
+arity :: Navigator a => a -> Int
+arity = length . downs
+
+depth :: Navigator a => a -> Int
+depth a | null xs   = 0
+        | otherwise = maximum (map depth xs) + 1
+ where
+   xs = downs a
+
+level :: Navigator a => a -> Int
+level = pred . length . fixpl up
+
+levelNext :: Navigator a => a -> Maybe a
+levelNext = right >|< f 1
+ where
+   f n = up >=> (g n >|< f (n+1))
+   g n = right >=> (leftMostAt n >|< g n)
+
+levelPrevious :: Navigator a => a -> Maybe a
+levelPrevious = fmap unwrap . levelNext . makeMirror
+
+leftMostAt :: Navigator a => Int -> a -> Maybe a
+leftMostAt n
+   | n == 0    = Just
+   | n <  0    = const Nothing
+   | otherwise = (down >=> leftMostAt (n-1)) >|< (right >=> leftMostAt n)
+
+rightMostAt :: Navigator a => Int -> a -> Maybe a
+rightMostAt n = fmap unwrap . leftMostAt n . makeMirror
+
+navigateTo :: Navigator a => Location -> a -> Maybe a
+navigateTo is a = go (navigation (location a) is) a
+ where
+   go = foldr (>=>) Just
+
+navigateTowards :: Navigator a => Location -> a -> a
+navigateTowards is a = go (navigation (location a) is) a
+ where
+   go = foldr (\f g -> safe (fmap g . f)) id
+
+navigation :: Navigator a => Location -> Location -> [a -> Maybe a]
+navigation old new = replicate upnr up ++ map downTo ds
+ where
+   os   = fromLocation old
+   ns   = fromLocation new
+   same = length (takeWhile id (zipWith (==) os ns))
+   upnr = length os - same
+   ds   = drop same ns
+
+----------------------------------------------------------------
+-- Tree walks
+
+newtype PreOrder a = Pre { fromPre :: a }
+   deriving (Show, Eq)
+
+makePreOrder :: a -> PreOrder a
+makePreOrder = wrap
+
+instance Wrapper PreOrder where
+   wrap   = Pre
+   unwrap = fromPre
+
+instance Update PreOrder where
+   update a = (unwrap a, wrap)
+
+instance Navigator a => Iterator (PreOrder a) where
+   previous = liftWrapper ((liftM rightMostLeaf . left) >|< up)
+   next     = let rec = right >|< (up >=> rec)
+              in liftWrapper (down >|< rec)
+   first    = mapWrapper top
+   final    = mapWrapper (rightMostLeaf . top)
+
+newtype PostOrder a = Post { fromPost :: Mirror (PreOrder (Mirror a))}
+   deriving (Show, Eq, Iterator)
+
+instance Wrapper PostOrder where
+   wrap   = Post . wrap . wrap . wrap
+   unwrap = unwrap . unwrap . unwrap . fromPost
+
+instance Update PostOrder where
+   update a = (unwrap a, wrap)
+
+makePostOrder :: a -> PostOrder a
+makePostOrder = wrap
+
+newtype LevelOrder a = Level { fromLevel :: a } -- breadth-first
+   deriving (Show, Eq)
+
+instance Wrapper LevelOrder where
+   wrap   = Level
+   unwrap = fromLevel
+
+instance Update LevelOrder where
+   update a = (unwrap a, wrap)
+
+instance Navigator a => Iterator (LevelOrder a) where
+   previous = let f a = rightMostAt (level a-1) (top a)
+              in liftWrapper (levelPrevious >|< f)
+   next     = let f a = leftMostAt (level a+1) (top a)
+              in liftWrapper (levelNext >|< f)
+   first    = mapWrapper top
+   final    = mapWrapper $ \a -> safe (rightMostAt (depth (top a))) (top a)
+
+makeLevelOrder :: a -> LevelOrder a
+makeLevelOrder = wrap
+
+newtype Horizontal a = Hor { fromHor :: a }
+   deriving (Show, Eq)
+
+instance Wrapper Horizontal where
+   wrap   = Hor
+   unwrap = fromHor
+
+instance Update Horizontal where
+   update a = (unwrap a, wrap)
+
+instance Navigator a => Iterator (Horizontal a) where
+   previous = liftWrapper left
+   next     = liftWrapper right
+   first    = mapWrapper leftMost
+   final    = mapWrapper rightMost
+   position = childnr . unwrap
+
+makeHorizontal :: a -> Horizontal a
+makeHorizontal = wrap
+
+newtype Leafs a = Leafs { fromLeafs :: a }
+   deriving (Show, Eq)
+
+makeLeafs :: Navigator a => a -> Leafs a
+makeLeafs = first . wrap
+
+instance Wrapper Leafs where
+   wrap   = Leafs
+   unwrap = fromLeafs
+
+instance Update Leafs where
+   update a = (unwrap a, wrap)
+
+instance Navigator a => Iterator (Leafs a) where
+   previous = liftWrapper $
+      let rec = left >|< (up >=> rec)
+      in liftM rightMostLeaf . rec
+   next = liftWrapper $
+      let rec = right >|< (up >=> rec)
+      in liftM leftMostLeaf . rec
+   first = mapWrapper (leftMostLeaf . top)
+   final = mapWrapper (rightMostLeaf . top)
+
+---------------------------------------------------------------
+-- Str navigator (private)
+
+data StrNavigator a = SN
+   { currentStr :: Str a
+   , strContext :: [Either (Str a) (Str a)]
+   }
+
+instance Navigator (StrNavigator a) where
+   up (SN a (x:xs)) = Just (SN (either (flip Two) Two x a) xs)
+   up _ = Nothing
+   down (SN (Two a b) xs) = Just (SN a (Left b:xs))
+   down _ = Nothing
+   downLast (SN (Two a b) xs) = Just (SN b (Right a:xs))
+   downLast _ = Nothing
+   left (SN a (Right b:xs)) = Just (SN b (Left a:xs))
+   left _ = Nothing
+   right (SN a (Left b:xs)) = Just (SN b (Right a:xs))
+   right _ = Nothing
+   childnr  = maybe 0 (either (const 0) (const 1)) . listToMaybe . strContext
+
+instance Focus (StrNavigator a) where
+   type Unfocus (StrNavigator a) = Str a
+   focus   = flip SN []
+   unfocus = currentStr . top
+
+sizeStrNavigator :: StrNavigator a -> Int
+sizeStrNavigator (SN a xs) =
+   sum (countStr a : map (either countStr countStr) xs)
+
+countStr :: Str a -> Int
+countStr Zero      = 0
+countStr (One _)   = 1
+countStr (Two a b) = countStr a + countStr b
+
+---------------------------------------------------------------
+-- Str iterator (private)
+
+data StrIterator a = SI
+   { posSI  :: !Int
+   , fromSI :: Leafs (StrNavigator a)
+   }
+
+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
+   first    (SI _ a) = SI 0 $ safe (searchForward ok) (first a)
+   final    (SI _ a) = finalSI $ safe (searchBackward ok) (final a)
+   position          = posSI
+
+instance Focus (StrIterator a) where
+   type Unfocus (StrIterator a) = Str a
+   focusM  = firstStrIterator
+   unfocus = unfocus . unwrap . fromSI
+
+instance Update StrIterator where
+   update (SI n (Leafs a)) =
+      case currentStr a of
+         One b -> (b, \c -> SI n $ wrap $ a {currentStr = One c})
+         _     -> error "unsafe update"
+
+firstStrIterator :: Str a -> Maybe (StrIterator a)
+firstStrIterator = fmap (SI 0) . searchForward ok . first . wrap . focus
+
+lastStrIterator :: Str a -> Maybe (StrIterator a)
+lastStrIterator = fmap finalSI . searchBackward ok . final . wrap . focus
+
+finalSI :: Leafs (StrNavigator a) -> StrIterator a
+finalSI a = SI (sizeStrNavigator (unwrap a) - 1) a
+
+ok :: Wrapper f => f (StrNavigator a) -> Bool
+ok = isOne . currentStr . unwrap
+ where
+   isOne (One _) = True
+   isOne _       = False
+
+---------------------------------------------------------------
+-- Uniplate navigator
+
+data UniplateNavigator a = U [StrIterator a -> StrIterator a] (StrIterator a)
+
+instance (Show a, Uniplate a) => Show (UniplateNavigator a) where
+   show a = show (current a) ++ " @ " ++ show (location a)
+
+instance (Eq a, Uniplate a) => Eq (UniplateNavigator a) where
+   (==) = on (==) $ \a -> (current a, unfocus a, location a)
+
+instance Uniplate a => Navigator (UniplateNavigator a) where
+   up (U [] _)     = Nothing
+   up (U (f:fs) a) = Just (U fs (f a))
+
+   down     = downWith focusM
+   downLast = downWith lastStrIterator
+
+   left  (U fs a) = liftM (U fs) (previous a)
+   right (U fs a) = liftM (U fs) (next a)
+
+   childnr (U _ a) = position a
+
+instance Update UniplateNavigator where
+   update (U xs a) = (current a, U xs . flip replace a)
+
+instance Uniplate a => Focus (UniplateNavigator a) where
+   type Unfocus (UniplateNavigator a) = a
+   focus   = U [] . focus . One
+   unfocus = current . top
+
+instance (Arbitrary a, Uniplate a) => Arbitrary (UniplateNavigator a) where
+   arbitrary = liftM focus arbitrary >>= genNav
+    where
+      genNav a =
+         case map genNav (downs a) of
+            [] -> return a
+            xs -> frequency [(1, return a), (4, oneof xs)]
+
+downWith :: Uniplate a => (Str a -> Maybe (StrIterator a))
+                       -> UniplateNavigator a -> Maybe (UniplateNavigator a)
+downWith make (U fs a) = liftM (U (f:fs)) (make cs)
+ where
+   (cs, g) = uniplate (current a)
+   f = (`replace` a) . g . unfocus
+ src/Ideas/Common/Traversal/Tests.hs view
@@ -0,0 +1,154 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Traversal.Tests
+   ( testIterator, testNavigator, tests
+   , uniGen, listGen
+   ) where
+
+import Control.Monad
+import Data.Maybe
+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 Test.QuickCheck
+
+testIterator :: (Show a, Eq a, Iterator a) => String -> Gen a -> TestSuite
+testIterator s gen = suite (s ++ " Iterator") $ do
+
+   suite "previous/next" $ do
+      prop gen "previous; next" $  hasPrevious ==>>  previous >=> next ==! id
+      prop gen "next; previous" $  hasNext     ==>>  next >=> previous ==! id
+
+   suite "next/final" $ do
+      prop gen "isFinal"       $  isFinal . final
+      prop gen "next to final" $  fixp next === final
+
+   suite "previous/first" $ do
+      prop gen "isFirst"           $  isFirst . first
+      prop gen "previous to first" $  fixp previous === first
+
+   suite "position" $ do
+      prop gen "pos previous" $
+         hasPrevious ==>> fmap position . previous ==! pred . position
+      prop gen "pos next" $
+         hasNext ==>> fmap position . next ==! succ . position
+      prop gen "pos first" $
+         (==0) . position . first
+      prop gen "pos final" $
+         position . final === position . fixp next
+
+testNavigator :: (Show a, Eq a, Navigator a) => String -> Gen a -> TestSuite
+testNavigator s gen = suite (s ++ " Navigator") $ do
+
+   suite "up/down" $ do
+      prop gen "down; up"     $  hasDown ==>>      down >=> up ==! id
+      prop gen "up; down"     $  hasUp   ==>>      up >=> down ==! leftMost
+      prop gen "up; downLast" $  hasUp   ==>>  up >=> downLast ==! rightMost
+
+   suite "left/right" $ do
+      prop gen "right; left" $  hasRight ==>>  right >=> left ==! id
+      prop gen "left; right" $  hasLeft  ==>>  left >=> right ==! id
+
+   suite "up/left+right" $ do
+      prop gen "left; up"  $  hasLeft  ==>>   left >=> up === up
+      prop gen "right; up" $  hasRight ==>>  right >=> up === up
+
+   suite "down/downLast" $ do
+      prop gen "down; rightMost"       $  liftM rightMost . down === downLast
+      prop gen "downLast; leftMost"    $  liftM leftMost . downLast === down
+      prop gen "down is leftMost"      $  isNothing . (down >=> left)
+      prop gen "downLast is rightMost" $  isNothing . (downLast >=> right)
+
+   suite "location" $ do
+      prop gen "loc up" $ hasUp    ==>>
+         fmap locationList . up ==! init . locationList
+      prop gen "loc down" $ hasDown  ==>>
+         fmap locationList . down ==! (++[0]) . locationList
+      prop gen "loc downLast" $ hasDown  ==>>
+         fmap locationList . downLast ==! (\a -> locationList a ++ [arity a-1])
+      prop gen "loc left" $ hasLeft  ==>>
+         fmap locationList . left ==! changeLast pred . locationList
+      prop gen "loc right" $ hasRight ==>>
+         fmap locationList . right ==! changeLast succ . locationList
+      prop gen "childnr" $
+         childnr === fromMaybe 0 . listToMaybe . reverse . locationList
+
+locationList :: Navigator a => a -> [Int]
+locationList = fromLocation . location
+
+-------------------------------------------------------------------------
+-- tests
+
+tests :: TestSuite
+tests = do
+
+   suite "Iterators" $ do
+      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
+
+   suite "Navigators" $ do
+      testNavigator "Uniplate" uniGen
+      testNavigator "Mirror" $ liftM makeMirror uniGen
+
+_go :: IO ()
+_go = runTestSuiteResult tests >>= print
+
+-------------------------------------------------------------------------
+-- test utils
+
+infixr 0 ===, ==!
+
+(===) :: Eq b => (a -> b) -> (a -> b) -> a -> Bool
+(f === g) a = f a == g a
+
+(==!) :: Eq b => (a -> Maybe b) -> (a -> b) -> a -> Bool
+f ==! g = f === Just . g
+
+infixr 0 ==>>
+
+(==>>) :: Testable prop => (a -> Bool) -> (a -> prop) -> a -> Property
+(p ==>> f) a = p a ==> f a
+
+prop :: (Testable prop, Show a) => Gen a -> String -> (a -> prop) -> TestSuite
+prop gen s = addProperty s . forAll gen
+
+changeLast :: (a -> a) -> [a] -> [a]
+changeLast _ []     = []
+changeLast f [x]    = [f x]
+changeLast f (x:xs) = x:changeLast f xs
+
+data T a = T a [T a] deriving (Show, Eq)
+
+instance Uniplate (T a) where
+   uniplate (T a xs) = plate (T a) ||* xs
+
+instance Arbitrary a => Arbitrary (T a) where
+   arbitrary = sized genT
+    where
+      genT n = do
+         a  <- arbitrary
+         i  <- if n==0 then return 0 else choose (0, 5)
+         xs <- vectorOf i (genT (n `div` 2))
+         return (T a xs)
+
+listGen :: Gen (ListIterator Int)
+listGen = arbitrary
+
+uniGen :: Gen (UniplateNavigator (T Int))
+uniGen = arbitrary
+ src/Ideas/Common/Traversal/Utils.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Traversal.Utils
+   ( -- * Update type class
+     Update(..), current, change, replace, changeM, changeG
+     -- * Focus type class
+   , Focus(..), liftFocus, unliftFocus
+     -- * Wrapper type class
+   , Wrapper(..), liftWrapper, unliftWrapper, mapWrapper
+     -- * Mirror
+   , Mirror, makeMirror
+     -- * Utility functions
+   , (>|<), safe, fixp, fixpl, mplus, (>=>)
+   ) where
+
+import Control.Monad
+import Data.Maybe
+
+---------------------------------------------------------------
+-- Update type class
+
+class Update f where
+   update  :: f a -> (a, a -> f a)
+
+current :: Update f => f a -> a
+current  = fst . update
+
+change  :: Update f => (a -> a) -> f a -> f a
+change f = (\(x, g) -> g (f x)) . update
+
+replace :: Update f => a -> f a -> f a
+replace  = change . const
+
+changeM :: Update f => (a -> Maybe a) -> f a -> Maybe (f a)
+changeM = changeG
+
+changeG :: (Update f, Monad g) => (a -> g a) -> f a -> g (f a)
+changeG f a = liftM (`replace` a) (f (current a))
+
+---------------------------------------------------------------
+-- Focus type class
+
+class Focus a where
+   type Unfocus a
+   focus   :: Unfocus a -> a
+   focusM  :: Unfocus a -> Maybe a
+   unfocus :: a -> Unfocus a
+   -- default definitions
+   focus  = fromMaybe (error "no focus") . focusM
+   focusM = Just . focus
+
+liftFocus :: Focus a => (Unfocus a -> Maybe (Unfocus a)) -> a -> Maybe a
+liftFocus f = liftM focus . f . unfocus
+
+unliftFocus :: Focus a => (a -> Maybe a) -> Unfocus a -> Maybe (Unfocus a)
+unliftFocus f = liftM unfocus . f . focus
+
+---------------------------------------------------------------
+-- Wrapper type class
+
+class Wrapper f where
+   wrap   :: a -> f a
+   unwrap :: f a -> a
+
+liftWrapper :: (Monad m, Wrapper f) => (a -> m a) -> f a -> m (f a)
+liftWrapper f = liftM wrap . f . unwrap
+
+unliftWrapper :: (Monad m, Wrapper f) => (f a -> m (f a)) -> a -> m a
+unliftWrapper f = liftM unwrap . f . wrap
+
+mapWrapper :: Wrapper f => (a -> a) -> f a -> f a
+mapWrapper f = wrap . f . unwrap
+
+---------------------------------------------------------------
+-- Mirror
+
+newtype Mirror a = Mirror { fromMirror :: a }
+   deriving (Show, Eq)
+
+instance Wrapper Mirror where
+   wrap   = Mirror
+   unwrap = fromMirror
+
+makeMirror :: a -> Mirror a
+makeMirror = wrap
+
+---------------------------------------------------------------
+-- Utility functions
+
+infixr 0 >|<
+
+(>|<) :: (a -> Maybe a) -> (a -> Maybe a) -> a -> Maybe a
+(f >|< g) a = f a `mplus` g a
+
+safe :: (a -> Maybe a) -> a -> a
+safe f a = fromMaybe a (f a)
+
+fixp :: (a -> Maybe a) -> a -> a
+fixp f = last . fixpl f
+
+fixpl :: (a -> Maybe a) -> a -> [a]
+fixpl f a = a : maybe [] (fixpl f) (f a)
+ src/Ideas/Common/Utils.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ExistentialQuantification #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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
+   , useFixedStdGen, timedSeconds
+   , fst3, snd3, thd3
+   , headM, findIndexM
+   , elementAt, changeAt, replaceAt
+   , list
+   ) where
+
+import Data.Char
+import Data.List
+import System.Random
+import System.Timeout
+
+data Some f = forall a . Some (f a)
+
+data ShowString = ShowString { fromShowString :: String }
+   deriving (Eq, Ord)
+
+instance Show ShowString where
+   show = fromShowString
+
+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 = stop . iterate f
+ where
+   stop []           = error "Ideas.Common.Utils: empty list"
+   stop (x:xs)
+      | x == head xs = x
+      | otherwise    = stop 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]
+
+-- | Use a fixed standard "random" number generator. This generator is
+-- accessible by calling System.Random.getStdGen
+useFixedStdGen :: IO ()
+useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -}
+
+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
+ src/Ideas/Common/Utils/QuickCheck.hs view
@@ -0,0 +1,102 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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.Monoid
+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)
+ src/Ideas/Common/Utils/StringRef.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE DeriveDataTypeable #-}
+
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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]
+
+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
+ src/Ideas/Common/Utils/TestSuite.hs view
@@ -0,0 +1,300 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A lightweight wrapper around the QuickCheck library. 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 test suite has a monadic
+-- interface.
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.Utils.TestSuite
+   ( -- * Test Suite Monad
+     TestSuite, MonadIO(..)
+     -- * Test suite constructors
+   , suite, addProperty, addPropertyWith, warn
+   , assertTrue, assertNull, assertEquals, assertIO
+     -- * Running a test suite
+   , runTestSuite, runTestSuiteResult
+     -- * Test Suite Result
+   , TestSuiteResult, subResults, findSubResult
+   , messages, topMessages, numberOfTests
+   , makeSummary, printSummary
+     -- * Messages
+   , Message, newMessage
+   , isError, warning, messageLabel
+   ) where
+
+import Control.Exception
+import Control.Monad.State
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.Time
+import Prelude hiding (catch)
+import System.IO
+import Test.QuickCheck
+import qualified Data.Foldable as F
+import qualified Data.Sequence as S
+
+----------------------------------------------------------------
+-- Test Suite Monad
+
+newtype TestSuiteM a = TSM { unTSM :: StateT Content IO a }
+
+data Content = C
+   { column :: !Int -- Number of characters on the current line, for formatting
+   , result :: !TestSuiteResult
+   }
+
+type TestSuite = TestSuiteM ()
+
+instance Monad TestSuiteM where
+   return  = TSM . return
+   m >>= f = TSM (unTSM m >>= unTSM . f)
+   fail s  = do assertTrue s False
+                return (error "TestSuite.fail: do not bind result")
+
+instance MonadIO TestSuiteM where
+   liftIO =  TSM . liftIO
+
+instance Monoid a => Monoid (TestSuiteM a) where
+   mempty  = return mempty
+   mappend = (>>)
+
+----------------------------------------------------------------
+-- Test suite constructors
+
+-- | Construct a (named) test suite containing tests and other suites
+suite :: String -> TestSuite -> TestSuite
+suite s m = TSM $ do
+   newline
+   liftIO $ putStrLn s
+   reset
+   t <- updateDiffTime (withEmptyTree (unTSM m))
+   addResult (suiteResult s t)
+
+-- | Add a QuickCheck property to the test suite. The first argument is
+-- a label for the property
+addProperty :: Testable prop => String -> prop -> TestSuite
+addProperty = flip addPropertyWith stdArgs
+
+-- | Add a QuickCheck property to the test suite, also providing a test
+-- configuration (Args)
+addPropertyWith :: Testable prop => String -> Args -> prop -> TestSuite
+addPropertyWith s args p = TSM $ do
+   newlineIndent
+   r <- liftIO $ quickCheckWithResult args p
+   reset
+   let f = addResult . messageResult . setLabel s
+   maybe (addResult okResult) f (toTestResult r)
+
+assertTrue :: String -> Bool -> TestSuite
+assertTrue msg = assertIO msg . return
+
+assertNull :: Show a => String -> [a] -> TestSuite
+assertNull s xs = addAssertion (f xs) (return (null xs))
+ where f = setLabel s . newMessage . intercalate "\n" . map show
+
+assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite
+assertEquals s x y = addAssertion (setLabel s msg) (return (x==y))
+ where msg = newMessage ("Not equal: " ++ show x ++ " and " ++ show y)
+
+assertIO :: String -> IO Bool -> TestSuite
+assertIO s = addAssertion (setLabel s $ newMessage "Assertion failed")
+
+warn :: String -> TestSuite
+warn = (`addAssertion` return False) . warning . newMessage
+
+-- local helpers
+addAssertion :: Message -> IO Bool -> TestSuite
+addAssertion msg io = TSM $ do
+   b <- liftIO (io `catch` handler)
+   if b then do
+      dot
+      addResult okResult
+    else do
+      newlineIndent
+      liftIO (print msg)
+      reset
+      addResult (messageResult msg)
+ where
+   handler :: SomeException -> IO Bool
+   handler _ = return False
+
+withEmptyTree :: StateT Content IO () -> StateT Content IO TestSuiteResult
+withEmptyTree m = do
+   t0 <- gets result
+   modify $ \c -> c {result = mempty}
+   m
+   tr <- gets result
+   modify $ \c -> c {result = t0}
+   return tr
+
+-- formatting helpers
+newline :: StateT Content IO ()
+newline = do
+   i <- gets column
+   when (i>0) (liftIO $ putChar '\n')
+   reset
+
+newlineIndent :: StateT Content IO ()
+newlineIndent = do
+   newline
+   liftIO $ putStr "   "
+   modify $ \c -> c {column = 3}
+
+dot :: StateT Content IO ()
+dot = do
+   i <- gets column
+   unless (i>0 && i<60) newlineIndent
+   liftIO $ putChar '.'
+   modify $ \c -> c {column = column c+1}
+
+addResult :: TestSuiteResult -> StateT Content IO ()
+addResult r = modify $ \c -> c {result = result c `mappend` r}
+
+reset :: StateT Content IO ()
+reset = modify $ \c -> c {column = 0}
+
+----------------------------------------------------------------
+-- Running a test suite
+
+runTestSuite :: TestSuite -> IO ()
+runTestSuite = void . runTestSuiteResult
+
+runTestSuiteResult :: TestSuite -> IO TestSuiteResult
+runTestSuiteResult s = do
+   hSetBuffering stdout NoBuffering
+   updateDiffTime $ liftM result $
+      execStateT (unTSM s >> newline) (C 0 mempty)
+
+----------------------------------------------------------------
+-- Test Suite Result
+
+data TestSuiteResult = TSR
+   { messageSeq     :: S.Seq Message
+   , suiteSeq       :: S.Seq (String, TestSuiteResult)
+   , numberOfTests  :: !Int
+   , diffTime       :: !NominalDiffTime
+   }
+
+instance Monoid TestSuiteResult where
+   mempty = TSR mempty mempty 0 0
+   mappend x y = TSR
+      { messageSeq    = messageSeq x `mappend` messageSeq y
+      , suiteSeq      = suiteSeq x `mappend` suiteSeq y
+      , numberOfTests = numberOfTests x + numberOfTests y
+      , diffTime      = diffTime x + diffTime y
+      }
+
+okResult :: TestSuiteResult
+okResult = mempty {numberOfTests = 1}
+
+messageResult :: Message -> TestSuiteResult
+messageResult m = okResult {messageSeq = S.singleton m}
+
+suiteResult :: String -> TestSuiteResult -> TestSuiteResult
+suiteResult s a = mempty
+   { suiteSeq = S.singleton (s, a)
+   , numberOfTests = numberOfTests a
+   }
+
+-- one-line summary
+instance Show TestSuiteResult where
+   show res =
+      let (xs, ys) = partition isError (messages res)
+      in "(tests: " ++ show (numberOfTests res) ++
+         ", errors: " ++ show (length xs) ++
+         ", warnings: " ++ show (length ys) ++
+         ", " ++ show (diffTime res) ++ ")"
+
+subResults :: TestSuiteResult -> [(String, TestSuiteResult)]
+subResults = F.toList . suiteSeq
+
+topMessages :: TestSuiteResult -> [Message]
+topMessages = F.toList . messageSeq
+
+messages :: TestSuiteResult -> [Message]
+messages res =
+   topMessages res ++ concatMap (messages . snd) (subResults res)
+
+data Message = Message
+   { message      :: String
+   , isError      :: Bool
+   , messageLabel :: Maybe String
+   }
+
+instance Show Message where
+   show a = (if null pre then "" else pre ++ ": ") ++ message a
+    where
+       parens s = "(" ++ s ++ ")"
+       pre = unwords $
+                [ "Warning" | not (isError a) ] ++
+                maybe [] (return . parens) (messageLabel a)
+
+newMessage :: String -> Message
+newMessage s = Message s True Nothing
+
+warning :: Message -> Message
+warning m = m {isError = False}
+
+setLabel :: String -> Message -> Message
+setLabel s m = m {messageLabel = Just s}
+
+findSubResult :: String -> TestSuiteResult -> Maybe TestSuiteResult
+findSubResult name = listToMaybe . recs
+ where
+   recs = concatMap rec . subResults
+   rec (n, t)
+      | n == name = [t]
+      | otherwise = recs t
+
+printSummary :: TestSuiteResult -> IO ()
+printSummary = putStrLn . makeSummary
+
+makeSummary :: TestSuiteResult -> String
+makeSummary res = unlines $
+   [ line
+   , "Tests    : " ++ show (numberOfTests res)
+   , "Failures : " ++ show (length xs)
+   , "Warnings : " ++ show (length ys)
+   , "\nTime     : " ++ show (diffTime res)
+   , "\nSuites: "
+   ] ++ map f (subResults res)
+     ++ [line]
+ where
+   line        = replicate 75 '-'
+   (xs, ys)    = partition isError (messages res)
+   f (name, r) = "   " ++ name ++ "   " ++ show r
+
+-----------------------------------------------------
+-- Utility functions
+
+toTestResult :: Result -> Maybe Message
+toTestResult res =
+   let make = Just . newMessage
+   in case res of
+         Success {}             -> Nothing
+         Failure {reason = msg} -> make msg
+         NoExpectedFailure {}   -> make "no expected failure"
+         GaveUp {numTests = i}  -> fmap warning $ make $
+                                   "passed only " ++ show i ++ " tests"
+
+updateDiffTime :: MonadIO m => m TestSuiteResult -> m TestSuiteResult
+updateDiffTime m = do
+   (res, d) <- getDiffTime m
+   return res {diffTime = d}
+
+getDiffTime :: MonadIO m => m a -> m (a, NominalDiffTime)
+getDiffTime action = do
+   t0 <- liftIO getCurrentTime
+   a  <- action
+   t1 <- liftIO getCurrentTime
+   return (a, diffUTCTime t1 t0)
+ src/Ideas/Common/Utils/Uniplate.hs view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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
+ src/Ideas/Common/View.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- This module defines views on data-types, as described in "Canonical Forms
+-- in Interactive Exercise Assistants"
+--
+-----------------------------------------------------------------------------
+module Ideas.Common.View
+   ( Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..)
+   , Control.Arrow.ArrowZero(..), Control.Arrow.ArrowPlus(..)
+   , (>>>), (<<<)
+     -- * @IsMatch@ type class
+   , IsMatcher(..), matchM, belongsTo, viewEquivalent, viewEquivalentWith
+   , Matcher, makeMatcher
+     -- * @IsView@ type class
+   , IsView(..), simplify, simplifyWith, simplifyWithM
+   , canonical, canonicalWith, canonicalWithM, isCanonical, isCanonicalWith
+     -- * Views
+   , View, identity, makeView, matcherView
+     -- * Isomorphisms
+   , Isomorphism, from, to, inverse
+     -- * Lifting with views
+   , LiftView(..)
+     -- * Some combinators
+   , swapView, listView, traverseView, ($<)
+     -- * Packaging a view
+   , ViewPackage(..)
+     -- * Properties on views
+   , propIdempotence, propSoundness, propNormalForm
+   ) where
+
+import Control.Arrow
+import Control.Monad
+import Data.Maybe
+import Ideas.Common.Classes
+import Ideas.Common.Id
+import Test.QuickCheck
+import qualified Control.Category as C
+import qualified Data.Traversable as T
+
+----------------------------------------------------------------------------------
+-- @IsMatch@ type class
+
+class IsMatcher f where
+   match   :: f a b -> a -> Maybe b
+   matcher :: f a b -> Matcher a b
+   -- default definitions
+   match   = runKleisli . unM . matcher
+   matcher = makeMatcher . match
+
+-- |generalized monadic variant of @match@
+matchM :: (Monad m, IsMatcher f) => f a b -> a -> m b
+matchM v = maybe (fail "no match") return . match v
+
+belongsTo :: IsMatcher f => a -> f a b -> Bool
+belongsTo a view = isJust (match view a)
+
+viewEquivalent :: (IsMatcher f, Eq b) => f a b -> a -> a -> Bool
+viewEquivalent = viewEquivalentWith (==)
+
+viewEquivalentWith :: IsMatcher f => (b -> b -> Bool) -> f a b -> a -> a -> Bool
+viewEquivalentWith eq view x y =
+   case (match view x, match view y) of
+      (Just a, Just b) -> a `eq` b
+      _                -> False
+
+newtype Matcher a b = M { unM :: Kleisli Maybe a b }
+   deriving (C.Category, Arrow, ArrowZero, ArrowPlus, ArrowChoice)
+
+instance IsMatcher Matcher where
+   matcher = id
+
+makeMatcher :: (a -> Maybe b) -> Matcher a b
+makeMatcher = M . Kleisli
+
+----------------------------------------------------------------------------------
+-- @IsView@ type class
+
+-- |Minimal complete definition: @toView@ or both @match@ and @build@.
+class IsMatcher f => IsView f where
+   build  :: f a b -> b -> a
+   toView :: f a b -> View a b
+   -- default definitions
+   build  f = build (toView f)
+   toView f = makeView (match f) (build f)
+
+canonical :: IsView f => f a b -> a -> Maybe a
+canonical = canonicalWith id
+
+canonicalWith :: IsView f => (b -> b) -> f a b -> a -> Maybe a
+canonicalWith f = canonicalWithM (return . f)
+
+canonicalWithM :: IsView f => (b -> Maybe b) -> f a b -> a -> Maybe a
+canonicalWithM f view a =
+   match view a >>= liftM (build view) . f
+
+isCanonical :: (IsView f, Eq a) => f a b -> a -> Bool
+isCanonical = isCanonicalWith (==)
+
+isCanonicalWith :: IsView f => (a -> a -> Bool) -> f a b -> a -> Bool
+isCanonicalWith eq v a = maybe False (eq a) (canonical v a)
+
+simplify :: IsView f => f a b -> a -> a
+simplify = simplifyWith id
+
+simplifyWith :: IsView f => (b -> b) -> f a b -> a -> a
+simplifyWith f = simplifyWithM (Just . f)
+
+simplifyWithM :: IsView f => (b -> Maybe b) -> f a b -> a -> a
+simplifyWithM f view a = fromMaybe a (canonicalWithM f view a)
+
+----------------------------------------------------------------------------------
+-- Views
+
+data View a b where
+   Prim     :: Matcher a b -> (b -> a) -> View a b
+   (:@)     :: Id -> View a b -> View a b
+   (:>>>:)  :: View a b -> View b c -> View a c
+   (:***:)  :: View a c -> View b d -> View (a, b) (c, d)
+   (:+++:)  :: View a c -> View b d -> View (Either a b) (Either c d)
+   Traverse :: T.Traversable f => View a b -> View (f a) (f b)
+
+instance C.Category View where
+   id    = makeView return id
+   v . w = w :>>>: v
+
+instance Arrow View where
+   arr     = (!->)
+   first   = (*** identity)
+   second  = (identity ***)
+   (***)   = (:***:)
+   f &&& g = copy >>> (f *** g)
+
+instance BiArrow View where
+   (<->) f = makeView (return . f)
+
+instance ArrowChoice View where
+   left    = (+++ identity)
+   right   = (identity +++)
+   (+++)   = (:+++:)
+   f ||| g = (f +++ g) >>> merge
+
+instance IsMatcher View where
+   matcher view =
+      case view of
+         Prim m _   -> m
+         _ :@ v     -> matcher v
+         v :>>>: w  -> matcher v >>> matcher w
+         v :***: w  -> matcher v *** matcher w
+         v :+++: w  -> matcher v +++ matcher w
+         Traverse v -> makeMatcher $ T.mapM (match v)
+
+instance IsView View where
+   build view =
+      case view of
+         Prim _ f   -> f
+         _ :@ v     -> build v
+         v :>>>: w  -> build v <<< build w
+         v :***: w  -> build v *** build w
+         v :+++: w  -> biMap (build v) (build w)
+         Traverse v -> fmap (build v)
+
+   toView = id
+
+instance HasId (View a b) where
+   getId (n :@ _) = n
+   getId _        = mempty
+   changeId f (n :@ a) = f n :@ a
+   changeId f a        = f mempty :@ a
+
+instance Identify (View a b) where
+   n @> v | isEmptyId a = v
+          | otherwise   = a :@ v
+    where
+      a = newId n
+
+makeView :: (a -> Maybe b) -> (b -> a) -> View a b
+makeView = matcherView . makeMatcher
+
+matcherView :: Matcher a b -> (b -> a) -> View a b
+matcherView = Prim
+
+identity :: C.Category f => f a a
+identity = C.id
+
+----------------------------------------------------------------------------------
+-- Isomorphisms (embedding-projection pairs)
+
+-- to ep . from ep == id
+data Isomorphism a b = EP { pid :: Id, from :: a -> b, to :: b -> a }
+
+instance C.Category Isomorphism where
+   id    = id <-> id
+   f . g = (from f . from g) <-> (to g . to f)
+
+instance Arrow Isomorphism where
+   arr     = (!->)
+   first   = (*** identity)
+   second  = (identity ***)
+   p *** q = from p *** from q <-> to p *** to q
+   f &&& g = copy >>> (f *** g)
+
+instance BiArrow Isomorphism where
+   (<->) = EP mempty
+
+instance ArrowChoice Isomorphism where
+   left    = (+++ identity)
+   right   = (identity +++)
+   p +++ q = from p +++ from q <-> to p +++ to q
+   f ||| g = (f +++ g) >>> merge
+
+instance IsMatcher Isomorphism where
+   match p = Just . from p
+
+instance IsView Isomorphism where
+   toView p = getId p @> makeView (match p) (to p)
+
+instance HasId (Isomorphism a b) where
+   getId = pid
+   changeId f p = p { pid = f (pid p) }
+
+instance Identify (Isomorphism a b) where
+   (@>) = changeId . const . newId
+
+inverse :: Isomorphism a b -> Isomorphism b a
+inverse f = to f <-> from f
+
+----------------------------------------------------------------------------------
+-- Type class for lifting with Views
+
+class LiftView f where
+   liftView   :: View a b -> f b -> f a
+   liftViewIn :: View a (b, c) -> f b -> f a
+   -- default definition
+   liftView v = liftViewIn (v &&& identity)
+
+----------------------------------------------------------------------------------
+-- Some combinators
+
+swapView :: Isomorphism (a, b) (b, a)
+swapView = "views.swap" @> swap
+
+-- | Specialized version of traverseView
+listView :: View a b -> View [a] [b]
+listView = traverseView
+
+-- or is liftView a better name?
+traverseView :: T.Traversable f => View a b -> View (f a) (f b)
+traverseView = Traverse
+
+($<) :: T.Traversable f => View a (f b) -> View b c -> View a (f c)
+a $< b = a >>> traverseView b
+
+swap :: BiArrow arr => arr (a, b) (b, a)
+swap = f <-> f
+ where
+   f :: (a, b) -> (b, a)
+   f (a, b) = (b, a)
+
+copy :: BiArrow arr => arr a (a, a)
+copy = (\a -> (a, a)) <-> fst
+
+merge :: BiArrow arr => arr (Either a a) a
+merge = either id id <-> Left
+
+----------------------------------------------------------------------------------
+-- Packaging a view for documentation purposes
+
+data ViewPackage where
+   ViewPackage ::
+      (Show a, Show b, Eq a) => (String -> Maybe a) -> View a b -> ViewPackage
+
+instance HasId ViewPackage where
+   getId      (ViewPackage _ a) = getId a
+   changeId f (ViewPackage p a) = ViewPackage p (changeId f a)
+
+----------------------------------------------------------------------------------
+-- Properties on views
+
+propIdempotence :: (Show a, Eq a) => Gen a -> View a b -> Property
+propIdempotence g v = forAll g $ \a ->
+   let b = simplify v a
+   in b == simplify v b
+
+propSoundness :: Show a => (a -> a -> Bool) -> Gen a -> View a c -> Property
+propSoundness semEq g v = forAll g $ \a ->
+   let b = simplify v a
+   in semEq a b
+
+propNormalForm :: (Show a, Eq a) => Gen a -> View a b -> Property
+propNormalForm g v = forAll g $ \a -> a == simplify v a
+ src/Ideas/Encoding/DecoderJSON.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE GADTs #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Services using JSON notation
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.DecoderJSON
+   ( JSONDecoder, JSONDecoderState(..), jsonDecoder
+   ) where
+
+import Control.Monad
+import Ideas.Common.Library hiding (exerciseId)
+import Ideas.Common.Utils (readM)
+import Ideas.Encoding.Evaluator
+import Ideas.Service.FeedbackScript.Syntax (Script)
+import Ideas.Service.State
+import Ideas.Service.Types hiding (String)
+import Ideas.Text.JSON
+import System.Random hiding (getStdGen)
+import qualified Ideas.Service.Types as Tp
+
+type JSONDecoder a = EncoderState (JSONDecoderState a) JSON
+
+data JSONDecoderState a = JSONDecoderState
+   { getExercise :: Exercise a
+   , getScript   :: Script
+   , getStdGen   :: StdGen
+   }
+
+jsonDecoder :: Type a t -> JSONDecoder a t
+jsonDecoder tp = encoderFor $ \json ->
+   case json of
+      Array xs -> liftM fst (decodeType tp // xs)
+      _ -> fail "expecting an array"
+
+decodeType :: Type a t -> EncoderState (JSONDecoderState a) [JSON] (t, [JSON])
+decodeType tp =
+   case tp of
+      Tag _ t -> decodeType t
+      Iso p t -> change (from p) (decodeType t)
+      Pair t1 t2 -> do
+         (a, xs) <- decodeType t1
+         (b, ys) <- decodeType t2 // xs
+         return ((a, b), ys)
+      t1 :|: t2 ->
+         change Left  (decodeType t1) `mplus`
+         change Right (decodeType t2)
+      Unit         -> result ()
+      Const StdGen -> withState getStdGen >>= result
+      Const Script -> withState getScript >>= result
+      Const t      -> encoderFor $ \xs ->
+                         case xs of
+                            hd:tl -> do a <- decodeConst t // hd
+                                        return (a, tl)
+                            _     -> fail "no more elements"
+      _ -> fail $ "No support for argument type: " ++ show tp
+ where
+   result a = simpleEncoder (\xs -> (a, xs))
+   change f = liftM (first f)
+
+decodeConst :: Const a t -> JSONDecoder a t
+decodeConst tp =
+   case tp of
+      State       -> decodeState
+      Context     -> decodeContext
+      Exercise    -> withState getExercise
+      Environment -> decodeEnvironment
+      Location    -> decodeLocation
+      Int         -> maybeEncoder fromJSON
+      Tp.String   -> maybeEncoder fromJSON
+      Rule        -> decodeRule
+      _           -> fail $ "No support for argument type: " ++ show tp
+
+decodeRule :: JSONDecoder a (Rule (Context a))
+decodeRule = do
+   ex <- withState getExercise
+   encoderFor $ \json ->
+      case json of
+         String s -> getRule ex (newId s)
+         _        -> fail "expecting a string for rule"
+
+decodeLocation :: JSONDecoder a Location
+decodeLocation = encoderFor $ \json ->
+   case json of
+      String s -> liftM toLocation (readM s)
+      _        -> fail "expecting a string for a location"
+
+decodeState :: JSONDecoder a (State a)
+decodeState = do
+   ex <- withState getExercise
+   encoderFor $ \json ->
+      case json of
+         Array [a] -> decodeState // a
+         Array [String _code, pref, term, jsonContext] -> do
+            ps   <- decodePrefixes    // pref
+            a    <- decodeTerm        // term
+            env  <- decodeEnvironment // jsonContext
+            return $ makeState ex ps (makeContext ex env a)
+         _ -> fail $ "invalid state" ++ show json
+
+decodePrefixes :: JSONDecoder a [Prefix (Context a)]
+decodePrefixes = do
+   ex <- withState getExercise
+   encoderFor $ \json ->
+      case json of
+         String p -> forM (deintercalate p) $
+                        readM >>= liftM (`makePrefix` strategy ex)
+         _ -> fail "invalid prefixes"
+
+decodeEnvironment :: JSONDecoder a Environment
+decodeEnvironment = encoderFor $ \json ->
+   case json of
+      String "" -> decodeEnvironment // Object []
+      Object xs -> foldM (flip add) mempty xs
+      _         -> fail $ "invalid context: " ++ show json
+ where
+   add (k, String s) = return . insertRef (makeRef k) s
+   add _             = fail "invalid item in context"
+
+decodeContext :: JSONDecoder a (Context a)
+decodeContext = do
+   ex <- withState getExercise
+   liftM (inContext ex) decodeTerm
+
+decodeTerm :: JSONDecoder a a
+decodeTerm = do
+   ex <- withState getExercise
+   eitherEncoder $ \json ->
+      case json of
+         String s -> parser ex s
+         _        -> Left "Expecting a string when reading a term"
+
+-- local helper
+deintercalate :: String -> [String]
+deintercalate xs
+   | null zs   = [ys]
+   | otherwise = ys : deintercalate (drop 1 zs)
+ where
+   (ys, zs) = break (== ';') xs
+ src/Ideas/Encoding/DecoderXML.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE GADTs #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Services using XML notation
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.DecoderXML
+   ( XMLDecoder, XMLDecoderState(..), xmlDecoder
+   ) where
+
+import Control.Monad
+import Data.Char
+import Data.List
+import Ideas.Common.Library hiding (exerciseId, (:=))
+import Ideas.Common.Utils (readM)
+import Ideas.Encoding.Evaluator
+import Ideas.Encoding.OpenMathSupport
+import Ideas.Service.FeedbackScript.Syntax (Script)
+import Ideas.Service.State
+import Ideas.Service.Types
+import Ideas.Text.OpenMath.Object
+import Ideas.Text.XML
+import System.Random (StdGen)
+
+type XMLDecoder a = EncoderState (XMLDecoderState a) XML
+
+data XMLDecoderState a = XMLDecoderState
+   { getExercise       :: Exercise a
+   , getScript         :: Script
+   , getStdGen         :: StdGen
+   , isOpenMath        :: Bool
+   , decodeTerm        :: XML -> Either String a
+   }
+
+xmlDecoder :: Type a t -> XMLDecoder a t
+xmlDecoder tp =
+   case tp of
+      Tag s t
+         | s == "answer" -> do
+              c <- encoderFor (findChild "answer")
+              xmlDecoder t // c
+         | s == "Difficulty" -> do
+              g <- equalM typed tp
+              a <- encoderFor (findAttribute "difficulty")
+              maybe (fail "unknown difficulty level") (return . g) (readDifficulty a)
+         | otherwise -> do
+              cx <- encoderFor (findChild s)
+              xmlDecoder t // cx
+      Iso p t  -> liftM (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)
+      Unit -> return ()
+      Const ctp ->
+         case ctp of
+            State       -> decodeState
+            Context     -> decodeContext
+            Rule        -> decodeRule
+            Environment -> decodeArgEnvironment
+            Location    -> decodeLocation
+            StratCfg    -> decodeConfiguration
+            StdGen      -> withState getStdGen
+            Script      -> withState getScript
+            Exercise    -> withState getExercise
+            Id          -> do -- improve!
+                              a <- encoderFor (findChild "location")
+                              return (newId (getData a))
+            _ -> fail $ "No support for argument type in XML: " ++ show tp
+      _ -> fail $ "No support for argument type in XML: " ++ show tp
+
+decodeRule :: XMLDecoder a (Rule (Context a))
+decodeRule = do
+   ex <- withState getExercise
+   xml0 <- encoderFor (findChild "ruleid")
+   getRule ex (newId (getData xml0))
+
+decodeLocation :: XMLDecoder a Location
+decodeLocation = do
+   xml <- encoderFor (findChild "location")
+   return (toLocation (read (getData xml)))
+
+decodeState :: XMLDecoder a (State a)
+decodeState = do
+   ex   <- withState getExercise
+   xml  <- encoderFor (findChild "state")
+   mpr  <- decodePrefix  // xml
+   term <- decodeContext // xml
+   return (makeState ex mpr term)
+
+decodePrefix :: XMLDecoder a [Prefix (Context a)]
+decodePrefix = do
+   str <- liftM strategy (withState getExercise)
+   prefixText <- simpleEncoder (maybe "" getData . findChild "prefix")
+   if all isSpace prefixText
+      then return [emptyPrefix str]
+      else if prefixText ~= "no prefix"
+      then return []
+      else do
+         a  <- readM prefixText
+         pr <- makePrefix a str
+         return [pr]
+ where
+   a ~= b = g a == g b
+   g = map toLower . filter (not . isSpace)
+
+decodeContext :: XMLDecoder a (Context a)
+decodeContext = do
+   ex   <- withState getExercise
+   f    <- withState decodeTerm
+   expr <- encoderFor (either fail return . f)
+   env  <- decodeEnvironment
+   return (makeContext ex env expr)
+
+decodeEnvironment :: XMLDecoder a Environment
+decodeEnvironment = encoderFor $ \xml ->
+   case findChild "context" xml of
+      Just this -> foldM add mempty (children this)
+      Nothing   -> return mempty
+ where
+   add env item = do
+      unless (name item == "item") $
+         fail $ "expecting item tag, found " ++ name item
+      n    <- findAttribute "name"  item
+      isOM <- withState isOpenMath
+      case findChild "OMOBJ" item of
+         -- OpenMath object found inside item tag
+         Just this | isOM ->
+            case xml2omobj this >>= fromOMOBJ of
+               Left err -> fail err
+               Right term ->
+                  return $ insertRef (makeRef n) (term :: Term) env
+         -- Simple value in attribute
+         _ -> do
+            value <- findAttribute "value" item
+            return $ insertRef (makeRef n) value env
+
+decodeConfiguration :: XMLDecoder a StrategyConfiguration
+decodeConfiguration = do
+   xml <- encoderFor (findChild "configuration")
+   liftM makeStrategyConfiguration $
+      mapM decodeAction (children xml)
+ where
+   decodeAction item = do
+      guard (null (children item))
+      action <-
+         case find (\a -> map toLower (show a) == name item) configActions of
+            Just a  -> return a
+            Nothing -> fail $ "unknown action " ++ show (name item)
+      cfgloc <- findAttribute "name" item
+      return (byName (newId cfgloc), action)
+
+decodeArgEnvironment :: XMLDecoder a Environment
+decodeArgEnvironment = encoderFor $ \xml ->
+   liftM makeEnvironment $ sequence
+      [ decodeBinding // x
+      | x <- children xml
+      , name x == "argument"
+      ]
+
+decodeBinding :: XMLDecoder a Binding
+decodeBinding = encoderFor $ \xml -> do
+   a <- findAttribute "description" xml
+   isOM <- withState isOpenMath
+   case findChild "OMOBJ" xml of
+      -- OpenMath object found inside tag
+      Just this | isOM ->
+         case xml2omobj this >>= fromOMOBJ of
+            Left err   -> fail err
+            Right term -> return (termBinding a term)
+      -- Simple value
+      _ -> return (makeBinding (makeRef a) (getData xml))
+ where
+   termBinding :: String -> Term -> Binding
+   termBinding = makeBinding . makeRef
+ src/Ideas/Encoding/EncoderHTML.hs view
@@ -0,0 +1,555 @@+{-# LANGUAGE GADTs #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Encoding in HTML
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.EncoderHTML (htmlEncoder) where
+
+import Control.Monad
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Ord
+import Ideas.Common.Library hiding (ready)
+import Ideas.Common.Strategy.Prefix
+import Ideas.Common.Utils
+import Ideas.Encoding.Evaluator
+import Ideas.Encoding.LinkManager
+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.State
+import Ideas.Service.Types
+import Ideas.Text.HTML
+import Ideas.Text.OpenMath.FMP
+import Ideas.Text.OpenMath.Object
+import Ideas.Text.XML
+
+type HTMLEncoder a t = EncoderState (HTMLEncoderState a) t HTMLBuilder
+
+data HTMLEncoderState a = HTMLEncoderState
+   { getLinkManager :: LinkManager
+   , getExercise    :: Exercise a
+   }
+
+htmlEncoder :: LinkManager -> DomainReasoner -> Exercise a -> TypedValue (Type a) -> HTMLPage
+htmlEncoder lm dr ex tv =
+   addCSS (resource "ideas.css") $
+   htmlPage "Ideas: documentation pages" $ mconcat
+      [ divClass "page-header" $ mconcat
+           [ divClass  "ideas-logo" $ image $ resource "ideas.png"
+           , divClass  "ounl-logo"  $ image $ resource "ounl.png"
+           , spanClass "menuitem"   $ linkToIndex lm $ string "Index"
+           , spanClass "menuitem"   $ linkToExercises lm $ string "Exercises"
+           , spanClass "menuitem"   $ linkToServices lm $ string "Services"
+           ]
+      , divClass "page-content" $
+           let hes = HTMLEncoderState lm ex in
+           case runEncoderState (encodeType lm ex) hes tv of
+              Left err -> string err
+              Right ok -> ok
+      , divClass "page-footer" $
+           string (fullVersion dr)
+      ]
+ where
+   resource = urlForResource lm
+
+encodeType :: LinkManager -> Exercise a -> HTMLEncoder a (TypedValue (Type a))
+encodeType lm ex = msum
+   [ encodeTyped encodeIndex
+   , encodeTyped (exerciseHeader // () <> htmlDiagnosis)
+   , encodeTyped (exerciseHeader // () <> encodeExampleList lm ex)
+   , encodeTyped (exerciseHeader // () <> htmlAllFirsts)
+   , encodeTyped (exerciseHeader // () <> htmlAllApplications)
+   , encodeTyped (exerciseHeader // () <> encodeDerivation lm ex)
+   , encodeTyped (exerciseHeader // () <> encodeDerivationList lm ex)
+   , encoderFor $ \(val ::: tp) ->
+        case tp of
+           Iso iso t  -> encodeType lm ex // (to iso val ::: t)
+           Tag _ t    -> encodeType lm ex // (val ::: t)
+           Pair t1 t2 -> encodeType lm ex // (fst val ::: t1) <>
+                         encodeType lm ex // (snd val ::: t2)
+           t1 :|: t2  -> case val of
+                            Left x  -> encodeType lm ex // (x ::: t1)
+                            Right x -> encodeType lm ex // (x ::: t2)
+           List (Const Service) -> encodeServiceList lm // val
+           List (Const SomeExercise) -> encodeExerciseList lm // val
+           List (Const Rule) -> (exerciseHeader // ()) <> encodeRuleList lm ex // val
+           List t -> ul [ encodeType lm ex // (x ::: t) | x <- val ]
+           Const t -> encodeConst lm ex // (val ::: t)
+           _ -> string $ "unknown: " ++ show tp
+   ]
+
+encodeConst :: LinkManager -> Exercise a -> HTMLEncoder a (TypedValue (Const a))
+encodeConst lm ex = encoderFor $ \tv@(val ::: tp) ->
+   case tp of
+      Service     -> encodeService // val
+      Exercise    -> (exerciseHeader // ()) <> encodeExercise lm // val
+      Strategy    -> (exerciseHeader // ()) <> encodeStrategy ex // val
+      Rule        -> encodeRule ex // val
+      State       -> (exerciseHeader // ()) <> (encodeState // val)
+      Location    -> text val
+      Environment -> text val
+      Context     -> string $ prettyPrinterContext ex val
+      String      -> string val
+      _           -> text tv
+
+encodeIndex :: HTMLEncoder a DomainReasoner
+encodeIndex = simpleEncoder $ \dr -> mconcat
+   [ h1 $ "Domain reasoner " ++ showId dr
+   , htmlDescription dr
+   , keyValueTable
+        [ ("version", string $ fullVersion dr)
+        , ("exercises", text $ length $ exercises dr)
+        , ("services", text $ length $ services dr)
+        ]
+   , munless (null $ aliases dr) $
+        h2 "Exercise aliases" <>
+        table True (
+           [ string "alias", string "exercise"] :
+           [ [string (showId a), string (showId b)]
+           | (a, b) <- aliases dr
+           ])
+   , munless (null $ scripts dr)
+        h2 "Feedback scripts" <>
+        table True (
+           [ string "exercise", string "script"] :
+           [ [string (showId a), string file]
+           | (a, file) <- scripts dr
+           ])
+   ]
+
+encodeServiceList :: LinkManager -> HTMLEncoder a [Service]
+encodeServiceList lm = simpleEncoder $ \srvs ->
+   h1 "Services" <>
+   mconcat
+      [ h2 (show i ++ ". " ++ s) <> table False (map make xs)
+      | (i, s, xs) <- groupById srvs
+      ]
+ where
+   make s = [ linkToService lm s (string (showId s)) <>
+              mwhen (serviceDeprecated s) (italic (string " (deprecated)"))
+            , string (description s)
+            ]
+
+encodeExerciseList :: LinkManager -> HTMLEncoder a [Some Exercise]
+encodeExerciseList lm = simpleEncoder $ \exs ->
+   h1 "Exercises" <>
+   mconcat
+      [ h2 (show i ++ ". " ++ dom) <> table False (map make xs)
+      | (i, dom, xs) <- groupsWith f exs
+      ]
+ where
+   f :: Some Exercise -> String
+   f (Some ex) = fromMaybe "" (listToMaybe (qualifiers (getId ex)))
+
+   make :: Some Exercise -> [HTMLBuilder]
+   make (Some ex) =
+      [ linkToExercise lm ex $ string $ showId ex
+      , string $ map toLower $ show $ status ex
+      , string $ description ex
+      ]
+
+groupById :: HasId a => [a] -> [(Int, String, [a])]
+groupById = groupsWith (fromMaybe "" . listToMaybe . qualifiers . getId)
+
+groupsWith :: (a -> String) -> [a] -> [(Int, String, [a])]
+groupsWith = orderedGroupsWith id
+
+orderedGroupsWith :: Ord b => (b -> String) -> (a -> b) -> [a] -> [(Int, String, [a])]
+orderedGroupsWith showf get =
+   zipWith f [1..] . groupBy eq . sortBy (comparing get)
+ where
+   eq x y = get x == get y
+   f i xs = (i, showf (get (head xs)), xs)
+
+encodeService :: HTMLEncoder a Service
+encodeService = simpleEncoder $ \srv -> mconcat
+   [ h1 $ "Service " ++ showId srv
+   , mwhen (serviceDeprecated srv) $
+        para $ spanClass "warning" $ string "Warning: this service is deprecated"
+   , htmlDescription srv
+   , case serviceFunction srv of
+        _ ::: tp ->
+           let (xs, ys) = inputOutputTypes tp
+               f :: Some (Type a) -> HTMLBuilder
+               f (Some (t :|: Unit)) = text t <> italic (string " (optional)")
+               f (Some t) = text t
+           in
+              munless (null xs) (para $
+                 bold (string "Input") <> ul (map f xs))
+              <>
+              munless (null ys) (para $
+                 bold (string "Output") <> ul (map f ys))
+   ]
+
+inputOutputTypes :: Type a t -> ([Some (Type a)], [Some (Type a)])
+inputOutputTypes tp =
+   case tp of
+      Iso _ t   -> inputOutputTypes t
+      t1 :-> t2 -> let (xs, ys) = inputOutputTypes t2
+                   in (productType t1 ++ xs, ys)
+      Const String :|: t -> ([], productType t)
+      _         -> ([], productType tp)
+
+productType :: Type a t -> [Some (Type a)]
+productType tp =
+   case tp of
+      Iso _ t    -> productType t
+      Pair t1 t2 -> productType t1 ++ productType t2
+      Unit       -> []
+      _          -> [Some tp]
+
+encodeExercise :: LinkManager -> HTMLEncoder a (Exercise a)
+encodeExercise lm = simpleEncoder $ \ex -> mconcat
+   [ generalInfo ex
+   , h2 "Example exercises"
+   , ul $ [ para $ linkToExamples lm ex $ string "list of examples"
+          | not (null (examples ex))
+          ] ++
+          [ para $ mconcat $
+               string "generate exercise: " :
+               intersperse (string ", ")
+                  [ linkToRandomExample lm ex d $ text d
+                  | d <- [VeryEasy .. VeryDifficult]
+                  ]
+          | isJust (randomExercise ex)
+          ] ++
+          [ para $ submitStateInfo lm ex
+          | not (isStatic lm)
+          ]
+   ]
+ where
+   generalInfo ex = keyValueTable
+      [ ("Code",   ttText (showId ex))
+      , ("Status", text $ status ex)
+      , ("Strategy", linkToStrategy lm ex $ string (showId $ strategy ex))
+      , ("Rules", text nrOfSoundRules)
+      , ("Buggy rules", text nrOfBuggyRules)
+      , ("OpenMath support", bool $ isJust $ hasTermView ex)
+      , ("Restartable strategy", bool $ canBeRestarted ex)
+      , ("Exercise generator", bool $ isJust $ randomExercise ex)
+      , ("Examples", text $ length $ examples ex)
+      ]
+    where
+      (nrOfBuggyRules, nrOfSoundRules) =
+         mapBoth length (partition isBuggy (ruleset ex))
+
+exerciseHeader :: HTMLEncoder a ()
+exerciseHeader = do
+   ex <- withState getExercise
+   mconcat
+      [ exerciseMenu
+      , h1 $ "Exercise " ++ showId ex
+      , return $ htmlDescription ex
+      ]
+
+exerciseMenu :: HTMLEncoder a ()
+exerciseMenu = divClass "menubox" $
+   bold (string "Exercise") <>
+   ul [ with linkToExercise    "information"
+      , with linkToStrategy "   strategy"
+      , with linkToRules       "rules"
+      , with linkToExamples    "examples"
+      , with linkToDerivations "derivations"
+      ]
+ where
+   with f s = do
+      lm <- withState getLinkManager
+      ex <- withState getExercise
+      return $ f lm ex $ string s
+
+encodeStrategy :: Exercise a -> HTMLEncoder a (Strategy (Context a))
+encodeStrategy ex = simpleEncoder $ \s -> mconcat
+   [ h2 "Strategy"
+   , highlightXML True (strategyToXML s)
+   , h2 "Locations"
+   , let f :: HasId a => ([Int], a) -> [HTMLBuilder]
+         f (loc, a) = [text loc, indent (length loc) <> string (showId a)]
+         indent n = string (replicate (3*n) '.')
+     in table True
+           ( [string "Location", string "Label"]
+           : map f (strategyLocations (strategy ex))
+           )
+   ]
+
+bool :: Bool -> HTMLBuilder
+bool b = string (if b then "yes" else "no")
+
+encodeRuleList :: LinkManager -> Exercise a -> HTMLEncoder a [Rule (Context a)]
+encodeRuleList lm ex = simpleEncoder $ \rs ->
+   let (rs1, rs2) = partition isBuggy rs
+   in mconcat
+         [ h2 $ "Rules for " ++ showId ex
+         , table True (header:map f rs2)
+         , h2 $ "Buggy rules for " ++ showId ex
+         , table True (header:map f rs1)
+         ]
+ where
+   header = [ string "Rule name", string "Args"
+            , string "Used", string "Rewrite rule"
+            ]
+   used = rulesInStrategy (strategy ex)
+   f r  = [ linkToRule lm ex r $ ttText (showId r)
+          , text $ length $ getRefs r
+          , bool $ r `elem` used
+          , mwhen (isRewriteRule r) $
+               ruleToHTML (Some ex) r
+          ]
+
+encodeRule :: Exercise a -> HTMLEncoder a (Rule (Context a))
+encodeRule ex = simpleEncoder $ \r -> mconcat
+   [ h1 $ "Rule " ++ showId r
+   , htmlDescription r
+   , let commas  = string . intercalate ", "
+         idList  = commas . map showId
+         refList = commas . map show . getRefIds
+     in para $ keyValueTable
+           [ ("Parameters", refList r)
+           , ("Buggy", bool (isBuggy r))
+           , ("Rewrite rule", bool (isRewriteRule r))
+           , ("Siblings", idList $ ruleSiblings r)
+           ]
+   , mwhen (isRewriteRule r) $
+        h2 "Rewrite rule" <> ruleToHTML (Some ex) r
+   -- FMPS
+   , let xs = getRewriteRules (transformation r)
+     in munless (null xs) $ mconcat $
+           h2 "Formal Mathematical Properties" :
+           [ para $
+              let fmp = rewriteRuleToFMP (not $ isBuggy r) rr
+              in highlightXML False $ makeXML "FMP" $
+                    builder $ omobj2xml $ toObject fmp
+           | Some rr <- xs
+           ]
+   ]
+
+encodeExampleList :: LinkManager -> Exercise a -> HTMLEncoder a [(Difficulty, Context a)]
+encodeExampleList lm ex = simpleEncoder $ \pairs -> mconcat $
+   h2 "Examples" :
+   [ h3 (s ++ " (" ++ show (length xs) ++ ")")
+       <> (if isStatic lm then ul else mconcat) (map make xs)
+   | (_, s, xs) <- orderedGroupsWith show fst pairs
+   ]
+ where
+   make (_, x) = para $
+      munless (isStatic lm) $
+         let st = emptyStateContext ex x
+         in spanClass "statelink" $ linkToState lm st $
+               element "img" ["src" .=. "external.png", "width" .=. "15"]
+      <> spanClass "term" (string (prettyPrinterContext ex x))
+
+encodeDerivation :: LinkManager -> Exercise a -> HTMLEncoder a (Derivation (Rule (Context a), Environment) (Context a))
+encodeDerivation lm ex =
+   h2 "Derivation" <> htmlDerivation lm ex
+
+encodeDerivationList :: LinkManager -> Exercise a -> HTMLEncoder a [Derivation (Rule (Context a), Environment) (Context a)]
+encodeDerivationList lm ex = encoderFor $ \ds ->
+   h2 "Derivations"
+   <> mconcat
+      [ h3 (show i ++ ".") <> htmlDerivation lm ex // d
+      | (i, d) <- zip [1::Int ..] ds
+      ]
+
+htmlDerivation :: LinkManager -> Exercise a -> HTMLEncoder a (Derivation (Rule (Context a), Environment) (Context a))
+htmlDerivation lm ex = encoderFor $ \d ->
+   arr derivationDiffEnv
+   >>> htmlDerivationWith (before d) forStep forTerm
+ where
+   before d =
+      stateLink lm (emptyStateContext ex (firstTerm d))
+      <> case fmap (isReady ex) (fromContext (lastTerm d)) of
+            Just True -> mempty
+            _ -> spanClass "error" (string "Final term is not finished")
+   forStep ((r, env1), env2) =
+      let showEnv e = munless (noBindings e) $ string $ ", " ++ show e in
+      spanClass "derivation-step" $ mconcat
+         [ unescaped "&#8658; "
+         , linkToRule lm ex r $ string $ showId r
+         , showEnv env1 -- local environment
+         , showEnv env2 -- global environment (diff)
+         ]
+   forTerm a =
+      divClass "term" $ string $ prettyPrinterContext ex a
+
+htmlState :: HTMLEncoder a (State a)
+htmlState = do
+   lm <- withState getLinkManager
+   simpleEncoder $ \state ->
+      para $ divClass "state" $
+         stateLink lm state
+         <> divClass "term" (string $ prettyPrinterContext (exercise state) (stateContext state))
+         <> string "ready: " <> bool (ready state)
+
+stateLink :: LinkManager -> State a -> HTMLBuilder
+stateLink lm st = munless (isStatic lm) $
+   spanClass "derivation-statelink" $ linkToState lm st $
+      element "img"
+         [ "src" .=. urlForResource lm "external.png"
+         , "width" .=. "15"
+         ]
+
+encodeState :: HTMLEncoder a (State a)
+encodeState = do
+   lm <- withState getLinkManager
+   htmlState <> simpleEncoder (\state -> mconcat
+      [ h2 "Feedback"
+      , submitDiagnose lm state
+      , ul [ linkToFirsts lm state $ string "allfirsts"
+           , linkToApplications lm state $ string "allapplications"
+           , linkToDerivation lm state $ string "derivation"
+           ]
+      , munless (noBindings state) $
+           h2 "Environment" <> text (environment state)
+      , encodePrefixes (statePrefixes state)
+      ])
+
+encodePrefixes :: [Prefix (Context a)] -> HTMLBuilder
+encodePrefixes = mconcat . zipWith make [1::Int ..]
+ where
+   make i pr = mconcat
+      [ h2 $ "Prefix " ++ show i
+      , let count p = text $ length $ filter p prSteps
+            enter   = spanClass "step-enter" . text
+        in keyValueTable
+              [ ("steps", count (const True))
+              , ("rules", count isRuleStep)
+              , ("major rules", count isMajor)
+              , ("active labels", ul $ map enter $ activeLabels pr)
+              ]
+      , mconcat $ intersperse (string ", ") $ map htmlStep prSteps
+      ]
+    where
+      prSteps = prefixToSteps pr
+
+isRuleStep :: Step l a -> Bool
+isRuleStep (RuleStep _ _) = True
+isRuleStep _ = False
+
+htmlStep :: Show l => Step l a -> HTMLBuilder
+htmlStep (Enter l)      = spanClass "step-enter" $ string $ "enter " ++ show l
+htmlStep (Exit  l)      = spanClass "step-exit"  $ string $ "exit " ++ show l
+htmlStep (RuleStep _ r) = let s = if isMinor r then "minor" else "major"
+                          in spanClass ("step-"++s) $ string $ showId r
+
+htmlDerivationWith :: HTMLBuilder -> (s -> HTMLBuilder) -> (t -> HTMLBuilder) -> HTMLEncoder a (Derivation s t)
+htmlDerivationWith before forStep forTerm = simpleEncoder $ \d ->
+   divClass "derivation" $ mconcat $
+      before : forTerm (firstTerm d) :
+         [ forStep s <> forTerm a | (_, s, a) <- triples d ]
+
+htmlAllFirsts :: HTMLEncoder a [(StepInfo a, State a)]
+htmlAllFirsts = encoderFor $ \xs ->
+   h2 "All firsts" <>
+   ul [ keyValueTable
+           [ ("Rule", string $ showId r)
+           , ("Location", text loc)
+           , ("Environment", text env)
+           ] <> htmlState // s
+      | ((r, loc, env), s) <- xs
+      ]
+
+htmlAllApplications :: HTMLEncoder a [(Rule (Context a), Location, State a)]
+htmlAllApplications = encoderFor $ \xs ->
+   h2 "All applications" <>
+   ul [ keyValueTable
+           [ ("Rule", string $ showId r)
+           , ("Location", text loc)
+           ] <> (if isBuggy r then mempty else htmlState // s)
+      | (r, loc, s) <- xs
+      ]
+
+htmlDiagnosis :: HTMLEncoder a (Diagnosis a)
+htmlDiagnosis = encoderFor $ \diagnosis ->
+   case diagnosis of
+      Buggy _ r ->
+         spanClass "error" $ string $ "Not equivalent: buggy rule " ++ show r
+      NotEquivalent ->
+         spanClass "error" $ string "Not equivalent"
+      Similar _ s ->
+         h2 "Similar term" <> encodeState // s
+      Expected _ s r ->
+         h2 ("Expected (" ++ show r ++ ")")
+         <> encodeState // s
+      Detour _ s _ r ->
+         h2 ("Detour (" ++ show r ++ ")")
+         <> encodeState // s
+      Correct _ s ->
+         h2 "Correct" <> encodeState // s
+
+htmlDescription :: HasId a => a -> HTMLBuilder
+htmlDescription a = munless (null (description a)) $
+   para $
+      bold (string "Description") <> br
+      <> spanClass "description" (string (description a))
+
+submitForm :: HTMLBuilder -> HTMLBuilder
+submitForm this = element "form"
+   [ "name"     .=. "myform"
+   , "onsubmit" .=. "return submitTerm()"
+   , "method"   .=. "post"
+   , this
+   , element "input" ["type" .=. "text", "name" .=. "myterm"]
+   , element "input" ["type"  .=. "submit", "value" .=. "Submit"]
+   ]
+
+-- stateinfo service
+submitStateInfo :: LinkManager -> Exercise a -> HTMLBuilder
+submitStateInfo lm ex =
+   submitForm (string "other exercise: ")
+   <> submitRequest lm request
+ where
+   request = "<request service='stateinfo' exerciseid='" ++ showId ex
+          ++ "' encoding='html'><state><expr>\" + getTerm() + \"</expr></state></request>"
+
+-- diagnose service
+submitDiagnose :: LinkManager -> State a -> HTMLBuilder
+submitDiagnose lm st = submitForm mempty <> submitRequest lm request
+ where
+   request = "<request service='diagnose' exerciseid='" ++ showId (exercise st)
+          ++ "' encoding='html'>" ++ ststr ++ "<expr>\"  + getTerm() + \"</expr></request>"
+
+   ststr   = case fromBuilder (stateToXML st) of
+                Just el -> concatMap f (show el)
+                Nothing -> ""
+
+   f '\\' = "\\\\"
+   f c = [c]
+
+submitRequest :: LinkManager -> String -> HTMLBuilder
+submitRequest lm request = submitURL $
+   quote (urlForRequest lm) ++ "+encodeURIComponent(" ++ quote request ++ ")"
+
+quote :: String -> String
+quote s = '"' : s ++ "\""
+
+-- Inject two JavaScript functions for handling the input form
+submitURL :: String -> HTMLBuilder
+submitURL url = tag "script" $
+   ("type" .=. "text/javascript")
+   <> unescaped (
+      "function getTerm() {\
+      \   var s = document.myform.myterm.value;\
+      \   var result = '';\
+      \   for (var i=0;i<s.length;i++) {\
+      \      if (s[i]=='<') result+='&lt;';\
+      \      else if (s[i]=='&') result+='&amp;';\
+	   \      else result+=s[i];\
+      \   }\
+      \   return result;\
+      \}\
+      \function submitTerm() {\
+      \   document.myform.action = " ++ url ++ ";\
+      \}")
+ src/Ideas/Encoding/EncoderJSON.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE GADTs #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Services using JSON notation
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.EncoderJSON (jsonEncoder) where
+
+import Control.Monad
+import Data.List (intercalate)
+import Ideas.Common.Library hiding (exerciseId)
+import Ideas.Common.Utils (Some(..), distinct)
+import Ideas.Encoding.Evaluator
+import Ideas.Service.State
+import Ideas.Service.Types hiding (String)
+import Ideas.Text.JSON
+import qualified Ideas.Service.Diagnose as Diagnose
+import qualified Ideas.Service.Submit as Submit
+import qualified Ideas.Service.Types as Tp
+
+type JSONEncoder a t = EncoderState (a -> JSON) t JSON
+
+jsonEncoder :: JSONEncoder a (TypedValue (Type a))
+jsonEncoder = encoderFor $ \tv@(val ::: tp) ->
+   case tp of
+      _ | length (tupleList tv) > 1 ->
+         jsonTuple <$> sequence [ jsonEncoder // x | x <- tupleList tv ]
+      Iso p t   -> jsonEncoder // (to p val ::: t)
+      t1 :|: t2 -> case val of
+         Left  x -> jsonEncoder // (x ::: t1)
+         Right y -> jsonEncoder // (y ::: t2)
+      Pair t1 t2 ->
+         let f x y = jsonTuple [x, y]
+         in liftA2 f (jsonEncoder // (fst val ::: t1))
+                     (jsonEncoder // (snd val ::: t2))
+      List (Const Rule) ->
+         pure $ Array $ map ruleShortInfo val
+      Tp.Tag s t
+         | s == "Result"     -> encodeTyped encodeResult
+         | s == "Diagnosis"  -> encodeTyped encodeDiagnosis
+         | s == "Derivation" -> encodeTyped encodeDerivation <+>
+                                encodeTyped encodeDerivationText
+         | s == "elem"       -> jsonEncoder // (val ::: t)
+         | otherwise -> (\b -> Object [(s, b)]) <$> jsonEncoder // (val ::: t)
+      Tp.Unit   -> pure Null
+      Tp.List t -> Array <$> sequence [ jsonEncoder // (x ::: t) | x <- val ]
+      Const ctp -> jsonEncodeConst // (val ::: ctp)
+      _ -> fail $ "Cannot encode type: " ++ show tp
+ where
+   tupleList :: TypedValue (TypeRep f) -> [TypedValue (TypeRep f)]
+   tupleList (x ::: Tp.Iso p t)   = tupleList (to p x ::: t)
+   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)
+   tupleList (ev ::: (t1 :|: t2)) =
+      either (\x -> tupleList (x ::: t1))
+             (\x -> tupleList (x ::: t2)) ev
+   tupleList tv = [tv]
+
+jsonEncodeConst :: JSONEncoder a (TypedValue (Const a))
+jsonEncodeConst = encoderStateFor $ \encTerm (val ::: tp) ->
+   case tp of
+      SomeExercise -> case val of
+                         Some ex -> pure (exerciseInfo ex)
+      State        -> encodeState // val
+      Rule         -> pure (toJSON (showId val))
+      Context      -> maybe zeroArrow (pure . encTerm) (fromContext val)
+      Location     -> pure (toJSON (show val))
+      Environment  -> encodeEnvironment // val
+      Text         -> pure (toJSON (show val))
+      Int          -> pure (toJSON val)
+      Bool         -> pure (toJSON val)
+      Tp.String    -> pure (toJSON val)
+      _ -> fail $ "Type " ++ show tp ++ " not supported in JSON"
+
+--------------------------
+
+-- legacy representation
+encodeEnvironment :: JSONEncoder a Environment
+encodeEnvironment = encoderFor $ \env ->
+   let f a = Object [(showId a, String (showValue a))]
+   in pure $ Array [ f a | a <- bindings env ]
+
+encodeState :: JSONEncoder a (State a)
+encodeState = encoderStateFor $ \encTerm st ->
+   let f x = [ String (showId (exercise st))
+             , String $ case statePrefixes st of
+                           [] -> "NoPrefix"
+                           ps -> intercalate ";" $ map show ps
+             , encTerm (stateTerm st)
+             , x
+             ]
+   in Array . f <$> encodeContext // stateContext st
+
+encodeContext :: JSONEncoder a (Context a)
+encodeContext = encoderFor $ \ctx ->
+   pure $ Object [ (showId a, String $ showValue a) | a <- bindings ctx ]
+
+encodeDerivation :: JSONEncoder a (Derivation (Rule (Context a), Environment) (Context a))
+encodeDerivation = encoderFor $ \d ->
+   let xs = [ (s, a) | (_, s, a) <- triples d ]
+   in jsonEncoder // (xs ::: typed)
+
+encodeDerivationText :: JSONEncoder a (Derivation String (Context a))
+encodeDerivationText = encoderFor $ \d ->
+   let xs = [ (s, a) | (_, s, a) <- triples d ]
+   in jsonEncoder // (xs ::: typed)
+
+encodeResult :: JSONEncoder a (Submit.Result a)
+encodeResult = encoderFor $ \result -> Object <$>
+   case result of
+      Submit.Buggy rs -> pure
+         [ ("result", String "Buggy")
+         , ("rules", Array $ map (String . showId) rs)
+         ]
+      Submit.NotEquivalent -> pure
+         [ ("result", String "NotEquivalent") ]
+      Submit.Ok rs st ->
+         let f x =
+                [ ("result", String "Ok")
+                , ("rules", Array $ map (String . showId) rs)
+                , ("state", x)
+                ]
+         in f <$> jsonEncoder // (st ::: typed)
+      Submit.Detour rs st ->
+         let f x =
+                [ ("result", String "Detour")
+                , ("rules", Array $ map (String . showId) rs)
+                , ("state", x)
+                ]
+         in f <$> jsonEncoder // (st ::: typed)
+      Submit.Unknown st ->
+         let f x =
+                [ ("result", String "Unknown")
+                , ("state", x)
+                ]
+         in f <$> jsonEncoder // (st ::: typed)
+
+encodeDiagnosis :: JSONEncoder a (Diagnose.Diagnosis a)
+encodeDiagnosis = encoderFor $ \diagnosis ->
+   case diagnosis of
+      Diagnose.NotEquivalent ->
+         pure $ Object [("notequiv", Null)]
+      Diagnose.Buggy env r ->
+         make "buggy" [fromEnv env, fromRule r]
+      Diagnose.Similar b st ->
+         make "similar" [fromReady b, fromState st]
+      Diagnose.Expected b st r ->
+         make "expected" [fromReady b, fromState st, fromRule r]
+      Diagnose.Detour b st env r ->
+         make "detour" [fromReady b, fromState st, fromEnv env, fromRule r]
+      Diagnose.Correct b st ->
+         make "correct" [fromReady b, fromState st]
+ where
+   make s = liftM (\xs -> Object [(s, Array xs)]) . sequence
+   fromEnv env  = jsonEncoder // (env ::: typed)
+   fromRule r   = return (toJSON (showId r))
+   fromReady b  = return (Object [("ready", toJSON b)])
+   fromState st = jsonEncoder // (st ::: typed)
+
+{-
+encodeTree :: Tree JSON -> JSON
+encodeTree (Node r ts) =
+  case r of
+    Array [x, t] -> Object
+       [ ("rootLabel", x)
+       , ("type", t)
+       , ("subForest", Array $ map encodeTree ts)
+       ]
+    _ -> error "ModeJSON: malformed tree!" -}
+
+jsonTuple :: [JSON] -> JSON
+jsonTuple xs =
+   case mapM f xs of
+      Just ys | distinct (map fst ys) -> Object ys
+      _ -> Array xs
+ where
+   f (Object [p]) = Just p
+   f _ = Nothing
+
+ruleShortInfo :: Rule a -> JSON
+ruleShortInfo r = Object
+   [ ("name",        toJSON (showId r))
+   , ("buggy",       toJSON (isBuggy r))
+   , ("arguments",   toJSON (length (getRefs r)))
+   , ("rewriterule", toJSON (isRewriteRule r))
+   ]
+
+exerciseInfo :: Exercise a -> JSON
+exerciseInfo ex = Object
+   [ ("exerciseid", toJSON (showId ex))
+   , ("description", toJSON (description ex))
+   , ("status", toJSON (show (status ex)))
+   ]
+ src/Ideas/Encoding/EncoderXML.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE GADTs #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Services using XML notation
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.EncoderXML
+   ( XMLEncoder, XMLEncoderState(..)
+   , xmlEncoder, encodeState
+   ) where
+
+import Control.Monad
+import Data.Char
+import Data.Maybe
+import Data.Monoid
+import Ideas.Common.Library hiding (exerciseId, (:=), (<|>))
+import Ideas.Common.Utils (Some(..))
+import Ideas.Encoding.Evaluator
+import Ideas.Encoding.OpenMathSupport
+import Ideas.Encoding.RulesInfo (rulesInfoXML)
+import Ideas.Encoding.StrategyInfo
+import Ideas.Service.Diagnose
+import Ideas.Service.FeedbackScript.Syntax
+import Ideas.Service.State
+import Ideas.Service.Types
+import Ideas.Text.OpenMath.Object
+import Ideas.Text.XML
+import qualified Ideas.Service.FeedbackText as FeedbackText
+import qualified Ideas.Service.ProblemDecomposition as PD
+
+-----------------
+
+type XMLEncoder a t = EncoderState (XMLEncoderState a) t XMLBuilder
+
+data XMLEncoderState a = XMLEncoderState
+   { getExercise :: Exercise a
+   , isOpenMath  :: Bool
+   , encodeTerm  :: a -> XMLBuilder
+   }
+
+xmlEncoder :: XMLEncoder a (TypedValue (Type a))
+xmlEncoder = msum
+   [ encodeTyped encodeDiagnosis
+   , encodeTyped encodeDecompositionReply
+   , encodeTyped encodeDerivation
+   , encodeTyped encodeDerivationText
+   , encodeTyped encodeDifficulty
+   , encodeTyped encodeMessage
+   , encoderStateFor $ \xp (val ::: tp) ->
+        case tp of
+           -- meta-information
+           Tag "RuleShortInfo" t ->
+              case equal t (Const Rule) of
+                 Just f  -> ruleShortInfo // f val
+                 Nothing -> fail "rule short info"
+           Tag "RulesInfo" _ ->
+              return (rulesInfoXML (getExercise xp) (encodeTerm xp))
+           Tag "elem" t ->
+              tag "elem" (xmlEncoder // (val ::: t))
+           -- special cases for lists
+           List (Const Rule) ->
+              encodeAsList [ ruleShortInfo // r | r <- val ]
+           List t ->
+              encodeAsList [ xmlEncoder // (a ::: t) | a <- val ]
+           -- standard
+           Tag _ t    -> xmlEncoder // (val ::: t)
+           Iso iso t  -> xmlEncoder // (to iso val ::: t)
+           Pair t1 t2 -> xmlEncoder // (fst val ::: t1) <>
+                         xmlEncoder // (snd val ::: t2)
+           t1 :|: t2  -> case val of
+                            Left  a -> xmlEncoder // (a ::: t1)
+                            Right b -> xmlEncoder // (b ::: t2)
+           Unit       -> mempty
+           Const t    -> xmlEncoderConst // (val ::: t)
+           _ -> fail $ show tp
+   ]
+
+xmlEncoderConst :: XMLEncoder a (TypedValue (Const a))
+xmlEncoderConst = encoderFor $ \tv@(val ::: tp) ->
+   case tp of
+      SomeExercise -> case val of
+                         Some a -> exerciseInfo // a
+      Strategy     -> builder (strategyToXML val)
+      Rule         -> "ruleid" .=. show val
+      State        -> encodeState // val
+      Context      -> encodeContext // val
+      Location     -> encodeLocation // val
+      Environment  -> encodeEnvironment // val
+      Text         -> encodeText // val
+      Bool         -> string (showBool val)
+      _            -> text tv
+
+encodeState :: XMLEncoder a (State a)
+encodeState = encoderFor $ \st -> element "state"
+   [ encodePrefixes // statePrefixes st
+   , encodeContext // stateContext st
+   ]
+
+encodePrefixes :: XMLEncoder a [Prefix (Context a)]
+encodePrefixes = encoderFor $ \ps ->
+   case ps of
+      [] -> mempty
+      _  -> element "prefix" [ text p | p <- ps ]
+
+encodeContext :: XMLEncoder a (Context a)
+encodeContext = encoderStateFor $ \xp ctx ->
+   liftM (encodeTerm xp) (fromContext ctx)
+   <>
+   let values = bindings (withLoc ctx)
+       loc    = fromLocation (location ctx)
+       withLoc
+          | null loc  = id
+          | otherwise = insertRef (makeRef "location") loc
+   in return $ munless (null values) $ element "context"
+         [  element "item"
+               [ "name"  .=. showId tb
+               , case getTermValue tb of
+                    term | isOpenMath xp ->
+                       builder (omobj2xml (toOMOBJ term))
+                    _ -> "value" .=. showValue tb
+               ]
+         | tb <- values
+         ]
+
+encodeLocation :: XMLEncoder a Location
+encodeLocation = encoderFor $ \loc -> return ("location" .=. show loc)
+
+encodeEnvironment :: HasEnvironment env => XMLEncoder a env
+encodeEnvironment = encoderFor $ \env ->
+   mconcat [ encodeTypedBinding // b | b <- bindings env ]
+
+encodeTypedBinding :: XMLEncoder a Binding
+encodeTypedBinding = encoderStateFor $ \xp tb ->
+   tag "argument" $
+      ("description" .=. showId tb) <>
+      case getTermValue tb of
+         term | isOpenMath xp -> builder $
+            omobj2xml $ toOMOBJ term
+         _ -> string (showValue tb)
+
+encodeDerivation :: XMLEncoder a (Derivation (Rule (Context a), Environment) (Context a))
+encodeDerivation = encoderFor $ \d ->
+   let xs = [ (s, a) | (_, s, a) <- triples d ]
+   in xmlEncoder // (xs ::: typed)
+
+encodeDerivationText :: XMLEncoder a (Derivation String (Context a))
+encodeDerivationText = encoderFor $ \d -> encodeAsList
+   [ ("ruletext" .=. s) <> encodeContext // a
+   | (_, s, a) <- triples d
+   ]
+
+ruleShortInfo :: XMLEncoder a (Rule (Context a))
+ruleShortInfo = simpleEncoder $ \r -> mconcat
+   [ "name"        .=. showId r
+   , "buggy"       .=. showBool (isBuggy r)
+   , "arguments"   .=. show (length (getRefs r))
+   , "rewriterule" .=. showBool (isRewriteRule r)
+   ]
+
+encodeDifficulty :: XMLEncoder a Difficulty
+encodeDifficulty = simpleEncoder $ \d ->
+   "difficulty" .=. show d
+
+encodeText :: XMLEncoder a Text
+encodeText = encoderFor $ \txt ->
+   mconcat [ encodeItem // item | item <- textItems txt ]
+ where
+   encodeItem = encoderStateFor $ \xp item -> return $
+      case item of
+         TextTerm a -> fromMaybe (text item) $ do
+            v <- hasTermView (getExercise xp)
+            b <- match v a
+            return (encodeTerm xp b)
+         _ -> text item
+
+encodeMessage :: XMLEncoder a FeedbackText.Message
+encodeMessage = encoderFor $ \msg ->
+   element "message"
+      [ case FeedbackText.accept msg of
+           Just b  -> "accept" .=. showBool b
+           Nothing -> mempty
+      , encodeText // FeedbackText.text msg
+      ]
+
+encodeDiagnosis :: XMLEncoder a (Diagnosis a)
+encodeDiagnosis = encoderFor $ \diagnosis ->
+   case diagnosis of
+      Buggy env r -> element "buggy"
+         [encodeEnvironment // env, "ruleid" .=. showId r]
+      NotEquivalent ->
+         return (emptyTag "notequiv")
+      Similar b st -> element "similar"
+         ["ready" .=. showBool b, encodeState // st]
+      Expected b st r -> element "expected"
+         ["ready" .=. showBool b, encodeState // st, "ruleid" .=. showId r]
+      Detour b st env r -> element "detour"
+         [ "ready" .=. showBool b, encodeState // st
+         , encodeEnvironment // env, "ruleid" .=. showId r
+         ]
+      Correct b st -> element "correct"
+         ["ready" .=. showBool b, encodeState // st]
+
+encodeDecompositionReply :: XMLEncoder a (PD.Reply a)
+encodeDecompositionReply = encoderFor $ \reply ->
+   case reply of
+      PD.Ok loc st ->
+         element "correct" [encLoc loc, encodeState // st]
+      PD.Incorrect eq loc st env ->
+         element "incorrect"
+            [ "equivalent" .=. showBool eq
+            , encLoc loc
+            , encodeState // st
+            , encodeEnvironment // env
+            ]
+ where
+    encLoc = tag "location" . text
+
+exerciseInfo :: XMLEncoder a (Exercise b)
+exerciseInfo = encoderFor $ \ex -> mconcat
+   [ "exerciseid"  .=. showId ex
+   , "description" .=. description ex
+   , "status"      .=. show (status ex)
+   ]
+
+------------------------------------------------
+-- helpers
+
+encodeAsList :: [XMLEncoder a t] -> XMLEncoder a t
+encodeAsList = element "list" . map (tag "elem")
+
+showBool :: Bool -> String
+showBool = map toLower . show
+ src/Ideas/Encoding/Evaluator.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE GADTs, RankNTypes #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.Evaluator
+   ( EncoderState, simpleEncoder, maybeEncoder, eitherEncoder
+   , encoderFor, encoderStateFor, encodeTyped
+   , runEncoderState, runEncoderStateM, (//)
+   , getState, withState
+     -- re-export
+   , pure, (<$>), (<**>)
+   , module Data.Monoid, liftA2
+     -- old
+   , Evaluator(..), evalService
+   ) where
+
+import Control.Applicative hiding (Const)
+import Control.Arrow
+import Control.Monad
+import Data.List
+import Data.Monoid
+import Ideas.Common.Classes
+import Ideas.Service.Types
+import Ideas.Text.XML
+import qualified Control.Category as C
+
+newtype EncoderState st a b = Enc (st -> a -> Either [String] b)
+
+instance C.Category (EncoderState st) where
+   id = Enc $ const Right
+   Enc f . Enc g = Enc $ \st -> either Left (f st) . g st
+
+instance Arrow (EncoderState st) where
+   arr f = Enc $ \_ -> Right . f
+   first  (Enc f) = Enc $ \st (a, c) -> fmap (\b -> (b, c)) (f st a)
+   second (Enc f) = Enc $ \st (a, b) -> fmap (\c -> (a, c)) (f st b)
+   Enc f *** Enc g = Enc $ \st (a, b) ->
+      case (f st a, g st b) of
+         (Right c, Right d) -> Right (c, d)
+         (Left err, _)      -> Left err
+         (_, Left err)      -> Left err
+
+instance ArrowZero (EncoderState st) where
+   zeroArrow = Enc $ \_ _ -> Left []
+
+instance ArrowPlus (EncoderState st) where
+   Enc f <+> Enc g = Enc $ \st a ->
+      case (f st a, g st a) of
+         (Right b, _      ) -> Right b
+         (_,       Right b) -> Right b
+         (Left e1, Left e2) -> Left (e1 ++ e2)
+
+instance ArrowChoice (EncoderState st) where
+   left  (Enc f) = Enc $ \st -> either (fmap Left . f st) (Right . Right)
+   right (Enc f) = Enc $ \st -> either (Right . Left) (fmap Right . f st)
+   Enc f +++ Enc g = Enc $ \st -> either (fmap Left . f st) (fmap Right . g st)
+
+instance ArrowApply (EncoderState st) where
+   app = Enc $ \st (Enc f, a) -> f st a
+
+instance Functor (EncoderState st a) where
+   fmap = liftA
+
+instance Applicative (EncoderState st a) where
+   pure    = arr . const
+   f <*> g = f &&& g >>> arr (uncurry ($))
+
+instance Monoid b => Monoid (EncoderState st a b) where
+   mempty  = pure mempty
+   mappend = liftA2 (<>)
+
+instance Monad (EncoderState st a) where
+   return = pure
+   fail s = Enc $ \_ _ -> Left [ s | not (null s) ]
+   Enc f >>= g = Enc $ \st a ->
+      case f st a of
+         Left err -> Left err
+         Right b  -> let Enc h = g b in h st a
+
+instance MonadPlus (EncoderState st a) where
+   mzero = zeroArrow
+   mplus = (<+>)
+
+instance BuildXML b => BuildXML (EncoderState st a b) where
+   n .=. s   = return (n .=. s)
+   unescaped = return . unescaped
+   builder   = return . builder
+   tag       = liftM . tag
+
+getState :: EncoderState st a st
+getState = Enc $ const . Right
+
+withState :: (st -> b) -> EncoderState st a b
+withState f = liftM f getState
+
+runEncoderState :: EncoderState st a b -> st -> a -> Either String b
+runEncoderState (Enc f) st = mapFirst (intercalate ", ") . f st
+
+---
+
+simpleEncoder :: (a -> b) -> EncoderState st a b
+simpleEncoder = arr
+
+maybeEncoder :: (a -> Maybe b) -> EncoderState st a b
+maybeEncoder f = C.id >>= maybe mzero return . f
+
+eitherEncoder :: (a -> Either String b) -> EncoderState st a b
+eitherEncoder f = C.id >>= either fail return . f
+
+encoderFor :: (a -> EncoderState st a b) -> EncoderState st a b
+encoderFor = encoderStateFor . const
+
+encoderStateFor :: (st -> a -> EncoderState st a b) -> EncoderState st a b
+encoderStateFor f = do
+   st <- getState
+   a  <- C.id
+   f st a
+
+runEncoderStateM :: Monad m => EncoderState st a b -> st -> a -> m b
+runEncoderStateM f st = either fail return . runEncoderState f st
+
+encodeTyped :: Typed a t => EncoderState st t b -> EncoderState st (TypedValue (Type a)) b
+encodeTyped enc = fromTyped >>> enc
+
+infixl 8 //
+
+(//) :: EncoderState st a c -> a -> EncoderState st b c
+f // a = arr (const a) >>> f
+
+----
+
+fromTyped :: Typed a t => EncoderState st (TypedValue (Type a)) t
+fromTyped = maybeEncoder $ \(val ::: tp) -> fmap ($ val) (equal tp typed)
+
+-------------------------------------------------------------------
+
+evalService :: Monad m => Evaluator a m b -> Service -> m b
+evalService f = eval f . serviceFunction
+
+data Evaluator a m b where
+   Evaluator :: (TypedValue (Type a) -> m b)  -- encoder
+             -> (forall t . Type a t -> m t)  -- decoder
+             -> Evaluator a m b
+
+{-
+type Fix a = a -> a
+
+encodeTypeRep :: Monoid a => (TypedValue f -> a) -> TypedValue (TypeRep f) -> a
+encodeTypeRep = fix . encodeTypeRepFix
+
+encodeTypeRepFix :: Monoid a => (TypedValue f -> a) -> Fix (TypedValue (TypeRep f) -> a)
+encodeTypeRepFix enc rec (val ::: tp) =
+   case tp of
+      _ :-> _    -> mempty
+      t1 :|: t2  -> case val of
+                       Left a  -> rec (a ::: t1)
+                       Right a -> rec (a ::: t2)
+      Pair t1 t2 -> rec (fst val ::: t1) <> rec (snd val ::: t2)
+      List t     -> mconcat (map (rec . (::: t)) val)
+      Tree t     -> F.fold (fmap (rec . (::: t)) val)
+      Unit       -> mempty
+      Tag _ t    -> rec (val ::: t)
+      Iso v t    -> rec (to v val ::: t)
+      Const ctp  -> enc (val ::: ctp)
+
+encodeWith :: (Monad m, Typed a t) => (t -> m b) -> TypedValue (Type a) -> m b
+encodeWith enc (val ::: tp) =
+   case equal tp typed of
+      Just f  -> enc (f val)
+      Nothing -> fail "encoding failed" -}
+
+eval :: Monad m => Evaluator a m b -> TypedValue (Type a) -> m b
+eval f@(Evaluator enc dec) tv@(val ::: tp) =
+   case tp of
+      -- handle exceptions
+      Const String :|: t ->
+         either fail (\a -> eval f (a ::: t)) val
+      -- uncurry function if possible
+      t1 :-> t2 :-> t3 ->
+         eval f (uncurry val ::: Pair t1 t2 :-> t3)
+      t1 :-> t2 -> do
+         a <- dec t1
+         eval f (val a ::: t2)
+      _ ->
+         enc tv
+ src/Ideas/Encoding/LinkManager.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE RankNTypes #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Manages links to information
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.LinkManager
+   ( LinkManager(..)
+   , dynamicLinks, stateToXML
+   , staticLinks, linksUp, pathLevel, (</>)
+     -- links to services and exercises
+   , linkToIndex, linkToExercises, linkToServices, linkToService
+     -- links to exercise information
+   , linkToExercise, linkToStrategy, linkToRules, linkToExamples
+   , linkToDerivations, linkToRule, linkToRandomExample
+     -- links to state information (dynamic)
+   , linkToState, linkToFirsts, linkToApplications, linkToDerivation
+   ) where
+
+import Data.Maybe
+import Ideas.Common.Library
+import Ideas.Encoding.EncoderXML
+import Ideas.Encoding.Evaluator
+import Ideas.Service.State
+import Ideas.Service.Types
+import Ideas.Text.HTML
+import Ideas.Text.XML
+
+data LinkManager = LinkManager
+   { urlForResource      :: String -> String
+   , urlForRequest       :: String
+   , isStatic            :: Bool
+     -- links to services and exercises
+   , urlForIndex         :: String
+   , urlForExercises     :: String
+   , urlForServices      :: String
+   , urlForService       :: Service -> String
+     -- links to exercise information
+   , urlForExercise      :: forall a . Exercise a -> String
+   , urlForStrategy      :: forall a . Exercise a -> String
+   , urlForRules         :: forall a . Exercise a -> String
+   , urlForExamples      :: forall a . Exercise a -> String
+   , urlForDerivations   :: forall a . Exercise a -> String
+   , urlForRule          :: forall a . Exercise a -> Rule (Context a) -> String
+     -- dynamic exercise information
+   , urlForRandomExample :: forall a . Exercise a -> Difficulty -> String
+     -- dynamic state information
+   , urlForState         :: forall a . State a -> String
+   , urlForFirsts        :: forall a . State a -> String
+   , urlForApplications  :: forall a . State a -> String
+   , urlForDerivation    :: forall a . State a -> String
+   }
+
+---------------------------------------------------------------------
+-- links to services and exercises
+
+linkToIndex :: LinkManager -> HTMLBuilder -> HTMLBuilder
+linkToIndex = linkWith urlForIndex
+
+linkToExercises :: LinkManager -> HTMLBuilder -> HTMLBuilder
+linkToExercises = linkWith urlForExercises
+
+linkToServices :: LinkManager -> HTMLBuilder -> HTMLBuilder
+linkToServices = linkWith urlForServices
+
+linkToService :: LinkManager -> Service -> HTMLBuilder -> HTMLBuilder
+linkToService = linkWith . urlForService
+
+---------------------------------------------------------------------
+-- links to exercise information
+
+linkToExercise :: LinkManager -> Exercise a -> HTMLBuilder -> HTMLBuilder
+linkToExercise = linkWith . urlForExercise
+
+linkToStrategy :: LinkManager -> Exercise a -> HTMLBuilder -> HTMLBuilder
+linkToStrategy = linkWith . urlForStrategy
+
+linkToRules :: LinkManager -> Exercise a -> HTMLBuilder -> HTMLBuilder
+linkToRules = linkWith . urlForRules
+
+linkToExamples :: LinkManager -> Exercise a -> HTMLBuilder -> HTMLBuilder
+linkToExamples = linkWith . urlForExamples
+
+linkToDerivations :: LinkManager -> Exercise a -> HTMLBuilder -> HTMLBuilder
+linkToDerivations = linkWith . urlForDerivations
+
+linkToRule :: LinkManager -> Exercise a -> Rule (Context a) -> HTMLBuilder -> HTMLBuilder
+linkToRule lm = linkWith . urlForRule lm
+
+---------------------------------------------------------------------
+-- dynamic exercise information
+
+linkToRandomExample :: LinkManager -> Exercise a -> Difficulty -> HTMLBuilder -> HTMLBuilder
+linkToRandomExample lm = linkWith . urlForRandomExample lm
+
+---------------------------------------------------------------------
+-- links to state information (dynamic)
+
+linkToState :: LinkManager -> State a -> HTMLBuilder -> HTMLBuilder
+linkToState = linkWith . urlForState
+
+linkToFirsts :: LinkManager -> State a -> HTMLBuilder -> HTMLBuilder
+linkToFirsts = linkWith . urlForFirsts
+
+linkToApplications :: LinkManager -> State a -> HTMLBuilder -> HTMLBuilder
+linkToApplications = linkWith . urlForApplications
+
+linkToDerivation :: LinkManager -> State a -> HTMLBuilder -> HTMLBuilder
+linkToDerivation = linkWith . urlForDerivation
+
+---------------------------------------------------------------------
+-- Dynamic links
+
+dynamicLinks :: String -> LinkManager
+dynamicLinks cgiBinary = LinkManager
+   { isStatic        = False
+   , urlForRequest   = prefix
+   , urlForResource  = id
+   , urlForIndex     = url $ simpleRequest "index"
+   , urlForExercises = url $ simpleRequest "exerciselist"
+   , urlForServices  = url $ simpleRequest "servicelist"
+   , urlForService   =
+        url . makeRequest "serviceinfo" . tag "location" . text
+   , urlForExercise    = url . exerciseRequest "exerciseinfo"
+   , urlForStrategy    = url . exerciseRequest "strategyinfo"
+   , urlForRules       = url . exerciseRequest "rulelist"
+   , urlForExamples    = url . exerciseRequest "examples"
+   , urlForDerivations = url . exerciseRequest "examplederivations"
+   , urlForRule = \ex r ->
+        url $ exerciseRequestWith "ruleinfo" ex $
+           tag "ruleid" $ text r
+   , urlForRandomExample = \ex d ->
+        url $ exerciseRequestWith "generate" ex $
+           "difficulty" .=. show d
+   , urlForState        = url . stateRequest "stateinfo"
+   , urlForFirsts       = url . stateRequest "allfirsts"
+   , urlForApplications = url . stateRequest "allapplications"
+   , urlForDerivation   = url . stateRequest "derivation"
+   }
+ where
+   prefix  = cgiBinary ++ "?input="
+   url req = prefix ++ show req
+
+simpleRequest :: String -> XML
+simpleRequest s = makeRequest s mempty
+
+makeRequest :: String -> XMLBuilder -> XML
+makeRequest s rest = makeXML "request" $
+   ("service"  .=. s) <>
+   ("encoding" .=. "html") <>
+   rest
+
+exerciseRequest :: String -> Exercise a -> XML
+exerciseRequest s ex = makeRequest s ("exerciseid" .=. showId ex)
+
+exerciseRequestWith :: String -> Exercise a -> XMLBuilder -> XML
+exerciseRequestWith s ex rest =
+   makeRequest s (("exerciseid" .=. showId ex) <> rest)
+
+stateRequest :: String -> State a -> XML
+stateRequest s state =
+   exerciseRequestWith s (exercise state) (stateToXML state)
+
+-- assume nothing goest wrong
+stateToXML :: State a -> XMLBuilder
+stateToXML st = fromMaybe mempty (runEncoderStateM encodeState xes st)
+ where
+   enc = tag "expr" . string . prettyPrinter (exercise st)
+   xes = XMLEncoderState (exercise st) False enc
+
+linkWith :: (a -> String) -> a -> HTMLBuilder -> HTMLBuilder
+linkWith f = link . escapeInURL . f
+
+escapeInURL :: String -> String
+escapeInURL = concatMap f
+ where
+   f '+' = "%2B"
+   f '>' = "%3E"
+   f '&' = "%26"
+   f '%' = "%25"
+   f '#' = "%23"
+   f ';' = "%3B"
+   f c   = [c]
+
+---------------------------------------------------------------------
+-- Static links
+
+staticLinks :: LinkManager
+staticLinks = LinkManager
+   { isStatic        = True
+   , urlForResource  = 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
+     -- dynamic exercise information
+   , urlForRandomExample = \_ _ -> ""
+     -- dynamic state information
+   , urlForState        = const ""
+   , urlForFirsts       = const ""
+   , urlForApplications = const ""
+   , urlForDerivation   = const ""
+   }
+
+linksUp :: Int -> LinkManager -> LinkManager
+linksUp n lm = lm
+   { isStatic        = isStatic lm
+   , urlForResource  = f1 urlForResource
+     -- 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
+   }
+ 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
+ src/Ideas/Encoding/ModeJSON.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Services using JSON notation
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.ModeJSON (processJSON) where
+
+import Control.Monad
+import Data.Char
+import Ideas.Common.Library hiding (exerciseId)
+import Ideas.Common.Utils (Some(..), timedSeconds)
+import Ideas.Encoding.DecoderJSON
+import Ideas.Encoding.EncoderJSON
+import Ideas.Encoding.Evaluator
+import Ideas.Service.DomainReasoner
+import Ideas.Service.Request
+import Ideas.Text.JSON
+import System.Random hiding (getStdGen)
+
+processJSON :: Bool -> DomainReasoner -> String -> IO (Request, String, String)
+processJSON cgiMode dr input = do
+   json <- either fail return (parseJSON input)
+   req  <- jsonRequest json
+   resp <- jsonRPC json (myHandler dr)
+   let f   = if cgiMode then showCompact else showPretty
+       out = addVersion (version dr) (toJSON resp)
+   return (req, f out, "application/json")
+
+-- TODO: Clean-up code
+extractExerciseId :: Monad m => JSON -> m Id
+extractExerciseId json =
+   case json of
+      String s -> return (newId s)
+      Array [String _, String _, a@(Array _)] -> extractExerciseId a
+      Array [String _, String _, _, a@(Array _)] -> extractExerciseId a
+      Array (String s:tl) | any p s -> extractExerciseId (Array tl)
+      Array (hd:_) -> extractExerciseId hd
+      _ -> fail "no code"
+ where
+   p c = not (isAlphaNum c || isSpace c || c `elem` ".-")
+
+addVersion :: String -> JSON -> JSON
+addVersion str json =
+   case json of
+      Object xs -> Object (xs ++ [info])
+      _         -> json
+ where
+   info = ("version", String str)
+
+jsonRequest :: Monad m => JSON -> m Request
+jsonRequest json = do
+   srv  <- case lookupM "method" json of
+              Just (String s) -> return s
+              _               -> fail "Invalid method"
+   let a = lookupM "params" json >>= extractExerciseId
+   enc  <- case lookupM "encoding" json of
+              Nothing         -> return Nothing
+              Just (String s) -> liftM Just (readEncoding s)
+              _               -> fail "Invalid encoding"
+   src  <- case lookupM "source" json of
+              Nothing         -> return Nothing
+              Just (String s) -> return (Just s)
+              _               -> fail "Invalid source"
+   return Request
+      { service    = srv
+      , exerciseId = a
+      , source     = src
+      , dataformat = JSON
+      , encoding   = enc
+      }
+
+myHandler :: DomainReasoner -> RPCHandler IO
+myHandler dr fun arg = timedSeconds 5 $ do
+   srv <- findService dr (newId fun)
+   Some ex <-
+      if fun == "exerciselist"
+      then return (Some emptyExercise)
+      else extractExerciseId arg >>= findExercise dr
+   script <- defaultScript dr (getId ex)
+   stdgen <- newStdGen
+   let jds = JSONDecoderState ex script stdgen
+   runEncoderStateM (evalService (jsonConverter ex) srv) jds arg
+
+jsonConverter :: Exercise a -> Evaluator a (JSONDecoder a) JSON
+jsonConverter ex = Evaluator
+   (runEncoderStateM jsonEncoder (String . prettyPrinter ex))
+   jsonDecoder
+ src/Ideas/Encoding/ModeXML.hs view
@@ -0,0 +1,153 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Services using XML notation
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.ModeXML (processXML) where
+
+import Control.Monad
+import Control.Monad.Error
+import Data.Maybe
+import Ideas.Common.Library hiding (exerciseId, (:=))
+import Ideas.Common.Utils (Some(..), timedSeconds)
+import Ideas.Encoding.DecoderXML
+import Ideas.Encoding.EncoderHTML
+import Ideas.Encoding.EncoderXML
+import Ideas.Encoding.Evaluator
+import Ideas.Encoding.LinkManager
+import Ideas.Encoding.OpenMathSupport
+import Ideas.Service.DomainReasoner
+import Ideas.Service.FeedbackScript.Parser (parseScriptSafe)
+import Ideas.Service.FeedbackScript.Syntax (Script)
+import Ideas.Service.Request
+import Ideas.Text.HTML
+import Ideas.Text.OpenMath.Object
+import Ideas.Text.XML
+import System.IO.Error
+import System.Random (StdGen, newStdGen)
+
+processXML :: DomainReasoner -> Maybe String -> String -> IO (Request, String, String)
+processXML dr cgiBin input = do
+   xml  <- either fail return (parseXML input)
+   req  <- either fail return (xmlRequest xml)
+   resp <- timedSeconds 5 (xmlReply dr cgiBin req xml)
+    `catchError` (return . resultError . ioeGetErrorString)
+   case encoding req of
+      Just HTMLEncoding ->
+         return (req, show resp, "text/html")
+      _ -> let out = addVersion (version dr) resp
+               f   = if isNothing cgiBin then showXML else show
+           in return (req, f out, "application/xml")
+
+addVersion :: String -> XML -> XML
+addVersion s xml =
+   let info = [ "version" := s ]
+   in xml { attributes = attributes xml ++ info }
+
+xmlRequest :: XML -> Either String Request
+xmlRequest xml = do
+   unless (name xml == "request") $
+      fail "expected xml tag request"
+   srv  <- findAttribute "service" xml
+   let a = extractExerciseId xml
+   enc  <- case findAttribute "encoding" xml of
+              Just s  -> liftM Just (readEncoding s)
+              Nothing -> return Nothing
+   return Request
+      { service    = srv
+      , exerciseId = a
+      , source     = findAttribute "source" xml
+      , dataformat = XML
+      , encoding   = enc
+      }
+
+xmlReply :: DomainReasoner -> Maybe String -> Request -> XML -> IO XML
+xmlReply dr cgiBin request xml = do
+   srv <- findService dr (newId (service request))
+   Some ex  <-
+      case exerciseId request of
+         Just code -> findExercise dr code
+         Nothing
+            | service request `elem` ["exerciselist", "servicelist", "serviceinfo", "index"] ->
+                 return (Some emptyExercise)
+            | otherwise ->
+                 fail "unknown exercise code"
+   script <- case findAttribute "script" xml of
+                Just s  -> parseScriptSafe s
+                Nothing
+                   | getId ex == mempty -> return mempty
+                   | otherwise          -> defaultScript dr (getId ex)
+   stdgen <- newStdGen
+   case encoding request of
+      Just StringEncoding -> do
+         res <- evalService (stringFormatConverter script ex stdgen xml) srv
+         return (resultOk res)
+
+      Just HTMLEncoding -> do
+         res <- evalService (htmlConverter dr cgiBin script ex stdgen xml) srv
+         return (toXML res)
+
+      _ -> do
+         res <- evalService (openMathConverter True script ex stdgen xml) srv
+         return (resultOk res)
+
+extractExerciseId :: Monad m => XML -> m Id
+extractExerciseId = liftM newId . findAttribute "exerciseid"
+
+resultOk :: XMLBuilder -> XML
+resultOk body = makeXML "reply" $
+   ("result" .=. "ok")
+   <> body
+
+resultError :: String -> XML
+resultError txt = makeXML "reply" $
+   ("result" .=. "error")
+   <> tag "message" (string txt)
+
+------------------------------------------------------------
+-- Mixing abstract syntax (OpenMath format) and concrete syntax (string)
+
+stringFormatConverter :: Script -> Exercise a -> StdGen -> XML -> Evaluator a IO XMLBuilder
+stringFormatConverter script ex stdgen xml =
+   Evaluator (runEncoderStateM xmlEncoder xes)
+             (\tp -> runEncoderStateM (xmlDecoder tp) xds xml)
+ where
+   xes = XMLEncoderState ex False (tag "expr" . string . prettyPrinter ex)
+   xds = XMLDecoderState ex script stdgen False g
+   g = (liftM getData . findChild "expr") >=> parser ex
+
+htmlConverter :: DomainReasoner -> Maybe String -> Script -> Exercise a -> StdGen -> XML -> Evaluator a IO HTMLPage
+htmlConverter dr cgiBin script ex stdgen xml =
+   Evaluator (return . htmlEncoder lm dr ex) d
+ where
+   lm = maybe staticLinks dynamicLinks cgiBin
+   Evaluator _ d = stringFormatConverter script ex stdgen xml
+
+openMathConverter :: Bool -> Script -> Exercise a -> StdGen -> XML -> Evaluator a IO XMLBuilder
+openMathConverter withMF script ex stdgen xml =
+   Evaluator (runEncoderStateM xmlEncoder xes)
+             (\tp -> runEncoderStateM (xmlDecoder tp) xds xml)
+ where
+   xes = XMLEncoderState ex True h
+   xds = XMLDecoderState ex script stdgen True g
+   h a = case toOpenMath ex a of
+            Left _      -> error "Error encoding term in OpenMath" -- fix me!
+            Right omobj -> builder (toXML (handleMixedFractions omobj))
+   g xml0 = do
+      xob <- findChild "OMOBJ" xml0
+      case xml2omobj xob of
+         Left  msg   -> Left msg
+         Right omobj ->
+            case fromOpenMath ex omobj of
+              Just a  -> Right a
+              Nothing -> Left "Invalid OpenMath object for this exercise"
+   -- Remove special mixed-fraction symbol (depending on boolean argument)
+   handleMixedFractions = if withMF then id else noMixedFractions
+ src/Ideas/Encoding/OpenMathSupport.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE Rank2Types #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.OpenMathSupport
+   ( -- * Conversion functions to/from OpenMath
+     toOpenMath, fromOpenMath, noMixedFractions
+   , toOMOBJ, fromOMOBJ
+   ) where
+
+import Control.Monad
+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 qualified Ideas.Text.OpenMath.Dictionary.List1 as OM
+import qualified Ideas.Text.OpenMath.Symbol as OM
+
+-----------------------------------------------------------------------------
+-- Utility functions for conversion to/from OpenMath
+
+toOpenMath :: Monad m => Exercise a -> a -> m OMOBJ
+toOpenMath ex a = do
+   v <- hasTermViewM ex
+   return (toOMOBJ (build v a))
+
+fromOpenMath :: MonadPlus m => Exercise a -> OMOBJ -> m a
+fromOpenMath ex omobj = do
+   v <- hasTermViewM ex
+   a <- fromOMOBJ omobj
+   matchM v a
+
+toOMOBJ :: IsTerm a => a -> OMOBJ
+toOMOBJ = rec . toTerm
+ where
+   rec term =
+      case term of
+         TVar s    -> OMV s
+         TCon s xs
+            | null xs   -> OMS (idToSymbol (getId s))
+            | otherwise -> make (OMS (idToSymbol (getId s)):map rec xs)
+         TMeta i   -> OMV ('$' : show i)
+         TNum n    -> OMI n
+         TFloat d  -> OMF d
+         TList xs  -> rec (function (newSymbol OM.listSymbol) xs)
+
+   make [OMS s, OMV x, body] | s == lambdaSymbol =
+      OMBIND (OMS s) [x] body
+   make xs = OMA xs
+
+fromOMOBJ :: (MonadPlus m, IsTerm a) => OMOBJ -> m a
+fromOMOBJ = (>>= fromTerm) . rec
+ where
+   rec omobj =
+      case omobj of
+         OMV x  -> case isMeta x of
+                      Just n  -> return (TMeta n)
+                      Nothing -> return (TVar x)
+         OMS s  -> return (symbol (newSymbol (OM.dictionary s, OM.symbolName s)))
+         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)
+                      _ -> fail "Invalid OpenMath object"
+         OMBIND binder xs body ->
+            rec (OMA (binder:map OMV xs++[body]))
+
+   isMeta ('$':xs) = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- '
+   isMeta _        = Nothing
+
+noMixedFractions :: OMOBJ -> OMOBJ
+noMixedFractions = transform f
+ where
+   f (OMA [OMS s, a, b, c]) | s == mfSymbol =
+      OMA [OMS plusSymbol, a, OMA [OMS divideSymbol, b, c]]
+   f a = a
+
+idToSymbol :: Id -> OM.Symbol
+idToSymbol a
+   | null (qualifiers a) =
+        OM.extraSymbol (unqualified a)
+   | otherwise =
+        OM.makeSymbol (qualification a) (unqualified a)
+
+hasTermViewM  :: Monad m => Exercise a -> m (View Term a)
+hasTermViewM = maybe (fail "No support for terms") return . hasTermView
+
+mfSymbol :: OM.Symbol
+mfSymbol = OM.makeSymbol "extra" "mixedfraction"
+ src/Ideas/Encoding/RulePresenter.hs view
@@ -0,0 +1,108 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.RulePresenter (ruleToHTML) where
+
+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
+ruleToHTML ex r = mconcat
+   [ rewriteRuleToHTML (not $ isBuggy r) ex rr
+   | Some rr <- getRewriteRules (transformation r)
+   ]
+
+rewriteRuleToHTML :: Bool -> Some Exercise -> RewriteRule a -> HTMLBuilder
+rewriteRuleToHTML sound ex r =
+   showTerm ex lhs <> spaces 3 <>
+   showLeadsTo sound <> spaces 3 <>
+   showTerm ex rhs <> br
+ where
+   lhs :~> rhs = ruleSpecTerm r
+
+showLeadsTo :: Bool -> HTMLBuilder
+showLeadsTo sound = string (if sound then "\x21D2" else "\x21CF")
+
+showTerm :: Some Exercise -> Term -> HTMLBuilder
+showTerm (Some ex) = string . rec
+ where
+   rec term =
+      case term of
+         TVar s    -> s
+         TNum i    -> show i
+         TFloat a  -> show a
+         TMeta n   -> showMeta ex n
+         TCon s xs -> concatMap (either id recp) $
+                      let txt = spaced (Left (show s) : map Right xs)
+                      in fromMaybe txt (specialSymbol s xs)
+         TList xs  -> "[" ++ intercalate ", " (map rec xs) ++ "]"
+
+   recp term = parIf (isCon term) (rec term)
+   spaced    = intersperse (Left " ")
+
+   isCon (TCon _ xs) = not (null xs)
+   isCon _           = False
+
+   parIf b s = if b then "(" ++ s ++ ")" else s
+
+specialSymbol :: Symbol -> [Term] -> Maybe [Either String Term]
+-- constants
+specialSymbol s []
+   | sameSymbol s "logic1.true"     = con "T"
+   | sameSymbol s "logic1.false"    = con "F"
+   | sameSymbol s "relalg.universe" = con "V" -- universe
+   | sameSymbol s "relalg.ident"    = con "I" -- identity
+ where
+   con x = return [Left x]
+-- unary symbols
+specialSymbol s [a]
+   | sameSymbol s "logic1.not"         = pref "\172" -- "~"
+   | sameSymbol s "arith1.unary_minus" = pref "-"
+   | sameSymbol s "relalg.not"         = post "\x203E"
+   | sameSymbol s "relalg.inv"         = post "~"
+ where
+   pref x  = return [Left x, Right a]
+   post x = return [Right a, Left x]
+-- binary symbols
+specialSymbol s [a, b]
+   | sameSymbol s "logic1.or"         = bin " \8744 " -- "||"
+   | sameSymbol s "logic1.and"        = bin " \8743 " -- "&&"
+   | sameSymbol s "logic1.implies"    = bin " \8594 " -- "->"
+   | sameSymbol s "logic1.equivalent" = bin " \8596 " -- "<->"
+   | sameSymbol s "relation1.eq"      = bin " = "
+   | sameSymbol s "arith1.plus"       = bin "+"
+   | sameSymbol s "arith1.minus"      = bin "-"
+   | sameSymbol s "arith1.power"      = bin "^"
+   | sameSymbol s "arith1.times"      = bin "\x00B7" -- "*"
+   | sameSymbol s "arith1.divide"     = bin "/"
+   | sameSymbol s "relalg.conj"       = bin " \x2229 " -- intersect
+   | sameSymbol s "relalg.disj"       = bin " \x222A " -- union
+   | sameSymbol s "relalg.comp"       = bin " ; " -- composition
+   | sameSymbol s "relalg.add"        = bin " \x2020 " -- relative addition/dagger
+ where
+   bin x = return [Right a, Left x, Right b]
+
+specialSymbol s1 [TCon s2 [x, a]]
+   | sameSymbol s1 "calculus1.diff" && sameSymbol s2 "fns1.lambda" =
+        return [Left "D(", Right x, Left ") ", Right a]
+specialSymbol _ _ = Nothing
+
+sameSymbol :: Symbol -> String -> Bool
+sameSymbol = (==) . show
+
+showMeta :: Exercise a -> Int -> String
+showMeta ex n
+   | listToMaybe (qualifiers ex) == Just "logic" = [ [c] | c <- ['p'..] ] !! n
+   | listToMaybe (qualifiers ex) == Just "relationalgebra" = [ [c] | c <- ['r'..] ] !! n
+   | otherwise = [ [c] | c <- ['a'..] ] !! n
+ src/Ideas/Encoding/RulesInfo.hs view
@@ -0,0 +1,76 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.RulesInfo
+   ( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap
+   ) where
+
+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
+import Ideas.Text.XML hiding (name)
+import qualified Data.Map as M
+
+rulesInfoXML :: Exercise a -> (a -> XMLBuilder) -> XMLBuilder
+rulesInfoXML ex enc = mconcat (map ruleInfoXML (ruleset ex))
+ where
+   ruleInfoXML r = element "rule"
+      [ "name"        .=. showId r
+      , "buggy"       .=. f (isBuggy r)
+      , "rewriterule" .=. f (isRewriteRule r)
+        -- More information
+      , let descr = description r
+            -- to do: rules should carry descriptions
+            txt   = if null descr then showId r else descr
+        in munless (null txt) $
+              tag "description" $ string txt
+      , mconcat [ tag "argument" (text a) | Some a <- getRefs r ]
+      , mconcat [ tag "sibling" $ text s | s <- ruleSiblings r ]
+      -- FMPs and CMPs
+      , mconcat [  case showRewriteRule ok rr of
+                      Nothing -> mempty
+                      Just s  -> tag "CMP" (string s)
+                <> tag "FMP" (builder (omobj2xml (toObject fmp)))
+                | Some rr <- getRewriteRules (transformation r)
+                , let ok  = not $ isBuggy r
+                , let fmp = rewriteRuleToFMP ok rr
+                ]
+      -- Examples
+      , mconcat [ element "example" [enc a, enc b]
+                | let pairs = M.findWithDefault [] (getId r) (collectExamples ex)
+                , (a, b) <- take 3 pairs
+                ]
+      ]
+   f = map toLower . show
+
+rewriteRuleToFMP :: Bool -> RewriteRule a -> FMP
+rewriteRuleToFMP sound r
+   | sound     = eqFMP    a b
+   | otherwise = buggyFMP a b
+ where
+   a :~> b = fmap toOMOBJ (ruleSpecTerm r)
+
+type ExampleMap a = M.Map Id [(a, a)]
+
+collectExamples :: Exercise a -> ExampleMap a
+collectExamples ex = foldr (add . snd) M.empty (examples ex)
+ where
+   add a m = let tree = derivationTree False (strategy ex) (inContext ex a)
+                 f Nothing = m
+                 f (Just d) = foldr g m (triples d)
+                 g (x, (r, _), y) =
+                    case fromContextWith2 (,) x y of
+                       Just p  -> M.insertWith (++) (getId r) [p]
+                       Nothing -> id
+             in f (derivation tree)
+ src/Ideas/Encoding/StrategyInfo.hs view
@@ -0,0 +1,179 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Converting a strategy to XML, and the other way around.
+--
+-----------------------------------------------------------------------------
+module Ideas.Encoding.StrategyInfo (strategyToXML, xmlToStrategy) where
+
+import Control.Monad
+import Data.Char
+import Data.Maybe
+import Ideas.Common.Library
+import Ideas.Common.Strategy.Abstract
+import Ideas.Common.Strategy.Core
+import Ideas.Common.Utils (readInt)
+import Ideas.Text.XML
+
+-----------------------------------------------------------------------
+-- Strategy to XML
+
+strategyToXML :: IsStrategy f => f a -> XML
+strategyToXML = coreToXML . toCore . toStrategy
+
+infoToXML :: LabelInfo -> XMLBuilder
+infoToXML info = mconcat
+   [ "name" .=. showId info
+   , mwhen (removed   info) ("removed"   .=. "true")
+   , mwhen (collapsed info) ("collapsed" .=. "true")
+   , mwhen (hidden    info) ("hidden"    .=. "true")
+   ]
+
+coreToXML :: Core LabelInfo a -> XML
+coreToXML core = makeXML "label" $
+   case core of
+      Label l a -> infoToXML l <> coreBuilder infoToXML a
+      _         -> coreBuilder infoToXML core
+
+coreBuilder :: HasId l => (l -> XMLBuilder) -> Core l a -> XMLBuilder
+coreBuilder f = rec
+ where
+   rec core =
+      case core of
+         _ :*:  _  -> asList "sequence"   isSequence
+         _ :|:  _  -> asList "choice"     isChoice
+         _ :|>: _  -> asList "orelse"     isOrElse
+         _ :%: _   -> asList "interleave" isInterleave
+         a :!%: b  -> tag "interleft"  (rec a <> rec b)
+         Many a    -> tag "many"       (rec a)
+         Repeat a  -> tag "repeat"     (rec a)
+         Label l (Rule r) | getId l == getId r
+                   -> tag "rule"       (f l)
+         Label l a -> tag "label"      (f l <> rec a)
+         Atomic a  -> tag "atomic"     (rec a)
+         Rec n a   -> tag "rec"        (("var" .=. show n) <> rec a)
+         Not a     -> tag "not"        (recNot a)
+         Rule r    -> tag "rule"       ("name" .=. show r)
+         Var n     -> tag "var"        ("var" .=. show n)
+         Succeed   -> emptyTag "succeed"
+         Fail      -> emptyTag "fail"
+    where
+      asList s g = element s (map rec (collect g core))
+      recNot = coreBuilder (const mempty)
+
+collect :: (a -> Maybe (a, a)) -> a -> [a]
+collect f = ($ []) . rec
+ where rec a = maybe (a:) (\(x, y) -> rec x . rec y) (f a)
+
+isSequence :: Core l a -> Maybe (Core l a, Core l a)
+isSequence (a :*: b) = Just (a, b)
+isSequence _ = Nothing
+
+isChoice :: Core l a -> Maybe (Core l a, Core l a)
+isChoice (a :|: b) = Just (a, b)
+isChoice _ = Nothing
+
+isOrElse :: Core l a -> Maybe (Core l a, Core l a)
+isOrElse (a :|>: b) = Just (a, b)
+isOrElse _ = Nothing
+
+isInterleave :: Core l a -> Maybe (Core l a, Core l a)
+isInterleave (a :%: b) = Just (a, b)
+isInterleave _ = Nothing
+
+-----------------------------------------------------------------------
+-- XML to strategy
+
+xmlToStrategy :: Monad m => (String -> Maybe (Rule a)) ->  XML -> m (Strategy a)
+xmlToStrategy f = liftM fromCore . readStrategy xmlToInfo g
+ where
+   g info = case f (showId info) of
+               Just r  -> return r
+               Nothing -> fail $ "Unknown rule: " ++ showId info
+
+xmlToInfo :: Monad m => XML -> m LabelInfo
+xmlToInfo xml = do
+   n <- findAttribute "name" xml
+   let boolAttr s = fromMaybe False (findBool s xml)
+   return (makeInfo n)
+      { removed   = boolAttr "removed"
+      , collapsed = boolAttr "collapsed"
+      , hidden    = boolAttr "hidden"
+      }
+
+findBool :: Monad m => String -> XML -> m Bool
+findBool attr xml = do
+   s <- findAttribute attr xml
+   case map toLower s of
+      "true"  -> return True
+      "false" -> return False
+      _       -> fail "not a boolean"
+
+readStrategy :: Monad m => (XML -> m l) -> (l -> m (Rule a)) -> XML -> m (Core l a)
+readStrategy toLabel findRule xml = do
+   xs <- mapM (readStrategy toLabel findRule) (children xml)
+   let s = name xml
+   case lookup s table of
+      Just f  -> f s xs
+      Nothing ->
+         fail $ "Unknown strategy combinator " ++ show s
+ where
+   buildSequence _ xs
+      | null xs   = return Succeed
+      | otherwise = return (foldr1 (:*:) xs)
+   buildChoice _ xs
+      | null xs   = return Fail
+      | otherwise = return (foldr1 (:|:) xs)
+   buildOrElse _ xs
+      | null xs   = return Fail
+      | otherwise = return (foldr1 (:|>:) xs)
+   buildInterleave _ xs
+      | null xs   = return Succeed
+      | otherwise = return (foldr1 (:%:) xs)
+   buildLabel x = do
+      info <- toLabel xml
+      return (Label info x)
+   buildRule = do
+      info <- toLabel xml
+      r    <- findRule info
+      return (Label info (Rule r))
+   buildRec x = do
+      s <- findAttribute "var" xml
+      i <- maybe (fail "var: not an int") return (readInt s)
+      return (Rec i x)
+   buildVar = do
+      s <- findAttribute "var" xml
+      i <- maybe (fail "var: not an int") return (readInt s)
+      return (Var i)
+
+   comb0 a _ [] = return a
+   comb0 _ s _  = fail $ "Strategy combinator " ++ s ++ "expects 0 args"
+
+   comb1 f _ [x] = return (f x)
+   comb1 _ s _   = fail $ "Strategy combinator " ++ s ++ "expects 1 arg"
+
+   join2 f g a b = join (f g a b)
+
+   table =
+      [ ("sequence",   buildSequence)
+      , ("choice",     buildChoice)
+      , ("orelse",     buildOrElse)
+      , ("interleave", buildInterleave)
+      , ("many",       comb1 Many)
+      , ("repeat",     comb1 Repeat)
+      , ("label",      join2 comb1 buildLabel)
+      , ("atomic",     comb1 Atomic)
+      , ("rec",        join2 comb1 buildRec)
+      , ("not",        comb1 (Not . noLabels))
+      , ("rule",       join2 comb0 buildRule)
+      , ("var",        join2 comb0 buildVar)
+      , ("succeed",    comb0 Succeed)
+      , ("fail",       comb0 Fail)
+      ]
+ src/Ideas/Main/BlackBoxTests.hs view
@@ -0,0 +1,101 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is 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 Control.Monad.Error
+import Data.List
+import Ideas.Common.Utils (useFixedStdGen, snd3)
+import Ideas.Common.Utils.TestSuite
+import Ideas.Encoding.ModeJSON
+import Ideas.Encoding.ModeXML
+import Ideas.Service.DomainReasoner
+import Ideas.Service.Request
+import System.Directory
+import System.IO
+
+-- Returns the number of tests performed
+blackBoxTests :: DomainReasoner -> String -> IO TestSuite
+blackBoxTests dr path = do
+   putStrLn ("Scanning " ++ path)
+   -- analyse content
+   xs0 <- getDirectoryContents path
+   let (xml,  xs1) = partition (".xml"  `isSuffixOf`) xs0
+       (json, xs2) = partition (".json" `isSuffixOf`) xs1
+   -- perform tests
+   ts1 <- forM json $ \x ->
+             doBlackBoxTest dr JSON (path ++ "/" ++ x)
+   ts2 <- forM xml $ \x ->
+             doBlackBoxTest dr XML (path ++ "/" ++ x)
+   -- recursively visit subdirectories
+   ts3 <- forM (filter ((/= ".") . take 1) xs2) $ \x -> do
+             let p = path ++ "/" ++ x
+             valid <- doesDirectoryExist p
+             if not valid
+                then return (return ())
+                else liftM (suite $ "Directory " ++ simplerDirectory p)
+                           (blackBoxTests dr p)
+   return $
+      sequence_ (ts1 ++ ts2 ++ ts3)
+
+doBlackBoxTest :: DomainReasoner -> DataFormat -> FilePath -> IO TestSuite
+doBlackBoxTest dr format path = do
+   hSetBinaryMode stdout True
+   b <- doesFileExist expPath
+   return $ if not b
+      then warn $ expPath ++ " does not exist"
+      else assertIO (stripDirectoryPart path) $ do
+         -- Comparing output with expected output
+         (h1, h2, txt, expt) <- liftIO $ do
+            useFixedStdGen -- fix the random number generator
+            h1   <- openBinaryFile path ReadMode
+            txt  <- hGetContents h1
+            h2   <- openBinaryFile expPath ReadMode
+            expt <- hGetContents h2
+            return (h1, h2, txt, expt)
+         out  <- case format of
+                    JSON -> liftM snd3 (processJSON False dr txt)
+                    XML  -> liftM snd3 (processXML dr Nothing txt)
+         -- Force evaluation of the result, to make sure that
+         -- all file handles are closed afterwards.
+         let result = out ~= expt
+         liftIO $ result `seq` (hClose h1 >> hClose h2 >> return result)
+       `catchError`
+         \_ -> return False
+ where
+   expPath = baseOf path ++ ".exp"
+   baseOf  = reverse . drop 1 . dropWhile (/= '.') . reverse
+   x ~= y  = filterVersion x == filterVersion y -- compare line-based
+
+   filterVersion =
+      let p s = not (null s || "version" `isInfixOf` s)
+      in filter p . lines . filter (/= '\r')
+
+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
+
+{-
+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 ]
+-}
+ src/Ideas/Main/Default.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE RankNTypes #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Main module for feedback services
+--
+-----------------------------------------------------------------------------
+module Ideas.Main.Default (defaultMain, newDomainReasoner) where
+
+import Control.Exception
+import Control.Monad
+import Data.IORef
+import Data.Maybe
+import Data.Time
+import Ideas.Common.Id
+import Ideas.Common.Utils (useFixedStdGen)
+import Ideas.Common.Utils.TestSuite
+import Ideas.Encoding.ModeJSON (processJSON)
+import Ideas.Encoding.ModeXML (processXML)
+import Ideas.Main.BlackBoxTests
+import Ideas.Main.Documentation
+import Ideas.Main.LoggingDatabase
+import Ideas.Main.Options hiding (fullVersion)
+import Ideas.Service.DomainReasoner
+import Ideas.Service.FeedbackScript.Analysis
+import Ideas.Service.Request
+import Network.CGI
+import Prelude hiding (catch)
+import System.IO
+import System.IO.Error (ioeGetErrorString)
+import qualified Ideas.Main.Options as Options
+
+defaultMain :: DomainReasoner -> IO ()
+defaultMain dr = do
+   startTime <- getCurrentTime
+   flags     <- getFlags
+   if null flags
+      then defaultCGI dr startTime
+      else defaultCommandLine dr flags
+
+-- Invoked as a cgi binary
+defaultCGI :: DomainReasoner -> UTCTime -> IO ()
+defaultCGI dr startTime = do
+   logRef <- newIORef (return ())
+   runCGI $ do
+      addr   <- remoteAddr       -- the IP address of the remote host making the request
+      cgiBin <- scriptName       -- get name of binary
+      raw    <- getInput "input" -- read input
+      input  <- case raw of
+                   Nothing -> fail "Invalid request: environment variable \"input\" is empty"
+                   Just s  -> return s
+      (req, txt, ctp) <- liftIO $ process dr (Just cgiBin) input
+      -- save logging action for later
+      unless (encoding req == Just HTMLEncoding) $
+         liftIO $ writeIORef logRef $
+            logMessage req input txt addr startTime
+      setHeader "Content-type" ctp
+      -- Cross-Origin Resource Sharing (CORS) prevents browser warnings
+      -- about cross-site scripting
+      setHeader "Access-Control-Allow-Origin" "*"
+      output txt
+   -- log request to database
+   join (readIORef logRef)
+   -- if something goes wrong
+ `catch` \ioe -> runCGI $ do
+   setHeader "Content-type" "text/plain"
+   setHeader "Access-Control-Allow-Origin" "*"
+   output ("Invalid request\n" ++ ioeGetErrorString ioe)
+
+-- Invoked from command-line with flags
+defaultCommandLine :: DomainReasoner -> [Flag] -> IO ()
+defaultCommandLine dr flags = do
+   hSetBinaryMode stdout True
+   useFixedStdGen -- always use a predictable "random" number generator
+   mapM_ doAction flags
+ where
+   doAction flag =
+      case flag of
+         -- information
+         Version -> putStrLn ("IDEAS, " ++ versionText)
+         Help    -> putStrLn helpText
+         -- process input file
+         InputFile file -> do
+            input <- readFile file
+            (_, txt, _) <- process dr Nothing input
+            putStrLn txt
+         -- blackbox tests
+         Test dir -> do
+            tests  <- blackBoxTests dr dir
+            result <- runTestSuiteResult tests
+            printSummary result
+         -- generate documentation pages
+         MakePages dir ->
+            makeDocumentation dr dir
+         -- feedback scripts
+         MakeScriptFor s    -> makeScriptFor dr s
+         AnalyzeScript file -> parseAndAnalyzeScript dr file
+
+process :: DomainReasoner -> Maybe String -> String -> IO (Request, String, String)
+process dr cgiBin input =
+   case discoverDataFormat input of
+      Just XML  -> processXML dr cgiBin input
+      Just JSON -> processJSON (isJust cgiBin) dr input
+      _ -> fail "Invalid input"
+
+newDomainReasoner :: IsId a => a -> DomainReasoner
+newDomainReasoner a = mempty
+   { reasonerId  = newId a
+   , version     = shortVersion
+   , fullVersion = Options.fullVersion
+   }
+ src/Ideas/Main/Documentation.hs view
@@ -0,0 +1,58 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Manages links to information
+--
+-----------------------------------------------------------------------------
+module Ideas.Main.Documentation (makeDocumentation) where
+
+import Control.Monad
+import Ideas.Common.Library
+import Ideas.Common.Utils
+import Ideas.Encoding.EncoderHTML
+import Ideas.Encoding.LinkManager
+import Ideas.Service.BasicServices
+import Ideas.Service.DomainReasoner
+import Ideas.Service.Types
+import Ideas.Text.HTML
+import System.Directory
+import System.FilePath (takeDirectory)
+
+makeDocumentation :: DomainReasoner -> String -> IO ()
+makeDocumentation dr dir = do
+   putStrLn "Generating index pages"
+   makeIndex urlForIndex     (dr ::: typed)
+   makeIndex urlForExercises (exercises dr ::: typed)
+   makeIndex urlForServices  (services dr ::: typed)
+   putStrLn "Generating service pages"
+   forM_ (services dr) $ \srv ->
+      makeIndex (`urlForService` srv) (srv ::: typed)
+   putStrLn "Generating exercise pages"
+   forM_ (exercises dr) $ \(Some ex) -> do
+      makeEx ex urlForExercise    (ex ::: typed)
+      makeEx ex urlForStrategy    (toStrategy (strategy ex) ::: typed)
+      makeEx ex urlForRules       (ruleset ex ::: typed)
+      makeEx ex urlForExamples    (map (second (inContext ex)) (examples ex) ::: typed)
+      makeEx ex urlForDerivations (exampleDerivations ex ::: typed)
+      forM_ (ruleset ex) $ \r ->
+         make ex (urlForRule lm ex r) (r ::: typed)
+ where
+   lm = staticLinks
+   makeIndex f = make emptyExercise (f lm)
+   makeEx ex f = make ex (f lm ex)
+   make ex url tv = safeWrite (dir </> url) $
+      showHTML $ htmlEncoder (linksUp (pathLevel url) lm) dr ex tv
+
+safeWrite :: FilePath -> String -> IO ()
+safeWrite filename txt = do
+   let dirpart = takeDirectory filename
+   unless (null dirpart) (createDirectoryIfMissing True dirpart)
+   putStrLn $ "- " ++ filename
+   writeFile filename txt
+ src/Ideas/Main/LoggingDatabase.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  alex.gerdes@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Facilities to create a log database
+--
+-----------------------------------------------------------------------------
+module Ideas.Main.LoggingDatabase (logMessage, logEnabled) where
+
+import Data.Time
+import Ideas.Service.Request
+#ifdef DB
+import Data.Maybe
+import Database.HDBC
+import Database.HDBC.Sqlite3 (connectSqlite3)
+
+logEnabled :: Bool
+logEnabled = True
+
+-- | Log a message to the database (a Sqlite database).
+logMessage :: Request -> String -> String -> String -> UTCTime -> IO ()
+logMessage req input output ipaddress begin = do
+     -- make a connection with the database
+     conn <- connectSqlite3 "service.db"
+
+     -- check if the database exists, if not make one
+     --tables <- getTables conn
+     --if not (elem "log" tables) then run conn createStmt [] else return 0
+
+     -- calculate duration
+     end <- getCurrentTime
+     let diff = diffUTCTime end begin
+
+     -- insert data into database
+     run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)"
+             [ toSql $ service req
+             , toSql $ maybe "unknown" show (exerciseId req)
+             , toSql $ fromMaybe "unknown" (source req)
+             , toSql $ show (dataformat req)
+             , toSql $ maybe "unknown" show (encoding req)
+             , toSql $ input
+             , toSql $ output
+             , toSql $ ipaddress
+             , toSql $ begin
+             , toSql $ diff
+             ]
+     commit conn
+
+     -- close the connection to the database
+     disconnect conn
+  `catch` \err -> do putStrLn $ "Error in logging to database: " ++ show err
+
+{-
+-- | Log table schema
+createStmt =  "CREATE TABLE log ( service      VARCHAR(250)"
+           ++                  ", exerciseId   VARCHAR(250)"
+           ++                  ", source       VARCHAR(250)"
+           ++                  ", dataformat   VARCHAR(250)"
+           ++                  ", encoding     VARCHAR(250)"
+           ++                  ", input        VARCHAR(250)"
+           ++                  ", output       VARCHAR(250)"
+           ++                  ", ipaddress    VARCHAR(20)"
+           ++                  ", time         TIME"
+           ++                  ", responsetime TIME)"
+-}
+#else
+logMessage :: Request -> String -> String -> String -> UTCTime -> IO ()
+logMessage _ _ _ _ _ = return ()
+
+logEnabled :: Bool
+logEnabled = False
+#endif
+ src/Ideas/Main/Options.hs view
@@ -0,0 +1,81 @@+----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Options and command-line flags for services
+--
+-----------------------------------------------------------------------------
+--  $Id: Options.hs 5781 2013-06-03 07:11:51Z bastiaan $
+
+module Ideas.Main.Options
+   ( Flag(..), getFlags
+   , versionText, helpText, shortVersion, fullVersion
+   ) where
+
+import Data.Maybe
+import Ideas.Main.LoggingDatabase (logEnabled)
+import Ideas.Main.Revision
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+
+data Flag = Version | Help | InputFile String
+          | MakePages FilePath | Test FilePath
+          | MakeScriptFor String | AnalyzeScript FilePath
+   deriving Eq
+
+header :: String
+header =
+   "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++
+   "Copyright 2013, Open Universiteit Nederland\n" ++
+   versionText ++
+   "\n\nUsage: ideas [OPTION]     (by default, CGI protocol)\n" ++
+   "\nOptions:"
+
+versionText :: String
+versionText =
+  "version " ++ ideasVersion ++ ", revision " ++ show ideasRevision ++
+  ", logging " ++ (if logEnabled then "enabled" else "disabled")
+
+helpText :: String
+helpText = usageInfo header options
+
+fullVersion :: String
+fullVersion = "version " ++ ideasVersion ++ " (revision "
+           ++ show ideasRevision ++ ", " ++ ideasLastChanged ++ ")"
+
+shortVersion :: String
+shortVersion = ideasVersion ++ " (" ++ show ideasRevision ++ ")"
+
+options :: [OptDescr Flag]
+options =
+   [ Option []  ["version"]        (NoArg Version) "show version number"
+   , Option "?" ["help"]           (NoArg Help)    "show options"
+   , Option "f" ["file"]           fileArg         "use input FILE as request"
+   , Option ""  ["make-pages"]     pagesArg        "generate pages for exercises and services"
+   , Option ""  ["test"]           testArg         "run tests on directory (default: 'test')"
+   , Option ""  ["make-script"]    makeScrArg      "generate feedback script for exercise"
+   , Option ""  ["analyze-script"] analyzeScrArg   "analyze feedback script and report errors"
+   ]
+
+fileArg, testArg, pagesArg, makeScrArg, analyzeScrArg :: ArgDescr Flag
+fileArg       = ReqArg InputFile "FILE"
+testArg       = OptArg (Test . fromMaybe "test") "DIR"
+pagesArg      = OptArg (MakePages . fromMaybe "docs") "DIR"
+makeScrArg    = ReqArg MakeScriptFor "ID"
+analyzeScrArg = ReqArg AnalyzeScript "FILE"
+
+getFlags :: IO [Flag]
+getFlags = do
+   args <- getArgs
+   case getOpt Permute options args of
+      (flags, [], []) -> return flags
+      (_, _, errs) -> do
+         putStrLn (concat errs ++ helpText)
+         exitFailure
+ src/Ideas/Main/Revision.hs view
@@ -0,0 +1,11 @@+-- Automatically generated by Makefile.  Do not change.+module Ideas.Main.Revision where++ideasVersion :: String+ideasVersion = "1.1"++ideasRevision :: Int+ideasRevision = 5787++ideasLastChanged :: String+ideasLastChanged = "za, 08 jun 2013"
+ src/Ideas/Service/BasicServices.hs view
@@ -0,0 +1,174 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.BasicServices
+   ( -- * Basic Services
+     stepsremaining, findbuggyrules, ready, allfirsts, derivation
+   , onefirst, applicable, allapplications, apply, generate, generateWith
+   , StepInfo, exampleDerivations
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Ideas.Common.Library hiding (derivation, applicable, apply, ready)
+import Ideas.Common.Traversal.Navigator (downs, navigateTo)
+import Ideas.Common.Utils (fst3)
+import Ideas.Service.State
+import System.Random
+import qualified Ideas.Common.Classes as Apply
+
+generate :: Exercise a -> Maybe Difficulty -> IO (State a)
+generate ex = liftM (emptyState ex) . randomTerm ex
+
+generateWith :: StdGen -> Exercise a -> Maybe Difficulty -> Either String (State a)
+generateWith rng ex md =
+   case randomTermWith rng ex md of
+      Just a  -> return (emptyState ex a)
+      Nothing -> fail "No random term"
+
+-- TODO: add a location to each step
+derivation :: Maybe StrategyConfiguration -> State a -> Either String (Derivation (Rule (Context a), Environment) (Context a))
+derivation mcfg state =
+   mapSecond (biMap (\(r, _, as) -> (r, as)) stateContext) $
+   case mcfg of
+      _ | null ps -> Left "Prefix is required"
+      -- configuration is only allowed beforehand: hence, the prefix
+      -- should be empty (or else, the configuration is ignored). This
+      -- restriction should probably be relaxed later on.
+      Just cfg | all (null . prefixToSteps) ps ->
+         let newStrategy = configure cfg (strategy ex)
+             newExercise = ex {strategy = newStrategy}
+         in rec timeout d0 (emptyStateContext newExercise (stateContext state))
+      _ -> rec timeout d0 state
+ where
+   d0 = emptyDerivation state
+   ex = exercise state
+   ps = statePrefixes state
+   timeout = 50 :: Int
+
+   rec i acc st =
+      case onefirst st of
+         Left _         -> Right acc
+         Right ((r, l, as), newState)
+            | i <= 0    -> Left msg
+            | otherwise -> rec (i-1) (acc `extend` ((r, l, as), newState)) newState
+    where
+      msg = "Time out after " ++ show timeout ++ " steps. " ++
+            show (biMap fst3 (prettyPrinterContext ex . stateContext) acc)
+
+type StepInfo a = (Rule (Context a), Location, Environment) -- find a good place
+
+-- Note that we have to inspect the last step of the prefix afterwards, because
+-- the remaining part of the derivation could consist of minor rules only.
+allfirsts :: State a -> Either String [(StepInfo a, State a)]
+allfirsts state
+   | null ps   = Left "Prefix is required"
+   | otherwise =
+        let trees  = map tree ps
+            tree p = cutOnStep (justMajor . lastStepInPrefix)
+                               (prefixTree False p (stateContext state))
+            f ((r1, _, _), _) ((r2, _, _), _) =
+               ruleOrdering (exercise state) r1 r2
+            justMajor = maybe False isMajor
+        in Right $ noDuplicates $ sortBy f $ mapMaybe make $ concatMap derivations trees
+ where
+   ps = statePrefixes state
+
+   make d = do
+      prefixEnd <- lastStep d
+      case lastStepInPrefix prefixEnd of
+         Just (RuleStep env r) | isMajor r -> return
+            ( (r
+              , location (lastTerm d)
+              , env)
+            , makeState (exercise state) [prefixEnd] (lastTerm d)
+            )
+         _ -> Nothing
+
+   noDuplicates []     = []
+   noDuplicates (x:xs) = x : noDuplicates (filter (not . eq x) xs)
+
+   eq ((r1, l1, a1), s1) ((r2, l2, a2), s2) =
+      r1==r2 && l1==l2 && a1==a2 && exercise s1 == exercise s2
+      && similarity (exercise s1) (stateContext s1) (stateContext s2)
+
+onefirst :: State a -> Either String (StepInfo a, State a)
+onefirst state =
+   case allfirsts state of
+      Right []     -> Left "No step possible"
+      Right (hd:_) -> Right hd
+      Left msg     -> Left msg
+
+applicable :: Location -> State a -> [Rule (Context a)]
+applicable loc state =
+   let p r = not (isBuggy r) && Apply.applicable r (setLocation loc (stateContext state))
+   in filter p (ruleset (exercise state))
+
+allapplications :: State a -> [(Rule (Context a), Location, State a)]
+allapplications state = sortBy cmp (xs ++ ys)
+ where
+   ex = exercise state
+   xs = either (const []) (map (\((r, l, _), s) -> (r, l, s))) (allfirsts state)
+   ps = [ (r, loc) | (r, loc, _) <- xs ]
+   ys = f (top (stateContext state))
+
+   f c = g c ++ concatMap f (downs c)
+   g c = [ (r, location new, makeNoState ex new)
+         | r   <- ruleset ex
+         , (r, location c) `notElem` ps
+         , new <- applyAll r c
+         ]
+
+   cmp (r1, loc1, _) (r2, loc2, _) =
+      case ruleOrdering ex r1 r2 of
+         EQ   -> loc1 `compare` loc2
+         this -> this
+
+-- local helper
+setLocation :: Location -> Context a -> Context a
+setLocation loc c0 = fromMaybe c0 (navigateTo loc c0)
+
+-- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the
+-- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied
+-- to the current term at the given location, in which case the request is invalid.
+apply :: Rule (Context a) -> Location -> Environment -> State a -> Either String (State a)
+apply r loc env state
+   | null (statePrefixes state) = applyOff
+   | otherwise                  = applyOn
+ where
+   applyOn = -- scenario 1: on-strategy
+      maybe applyOff Right $ listToMaybe
+      [ s1 | Right xs <- [allfirsts state], ((r1, loc1, env1), s1) <- xs, r==r1, loc==loc1, noBindings env || env==env1 ]
+
+   ca = setLocation loc (stateContext state)
+   applyOff  = -- scenario 2: off-strategy
+      case transApplyWith env (transformation r) ca of
+         (new, _):_ -> Right (makeNoState (exercise state) new)
+         []         -> Left ("Cannot apply " ++ show r)
+
+ready :: State a -> Bool
+ready state = isReady (exercise state) (stateTerm state)
+
+stepsremaining :: State a -> Either String Int
+stepsremaining = mapSecond derivationLength . derivation Nothing
+
+findbuggyrules :: State a -> Context a -> [(Rule (Context a), Location, Environment)]
+findbuggyrules state a =
+   [ (r, loc, as)
+   | r         <- filter isBuggy (ruleset ex)
+   , (loc, as) <- recognizeRule ex r (stateContext state) a
+   ]
+ where
+   ex = exercise state
+
+exampleDerivations :: Exercise a -> Either String [Derivation (Rule (Context a), Environment) (Context a)]
+exampleDerivations ex = mapM (derivation Nothing . emptyState ex . snd) (examples ex)
+ src/Ideas/Service/Diagnose.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Diagnose a term submitted by a student
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.Diagnose
+   ( Diagnosis(..), diagnose, restartIfNeeded, newState
+   ) where
+
+import Data.List (sortBy)
+import Data.Maybe
+import Ideas.Common.Library hiding (ready)
+import Ideas.Service.BasicServices hiding (apply)
+import Ideas.Service.State
+import Ideas.Service.Types
+
+----------------------------------------------------------------
+-- Result types for diagnose service
+
+data Diagnosis a
+   = Buggy          Environment (Rule (Context a))
+--   | Missing
+--   | IncorrectPart  [a]
+   | NotEquivalent
+   | Similar        Bool (State a)
+   | Expected       Bool (State a) (Rule (Context a))
+   | Detour         Bool (State a) Environment (Rule (Context a))
+   | Correct        Bool (State a)
+
+instance Show (Diagnosis a) where
+   show diagnosis =
+      case diagnosis of
+         Buggy as r        -> "Buggy rule " ++ show (show r) ++ showArgs as
+--         Missing          -> "Missing solutions"
+--         IncorrectPart xs -> "Incorrect parts (" ++ show (length xs) ++ " items)"
+         NotEquivalent    -> "Unknown mistake"
+         Similar _ _      -> "Very similar"
+         Expected _ _ r   -> "Rule " ++ show (show r) ++ ", expected by strategy"
+         Detour _ _ _ r   -> "Rule " ++ show (show r) ++ ", not following strategy"
+         Correct _ _      -> "Unknown step"
+    where
+      showArgs as
+         | noBindings as = ""
+         | otherwise     = " (" ++ show as ++ ")"
+
+newState :: Diagnosis a -> Maybe (State a)
+newState diagnosis =
+   case diagnosis of
+      Buggy _ _        -> Nothing
+      NotEquivalent    -> Nothing
+      Similar  _ s     -> Just s
+      Expected _ s _   -> Just s
+      Detour   _ s _ _ -> Just s
+      Correct  _ s     -> Just s
+
+----------------------------------------------------------------
+-- The diagnose service
+
+diagnose :: State a -> Context a -> Diagnosis a
+diagnose state new
+   -- Is the submitted term equivalent?
+   | not (equivalence ex (stateContext state) new) =
+        -- Is the rule used discoverable by trying all known buggy rules?
+        case discovered True of
+           Just (r, as) -> Buggy as r -- report the buggy rule
+           Nothing      -> NotEquivalent -- compareParts state new
+
+   -- Was the submitted term expected by the strategy?
+   | isJust expected =
+        -- If yes, return new state and rule
+        let ((r, _, _), ns) = fromJust expected
+        in Expected (ready ns) ns r
+
+   -- Is the submitted term (very) similar to the previous one?
+   | similar = Similar (ready state) state
+
+   -- Is the rule used discoverable by trying all known rules?
+   | otherwise =
+        case discovered False of
+           Just (r, as) ->  -- If yes, report the found rule as a detour
+              Detour (ready restarted) restarted as r
+           Nothing -> -- If not, we give up
+              Correct (ready restarted) restarted
+ where
+   ex        = exercise state
+   restarted = restartIfNeeded (makeNoState ex new)
+   similar   = similarity ex (stateContext state) new
+
+   expected = do
+      let xs = either (const []) id $ allfirsts (restartIfNeeded state)
+          p (_, ns) = similarity ex new (stateContext ns) -- use rule recognizer?
+      listToMaybe (filter p xs)
+
+   discovered searchForBuggy = listToMaybe
+      [ (r, env)
+      | r <- sortBy (ruleOrdering ex) (ruleset ex)
+      , isBuggy r == searchForBuggy
+      , (_, env) <- recognizeRule ex r sub1 sub2
+      ]
+    where
+      diff = if searchForBuggy then difference else differenceEqual
+      (sub1, sub2) = fromMaybe (stateContext state, new) $ do
+         newTerm <- fromContext new
+         (a, b)  <- diff ex (stateTerm state) newTerm
+         return (inContext ex a, inContext ex b)
+
+----------------------------------------------------------------
+-- Helpers
+
+-- If possible (and if needed), restart the strategy
+-- Make sure that the new state has a prefix
+-- When resetting the prefix, also make sure that the context is refreshed
+restartIfNeeded :: State a -> State a
+restartIfNeeded state
+   | null (statePrefixes state) && canBeRestarted ex =
+        emptyState ex (stateTerm state)
+   | otherwise = state
+ where
+   ex = exercise state
+
+instance Typed a (Diagnosis a) where
+   typed = Tag "Diagnosis" $ Iso (f <-> g) typed
+    where
+      f (Left (Left (as, r))) = Buggy as r
+   --   f (Left (Right (Left ()))) = Missing
+   --   f (Left (Right (Right (Left xs)))) = IncorrectPart xs
+      f (Left (Right ())) = NotEquivalent
+      f (Right (Left (b, s))) = Similar b s
+      f (Right (Right (Left (b, s, r)))) = Expected b s r
+      f (Right (Right (Right (Left (b, s, as, r))))) = Detour b s as r
+      f (Right (Right (Right (Right (b, s))))) = Correct b s
+
+      g (Buggy as r)       = Left (Left (as, r))
+   --   g Missing            = Left (Right (Left ()))
+   --   g (IncorrectPart xs) = Left (Right (Right (Left xs)))
+      g NotEquivalent      = Left (Right ())
+      g (Similar b s)      = Right (Left (b, s))
+      g (Expected b s r)   = Right (Right (Left (b, s, r)))
+      g (Detour b s as r)  = Right (Right (Right (Left (b, s, as, r))))
+      g (Correct b s)      = Right (Right (Right (Right (b, s))))
+
+----------------------------------------------------------------
+-- Compare answer sets (and search for missing parts/incorrect parts)
+{-  splitParts     :: a -> [a]
+compareParts :: State a -> a -> Diagnosis a
+compareParts state = answerList eq split solve (stateTerm state)
+ where
+   ex    = exercise (exercise state)
+   eq    = equivalence ex
+   split = splitParts ex
+   solve = \a -> fromMaybe a $
+                    apply (strategy ex) (inContext ex a) >>= fromContext
+
+answerList :: (a -> a -> Bool) -> (a -> [a]) -> (a -> a) -> a -> a -> Diagnosis a
+answerList eq split solve a b
+   | noSplit               = NotEquivalent
+   | present && null wrong = NotEquivalent -- error situation
+   | null wrong            = Missing
+   | partly                = IncorrectPart wrong
+   | otherwise             = NotEquivalent
+ where
+   as = split (solve a) -- expected
+   ps = [ (x, split (solve x)) | x <- split b ] -- student (keep original parts)
+   bs = concatMap snd ps -- student answer, but then fully solved
+   wrong   = [ x | (x, xs) <- ps, any notInAs xs ] -- is a (student) part incorrect?
+   present = all (flip any bs . eq) as -- are all expected answers present
+   notInAs = not . flip any as . eq
+   partly  = length wrong < length ps
+   noSplit = length as < 2 && length bs < 2 -}
+ src/Ideas/Service/DomainReasoner.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.DomainReasoner
+   ( DomainReasoner(..)
+   , exercisesSorted, servicesSorted
+   , findExercise, findService
+   , defaultScript -- , readScript
+   ) where
+
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.Ord
+import Ideas.Common.Library
+import Ideas.Common.Utils
+import Ideas.Common.Utils.TestSuite
+import Ideas.Service.FeedbackScript.Parser
+import Ideas.Service.Types
+
+-----------------------------------------------------------------------
+-- Domain Reasoner data type
+
+data DomainReasoner = DR
+   { reasonerId  :: Id
+   , exercises   :: [Some Exercise]
+   , services    :: [Service]
+   , views       :: [ViewPackage]
+   , aliases     :: [(Id, Id)]
+   , scripts     :: [(Id, FilePath)]
+   , testSuite   :: TestSuite
+   , version     :: String
+   , fullVersion :: String
+   }
+
+instance Monoid DomainReasoner where
+   mempty = DR mempty mempty mempty mempty mempty mempty mempty mempty mempty
+   mappend c1 c2 = DR
+      { reasonerId  = reasonerId c1  <> reasonerId c2
+      , exercises   = exercises c1   <> exercises c2
+      , services    = services c1    <> services c2
+      , views       = views c1       <> views c2
+      , aliases     = aliases c1     <> aliases c2
+      , scripts     = scripts c1     <> scripts c2
+      , testSuite   = testSuite c1   <> testSuite c2
+      , version     = version c1     <> version c2
+      , fullVersion = fullVersion c1 <> fullVersion c2
+      }
+
+instance HasId DomainReasoner where
+   getId = reasonerId
+   changeId f dr = dr { reasonerId = f (reasonerId dr) }
+
+instance Typed a DomainReasoner where
+   -- ignores views, testSuite
+   typed = Tag "DomainReasoner" $ Iso (f <-> g) typed
+    where
+      f ((rid, ex, serv), (al, scr), (v, fv)) =
+         DR rid ex serv [] al scr mempty v fv
+      g dr = ( (reasonerId dr, exercises dr, services dr)
+             , (aliases dr, scripts dr)
+             , (version dr, fullVersion dr)
+             )
+
+-----------------------------------------------------------------------
+-- Domain Reasoner functions
+
+exercisesSorted :: DomainReasoner -> [Some Exercise]
+exercisesSorted = sortBy (comparing f) . exercises
+ where
+   f :: Some Exercise -> String
+   f (Some ex) = showId ex
+
+servicesSorted :: DomainReasoner -> [Service]
+servicesSorted = sortBy (comparing showId) . services
+
+findExercise :: Monad m => DomainReasoner -> Id -> m (Some Exercise)
+findExercise dr i =
+   case [ a | a@(Some ex) <- exercises dr, getId ex == realName ] of
+      [this] -> return this
+      _      -> fail $ "Exercise " ++ show i ++ " not found"
+ where
+   realName = fromMaybe i (lookup i (aliases dr))
+
+findService :: Monad m => DomainReasoner -> Id -> m Service
+findService dr a
+   | null (qualifiers a) = -- search for unqualified string
+        findWith (\s -> unqualified s == unqualified a)
+   | otherwise =
+        findWith (\s -> getId s == a)
+ where
+   findWith p  = single $ filter p $ services dr
+
+   single []   = fail $ "No service " ++ showId a
+   single [hd] = return hd
+   single _    = fail $ "Ambiguous service " ++ showId a
+
+defaultScript :: DomainReasoner -> Id -> IO Script
+defaultScript dr =
+   maybe (return mempty) parseScriptSafe . (`lookup` scripts dr)
+ src/Ideas/Service/FeedbackScript/Analysis.hs view
@@ -0,0 +1,99 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Analysis of a feedbackscript
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.FeedbackScript.Analysis
+   ( -- Analysis functions
+     makeScriptFor, parseAndAnalyzeScript, analyzeScript
+     -- Message type
+   , Message(..)
+   ) where
+
+import Control.Monad
+import Control.Monad.Error
+import Data.Either
+import Data.List
+import Ideas.Common.Library
+import Ideas.Common.Utils (Some(..))
+import Ideas.Common.Utils.Uniplate
+import Ideas.Service.DomainReasoner
+import Ideas.Service.FeedbackScript.Parser
+import Ideas.Service.FeedbackScript.Run
+import Ideas.Service.FeedbackScript.Syntax
+
+makeScriptFor :: IsId a => DomainReasoner -> a -> IO ()
+makeScriptFor dr exId = do
+   Some ex <- findExercise dr (newId exId)
+   let (brs, nrs) = partition isBuggy (ruleset ex)
+   print $ makeScript $
+      Supports [getId ex] :
+      [ feedbackDecl s mempty | s <- feedbackIds ] ++
+      [ textForIdDecl r (makeText (description r)) | r <- nrs ] ++
+      [ textForIdDecl r (makeText (description r)) | r <- brs ]
+
+parseAndAnalyzeScript :: DomainReasoner -> FilePath -> IO ()
+parseAndAnalyzeScript dr file = do
+   putStrLn $ "Parsing " ++ show file
+   script <- parseScript file
+   let sups = [ a | Supports as <- scriptDecls script, a <- as ]
+   exs <- forM sups $ \a ->
+             liftM Right (findExercise dr a)
+           `catchError` \_ -> return $ Left $ UnknownExercise a
+
+   let ms = lefts exs ++ analyzeScript (rights exs) script
+   putStrLn $ unlines $ map show ms
+   putStrLn $ "(errors: " ++ show (length ms) ++ ")"
+
+analyzeScript :: [Some Exercise] -> Script -> [Message]
+analyzeScript exs script =
+   map FeedbackUndefined (filter (`notElem` fbids) feedbackIds) ++
+   map UnknownFeedback   (filter (`notElem`feedbackIds ) fbids) ++
+   [ NoTextForRule (getId r) (getId ex)
+   | Some ex <- exs, r <- ruleset ex, noTextFor (getId r)
+   ] ++
+   [ UnknownAttribute a | a <- textRefs
+   , a `notElem` feedbackIds ++ attributeIds ++ strids ] ++
+   [ UnknownCondAttr a | a <- condRefs, a `notElem` conditionIds ]
+ where
+   decls = scriptDecls script
+   fbids = [ a | Simple  Feedback as _ <- decls, a <- as ] ++
+           [ a | Guarded Feedback as _ <- decls, a <- as ]
+   txids = [ a | Simple  TextForId as _ <- decls, a <- as ] ++
+           [ a | Guarded TextForId as _ <- decls, a <- as ]
+   strids = [ a | Simple  StringDecl as _ <- decls, a <- as ] ++
+            [ a | Guarded StringDecl as _ <- decls, a <- as ]
+   namespaces = nub $ mempty : [ a | NameSpace as <- scriptDecls script, a <- as ]
+   noTextFor a = null [ () | n <- namespaces, b <- txids, n#b == a ]
+
+   texts = [ t | Simple  _ _ t <- decls ] ++
+           [ t | Guarded _ _ xs <- decls, (_, t) <- xs ]
+   textRefs = [ a | t <- texts, TextRef a <- universe t ]
+
+   conditions  = [ c | Guarded _ _ xs <- decls , (c, _) <- xs ]
+   condRefs = [ a | c <- conditions, CondRef a <- universe c ]
+
+data Message = UnknownExercise   Id
+             | UnknownFeedback   Id
+             | FeedbackUndefined Id
+             | NoTextForRule Id Id
+             | UnknownAttribute Id
+             | UnknownCondAttr  Id
+
+instance Show Message where
+   show message =
+      case message of
+         UnknownExercise a   -> "Unknown exercise id " ++ show a
+         UnknownFeedback a   -> "Unknown feedback category " ++ show a
+         FeedbackUndefined a -> "Feedback category " ++ show a ++ " is not defined"
+         NoTextForRule a b   -> "No text for rule " ++ show a ++ " of exercise " ++ show b
+         UnknownAttribute a  -> "Unknown attribute @" ++ show a ++ " in text"
+         UnknownCondAttr a   -> "Unknown attribute @" ++ show a ++ " in condition"
+ src/Ideas/Service/FeedbackScript/Parser.hs view
@@ -0,0 +1,155 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Simple parser for feedback scripts
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.FeedbackScript.Parser
+   ( parseScript, parseScriptSafe, Script
+   ) where
+
+import Control.Exception hiding (try)
+import Control.Monad.Error
+import Data.Char
+import Data.List
+import Data.Monoid
+import Ideas.Common.Id
+import Ideas.Service.FeedbackScript.Syntax
+import Ideas.Text.Parsing
+import Prelude hiding (catch)
+import System.Directory
+import System.FilePath
+
+-- returns the empty script if something goes wrong
+parseScriptSafe :: FilePath -> IO Script
+parseScriptSafe file = parseScript file `mplus` return mempty
+
+-- chases all included script files
+parseScript :: FilePath -> IO Script
+parseScript file = rec [] [file]
+ where
+   rec _ [] = return mempty
+   rec hist (a:as)
+      | a `elem` hist = rec hist as
+      | otherwise = do
+           s1 <- parseOneScriptFile a
+           let new = map (replaceFileName file) (includes s1)
+           s2 <- rec (a:hist) (new++as) -- depth-first
+           return (s1 <> s2) -- included parts are inserted at the end
+
+parseOneScriptFile :: FilePath -> IO Script
+parseOneScriptFile file = do
+   result <- parseFromFile script file `catch` handler
+   case result of
+      Left e   -> print e >> return mempty
+      Right xs -> return xs
+ where
+   -- on failure, visit scripts directory (if this directory exists)
+   handler :: IOException -> IO (Either ParseError Script)
+   handler io = do
+      b <- doesDirectoryExist "scripts"
+      if b && not ("scripts" `isPrefixOf` file)
+         then parseFromFile script ("scripts/" ++ file)
+         else throw io
+
+script :: Parser Script
+script = makeScript <$> complete decls
+
+decls :: Parser [Decl]
+decls = many $ do
+   pos <- getPosition
+   guard (sourceColumn pos == 1)
+   decl
+
+decl :: Parser Decl
+decl = do
+   dt <- declType
+   a  <- identifiers
+   f  <- simpleDecl <|> guardedDecl
+   return (f dt a)
+ <|>
+   NameSpace <$ lexString "namespace" <*>  identifiers
+ <|>
+   Supports <$ lexString "supports" <*> identifiers
+ <|>
+   Include <$ lexString "include" <*> filenames
+ <?> "declaration"
+
+simpleDecl, guardedDecl :: Parser (DeclType -> [Id] -> Decl)
+simpleDecl  =  (\t dt a -> Simple dt a t)
+           <$> text
+guardedDecl =  (\xs dt a -> Guarded dt a xs)
+           <$> many1 ((,) <$> (lexChar '|' *> condition) <*> text)
+
+declType :: Parser DeclType
+declType =  (TextForId  <$ lexString "text")
+        <|> (StringDecl <$ lexString "string")
+        <|> (Feedback   <$ lexString "feedback")
+
+condition :: Parser Condition
+condition = choice
+   [ CondRef         <$> lexeme attribute
+   , RecognizedIs    <$  lexString "recognize" <*> identifier
+   , CondConst True  <$  lexString "true"
+   , CondConst False <$  lexString "false"
+   , CondNot         <$  lexString "not" <*> condition
+   ]
+
+text :: Parser Text
+text = lexChar '=' *> (singleLineText <|> multiLineText)
+
+singleLineText :: Parser Text
+singleLineText =
+   mconcat <$> manyTill textItem (lexeme (skip newline <|> comment))
+
+multiLineText :: Parser Text
+multiLineText =
+   mconcat <$  char '{'
+           <*> manyTill (textItem <|> (mempty <$ newline)) (lexChar '}')
+
+textItem :: Parser Text
+textItem = makeText <$> many1 (noneOf "@#{}\n" <|> try escaped)
+       <|> TextRef  <$> attribute
+ where
+   escaped = char '@' *> satisfy (not . isAlphaNum)
+
+identifiers :: Parser [Id]
+identifiers = sepBy1 identifier (lexChar ',')
+
+-- Lexical units
+identifier :: Parser Id
+identifier = lexeme (mconcat . map newId <$> idPart `sepBy1` char '.')
+ <?> "identifier"
+ where
+   idPart   = many1 idLetter
+   idLetter = alphaNum <|> oneOf "-_"
+
+attribute :: Parser Id
+attribute = newId <$ skip (char '@') <*>  many1 (alphaNum <|> oneOf "-_")
+   <?> "attribute"
+
+filenames :: Parser [FilePath]
+filenames = sepBy1 filename (lexChar ',')
+
+filename :: Parser FilePath
+filename = lexeme $ many1 (alphaNum <|> oneOf "+-_./\\:;|")
+
+lexChar :: Char -> Parser ()
+lexChar = skip . lexeme . char
+
+lexString :: String -> Parser ()
+lexString s = skip (lexeme (try (string s))) <?> "string " ++ show s
+
+comment :: Parser ()
+comment = skip (char '#' <* manyTill (noneOf "\n") (skip newline <|> eof))
+
+-- parse white space and comments afterwards
+lexeme :: Parser a -> Parser a
+lexeme p = p <* skipMany (skip space <|> comment)
+ src/Ideas/Service/FeedbackScript/Run.hs view
@@ -0,0 +1,176 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Run a feedbackscript
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.FeedbackScript.Run
+   ( Script
+   , Environment(..), newEnvironment
+   , feedbackDiagnosis, feedbackHint, feedbackHints
+   , ruleToString, feedbackIds, attributeIds, conditionIds
+   , eval
+   ) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Ideas.Common.Library hiding (ready, Environment)
+import Ideas.Common.Strategy.Abstract (LabelInfo)
+import Ideas.Service.BasicServices
+import Ideas.Service.Diagnose
+import Ideas.Service.FeedbackScript.Syntax
+import Ideas.Service.State
+
+data Environment a = Env
+   { oldReady   :: Bool
+   , expected   :: Maybe (Rule (Context a))
+   , recognized :: Maybe (Rule (Context a))
+   , actives    :: Maybe [LabelInfo]
+   , diffPair   :: Maybe (String, String)
+   , before     :: Maybe Term
+   , after      :: Maybe Term
+   , afterText  :: Maybe String
+   }
+
+newEnvironment :: State a -> Environment a
+newEnvironment st = newEnvironmentFor st next
+  where
+    next = either (const Nothing) Just (onefirst st)
+
+newEnvironmentFor :: State a -> Maybe ((Rule (Context a), b, c), State a) -> Environment a
+newEnvironmentFor st next = Env
+  { oldReady   = ready st
+  , expected   = fmap (\((x,_,_),_) -> x) next
+  , recognized = Nothing
+  , actives    = listToMaybe (stateLabels st)
+  , diffPair   = Nothing
+  , before     = f st
+  , after      = liftM snd next >>= f
+  , afterText  = liftM snd next >>= g
+  }
+ where
+  f s  = fmap (`build` stateTerm s) (hasTermView (exercise s))
+  g s  = return $ prettyPrinter (exercise s) (stateTerm s)
+
+toText :: Environment a -> Script -> Text -> Maybe Text
+toText env script = eval env script . Right
+
+ruleToString :: Environment a -> Script -> Rule b -> String
+ruleToString env script r =
+   let f = eval env script . Left . getId
+   in maybe (showId r) show (f r)
+
+eval :: Environment a -> Script -> Either Id Text -> Maybe Text
+eval env script = either (return . findIdRef) evalText
+ where
+   evalText :: Text -> Maybe Text
+   evalText = liftM mconcat . mapM unref . textItems
+    where
+      unref (TextRef a)
+         | a == expectedId   = fmap (findIdRef . getId) (expected env)
+         | a == recognizedId = fmap (findIdRef . getId) (recognized env)
+         | a == diffbeforeId = fmap (TextString . fst) (diffPair env)
+         | a == diffafterId  = fmap (TextString . snd) (diffPair env)
+         | a == beforeId     = fmap TextTerm (before env)
+         | a == afterId      = fmap TextTerm (after env)
+         | a == afterTextId  = fmap TextString (afterText env)
+         | otherwise         = findRef (==a)
+      unref t = Just t
+
+   evalBool :: Condition -> Bool
+   evalBool (RecognizedIs a) = maybe False (eqId a . getId) (recognized env)
+   evalBool (CondNot c)      = not (evalBool c)
+   evalBool (CondConst b)    = b
+   evalBool (CondRef a)
+      | a == oldreadyId    = oldReady env
+      | a == hasexpectedId = isJust (expected env)
+      | otherwise          = False
+
+   namespaces = nub $ mempty : [ a | NameSpace as <- scriptDecls script, a <- as ]
+
+   -- equality with namespaces
+   eqId :: Id -> Id -> Bool
+   eqId a b = any (\n -> n#a == b) namespaces
+
+   findIdRef :: Id -> Text
+   findIdRef x = fromMaybe (TextString (showId x)) (findRef (`eqId` x))
+
+   findRef :: (Id -> Bool) -> Maybe Text
+   findRef p = listToMaybe $ catMaybes
+      [ evalText t
+      | (as, c, t) <- allDecls
+      , any p as && evalBool c
+      ]
+
+   allDecls =
+      let f (Simple _ as t)   = [ (as, CondConst True, t) ]
+          f (Guarded _ as xs) = [ (as, c, t) | (c, t) <- xs ]
+          f _ = []
+      in concatMap f (scriptDecls script)
+
+feedbackDiagnosis :: Diagnosis a -> Environment a -> Script -> Text
+feedbackDiagnosis diagnosis env =
+   case diagnosis of
+      Buggy _ r      -> makeWrong "buggy"   env {recognized = Just r}
+      NotEquivalent  -> makeWrong "noteq"   env
+      Expected _ _ r -> makeOk    "ok"      env {recognized = Just r}
+      Similar _ _    -> makeOk    "same"    env
+      Detour _ _ _ r -> makeOk    "detour"  env {recognized = Just r}
+      Correct _ _    -> makeOk    "unknown" env
+ where
+   makeOk    = makeDefault "Well done!"
+   makeWrong = makeDefault "This is incorrect."
+   makeDefault dt s e = fromMaybe (TextString dt) . make (newId s) e
+
+feedbackHint :: Id -> Environment a -> Script -> Text
+feedbackHint feedbackId env script =
+   fromMaybe (defaultHint env script) $ make feedbackId env script
+
+feedbackHints :: Id -> [((Rule (Context a), b, c), State a)] -> State a -> Script -> [Text]
+feedbackHints feedbackId nexts state script =
+   map (\env -> fromMaybe (defaultHint env script) $
+     make feedbackId env script) envs
+  where
+    envs = map (newEnvironmentFor state . Just) nexts
+
+defaultHint :: Environment a -> Script -> Text
+defaultHint env script = makeText $
+   case expected env of
+      Just r  -> ruleToString env script r
+      Nothing -> "Sorry, not hint available."
+
+make :: Id -> Environment a -> Script -> Maybe Text
+make feedbackId env script = toText env script (TextRef feedbackId)
+
+feedbackIds :: [Id]
+feedbackIds = map newId
+   ["same", "noteq", "unknown", "ok", "buggy", "detour", "hint", "step", "label"]
+
+attributeIds :: [Id]
+attributeIds =
+   [expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId]
+
+conditionIds :: [Id]
+conditionIds = [oldreadyId, hasexpectedId]
+
+expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId :: Id
+expectedId   = newId "expected"
+recognizedId = newId "recognized"
+diffbeforeId = newId "diffbefore"
+diffafterId  = newId "diffafter"
+beforeId     = newId "before"
+afterId      = newId "after"
+afterTextId  = newId "aftertext"
+
+oldreadyId, hasexpectedId :: Id
+oldreadyId    = newId "oldready"
+hasexpectedId = newId "hasexpected"
+ src/Ideas/Service/FeedbackScript/Syntax.hs view
@@ -0,0 +1,136 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Abstract syntax for feedback scripts, and pretty-printer (Show instance)
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.FeedbackScript.Syntax
+   ( Script, makeScript, scriptDecls, makeText, textItems
+   , Decl(..), DeclType(..), Text(..), Condition(..), includes
+   , feedbackDecl, textForIdDecl
+   ) where
+
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Ideas.Common.Library
+import Ideas.Common.Utils.Uniplate
+
+newtype Script = S { scriptDecls :: [Decl] }
+
+makeScript :: [Decl] -> Script
+makeScript = S
+
+data Decl
+   = NameSpace [Id]
+   | Supports  [Id]
+   | Include [FilePath]
+   | Simple  DeclType [Id] Text
+   | Guarded DeclType [Id] [(Condition, Text)]
+
+data DeclType = TextForId | StringDecl | Feedback
+
+data Text
+   = TextString String
+   | TextTerm   Term
+   | TextRef Id
+   | TextEmpty
+   | Text :<>: Text
+
+data Condition
+   = RecognizedIs Id
+   | CondNot   Condition
+   | CondConst Bool
+   | CondRef Id
+
+makeText :: String -> Text
+makeText s = case words s of
+                [] -> TextEmpty
+                xs -> TextString (combineList xs)
+
+feedbackDecl, textForIdDecl :: HasId a => a -> Text -> Decl
+feedbackDecl  a = Simple Feedback  [getId a]
+textForIdDecl a = Simple TextForId [getId a]
+
+includes :: Script -> [FilePath]
+includes script = [ file | Include xs <- scriptDecls script, file <- xs ]
+
+instance Show Script where
+   show = unlines . map show . scriptDecls
+
+instance Show Decl where
+   show decl =
+      let idList   = intercalate ", " . map show
+          f dt as  = unwords [show dt, idList as]
+          g (c, t) = "   | " ++ show c ++ " = " ++ nonEmpty (show t)
+          nonEmpty xs = if null xs then "{}" else xs
+      in case decl of
+            NameSpace as     -> "namespace " ++ idList as
+            Supports as      -> "supports "  ++ idList as
+            Include xs       -> "include "   ++ intercalate ", " xs
+            Simple dt as t   -> f dt as ++ " = " ++ nonEmpty (show t)
+            Guarded dt as xs -> unlines (f dt as : map g xs)
+
+instance Show DeclType where
+   show TextForId  = "text"
+   show StringDecl = "string"
+   show Feedback   = "feedback"
+
+instance Show Condition where
+   show (RecognizedIs a) = "recognize " ++ show a
+   show (CondNot c)      = "not " ++ show c
+   show (CondConst b)    = map toLower (show b)
+   show (CondRef a)      = '@' : show a
+
+instance Show Text where
+   show (TextString s) = s
+   show (TextTerm a)   = show a
+   show TextEmpty      = ""
+   show t@(_ :<>: _)   = show [t]
+   show (TextRef a)    = '@' : show a
+
+   showList xs ys =
+      foldr (combine . show) ys (concatMap textItems xs)
+
+instance Monoid Script where
+   mempty = makeScript []
+   mappend s t = makeScript (scriptDecls s ++ scriptDecls t)
+
+instance Monoid Text where
+   mempty  = TextEmpty
+   mappend = (:<>:)
+
+instance Uniplate Condition where
+   uniplate (CondNot a) = plate CondNot |* a
+   uniplate c           = plate c
+
+instance Uniplate Text where
+   uniplate (a :<>: b) = plate (:<>:) |* a |* b
+   uniplate t          = plate t
+
+textItems :: Text -> [Text]
+textItems t = rec t []
+ where
+   rec (a :<>: b) = rec a . rec b
+   rec TextEmpty  = id
+   rec a          = (a:)
+
+combineList :: [String] -> String
+combineList = foldr combine []
+
+combine :: String -> String -> String
+combine a b
+   | null a    = b
+   | null b    = a
+   | maybe False special (listToMaybe b) = a ++ b
+   | otherwise = a ++ " " ++ b
+ where
+    special = (`elem` ".,:;?!")
+ src/Ideas/Service/FeedbackText.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.FeedbackText
+   ( Message, accept, text
+   , onefirsttext, submittext, derivationtext, feedbacktext
+   ) where
+
+import Ideas.Common.Library hiding (derivation)
+import Ideas.Service.BasicServices
+import Ideas.Service.Diagnose
+import Ideas.Service.FeedbackScript.Run
+import Ideas.Service.FeedbackScript.Syntax
+import Ideas.Service.State
+import Ideas.Service.Types
+
+data Message = M { accept :: Maybe Bool, text :: Text }
+
+instance Typed a Message where
+   typed = Tag "Message" $ Iso (f <-> g) typed
+    where
+      f   = either (\(b, t) -> M (Just b) t) (M Nothing)
+      g m = maybe (Right (text m)) (\b -> Left (b, text m)) (accept m)
+
+------------------------------------------------------------
+-- Services
+
+derivationtext :: Script -> State a -> Either String (Derivation String (Context a))
+derivationtext script state =
+   let f = ruleToString (newEnvironment state) script . fst
+   in right (mapFirst f) (derivation Nothing state)
+
+onefirsttext :: Script -> State a -> Maybe String -> (Message, Maybe (State a))
+onefirsttext script old event =
+   ( M Nothing (feedbackHint feedbackId env script)
+   , fmap snd next
+   )
+ where
+   feedbackId = newId $ if event == Just "hint button"
+                        then "hint"
+                        else "step"
+   ex   = exercise old
+   next = either (const Nothing) Just (onefirst old)
+   env  = (newEnvironment old)
+      { diffPair = do
+          new      <- fmap snd next
+          oldC     <- fromContext (stateContext old)
+          a        <- fromContext (stateContext new)
+          (d1, d2) <- difference ex oldC a
+          return (prettyPrinter ex d1, prettyPrinter ex d2)
+      }
+
+-- Feedback messages for submit service (free student input). The boolean
+-- indicates whether the student is allowed to continue (True), or forced
+-- to go back to the previous state (False)
+submittext :: Script -> State a -> String -> (Message, State a)
+submittext script old input =
+   case parser ex input of
+      Left msg -> (M (Just False) (TextString msg), old)
+      Right a  -> feedbacktext script old (inContext ex a)
+ where
+   ex = exercise old
+
+feedbacktext :: Script -> State a -> Context a -> (Message, State a)
+feedbacktext script old new =
+   case diagnosis of
+      Buggy _ _      -> (msg False, old)
+      NotEquivalent  -> (msg False, old)
+      Expected _ s _ -> (msg True, s)
+      Similar _ s    -> (msg True, s)
+      Detour _ s _ _ -> (msg True, s)
+      Correct _ s    -> (msg False, s)
+ where
+   diagnosis = diagnose old new
+   output    = feedbackDiagnosis diagnosis env script
+   msg b     = M (Just b) output
+   ex  = exercise old
+   env = (newEnvironment old)
+            { diffPair = do
+                 oldTerm  <- fromContext (stateContext old)
+                 newTerm  <- fromContext new
+                 (d1, d2) <- difference ex oldTerm newTerm
+                 return (prettyPrinter ex d1, prettyPrinter ex d2)
+            }
+ src/Ideas/Service/ProblemDecomposition.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.ProblemDecomposition
+   ( problemDecomposition, Reply(..)
+   ) where
+
+import Data.Maybe
+import Ideas.Common.Library
+import Ideas.Service.State
+import Ideas.Service.Types
+
+problemDecomposition :: Maybe Id -> State a -> Maybe (Answer a) -> Either String (Reply a)
+problemDecomposition msloc state maybeAnswer
+   | isNothing $ subStrategy sloc (strategy ex) =
+        Left "request error: invalid location for strategy"
+   | null answers =
+        Left "strategy error: not able to compute an expected answer"
+   | otherwise =
+         case maybeAnswer of
+            Just (Answer answeredTerm) | not (null witnesses) -> Right $
+                    Ok newLocation newState
+                  where
+                    witnesses   = filter (similarity ex answeredTerm . fst) $ take 1 answers
+                    (newCtx, newPrefix) = head witnesses
+                    newLocation = nextTaskLocation (strategy ex) sloc $
+                                     fromMaybe topId $ nextMajorForPrefix newPrefix newCtx
+                    newState    = makeState ex [newPrefix] newCtx
+            _ -> Right $
+                    Incorrect isEquiv newLocation expState arguments
+             where
+               newLocation = subTaskLocation (strategy ex) sloc loc
+               expState = makeState ex [pref] expected
+               isEquiv  = maybe False (equivalence ex expected . fromAnswer) maybeAnswer
+               (expected, pref) = head answers
+               (loc, arguments) = fromMaybe (topId, mempty) $
+                                     firstMajorInPrefix prefix pref
+ where
+   ex    = exercise state
+   topId = getId (strategy ex)
+   sloc  = fromMaybe topId msloc
+   answers       = runPrefixLocation sloc prefix requestedTerm
+   requestedTerm = stateContext state
+   prefix = case statePrefixes state of
+               []   -> emptyPrefix (strategy ex)
+               hd:_ -> hd
+
+-- | Continue with a prefix until a certain strategy location is reached. At least one
+-- major rule should have been executed
+runPrefixLocation :: Id -> Prefix a -> a -> [(a, Prefix a)]
+runPrefixLocation loc p0 =
+   concatMap (checkPair . f) . derivations .
+   cutOnStep (stop . lastStepInPrefix) . prefixTree False p0
+ where
+   f d = (lastTerm d, fromMaybe p0 (lastStep d))
+   stop (Just (Exit info)) = getId info == loc
+   stop _ = False
+
+   checkPair result@(a, p)
+      | null rules        = [result]
+      | all isMinor rules = runPrefixLocation loc p a
+      | otherwise         = [result]
+    where
+      rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p
+
+firstMajorInPrefix :: Prefix a -> Prefix a -> Maybe (Id, Environment)
+firstMajorInPrefix p0 = rec . drop len . prefixToSteps
+ where
+   len = length (prefixToSteps p0)
+   rec xs =
+      case xs of
+         Enter info:RuleStep env r:_ | isMajor r ->
+            Just (getId info, env)
+         _:rest -> rec rest
+         []     -> Nothing
+
+nextMajorForPrefix :: Prefix a -> a -> Maybe Id
+nextMajorForPrefix p0 a = do
+   (_, p1)  <- listToMaybe $ runPrefixMajor p0 a
+   rec (reverse (prefixToSteps p1))
+ where
+   rec [] = Nothing
+   rec (Enter info:_) = Just (getId info)
+   rec (Exit  info:_) = Just (getId info)
+   rec (_:rest)       = rec rest
+
+-- Copied from TypedAbstractService: clean me up
+runPrefixMajor :: Prefix a -> a -> [(a, Prefix a)]
+runPrefixMajor p0 =
+   map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree False p0
+ where
+   f d = (lastTerm d, fromMaybe p0 (lastStep d))
+   stop = maybe False isMajor
+
+------------------------------------------------------------------------
+-- Data types for replies
+
+newtype Answer a = Answer { fromAnswer :: Context a }
+
+data Reply a = Ok Id (State a)
+             | Incorrect Bool Id (State a) Environment
+
+------------------------------------------------------------------------
+-- Type definition
+
+instance Typed a (Answer a) where
+   typed = Tag "answer" $ Iso (Answer <-> fromAnswer) (Const Context)
+
+instance Typed a (Reply a) where
+   typed = Tag "DecompositionReply" (Iso (f <-> g) typed)
+    where
+      f (Left (a, b))        = Ok a b
+      f (Right (a, b, c, d)) = Incorrect a b c d
+
+      g (Ok a b)            = Left (a, b)
+      g (Incorrect a b c d) = Right (a, b, c, d)
+ src/Ideas/Service/Request.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.Request where
+
+import Data.Char
+import Ideas.Common.Library hiding (exerciseId)
+
+data Request = Request
+   { service    :: String
+   , exerciseId :: Maybe Id
+   , source     :: Maybe String
+   , dataformat :: DataFormat
+   , encoding   :: Maybe Encoding
+   }
+
+data DataFormat = XML | JSON
+   deriving Show -- needed for LoggingDatabase
+
+data Encoding = OpenMath | StringEncoding | HTMLEncoding
+   deriving (Show, Eq) -- show needed for LoggingDatabase
+
+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 xs =
+   case map toLower xs of
+      "openmath" -> return OpenMath
+      "string"   -> return StringEncoding
+      "html"     -> return HTMLEncoding
+      _          -> fail $ "Invalid encoding: " ++ xs
+ src/Ideas/Service/ServiceList.hs view
@@ -0,0 +1,250 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.ServiceList (serviceList, metaServiceList) where
+
+import Ideas.Common.Library hiding (apply, applicable, derivation, ready)
+import Ideas.Service.BasicServices
+import Ideas.Service.DomainReasoner
+import Ideas.Service.FeedbackText
+import Ideas.Service.ProblemDecomposition (problemDecomposition)
+import Ideas.Service.State
+import Ideas.Service.Types
+import qualified Ideas.Service.Diagnose as Diagnose
+import qualified Ideas.Service.Submit as Submit
+
+------------------------------------------------------
+-- Querying a service
+
+serviceList :: [Service]
+serviceList =
+   -- basic services
+   [ derivationS, allfirstsS, onefirstS, readyS
+   , stepsremainingS, allapplicationsS
+   , applyS, generateS, applicableS
+   , examplesS, submitS, diagnoseS
+   , findbuggyrulesS, problemdecompositionS
+   -- textual services
+   , onefirsttextS, submittextS
+   , derivationtextS, feedbacktextS
+   ]
+
+metaServiceList :: DomainReasoner -> [Service]
+metaServiceList dr =
+   [ indexS dr, servicelistS dr, serviceinfoS dr, exerciselistS dr
+   , rulelistS, ruleinfoS, rulesinfoS, strategyinfoS, exerciseinfoS
+   , stateinfoS, examplederivationsS
+   ]
+
+------------------------------------------------------
+-- Basic services
+
+derivationS :: Service
+derivationS = makeService "basic.derivation"
+   "Returns one possible derivation (or: worked-out example) starting with the \
+   \current expression. The first optional argument lets you configure the \
+   \strategy, i.e., make some minor modifications to it. Rules used and \
+   \intermediate expressions are returned in a list." $
+   derivation ::: typed
+
+allfirstsS :: Service
+allfirstsS = makeService "basic.allfirsts"
+   "Returns all next steps that are suggested by the strategy. See the \
+   \onefirst service to get only one suggestion. For each suggestion, a new \
+   \state, the rule used, and the location where the rule was applied are \
+   \returned." $
+   allfirsts ::: typed
+
+onefirstS :: Service
+onefirstS = makeService "basic.onefirst"
+   "Returns a possible next step according to the strategy. Use the allfirsts \
+   \service to get all possible steps that are allowed by the strategy. In \
+   \addition to a new state, the rule used and the location where to apply \
+   \this rule are returned." $
+   onefirst ::: typed :-> Const String :|: Tag "elem" typed
+   -- special tag for (legacy) xml encoding
+
+readyS :: Service
+readyS = makeService "basic.ready"
+   "Test if the current expression is in a form accepted as a final answer. \
+   \For this, the strategy is not used." $
+   ready ::: typed
+
+stepsremainingS :: Service
+stepsremainingS = makeService "basic.stepsremaining"
+   "Computes how many steps are remaining to be done, according to the \
+   \strategy. For this, only the first derivation is considered, which \
+   \corresponds to the one returned by the derivation Ideas.Service." $
+   stepsremaining ::: typed
+
+applicableS :: Service
+applicableS = deprecate $ makeService "basic.applicable"
+   "Given a current expression and a location in this expression, this service \
+   \yields all rules that can be applied at this location, regardless of the \
+   \strategy." $
+   applicable ::: typed
+
+allapplicationsS :: Service
+allapplicationsS = makeService "basic.allapplications"
+   "Given a current expression, this service yields all rules that can be \
+   \applied at a certain location, regardless wether the rule used is buggy \
+   \or not. Some results are within the strategy, others are not." $
+   allapplications ::: typed
+
+applyS :: Service
+applyS = makeService "basic.apply"
+   "Apply a rule at a certain location to the current expression. If this rule \
+   \was not expected by the strategy, we deviate from it. If the rule cannot \
+   \be applied, this service call results in an error." $
+   apply ::: typed
+
+generateS :: Service
+generateS = makeService "basic.generate"
+   "Given an exercise code and a difficulty level (optional), this service \
+   \returns an initial state with a freshly generated expression." $
+   generateWith ::: typed
+
+examplesS :: Service
+examplesS = makeService "basic.examples"
+   "This services returns a list of example expresssions that can be solved \
+   \with an exercise. These are the examples that appear at the page generated \
+   \for each exercise. Also see the generate service, which returns a random \
+   \start term." $
+   examplesContext ::: typed
+
+findbuggyrulesS :: Service
+findbuggyrulesS = makeService "basic.findbuggyrules"
+   "Search for common misconceptions (buggy rules) in an expression (compared \
+   \to the current state). It is assumed that the expression is indeed not \
+   \correct. This service has been superseded by the diagnose service." $
+   findbuggyrules ::: typed
+
+submitS :: Service
+submitS = deprecate $ makeService "basic.submit"
+   "Analyze an expression submitted by a student. Possible answers are Buggy, \
+   \NotEquivalent, Ok, Detour, and Unknown. This service has been superseded \
+   \by the diagnose Ideas.Service." $
+   Submit.submit ::: typed
+
+diagnoseS :: Service
+diagnoseS = makeService "basic.diagnose"
+   "Diagnose an expression submitted by a student. Possible diagnosis are \
+   \Buggy (a common misconception was detected), NotEquivalent (something is \
+   \wrong, but we don't know what), Similar (the expression is pretty similar \
+   \to the last expression in the derivation), Expected (the submitted \
+   \expression was anticipated by the strategy), Detour (the submitted \
+   \expression was not expected by the strategy, but the applied rule was \
+   \detected), and Correct (it is correct, but we don't know which rule was \
+   \applied)." $
+   Diagnose.diagnose ::: typed
+
+------------------------------------------------------
+-- Problem decomposition service
+
+problemdecompositionS :: Service
+problemdecompositionS = makeService "basic.problemdecomposition"
+   "Strategy service developed for the SURF project Intelligent Feedback for a \
+   \binding with the MathDox system on linear algebra exercises. This is a \
+   \composite service, and available for backwards compatibility." $
+   problemDecomposition ::: typed
+
+------------------------------------------------------
+-- Services with a feedback component
+
+onefirsttextS :: Service
+onefirsttextS = makeService "textual.onefirsttext"
+   "Similar to the onefirst service, except that the result is now returned as \
+   \a formatted text message. The optional string is for announcing the event \
+   \leading to this service call (which can influence the returned result)." $
+   onefirsttext ::: typed
+
+derivationtextS :: Service
+derivationtextS = makeService "textual.derivationtext"
+   "Similar to the derivation service, but the rules appearing in the derivation \
+   \have been replaced by a short description of the rule." $
+   derivationtext ::: typed
+
+submittextS :: Service
+submittextS = deprecate $ makeService "textual.submittext"
+   "Similar to the submit service, except that the result is now returned as \
+   \a formatted text message. The expression 'submitted' by the student is sent \
+   \in plain text (and parsed by the exercise's parser). \
+   \The boolean in the \
+   \result specifies whether the submitted term is accepted and incorporated \
+   \in the new state." $
+   submittext ::: typed
+
+feedbacktextS :: Service
+feedbacktextS = makeService "textual.feedbacktext"
+   "Textual feedback for diagnose Ideas.Service. Experimental." $
+   feedbacktext ::: typed
+
+------------------------------------------------------
+-- Reflective services
+
+indexS :: DomainReasoner -> Service
+indexS dr = makeService "meta.index"
+   "Index of the domain reasoner" $
+   dr ::: typed
+
+exerciselistS :: DomainReasoner -> Service
+exerciselistS dr = makeService "meta.exerciselist"
+   "Returns all exercises known to the system. For each exercise, its domain, \
+   \identifier, a short description, and its current status are returned." $
+   exercisesSorted dr ::: typed
+
+servicelistS :: DomainReasoner -> Service
+servicelistS dr = makeService "meta.servicelist"
+   "List of all supported feedback services" $
+   servicesSorted dr ::: typed
+
+serviceinfoS :: DomainReasoner -> Service
+serviceinfoS dr = makeService "meta.serviceinfo"
+   "Information about a feedback service" $
+   (findService dr :: Id -> Either String Service) ::: typed
+
+rulelistS :: Service
+rulelistS = makeService "meta.rulelist"
+   "Returns all rules of a particular exercise. For each rule, we return its \
+   \name (or identifier), whether the rule is buggy, and whether the rule was \
+   \expressed as an observable rewrite rule. See rulesinfo for more details \
+   \about the rules." $
+   ruleset ::: typed
+
+ruleinfoS :: Service
+ruleinfoS = makeService "meta.ruleinfo"
+   "Information about a rule" $
+   (id :: Rule (Context a) -> Rule (Context a)) ::: typed
+
+rulesinfoS :: Service
+rulesinfoS = makeService "meta.rulesinfo"
+   "Returns a list of all rules of a particular exercise, with many details \
+   \including Formal Mathematical Properties (FMPs) and example applications." $
+   () ::: Tag "RulesInfo" Unit
+
+strategyinfoS :: Service
+strategyinfoS = makeService "meta.strategyinfo"
+   "Returns the representation of the strategy of a particular exercise." $
+   (toStrategy . strategy) ::: typed
+
+exerciseinfoS :: Service
+exerciseinfoS = makeService "meta.exerciseinfo"
+   "Exercise information" $
+   (id :: Exercise a -> Exercise a) ::: typed
+
+stateinfoS :: Service
+stateinfoS = makeService "meta.stateinfo"
+   "State information" $
+   (id :: State a -> State a) ::: typed
+
+examplederivationsS :: Service
+examplederivationsS = makeService "meta.examplederivations"
+   "Show example derivations" $ exampleDerivations ::: typed
+ src/Ideas/Service/State.hs view
@@ -0,0 +1,77 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- The information maintained for a learner trying to complete a
+-- derivation.
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.State
+   ( -- * Exercise state
+     State, makeState, makeNoState, emptyStateContext, emptyState
+   , exercise, statePrefixes, stateContext, stateTerm, stateLabels
+   ) where
+
+import Data.List
+import Data.Maybe
+import Ideas.Common.Library
+import Ideas.Common.Strategy.Abstract (LabelInfo)
+import Ideas.Common.Strategy.Prefix (activeLabels)
+
+data State a = State
+   { exercise      :: Exercise a
+   , statePrefixes :: [Prefix (Context a)]
+   , stateContext  :: Context a
+   }
+
+instance Show (State a) where
+   show s = unlines $ "State {" : map ("   "++) xs ++ ["}"]
+    where
+      xs = [ "exercise = " ++ showId s
+           , "prefix   = " ++ intercalate ";" (map show (statePrefixes s))
+           , "steps    = " ++ intercalate ";" (map (show . prefixToSteps) (statePrefixes s))
+           , "term     = " ++ prettyPrinterContext (exercise s) (stateContext s)
+           ]
+
+instance HasId (State a) where
+   getId = getId . exercise
+   changeId f s = s { exercise = changeId f (exercise s) }
+
+instance HasEnvironment (State a) where
+   environment = environment . stateContext
+   setEnvironment env s =
+      s { stateContext = setEnvironment env (stateContext s) }
+
+stateTerm :: State a -> a
+stateTerm = fromMaybe (error "invalid term") . fromContext . stateContext
+
+stateLabels :: State a -> [[LabelInfo]]
+stateLabels state =
+    map (filterRules . activeLabels) $ statePrefixes state
+  where
+    rs          = ruleset $ exercise state
+    isRule      = flip elem (map getId rs) . getId
+    filterRules = filter (not . isRule)
+
+-----------------------------------------------------------
+
+makeState :: Exercise a -> [Prefix (Context a)] -> Context a -> State a
+makeState = State
+
+-- State without a prefix
+makeNoState :: Exercise a -> Context a -> State a
+makeNoState = flip makeState []
+
+emptyStateContext :: Exercise a -> Context a -> State a
+emptyStateContext ex = makeState ex [pr]
+ where
+   pr = emptyPrefix (strategy ex)
+
+emptyState :: Exercise a -> a -> State a
+emptyState ex = emptyStateContext ex . inContext ex
+ src/Ideas/Service/Submit.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Diagnose a term submitted by a student. Deprecated (see diagnose service).
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.Submit
+   ( submit, Result(..)
+   ) where
+
+import Ideas.Common.Library
+import Ideas.Service.Diagnose (Diagnosis, diagnose)
+import Ideas.Service.State
+import Ideas.Service.Types
+import qualified Ideas.Service.Diagnose as Diagnose
+
+-- Note that in the typed setting there is no syntax error
+data Result a = Buggy  [Rule (Context a)]
+              | NotEquivalent
+              | Ok     [Rule (Context a)] (State a)  -- equivalent
+              | Detour [Rule (Context a)] (State a)  -- equivalent
+              | Unknown                   (State a)  -- equivalent
+
+fromDiagnose :: Diagnosis a -> Result a
+fromDiagnose diagnosis =
+   case diagnosis of
+      Diagnose.Buggy _ r       -> Buggy [r]
+      Diagnose.NotEquivalent   -> NotEquivalent
+      Diagnose.Similar _ s     -> Ok [] s
+      Diagnose.Expected _ s r  -> Ok [r] s
+      Diagnose.Detour _ s _ r  -> Detour [r] s
+      Diagnose.Correct _ s     -> Unknown s
+--      Diagnose.Missing         -> NotEquivalent
+--      Diagnose.IncorrectPart _ -> NotEquivalent
+
+submit :: State a -> Context a -> Result a
+submit state = fromDiagnose . diagnose state
+
+instance Typed a (Result a) where
+   typed = Tag "Result" (Iso (f <-> g) typed)
+    where
+      f (Left rs) = Buggy rs
+      f (Right (Left ())) = NotEquivalent
+      f (Right (Right (Left (rs, s)))) = Ok rs s
+      f (Right (Right (Right (Left (rs, s))))) = Detour rs s
+      f (Right (Right (Right (Right s)))) = Unknown s
+
+      g (Buggy rs)      = Left rs
+      g (NotEquivalent) = Right (Left ())
+      g (Ok rs s)       = Right (Right (Left (rs, s)))
+      g (Detour rs s)   = Right (Right (Right (Left (rs, s))))
+      g (Unknown s)     = Right (Right (Right (Right s)))
+ src/Ideas/Service/Types.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE GADTs, Rank2Types, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Service.Types
+   ( -- * Services
+     Service, makeService, deprecate
+   , serviceDeprecated, serviceFunction
+     -- * Types
+   , TypeRep(..), Const(..), Type, TypedValue(..), Typed(..)
+   , Equal(..), ShowF(..), equalM
+   ) where
+
+import Control.Monad
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Tree
+import Ideas.Common.Library
+import Ideas.Common.Utils
+import Ideas.Service.FeedbackScript.Syntax
+import Ideas.Service.State
+import System.Random
+
+-----------------------------------------------------------------------------
+-- Services
+
+data Service = S
+   { serviceId         :: Id
+   , serviceDeprecated :: Bool
+   , serviceFunction   :: forall a . TypedValue (Type a)
+   }
+
+instance Show Service where
+   show = showId
+
+instance HasId Service where
+   getId = serviceId
+   changeId f a = a { serviceId = f (serviceId a) }
+
+makeService :: String -> String -> (forall a . TypedValue (Type a)) -> Service
+makeService s descr f = describe descr (S (newId s) False f)
+
+deprecate :: Service -> Service
+deprecate s = s { serviceDeprecated = True }
+
+class Equal f where
+   equal :: f a -> f b -> Maybe (a -> b)
+
+equalM :: Monad m => Type a t1 -> Type a t2 -> m (t1 -> t2)
+equalM t1 t2 = maybe (fail msg) return (equal t1 t2)
+ where msg = "Types not equal: " ++ show t1 ++ " and " ++ show t2
+
+instance Equal f => Equal (TypeRep f) where
+   equal (Iso p a)  t2         = fmap (. to p) (equal a t2)
+   equal t1         (Iso p b)  = fmap (from p .) (equal t1 b)
+   equal (Pair a b) (Pair c d) = do f <- equal a c
+                                    g <- equal b d
+                                    return $ f *** g
+   equal (a :|: b)  (c :|: d)  = liftM2 biMap (equal a c) (equal b d)
+   equal (List a)   (List b)   = fmap map (equal a b)
+   equal (Tag s1 a) (Tag s2 b) | s1 == s2 = equal a b
+   equal Unit       Unit       = Just id
+   equal (Const a)  (Const b)  = equal a b
+   equal _          _          = Nothing
+
+instance Equal (Const a) where
+   equal Int         Int         = Just id
+   equal Bool        Bool        = Just id
+   equal String      String      = Just id
+   equal Service     Service     = Just id
+   equal Exercise    Exercise    = Just id
+   equal Strategy    Strategy    = Just id
+   equal State       State       = Just id
+   equal Rule         Rule       = Just id
+   equal Context     Context     = Just id
+   equal Id          Id          = Just id
+   equal Location    Location    = Just id
+   equal Script      Script      = Just id
+   equal StratCfg    StratCfg    = Just id
+   equal Environment Environment = Just id
+   equal SomeExercise SomeExercise = Just id
+   equal Text        Text        = Just id
+   equal StdGen      StdGen      = Just id
+   equal _           _           = Nothing
+
+infixr 5 :|:
+
+-----------------------------------------------------------------------------
+-- Types
+
+infix  2 :::
+infixr 3 :->
+
+data TypedValue f where
+   (:::) :: t -> f t -> TypedValue f
+
+type Type a = TypeRep (Const a)
+
+data TypeRep f t where
+   -- Type isomorphisms (for defining type synonyms)
+   Iso   :: Isomorphism t1 t2 -> TypeRep f t1 -> TypeRep f t2
+   -- Function type
+   (:->) :: TypeRep f t1 -> TypeRep f t2 -> TypeRep f (t1 -> t2)
+   -- Special annotations
+   Tag   :: String -> TypeRep f t1 -> TypeRep f t1
+   -- Type constructors
+   List  :: TypeRep f t  -> TypeRep f [t]
+   Pair  :: TypeRep f t1 -> TypeRep f t2 -> TypeRep f (t1, t2)
+   (:|:) :: TypeRep f t1 -> TypeRep f t2 -> TypeRep f (Either t1 t2)
+   Unit  :: TypeRep f ()
+   -- Type constants
+   Const :: f t -> TypeRep f t
+
+data Const a t where
+   -- exercise specific
+   Service      :: Const a Service
+   Exercise     :: Const a (Exercise a)
+   Strategy     :: Const a (Strategy (Context a))
+   State        :: Const a (State a)
+   Rule         :: Const a (Rule (Context a))
+   Context      :: Const a (Context a)
+   -- other types
+   Id           :: Const a Id
+   Location     :: Const a Location
+   Script       :: Const a Script
+   StratCfg     :: Const a StrategyConfiguration
+   Environment  :: Const a Environment
+   Text         :: Const a Text
+   StdGen       :: Const a StdGen
+   SomeExercise :: Const a (Some Exercise)
+   -- basic types
+   Bool         :: Const a Bool
+   Int          :: Const a Int
+   String       :: Const a String
+
+class ShowF f where
+   showF :: f a -> String
+
+instance ShowF f => ShowF (TypeRep f) where
+   showF = show
+
+instance ShowF f => Show (TypeRep f t) where
+   show (Iso _ t)      = show t
+   show (t1 :-> t2)    = show t1 ++ " -> " ++ show t2
+   show t@(Pair _ _)   = showTuple t
+   show (t1 :|: t2)    = show t1 ++ " | " ++ show t2
+   show (Tag s _)      = s
+   show (List t)       = "[" ++ show t ++ "]"
+   show Unit           = "()"
+   show (Const c)      = showF c
+
+instance Show (TypedValue f) => Show (TypedValue (TypeRep f)) where
+   show (val ::: tp) =
+      case tp of
+         Iso iso t  -> show (to iso val ::: t)
+         _ :-> _    -> "<<function>>"
+         Tag _ t    -> show (val ::: t)
+         List t     -> showAsList (map (show . (::: t)) val)
+         Pair t1 t2 -> "(" ++ show (fst val ::: t1) ++
+                       "," ++ show (snd val ::: t2) ++ ")"
+         t1 :|: t2  -> either (show . (::: t1)) (show . (::: t2)) val
+         Unit       -> "()"
+         Const t    -> show (val ::: t)
+
+showAsList :: [String] -> String
+showAsList xs = "[" ++ intercalate "," xs ++ "]"
+
+instance Show (TypedValue (Const a)) where
+   show (val ::: tp) =
+      case tp of
+         Service          -> showId val
+         Exercise         -> showId val
+         Strategy         -> show val
+         Rule             -> showId val
+         Id               -> showId val
+         SomeExercise     -> case val of Some ex -> showId ex
+         State            -> show val
+         Context          -> show (location val, environment val)
+         Location         -> show val
+         Script           -> show val
+         StratCfg         -> show val
+         Environment      -> show val
+         Text             -> show val
+         StdGen           -> show val
+         Bool             -> map toLower (show val)
+         Int              -> show val
+         String           -> val
+
+instance Show (Const a t) where
+   show = showF
+
+instance ShowF (Const a) where
+   showF Service      = "Service"
+   showF Exercise     = "Exercise"
+   showF Strategy     = "Strategy"
+   showF State        = "State"
+   showF Rule         = "Rule"
+   showF Context      = "Context"
+   showF Id           = "Id"
+   showF Location     = "Location"
+   showF Script       = "Script"
+   showF StratCfg     = "StrategyConfiguration"
+   showF Environment  = "Environment"
+   showF Text         = "TextMessage"
+   showF StdGen       = "StdGen"
+   showF SomeExercise = "Exercise"
+   showF Bool         = "Bool"
+   showF Int          = "Int"
+   showF String       = "String"
+
+showTuple :: ShowF f => TypeRep f t -> String
+showTuple tp = "(" ++ intercalate ", " (collect tp) ++ ")"
+ where
+   collect :: ShowF f => TypeRep f t -> [String]
+   collect (Pair t1 t2) = collect t1 ++ collect t2
+   collect (Iso _ t)    = collect t
+   collect t            = [showF t]
+
+---------------------------------------------------------------
+
+class Typed a t | t -> a where
+   typeOf    :: t -> Type a t
+   typed     :: Type a t
+   typedList :: Type a [t]
+   -- default implementation
+   typeOf    = const typed
+   typedList = List typed
+
+instance Typed a Int where
+   typed = Const Int
+
+instance Typed a Bool where
+   typed = Const Bool
+
+instance Typed a () where
+   typed = Unit
+
+instance Typed a Char where
+   typed     = Iso (head <-> return) typed
+   typedList = Const String
+
+instance Typed a (Rule (Context a)) where
+   typed = Const Rule
+
+instance Typed a (Strategy (Context a)) where
+   typed = Const Strategy
+
+instance Typed a Id where
+   typed = Const Id
+
+instance Typed a Location where
+   typed = Const Location
+
+instance Typed a Environment where
+   typed = Const Environment
+
+instance Typed a StdGen where
+   typed = Const StdGen
+
+instance Typed a Difficulty where
+   typed = Tag "Difficulty" (Iso (f <-> show) typed)
+    where
+      f = fromMaybe Medium . readDifficulty
+
+instance Typed a Service where
+   typed = Const Service
+
+instance Typed a (State a) where
+   typed = Const State
+
+instance Typed a (Exercise a) where
+   typed = Const Exercise
+
+instance Typed a (Context a) where
+   typed = Const Context
+
+instance Typed a StrategyConfiguration where
+   typed = Const StratCfg
+
+instance Typed a Script where
+   typed = Const Script
+
+instance Typed a Text where
+   typed = Const Text
+
+instance (Typed a t1, Typed a t2) => Typed a (t1, t2) where
+   typed = Pair typed typed
+
+instance (Typed a t1, Typed a t2, Typed a t3) => Typed a (t1, t2, t3) where
+   typed = Iso (f <-> g) (Pair typed (Pair typed typed))
+    where
+      f (a, (b, c)) = (a, b, c)
+      g (a, b, c)   = (a, (b, c))
+
+instance (Typed a t1, Typed a t2, Typed a t3, Typed a t4) => Typed a (t1, t2, t3, t4) where
+   typed = Iso (f <-> g) (Pair typed (Pair typed (Pair typed typed)))
+    where
+      f (a, (b, (c, d))) = (a, b, c, d)
+      g (a, b, c, d)     = (a, (b, (c, d)))
+
+instance (Typed a t1, Typed a t2) => Typed a (t1 -> t2) where
+   typed = typed :-> typed
+
+instance Typed a t => Typed a (Maybe t) where
+   typed = Iso (f <-> g) (typed :|: Unit)
+    where
+      f = either Just (const Nothing)
+      g = maybe (Right ()) Left
+
+instance (Typed a t1, Typed a t2) => Typed a (Either t1 t2) where
+   typed = typed :|: typed
+
+instance (Typed a t1, Typed a t2) => Typed a (Derivation t1 t2) where
+   typed = Tag "Derivation" $ Iso (f <-> g) typed
+    where
+      f (a, xs) = foldl extend (emptyDerivation a) xs
+      g d = (firstTerm d, [ (s, a) | (_, s, a) <- triples d ])
+
+instance Typed a t => Typed a [t] where
+   typed = typedList
+
+instance Typed a t => Typed a (Tree t) where
+   typed = Tag "Tree" $ Iso (f <-> g) typed
+    where
+      f = uncurry Node
+      g (Node a xs) = (a, xs)
+
+instance Typed a (Some Exercise) where
+   typed = Const SomeExercise
+ src/Ideas/Text/HTML.hs view
@@ -0,0 +1,210 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A minimal interface for constructing simple HTML pages
+-- See http://www.w3.org/TR/html4/
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.HTML
+   ( HTMLPage, HTMLBuilder
+   , addCSS, addScript, showHTML
+   , string, text
+   , htmlPage, link
+   , h1, h2, h3, h4, h5, h6
+   , preText, ul, table, keyValueTable
+   , image, space, spaces, highlightXML
+   , para, ttText, hr, br, pre, bullet
+   , divClass, spanClass
+     -- HTML generic attributes
+   , idA, classA, styleA, titleA
+     -- Font style elements
+   , tt, italic, bold, big, small
+   , module Data.Monoid
+   ) where
+
+import Data.Char
+import Data.List
+import Data.Monoid
+import Ideas.Text.XML
+import Prelude hiding (div)
+import qualified Ideas.Text.XML as XML
+
+type HTMLBuilder = XMLBuilder
+
+data HTMLPage = HTMLPage
+   { title       :: String
+   , styleSheets :: [FilePath]
+   , scripts     :: [FilePath]
+   , htmlContent :: HTMLBuilder
+   }
+
+instance InXML HTMLPage where
+   toXML page = makeXML "html" $
+      element "head"
+         [ tag "title" (string (title page))
+         , mconcat
+              [ element "link"
+                   [ "rel"  .=. "STYLESHEET"
+                   , "href" .=. css
+                   , "type" .=. "text/css"
+                   ]
+              | css <- styleSheets page
+              ]
+         , mconcat
+              [ tag "script" ("src" .=. js)
+              | js <- scripts page
+              ]
+         ]
+      <> tag "body" (htmlContent page)
+   fromXML _ = fail "HTMLPage.fromXML"
+
+showHTML :: HTMLPage -> String
+showHTML = compactXML . toXML
+
+addCSS :: FilePath -> HTMLPage -> HTMLPage
+addCSS css page = page { styleSheets = css : styleSheets page }
+
+addScript :: FilePath -> HTMLPage -> HTMLPage
+addScript js page = page { scripts = js : scripts page }
+
+-- html helper functions
+htmlPage :: String -> HTMLBuilder -> HTMLPage
+htmlPage s = HTMLPage s [] []
+
+link :: BuildXML a => String -> a -> a
+link url body = tag "a" $
+   ("href" .=. url) <> body
+
+h1, h2, h3, h4, h5, h6 :: BuildXML a => String -> a
+h1 = tag "h1" . string
+h2 = tag "h2" . string
+h3 = tag "h3" . string
+h4 = tag "h4" . string
+h5 = tag "h5" . string
+h6 = tag "h6" . string
+
+para :: BuildXML a => a -> a
+para = tag "p"
+
+preText :: BuildXML a => String -> a
+preText = pre . string
+
+pre :: BuildXML a => a -> a
+pre = tag "pre"
+
+hr :: BuildXML a => a
+hr = emptyTag "hr"
+
+br :: BuildXML a => a
+br = emptyTag "br"
+
+ttText :: BuildXML a => String -> a
+ttText = tt . string
+
+ul :: BuildXML a => [a] -> a
+ul = element "ul" . map (tag "li")
+
+-- | First argument indicates whether the table has a header or not
+table :: BuildXML a => Bool -> [[a]] -> a
+table b rows = element "table" $
+   ("border" .=. "1") :
+   [ element "tr" $
+        ("class" .=. getClass i) :
+        [ tag "td" c | c <- row ]
+   | (i, row) <- zip [0::Int ..] rows
+   ]
+ where
+   getClass i
+      | i == 0 && b = "top-row"
+      | even i      = "even-row"
+      | otherwise   = "odd-row"
+
+keyValueTable :: BuildXML a => [(String, a)] -> a
+keyValueTable =
+   let f (s, a) = [spanClass "table-key" (string s), a]
+   in para . table False . map f
+
+spaces :: BuildXML a => Int -> a
+spaces n = mconcat (replicate n space)
+
+space, bullet :: BuildXML a => a
+space  = XML.unescaped "&nbsp;"
+bullet = XML.unescaped "&#8226;"
+
+image :: BuildXML a => String -> a
+image n = tag "img" ("src" .=. n)
+
+divClass :: BuildXML a =>  String -> a -> a
+divClass n a = tag "div" (classA n <> a)
+
+spanClass :: BuildXML a =>  String -> a -> a
+spanClass n a = tag "span" (classA n <> a)
+
+-- A simple XML highlighter
+highlightXML :: Bool -> XML -> HTMLBuilder
+highlightXML nice
+   | nice      = builder . highlight . makeXML "pre" . string . showXML
+   | otherwise = builder . highlight . makeXML "tt"  . string . compactXML
+ where
+   highlight :: XML -> XML
+   highlight html = html {content = map (either (Left . f) Right) (content html)}
+
+   -- find <
+   f :: String -> String
+   f [] = []
+   f list@(x:xs)
+      | "&lt;/" `isPrefixOf` list = -- close tag
+           let (as, bs) = span isAlphaNum (drop 5 list)
+           in "<font color='blue'>&lt;/" ++ as ++ "<font color='green'>" ++ g bs
+      | "&lt;" `isPrefixOf` list = -- open tag
+           let (as, bs) = span isAlphaNum (drop 4 list)
+           in "<font color='blue'>&lt;" ++ as ++ "<font color='green'>" ++ g bs
+      | otherwise = x : f xs
+   -- find >
+   g [] = []
+   g list@(x:xs)
+      | "/&gt;" `isPrefixOf` list =
+           "</font>/&gt;</font>" ++ f (drop 5 list)
+      | "&gt;" `isPrefixOf` list =
+           "</font>&gt;</font>" ++ f (drop 4 list)
+      | x=='=' = "<font color='orange'>=</font>" ++ g xs
+      | otherwise = x : g xs
+
+-----------------------------------------------------------
+-- * HTML generic attributes
+
+idA, classA, styleA, titleA :: BuildXML a => String -> a
+idA    = ("id"     .=.)  -- document-wide unique id
+classA = ("class"  .=.)  -- space-separated list of classes
+styleA = ("style"  .=.)  -- associated style info
+titleA = ("title"  .=.)  -- advisory title
+
+-----------------------------------------------------------
+-- * Font style elements
+
+-- | Renders as teletype or monospaced Ideas.Text.
+tt :: BuildXML a => a -> a
+tt = tag "tt"
+
+-- | Renders as italic text style.
+italic :: BuildXML a => a -> a
+italic = tag "i"
+
+-- | Renders as bold text style.
+bold :: BuildXML a => a -> a
+bold = tag "b"
+
+-- BIG: Renders text in a "large" font.
+big :: BuildXML a => a -> a
+big = tag "big"
+
+-- SMALL: Renders text in a "small" font.
+small :: BuildXML a => a -> a
+small = tag "small"
+ src/Ideas/Text/JSON.hs view
@@ -0,0 +1,294 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Support for JavaScript Object Notation (JSON) and remote procedure calls using
+-- JSON. JSON is a lightweight alternative for XML.
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.JSON
+   ( JSON(..), Key, Number(..)            -- types
+   , InJSON(..)                           -- type class"
+   , lookupM
+   , parseJSON, showCompact, showPretty   -- parser and pretty-printers
+   , jsonRPC, RPCHandler, propEncoding
+   ) where
+
+import Control.Exception
+import Control.Monad.Error
+import Data.List (intercalate)
+import Data.Maybe
+import Ideas.Text.Parsing
+import System.IO.Error
+import Test.QuickCheck
+import qualified Ideas.Text.UTF8 as UTF8
+import qualified Text.ParserCombinators.Parsec.Token as P
+
+data JSON
+   = Number  Number        -- integer, real, or floating point
+   | String  String        -- double-quoted Unicode with backslash escapement
+   | Boolean Bool          -- true and false
+   | Array   [JSON]        -- ordered sequence (comma-separated, square brackets)
+   | Object  [(Key, JSON)] -- collection of key/value pairs (comma-separated, curly brackets
+   | Null
+ deriving Eq
+
+type Key = String
+
+data Number = I Integer | D Double deriving Eq
+
+instance Show JSON where
+   show = showPretty
+
+showCompact :: JSON -> String
+showCompact json =
+   case json of
+      Number n  -> show n
+      String s  -> "\"" ++ escape s ++ "\""
+      Boolean b -> if b then "true" else "false"
+      Array xs  -> squareBrackets $ intercalate ", " $ map showCompact xs
+      Object xs -> let f (k, v) = show k ++ ": " ++ showCompact v
+                   in curlyBrackets  $ intercalate ", " $ map f xs
+      Null      -> "null"
+
+-- Escape double quote and backslash, and convert to UTF8 encoding
+escape :: String -> String
+escape = concatMap f . fromMaybe "invalid UTF8 string" . UTF8.encodeM
+ where
+   f '\n' = "\\\\n"
+   f '"'  = "\\\""
+   f '\\' = "\\\\"
+   f c    = [c]
+
+showPretty :: JSON -> String
+showPretty json =
+   case json of
+      Array xs  -> squareBrackets $ '\n' : indent 3 (commas (map showPretty xs))
+      Object xs -> let f (k, v) = show k ++ ": " ++ showPretty v
+                   in curlyBrackets $ '\n' : indent 3 (commas (map f xs))
+      _         -> showCompact json
+ where
+   commas []     = []
+   commas [x]    = x
+   commas (x:xs) = x ++ ",\n" ++ commas xs
+
+squareBrackets, curlyBrackets :: String -> String
+squareBrackets s = "[" ++ s ++ "]"
+curlyBrackets  s = "{" ++ s ++ "}"
+
+instance Show Number where
+   show (I n) = show n
+   show (D d) = show d
+
+class InJSON a where
+   toJSON       :: a -> JSON
+   listToJSON   :: [a] -> JSON
+   fromJSON     :: Monad m => JSON -> m a
+   listFromJSON :: Monad m => JSON -> m [a]
+   -- default definitions
+   listToJSON   = Array . map toJSON
+   listFromJSON (Array xs) = mapM fromJSON xs
+   listFromJSON _          = fail "expecting an array"
+
+instance InJSON Int where
+   toJSON   = toJSON . toInteger
+   fromJSON = liftM fromInteger . fromJSON
+
+instance InJSON Integer where
+   toJSON                  = Number . I
+   fromJSON (Number (I n)) = return n
+   fromJSON _              = fail "expecting a number"
+
+instance InJSON Double where
+   toJSON = Number . D
+   fromJSON (Number (D n)) = return n
+   fromJSON _              = fail "expecting a number"
+
+instance InJSON Char where
+   toJSON c   = String [c]
+   listToJSON = String
+   fromJSON (String [c]) = return c
+   fromJSON _ = fail "expecting a string"
+   listFromJSON (String s) = return s
+   listFromJSON _ = fail "expecting a string"
+
+instance InJSON Bool where
+   toJSON = Boolean
+   fromJSON (Boolean b) = return b
+   fromJSON _           = fail "expecting a boolean"
+
+instance InJSON a => InJSON [a] where
+   toJSON   = listToJSON
+   fromJSON = listFromJSON
+
+instance (InJSON a, InJSON b) => InJSON (a, b) where
+   toJSON (a, b)           = Array [toJSON a, toJSON b]
+   fromJSON (Array [a, b]) = liftM2 (,) (fromJSON a) (fromJSON b)
+   fromJSON _              = fail "expecting an array with 2 elements"
+
+instance (InJSON a, InJSON b, InJSON c) => InJSON (a, b, c) where
+   toJSON (a, b, c)           = Array [toJSON a, toJSON b, toJSON c]
+   fromJSON (Array [a, b, c]) = liftM3 (,,) (fromJSON a) (fromJSON b) (fromJSON c)
+   fromJSON _                 = fail "expecting an array with 3 elements"
+
+instance (InJSON a, InJSON b, InJSON c, InJSON d) => InJSON (a, b, c, d) where
+   toJSON (a, b, c, d)           = Array [toJSON a, toJSON b, toJSON c, toJSON d]
+   fromJSON (Array [a, b, c, d]) = liftM4 (,,,) (fromJSON a) (fromJSON b) (fromJSON c) (fromJSON d)
+   fromJSON _                    = fail "expecting an array with 4 elements"
+
+instance InJSON IOException where
+   toJSON     = toJSON . ioeGetErrorString
+   fromJSON (String s) = return (userError s)
+   fromJSON _ = fail "excepting a string"
+
+--------------------------------------------------------
+-- Parser
+
+parseJSON :: String -> Either String JSON
+parseJSON = parseSimple json
+ where
+   json :: Parser JSON
+   json = choice
+      [ Null          <$ P.reserved lexer "null"
+      , Boolean True  <$ P.reserved lexer "true"
+      , Boolean False <$ P.reserved lexer "false"
+      , Number . either I D <$> naturalOrFloat -- redefined in Ideas.Text.Parsing
+      , String . fromMaybe [] . UTF8.decodeM <$> P.stringLiteral lexer
+      , Array  <$> P.brackets lexer (sepBy json (P.comma lexer))
+      , Object <$> P.braces lexer (sepBy keyValue (P.comma lexer))
+      ]
+
+   keyValue :: Parser (String, JSON)
+   keyValue = (,) <$> P.stringLiteral lexer <* P.colon lexer <*> json
+
+   lexer :: P.TokenParser a
+   lexer = P.makeTokenParser $ emptyDef
+      { reservedNames = ["true", "false", "null"] }
+
+--------------------------------------------------------
+-- JSON-RPC
+
+data RPCRequest = Request
+   { requestMethod :: String
+   , requestParams :: JSON
+   , requestId     :: JSON
+   }
+
+data RPCResponse = Response
+   { responseResult :: JSON
+   , responseError  :: JSON
+   , responseId     :: JSON
+   }
+
+instance Show RPCRequest where
+   show = show . toJSON
+
+instance Show RPCResponse where
+   show = show . toJSON
+
+instance InJSON RPCRequest where
+   toJSON req = Object
+      [ ("method", String $ requestMethod req)
+      , ("params", requestParams req)
+      , ("id"    , requestId req)
+      ]
+   fromJSON obj = do
+      mj <- lookupM "method" obj
+      pj <- lookupM "params" obj
+      ij <- lookupM "id"     obj
+      case mj of
+         String s -> return (Request s pj ij)
+         _        -> fail "expecting a string"
+
+instance InJSON RPCResponse where
+   toJSON resp = Object
+      [ ("result", responseResult resp)
+      , ("error" , responseError resp)
+      , ("id"    , responseId resp)
+      ]
+   fromJSON obj = do
+      rj <- lookupM "result" obj
+      ej <- lookupM "error"  obj
+      ij <- lookupM "id"     obj
+      return (Response rj ej ij)
+
+okResponse :: JSON -> JSON -> RPCResponse
+okResponse x y = Response
+   { responseResult = x
+   , responseError  = Null
+   , responseId     = y
+   }
+
+errorResponse :: JSON -> JSON -> RPCResponse
+errorResponse x y = Response
+   { responseResult = Null
+   , responseError  = x
+   , responseId     = y
+   }
+
+lookupM :: Monad m => String -> JSON -> m JSON
+lookupM x (Object xs) = maybe (fail $ "field " ++ x ++ " not found") return (lookup x xs)
+lookupM _ _ = fail "expecting a JSON object"
+
+indent :: Int -> String -> String
+indent n = unlines . map (replicate n ' ' ++) . lines
+
+--------------------------------------------------------
+-- JSON-RPC over HTTP
+
+type RPCHandler m = String -> JSON -> m JSON
+
+jsonRPC :: (MonadError a m, InJSON a)
+        => JSON -> RPCHandler m -> m RPCResponse
+jsonRPC input handler =
+   case fromJSON input of
+      Nothing  -> return (errorResponse (String "Invalid request") Null)
+      Just req -> do
+         json <- handler (requestMethod req) (requestParams req)
+         return (okResponse json (requestId req))
+       `catchError` \msg ->
+          return (errorResponse (toJSON msg) (requestId req))
+
+--------------------------------------------------------
+-- Testing parser/pretty-printer
+
+instance Arbitrary JSON where
+   arbitrary = sized arbJSON
+
+instance Arbitrary Number where
+   arbitrary = oneof [liftM I arbitrary, liftM (D . fromInteger) arbitrary]
+
+arbJSON :: Int -> Gen JSON
+arbJSON n
+   | n == 0 = oneof
+        [ liftM Number arbitrary, liftM String myStringGen
+        , liftM Boolean arbitrary, return Null
+        ]
+   | otherwise = oneof
+        [ arbJSON 0
+        , do i  <- choose (0, 6)
+             xs <- replicateM i rec
+             return (Array xs)
+        , do i  <- choose (0, 6)
+             xs <- replicateM i myStringGen
+             ys <- replicateM i rec
+             return (Object (zip xs ys))
+        ]
+ where
+   rec = arbJSON (n `div` 2)
+
+myStringGen :: Gen String
+myStringGen = do
+   n <- choose (1, 10)
+   replicateM n $ elements $
+      ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9']
+
+propEncoding :: Property
+propEncoding = property $ \a ->
+   parseJSON (show a) == Right a
+ src/Ideas/Text/OpenMath/Dictionary/Arith1.hs view
@@ -0,0 +1,79 @@+-- Automatically generated from content dictionary arith1.ocd.  Do not change.
+module Ideas.Text.OpenMath.Dictionary.Arith1 where
+
+import Ideas.Text.OpenMath.Symbol
+
+-- | List of symbols defined in arith1 dictionary
+arith1List :: [Symbol]
+arith1List = [lcmSymbol, gcdSymbol, plusSymbol, unaryMinusSymbol, minusSymbol, timesSymbol, divideSymbol, powerSymbol, absSymbol, rootSymbol, sumSymbol, productSymbol]
+
+{-| The symbol to represent the n-ary function to return the least common
+multiple of its arguments. -}
+lcmSymbol :: Symbol
+lcmSymbol = makeSymbol "arith1" "lcm"
+
+{-| The symbol to represent the n-ary function to return the gcd (greatest
+common divisor) of its arguments. -}
+gcdSymbol :: Symbol
+gcdSymbol = makeSymbol "arith1" "gcd"
+
+{-| The symbol representing an n-ary commutative function plus. -}
+plusSymbol :: Symbol
+plusSymbol = makeSymbol "arith1" "plus"
+
+{-| This symbol denotes unary minus, i.e. the additive inverse. -}
+unaryMinusSymbol :: Symbol
+unaryMinusSymbol = makeSymbol "arith1" "unary_minus"
+
+{-| The symbol representing a binary minus function. This is equivalent to
+adding the additive inverse. -}
+minusSymbol :: Symbol
+minusSymbol = makeSymbol "arith1" "minus"
+
+{-| The symbol representing an n-ary multiplication function. -}
+timesSymbol :: Symbol
+timesSymbol = makeSymbol "arith1" "times"
+
+{-| This symbol represents a (binary) division function denoting the first
+argument right-divided by the second, i.e. divide(a,b)=a*inverse(b). It is the
+inverse of the multiplication function defined by the symbol times in this CD.
+-}
+divideSymbol :: Symbol
+divideSymbol = makeSymbol "arith1" "divide"
+
+{-| This symbol represents a power function. The first argument is raised to
+the power of the second argument. When the second argument is not an integer,
+powering is defined in terms of exponentials and logarithms for the complex
+and real numbers. This operator can represent general powering. -}
+powerSymbol :: Symbol
+powerSymbol = makeSymbol "arith1" "power"
+
+{-| A unary operator which represents the absolute value of its argument. The
+argument should be numerically valued. In the complex case this is often
+referred to as the modulus. -}
+absSymbol :: Symbol
+absSymbol = makeSymbol "arith1" "abs"
+
+{-| A binary operator which represents its first argument "lowered" to its
+n'th root where n is the second argument. This is the inverse of the operation
+represented by the power symbol defined in this CD. Care should be taken as to
+the precise meaning of this operator, in particular which root is represented,
+however it is here to represent the general notion of taking n'th roots. As
+inferred by the signature relevant to this symbol, the function represented by
+this symbol is the single valued function, the specific root returned is the
+one indicated by the first CMP. Note also that the converse of the second CMP
+is not valid in general. -}
+rootSymbol :: Symbol
+rootSymbol = makeSymbol "arith1" "root"
+
+{-| An operator taking two arguments, the first being the range of summation,
+e.g. an integral interval, the second being the function to be summed. Note
+that the sum may be over an infinite interval. -}
+sumSymbol :: Symbol
+sumSymbol = makeSymbol "arith1" "sum"
+
+{-| An operator taking two arguments, the first being the range of
+multiplication e.g. an integral interval, the second being the function to be
+multiplied. Note that the product may be over an infinite interval. -}
+productSymbol :: Symbol
+productSymbol = makeSymbol "arith1" "product"
+ src/Ideas/Text/OpenMath/Dictionary/Calculus1.hs view
@@ -0,0 +1,36 @@+-- Automatically generated from content dictionary calculus1.ocd.  Do not change.
+module Ideas.Text.OpenMath.Dictionary.Calculus1 where
+
+import Ideas.Text.OpenMath.Symbol
+
+-- | List of symbols defined in calculus1 dictionary
+calculus1List :: [Symbol]
+calculus1List = [diffSymbol, nthdiffSymbol, partialdiffSymbol, intSymbol, defintSymbol]
+
+{-| This symbol is used to express ordinary differentiation of a unary
+function. The single argument is the unary function. -}
+diffSymbol :: Symbol
+diffSymbol = makeSymbol "calculus1" "diff"
+
+{-| This symbol is used to express the nth-iterated ordinary differentiation
+of a unary function. The first argument is n, and the second the unary
+function. -}
+nthdiffSymbol :: Symbol
+nthdiffSymbol = makeSymbol "calculus1" "nthdiff"
+
+{-| This symbol is used to express partial differentiation of a function of
+more than one variable. It has two arguments, the first is a list of integers
+which index the variables of the function, the second is the function. -}
+partialdiffSymbol :: Symbol
+partialdiffSymbol = makeSymbol "calculus1" "partialdiff"
+
+{-| This symbol is used to represent indefinite integration of unary
+functions. The argument is the unary function. -}
+intSymbol :: Symbol
+intSymbol = makeSymbol "calculus1" "int"
+
+{-| This symbol is used to represent definite integration of unary functions.
+It takes two arguments; the first being the range (e.g. a set) of integration,
+and the second the function. -}
+defintSymbol :: Symbol
+defintSymbol = makeSymbol "calculus1" "defint"
+ src/Ideas/Text/OpenMath/Dictionary/Fns1.hs view
@@ -0,0 +1,73 @@+-- Automatically generated from content dictionary fns1.ocd.  Do not change.
+module Ideas.Text.OpenMath.Dictionary.Fns1 where
+
+import Ideas.Text.OpenMath.Symbol
+
+-- | List of symbols defined in fns1 dictionary
+fns1List :: [Symbol]
+fns1List = [domainofapplicationSymbol, domainSymbol, rangeSymbol, imageSymbol, identitySymbol, leftInverseSymbol, rightInverseSymbol, inverseSymbol, leftComposeSymbol, lambdaSymbol]
+
+{-| The domainofapplication element denotes the domain over which a given
+function is being applied. It is intended in MathML to be a more general
+alternative to specification of this domain using such quantifier elements as
+bvar, lowlimit or condition. -}
+domainofapplicationSymbol :: Symbol
+domainofapplicationSymbol = makeSymbol "fns1" "domainofapplication"
+
+{-| This symbol denotes the domain of a given function, which is the set of
+values it is defined over. -}
+domainSymbol :: Symbol
+domainSymbol = makeSymbol "fns1" "domain"
+
+{-| This symbol denotes the range of a function, that is a set that the
+function will map to. The single argument should be the function whos range is
+being queried. It should be noted that this is not necessarily equal to the
+image, it is merely required to contain the image. -}
+rangeSymbol :: Symbol
+rangeSymbol = makeSymbol "fns1" "range"
+
+{-| This symbol denotes the image of a given function, which is the set of
+values the domain of the given function maps to. -}
+imageSymbol :: Symbol
+imageSymbol = makeSymbol "fns1" "image"
+
+{-| The identity function, it takes one argument and returns the same value.
+-}
+identitySymbol :: Symbol
+identitySymbol = makeSymbol "fns1" "identity"
+
+{-| This symbol is used to describe the left inverse of its argument (a
+function). This inverse may only be partially defined because the function may
+not have been surjective. If the function is not surjective the left inverse
+function is ill-defined without further stipulations. No other assumptions are
+made on the semantics of this left inverse. -}
+leftInverseSymbol :: Symbol
+leftInverseSymbol = makeSymbol "fns1" "left_inverse"
+
+{-| This symbol is used to describe the right inverse of its argument (a
+function). This inverse may only be partially defined because the function may
+not have been surjective. If the function is not surjective the right inverse
+function is ill-defined without further stipulations. No other assumptions are
+made on the semantics of this right inverse. -}
+rightInverseSymbol :: Symbol
+rightInverseSymbol = makeSymbol "fns1" "right_inverse"
+
+{-| This symbol is used to describe the inverse of its argument (a function).
+This inverse may only be partially defined because the function may not have
+been surjective. If the function is not surjective the inverse function is
+ill-defined without further stipulations. No assumptions are made on the
+semantics of this inverse. -}
+inverseSymbol :: Symbol
+inverseSymbol = makeSymbol "fns1" "inverse"
+
+{-| This symbol represents the function which forms the left-composition of
+its two (function) arguments. -}
+leftComposeSymbol :: Symbol
+leftComposeSymbol = makeSymbol "fns1" "left_compose"
+
+{-| This symbol is used to represent anonymous functions as lambda expansions.
+It is used in a binder that takes two further arguments, the first of which is
+a list of variables, and the second of which is an expression, and it forms
+the function which is the lambda extraction of the expression -}
+lambdaSymbol :: Symbol
+lambdaSymbol = makeSymbol "fns1" "lambda"
+ src/Ideas/Text/OpenMath/Dictionary/Linalg2.hs view
@@ -0,0 +1,24 @@+-- Automatically generated from content dictionary linalg2.ocd.  Do not change.
+module Ideas.Text.OpenMath.Dictionary.Linalg2 where
+
+import Ideas.Text.OpenMath.Symbol
+
+-- | List of symbols defined in linalg2 dictionary
+linalg2List :: [Symbol]
+linalg2List = [vectorSymbol, matrixrowSymbol, matrixSymbol]
+
+{-| This symbol represents an n-ary function used to construct (or describe)
+vectors. Vectors in this CD are considered to be row vectors and must
+therefore be transposed to be considered as column vectors. -}
+vectorSymbol :: Symbol
+vectorSymbol = makeSymbol "linalg2" "vector"
+
+{-| This symbol is an n-ary constructor used to represent rows of matrices.
+Its arguments should be members of a ring. -}
+matrixrowSymbol :: Symbol
+matrixrowSymbol = makeSymbol "linalg2" "matrixrow"
+
+{-| This symbol is an n-ary matrix constructor which requires matrixrow's as
+arguments. It is used to represent matrices. -}
+matrixSymbol :: Symbol
+matrixSymbol = makeSymbol "linalg2" "matrix"
+ src/Ideas/Text/OpenMath/Dictionary/List1.hs view
@@ -0,0 +1,28 @@+-- Automatically generated from content dictionary list1.ocd.  Do not change.
+module Ideas.Text.OpenMath.Dictionary.List1 where
+
+import Ideas.Text.OpenMath.Symbol
+
+-- | List of symbols defined in list1 dictionary
+list1List :: [Symbol]
+list1List = [mapSymbol, suchthatSymbol, listSymbol]
+
+{-| This symbol represents a mapping function which may be used to construct
+lists, it takes as arguments a function from X to Y and a list over X in that
+order. The value that is returned is a list of values in Y. The argument list
+may be a set or an integer_interval. -}
+mapSymbol :: Symbol
+mapSymbol = makeSymbol "list1" "map"
+
+{-| This symbol represents the suchthat function which may be used to
+construct lists, it takes two arguments. The first argument should be the set
+which contains the elements of the list, the second argument should be a
+predicate, that is a function from the set to the booleans which describes if
+an element is to be in the list returned. -}
+suchthatSymbol :: Symbol
+suchthatSymbol = makeSymbol "list1" "suchthat"
+
+{-| This symbol denotes the list construct which is an n-ary function. The
+list entries must be given explicitly. -}
+listSymbol :: Symbol
+listSymbol = makeSymbol "list1" "list"
+ src/Ideas/Text/OpenMath/Dictionary/Logic1.hs view
@@ -0,0 +1,50 @@+-- Automatically generated from content dictionary logic1.ocd.  Do not change.
+module Ideas.Text.OpenMath.Dictionary.Logic1 where
+
+import Ideas.Text.OpenMath.Symbol
+
+-- | List of symbols defined in logic1 dictionary
+logic1List :: [Symbol]
+logic1List = [equivalentSymbol, notSymbol, andSymbol, xorSymbol, orSymbol, impliesSymbol, trueSymbol, falseSymbol]
+
+{-| This symbol is used to show that two boolean expressions are logically
+equivalent, that is have the same boolean value for any inputs. -}
+equivalentSymbol :: Symbol
+equivalentSymbol = makeSymbol "logic1" "equivalent"
+
+{-| This symbol represents the logical not function which takes one boolean
+argument, and returns the opposite boolean value. -}
+notSymbol :: Symbol
+notSymbol = makeSymbol "logic1" "not"
+
+{-| This symbol represents the logical and function which is an n-ary function
+taking boolean arguments and returning a boolean value. It is true if all
+arguments are true or false otherwise. -}
+andSymbol :: Symbol
+andSymbol = makeSymbol "logic1" "and"
+
+{-| This symbol represents the logical xor function which is an n-ary function
+taking boolean arguments and returning a boolean value. It is true if there
+are an odd number of true arguments or false otherwise. -}
+xorSymbol :: Symbol
+xorSymbol = makeSymbol "logic1" "xor"
+
+{-| This symbol represents the logical or function which is an n-ary function
+taking boolean arguments and returning a boolean value. It is true if any of
+the arguments are true or false otherwise. -}
+orSymbol :: Symbol
+orSymbol = makeSymbol "logic1" "or"
+
+{-| This symbol represents the logical implies function which takes two
+boolean expressions as arguments. It evaluates to false if the first argument
+is true and the second argument is false, otherwise it evaluates to true. -}
+impliesSymbol :: Symbol
+impliesSymbol = makeSymbol "logic1" "implies"
+
+{-| This symbol represents the boolean value true. -}
+trueSymbol :: Symbol
+trueSymbol = makeSymbol "logic1" "true"
+
+{-| This symbol represents the boolean value false. -}
+falseSymbol :: Symbol
+falseSymbol = makeSymbol "logic1" "false"
+ src/Ideas/Text/OpenMath/Dictionary/Nums1.hs view
@@ -0,0 +1,54 @@+-- Automatically generated from content dictionary nums1.ocd.  Do not change.
+module Ideas.Text.OpenMath.Dictionary.Nums1 where
+
+import Ideas.Text.OpenMath.Symbol
+
+-- | List of symbols defined in nums1 dictionary
+nums1List :: [Symbol]
+nums1List = [basedIntegerSymbol, rationalSymbol, infinitySymbol, eSymbol, iSymbol, piSymbol, gammaSymbol, naNSymbol]
+
+{-| This symbol represents the constructor function for integers, specifying
+the base. It takes two arguments, the first is a positive integer to denote
+the base to which the number is represented, the second argument is a string
+which contains an optional sign and the digits of the integer, using 0-9a-z
+(as a consequence of this no radix greater than 35 is supported). Base 16 and
+base 10 are already covered in the encodings of integers. -}
+basedIntegerSymbol :: Symbol
+basedIntegerSymbol = makeSymbol "nums1" "based_integer"
+
+{-| This symbol represents the constructor function for rational numbers. It
+takes two arguments, the first is an integer p to denote the numerator and the
+second a nonzero integer q to denote the denominator of the rational p/q. -}
+rationalSymbol :: Symbol
+rationalSymbol = makeSymbol "nums1" "rational"
+
+{-| A symbol to represent the notion of infinity. -}
+infinitySymbol :: Symbol
+infinitySymbol = makeSymbol "nums1" "infinity"
+
+{-| This symbol represents the base of the natural logarithm, approximately
+2.718. See Abramowitz and Stegun, Handbook of Mathematical Functions, section
+4.1. -}
+eSymbol :: Symbol
+eSymbol = makeSymbol "nums1" "e"
+
+{-| This symbol represents the square root of -1. -}
+iSymbol :: Symbol
+iSymbol = makeSymbol "nums1" "i"
+
+{-| A symbol to convey the notion of pi, approximately 3.142. The ratio of the
+circumference of a circle to its diameter. -}
+piSymbol :: Symbol
+piSymbol = makeSymbol "nums1" "pi"
+
+{-| A symbol to convey the notion of the gamma constant as defined in
+Abramowitz and Stegun, Handbook of Mathematical Functions, section 6.1.3. It
+is the limit of 1 + 1/2 + 1/3 + ... + 1/m - ln m as m tends to infinity, this
+is approximately 0.5772 15664. -}
+gammaSymbol :: Symbol
+gammaSymbol = makeSymbol "nums1" "gamma"
+
+{-| A symbol to convey the notion of not-a-number. The result of an ill-posed
+floating computation. See IEEE standard for floating point representations. -}
+naNSymbol :: Symbol
+naNSymbol = makeSymbol "nums1" "NaN"
+ src/Ideas/Text/OpenMath/Dictionary/Quant1.hs view
@@ -0,0 +1,22 @@+-- Automatically generated from content dictionary quant1.ocd.  Do not change.
+module Ideas.Text.OpenMath.Dictionary.Quant1 where
+
+import Ideas.Text.OpenMath.Symbol
+
+-- | List of symbols defined in quant1 dictionary
+quant1List :: [Symbol]
+quant1List = [forallSymbol, existsSymbol]
+
+{-| This symbol represents the universal ("for all") quantifier which takes
+two arguments. It must be placed within an OMBIND element. The first argument
+is the bound variables (placed within an OMBVAR element), and the second is an
+expression. -}
+forallSymbol :: Symbol
+forallSymbol = makeSymbol "quant1" "forall"
+
+{-| This symbol represents the existential ("there exists") quantifier which
+takes two arguments. It must be placed within an OMBIND element. The first
+argument is the bound variables (placed within an OMBVAR element), and the
+second is an expression. -}
+existsSymbol :: Symbol
+existsSymbol = makeSymbol "quant1" "exists"
+ src/Ideas/Text/OpenMath/Dictionary/Relation1.hs view
@@ -0,0 +1,44 @@+-- Automatically generated from content dictionary relation1.ocd.  Do not change.
+module Ideas.Text.OpenMath.Dictionary.Relation1 where
+
+import Ideas.Text.OpenMath.Symbol
+
+-- | List of symbols defined in relation1 dictionary
+relation1List :: [Symbol]
+relation1List = [eqSymbol, ltSymbol, gtSymbol, neqSymbol, leqSymbol, geqSymbol, approxSymbol]
+
+{-| This symbol represents the binary equality function. -}
+eqSymbol :: Symbol
+eqSymbol = makeSymbol "relation1" "eq"
+
+{-| This symbol represents the binary less than function which returns true if
+the first argument is less than the second, it returns false otherwise. -}
+ltSymbol :: Symbol
+ltSymbol = makeSymbol "relation1" "lt"
+
+{-| This symbol represents the binary greater than function which returns true
+if the first argument is greater than the second, it returns false otherwise.
+-}
+gtSymbol :: Symbol
+gtSymbol = makeSymbol "relation1" "gt"
+
+{-| This symbol represents the binary inequality function. -}
+neqSymbol :: Symbol
+neqSymbol = makeSymbol "relation1" "neq"
+
+{-| This symbol represents the binary less than or equal to function which
+returns true if the first argument is less than or equal to the second, it
+returns false otherwise. -}
+leqSymbol :: Symbol
+leqSymbol = makeSymbol "relation1" "leq"
+
+{-| This symbol represents the binary greater than or equal to function which
+returns true if the first argument is greater than or equal to the second, it
+returns false otherwise. -}
+geqSymbol :: Symbol
+geqSymbol = makeSymbol "relation1" "geq"
+
+{-| This symbol is used to denote the approximate equality of its two
+arguments. -}
+approxSymbol :: Symbol
+approxSymbol = makeSymbol "relation1" "approx"
+ src/Ideas/Text/OpenMath/Dictionary/Transc1.hs view
@@ -0,0 +1,149 @@+-- Automatically generated from content dictionary transc1.ocd.  Do not change.
+module Ideas.Text.OpenMath.Dictionary.Transc1 where
+
+import Ideas.Text.OpenMath.Symbol
+
+-- | List of symbols defined in transc1 dictionary
+transc1List :: [Symbol]
+transc1List = [logSymbol, lnSymbol, expSymbol, sinSymbol, cosSymbol, tanSymbol, secSymbol, cscSymbol, cotSymbol, sinhSymbol, coshSymbol, tanhSymbol, sechSymbol, cschSymbol, cothSymbol, arcsinSymbol, arccosSymbol, arctanSymbol, arcsecSymbol, arccscSymbol, arccotSymbol, arcsinhSymbol, arccoshSymbol, arctanhSymbol, arcsechSymbol, arccschSymbol, arccothSymbol]
+
+{-| This symbol represents a binary log function; the first argument is the
+base, to which the second argument is log'ed. It is defined in Abramowitz and
+Stegun, Handbook of Mathematical Functions, section 4.1 -}
+logSymbol :: Symbol
+logSymbol = makeSymbol "transc1" "log"
+
+{-| This symbol represents the ln function (natural logarithm) as described in
+Abramowitz and Stegun, section 4.1. It takes one argument. Note the
+description in the CMP/FMP of the branch cut. If signed zeros are in use, the
+inequality needs to be non-strict. -}
+lnSymbol :: Symbol
+lnSymbol = makeSymbol "transc1" "ln"
+
+{-| This symbol represents the exponentiation function as described in
+Abramowitz and Stegun, section 4.2. It takes one argument. -}
+expSymbol :: Symbol
+expSymbol = makeSymbol "transc1" "exp"
+
+{-| This symbol represents the sin function as described in Abramowitz and
+Stegun, section 4.3. It takes one argument. -}
+sinSymbol :: Symbol
+sinSymbol = makeSymbol "transc1" "sin"
+
+{-| This symbol represents the cos function as described in Abramowitz and
+Stegun, section 4.3. It takes one argument. -}
+cosSymbol :: Symbol
+cosSymbol = makeSymbol "transc1" "cos"
+
+{-| This symbol represents the tan function as described in Abramowitz and
+Stegun, section 4.3. It takes one argument. -}
+tanSymbol :: Symbol
+tanSymbol = makeSymbol "transc1" "tan"
+
+{-| This symbol represents the sec function as described in Abramowitz and
+Stegun, section 4.3. It takes one argument. -}
+secSymbol :: Symbol
+secSymbol = makeSymbol "transc1" "sec"
+
+{-| This symbol represents the csc function as described in Abramowitz and
+Stegun, section 4.3. It takes one argument. -}
+cscSymbol :: Symbol
+cscSymbol = makeSymbol "transc1" "csc"
+
+{-| This symbol represents the cot function as described in Abramowitz and
+Stegun, section 4.3. It takes one argument. -}
+cotSymbol :: Symbol
+cotSymbol = makeSymbol "transc1" "cot"
+
+{-| This symbol represents the sinh function as described in Abramowitz and
+Stegun, section 4.5. It takes one argument. -}
+sinhSymbol :: Symbol
+sinhSymbol = makeSymbol "transc1" "sinh"
+
+{-| This symbol represents the cosh function as described in Abramowitz and
+Stegun, section 4.5. It takes one argument. -}
+coshSymbol :: Symbol
+coshSymbol = makeSymbol "transc1" "cosh"
+
+{-| This symbol represents the tanh function as described in Abramowitz and
+Stegun, section 4.5. It takes one argument. -}
+tanhSymbol :: Symbol
+tanhSymbol = makeSymbol "transc1" "tanh"
+
+{-| This symbol represents the sech function as described in Abramowitz and
+Stegun, section 4.5. It takes one argument. -}
+sechSymbol :: Symbol
+sechSymbol = makeSymbol "transc1" "sech"
+
+{-| This symbol represents the csch function as described in Abramowitz and
+Stegun, section 4.5. It takes one argument. -}
+cschSymbol :: Symbol
+cschSymbol = makeSymbol "transc1" "csch"
+
+{-| This symbol represents the coth function as described in Abramowitz and
+Stegun, section 4.5. It takes one argument. -}
+cothSymbol :: Symbol
+cothSymbol = makeSymbol "transc1" "coth"
+
+{-| This symbol represents the arcsin function. This is the inverse of the sin
+function as described in Abramowitz and Stegun, section 4.4. It takes one
+argument. -}
+arcsinSymbol :: Symbol
+arcsinSymbol = makeSymbol "transc1" "arcsin"
+
+{-| This symbol represents the arccos function. This is the inverse of the cos
+function as described in Abramowitz and Stegun, section 4.4. It takes one
+argument. -}
+arccosSymbol :: Symbol
+arccosSymbol = makeSymbol "transc1" "arccos"
+
+{-| This symbol represents the arctan function. This is the inverse of the tan
+function as described in Abramowitz and Stegun, section 4.4. It takes one
+argument. -}
+arctanSymbol :: Symbol
+arctanSymbol = makeSymbol "transc1" "arctan"
+
+{-| This symbol represents the arcsec function as described in Abramowitz and
+Stegun, section 4.4. -}
+arcsecSymbol :: Symbol
+arcsecSymbol = makeSymbol "transc1" "arcsec"
+
+{-| This symbol represents the arccsc function as described in Abramowitz and
+Stegun, section 4.4. -}
+arccscSymbol :: Symbol
+arccscSymbol = makeSymbol "transc1" "arccsc"
+
+{-| This symbol represents the arccot function as described in Abramowitz and
+Stegun, section 4.4. -}
+arccotSymbol :: Symbol
+arccotSymbol = makeSymbol "transc1" "arccot"
+
+{-| This symbol represents the arcsinh function as described in Abramowitz and
+Stegun, section 4.6. -}
+arcsinhSymbol :: Symbol
+arcsinhSymbol = makeSymbol "transc1" "arcsinh"
+
+{-| This symbol represents the arccosh function as described in Abramowitz and
+Stegun, section 4.6. -}
+arccoshSymbol :: Symbol
+arccoshSymbol = makeSymbol "transc1" "arccosh"
+
+{-| This symbol represents the arctanh function as described in Abramowitz and
+Stegun, section 4.6. -}
+arctanhSymbol :: Symbol
+arctanhSymbol = makeSymbol "transc1" "arctanh"
+
+{-| This symbol represents the arcsech function as described in Abramowitz and
+Stegun, section 4.6. -}
+arcsechSymbol :: Symbol
+arcsechSymbol = makeSymbol "transc1" "arcsech"
+
+{-| This symbol represents the arccsch function as described in Abramowitz and
+Stegun, section 4.6. -}
+arccschSymbol :: Symbol
+arccschSymbol = makeSymbol "transc1" "arccsch"
+
+{-| This symbol represents the arccoth function as described in Abramowitz and
+Stegun, section 4.6. -}
+arccothSymbol :: Symbol
+arccothSymbol = makeSymbol "transc1" "arccoth"
+ src/Ideas/Text/OpenMath/FMP.hs view
@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Formal mathematical properties (FMP)
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.OpenMath.FMP where
+
+import Data.List (union)
+import Ideas.Text.OpenMath.Dictionary.Quant1 (forallSymbol, existsSymbol)
+import Ideas.Text.OpenMath.Dictionary.Relation1 (eqSymbol, neqSymbol)
+import Ideas.Text.OpenMath.Object
+import Ideas.Text.OpenMath.Symbol
+
+data FMP = FMP
+   { quantor       :: Symbol
+   , metaVariables :: [String]
+   , leftHandSide  :: OMOBJ
+   , relation      :: Symbol
+   , rightHandSide :: OMOBJ
+   }
+
+toObject :: FMP -> OMOBJ
+toObject fmp
+   | null (metaVariables fmp) = body
+   | otherwise =
+        OMBIND (OMS (quantor fmp)) (metaVariables fmp) body
+ where
+   body = OMA [OMS (relation fmp), leftHandSide fmp, rightHandSide fmp]
+
+eqFMP :: OMOBJ -> OMOBJ -> FMP
+eqFMP lhs rhs = FMP
+   { quantor       = forallSymbol
+   , metaVariables = getOMVs lhs `union` getOMVs rhs
+   , leftHandSide  = lhs
+   , relation      = eqSymbol
+   , rightHandSide = rhs
+   }
+
+-- | Represents a common misconception. In certain (most) situations,
+-- the two objects are not the same.
+buggyFMP :: OMOBJ -> OMOBJ -> FMP
+buggyFMP lhs rhs = (eqFMP lhs rhs)
+   { quantor  = existsSymbol
+   , relation = neqSymbol
+   }
+ src/Ideas/Text/OpenMath/Object.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.OpenMath.Object
+   ( OMOBJ(..), getOMVs, xml2omobj, omobj2xml
+   ) where
+
+import Data.Char
+import Data.Generics.Uniplate.Direct hiding (children)
+import Data.List (nub)
+import Data.Maybe
+import Data.Typeable
+import Ideas.Text.OpenMath.Symbol
+import Ideas.Text.XML
+
+-- internal representation for OpenMath objects
+data OMOBJ = OMI Integer
+           | OMF Double
+           | OMV String
+           | OMS Symbol
+           | OMA [OMOBJ]
+           | OMBIND OMOBJ [String] OMOBJ
+   deriving (Show, Eq, Typeable)
+
+instance InXML OMOBJ where
+   toXML   = omobj2xml
+   fromXML = either fail return . xml2omobj
+
+instance Uniplate OMOBJ where
+   uniplate omobj =
+      case omobj of
+         OMA xs        -> plate OMA ||* xs
+         OMBIND a ss b -> plate OMBIND |* a |- ss |* b
+         _             -> plate omobj
+
+getOMVs :: OMOBJ -> [String]
+getOMVs omobj = nub [ x | OMV x <- universe omobj ]
+
+----------------------------------------------------------
+-- conversion functions: XML <-> OMOBJ
+
+xml2omobj :: XML -> Either String OMOBJ
+xml2omobj xmlTop =
+   case xmlTop of
+      Element "OMOBJ" _ [Right e] -> rec e
+      _ -> fail $ "expected an OMOBJ tag" ++ show xmlTop
+ where
+   rec xml =
+      case content xml of
+
+         _ | name xml == "OMA" -> do
+            ys <- mapM rec (children xml)
+            return (OMA ys)
+
+         [] | name xml == "OMS" -> do
+            let mcd = findAttribute "cd" xml
+            n <- findAttribute "name" xml
+            return (OMS (mcd, n))
+
+         [Left s] | name xml == "OMI" ->
+            case readInt s of
+               Just i -> return (OMI (toInteger i))
+               _      -> fail "invalid integer in OMI"
+
+         [] | name xml == "OMF" -> do
+            s <- findAttribute "dec" xml
+            case readDouble s of
+               Just nr -> return (OMF nr)
+               _       -> fail "invalid floating-point in OMF"
+
+         [] | name xml == "OMV" -> do
+            s <- findAttribute "name" xml
+            return (OMV s)
+
+         [Right x1, Right x2, Right x3] | name xml == "OMBIND" -> do
+            y1 <- rec x1
+            y2 <- recOMBVAR x2
+            y3 <- rec x3
+            return (OMBIND y1 y2 y3)
+
+         _ -> fail ("invalid tag " ++ show (name xml))
+
+   recOMBVAR xml
+      | name xml == "OMBVAR" =
+           let f (Right (OMV s)) = return s
+               f this = fail $ "expected tag OMV in OMBVAR, but found " ++ show this
+           in mapM (f . rec) (children xml)
+      | otherwise =
+           fail ("expected tag OMVAR, but found " ++ show (name xml))
+
+omobj2xml :: OMOBJ -> XML
+omobj2xml object = makeXML "OMOBJ" $ mconcat
+   [ "xmlns"   .=. "http://www.openmath.org/OpenMath"
+   , "version" .=. "2.0"
+   , "cdbase"  .=. "http://www.openmath.org/cd"
+   , rec object
+   ]
+ where
+   rec :: OMOBJ -> XMLBuilder
+   rec omobj =
+      case omobj of
+         OMI i  -> element "OMI" [text i]
+         OMF f  -> element "OMF" ["dec" .=. show f]
+         OMV v  -> element "OMV" ["name" .=. v]
+         OMA xs -> element "OMA" (map rec xs)
+         OMS s  -> element "OMS"
+            [ "cd"   .=. fromMaybe "unknown" (dictionary s)
+            , "name" .=. symbolName s
+            ]
+         OMBIND x ys z -> element "OMBIND"
+            [ rec x
+            , element "OMBVAR" (map (rec . OMV) ys)
+            , rec z
+            ]
+
+readInt :: String -> Maybe Integer
+readInt s = case reads s of
+               [(n, xs)] | all isSpace xs -> Just n
+               _ -> Nothing
+
+readDouble :: String -> Maybe Double
+readDouble s = case reads s of
+                  [(n, xs)] | all isSpace xs -> Just n
+                  _ -> Nothing
+ src/Ideas/Text/OpenMath/Symbol.hs view
@@ -0,0 +1,35 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.OpenMath.Symbol where
+
+type Symbol = (Maybe String, String)
+
+-- * Constructor functions
+
+makeSymbol :: String -> String -> Symbol
+makeSymbol = (,) . Just
+
+extraSymbol :: String -> Symbol
+extraSymbol = (,) Nothing
+
+-- * Selector functions
+
+dictionary :: Symbol -> Maybe String
+dictionary = fst
+
+symbolName :: Symbol -> String
+symbolName = snd
+
+-- * Utility function
+
+showSymbol :: Symbol -> String
+showSymbol s = maybe "" (++".") (dictionary s) ++ symbolName s
+ src/Ideas/Text/OpenMath/Tests.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.OpenMath.Tests (propEncoding) where
+
+import Control.Monad
+import Ideas.Text.OpenMath.Dictionary.Arith1
+import Ideas.Text.OpenMath.Dictionary.Calculus1
+import Ideas.Text.OpenMath.Dictionary.Fns1
+import Ideas.Text.OpenMath.Dictionary.Linalg2
+import Ideas.Text.OpenMath.Dictionary.List1
+import Ideas.Text.OpenMath.Dictionary.Logic1
+import Ideas.Text.OpenMath.Dictionary.Nums1
+import Ideas.Text.OpenMath.Dictionary.Quant1
+import Ideas.Text.OpenMath.Dictionary.Relation1
+import Ideas.Text.OpenMath.Dictionary.Transc1
+import Ideas.Text.OpenMath.Object
+import Test.QuickCheck
+
+arbOMOBJ :: Gen OMOBJ
+arbOMOBJ = sized rec
+ where
+   symbols = arith1List ++ calculus1List ++ fns1List ++ linalg2List ++
+      list1List ++ logic1List ++ nums1List ++ quant1List ++
+      relation1List ++ transc1List
+
+   rec 0 = frequency
+      [ (1, liftM OMI arbitrary)
+      , (1, liftM (\n -> OMF (fromInteger n / 1000)) arbitrary)
+      , (1, liftM OMV arbitrary)
+      , (5, elements $ map OMS symbols)
+      ]
+   rec n = frequency
+      [ (1, rec 0)
+      , (3, choose (1,4) >>= liftM OMA . (`replicateM` f))
+      , (1, liftM3 OMBIND f arbitrary f)
+      ]
+    where
+      f = rec (n `div` 2)
+
+propEncoding :: Property
+propEncoding = forAll arbOMOBJ $ \x -> xml2omobj (omobj2xml x) == Right x
+ src/Ideas/Text/Parsing.hs view
@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Utility functions for parsing with Parsec library
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.Parsing
+   ( module Export
+   , (<*>), (*>), (<*), (<$>), (<$), (<**>)
+   , parseSimple, complete, skip, (<..>), ranges, stopOn
+   , naturalOrFloat, float
+   , UnbalancedError(..), balanced
+   ) where
+
+import Control.Applicative hiding ((<|>))
+import Control.Arrow
+import Control.Monad
+import Data.Char
+import Data.List
+import Text.ParserCombinators.Parsec as Export
+import Text.ParserCombinators.Parsec.Expr as Export
+import Text.ParserCombinators.Parsec.Language as Export
+import Text.ParserCombinators.Parsec.Pos
+
+parseSimple :: Parser a -> String -> Either String a
+parseSimple p = left show . runParser (complete p) () ""
+
+complete :: Parser a -> Parser a
+complete p = spaces *> (p <* eof)
+
+skip :: Parser a -> Parser ()
+skip = void
+
+-- Like the combinator from parser, except that for doubles
+-- the read instance is used. This is a more precies representation
+-- of the double (e.g., 1.413 is not 1.413000000001).
+naturalOrFloat :: Parser (Either Integer Double)
+naturalOrFloat = do
+   a <- num
+   b <- option "" ((:) <$> char '.' <*> nat)
+   c <- option "" ((:) <$> oneOf "eE" <*> num)
+   spaces
+   case reads (a++b++c) of
+      _ | null b && null c ->
+         case a of
+            '-':xs -> return (Left (negate (readInt xs)))
+            xs     -> return (Left (readInt xs))
+      [(d, [])] -> return (Right d)
+      _         -> fail "not a float"
+ where
+   nat = many1 digit
+   num = maybe id (:) <$> optionMaybe (char '-') <*> nat
+   readInt = foldl' op 0 -- '
+   op a b  = a*10+fromIntegral (ord b)-48
+
+float :: Parser Double
+float = do
+   a <- nat
+   b <- option "" ((:) <$> char '.' <*> nat)
+   c <- option "" ((:) <$> oneOf "eE" <*> num)
+   case reads (a++b++c) of
+      [(d, [])] -> return d
+      _         -> fail "not a float"
+ where
+   nat = many1 digit
+   num = (:) <$> char '-' <*> nat
+
+infix  6 <..>
+
+(<..>) :: Char -> Char -> Parser Char
+x <..> y = satisfy (\c -> c >= x && c <= y)
+
+ranges :: [(Char, Char)] -> Parser Char
+ranges xs = choice [ a <..> b | (a, b) <- xs ]
+
+-- return in local function f needed for backwards compatibility
+stopOn :: [String] -> Parser String
+stopOn ys = rec
+ where
+   stop = choice (map f ys)
+   f x  = try (string x >> return ' ')
+   rec  =  (:) <$ notFollowedBy stop <*> anyChar <*> rec
+       <|> return []
+
+-- simple function for finding unbalanced pairs (e.g. parentheses)
+balanced :: [(Char, Char)] -> String -> Maybe UnbalancedError
+balanced table = run (initialPos "") []
+ where
+   run _ [] [] = Nothing
+   run _ ((pos, c):_) [] = return (NotClosed pos c)
+   run pos stack (x:xs)
+      | x `elem` opens  =
+           run next ((pos, x):stack) xs
+      | x `elem` closes =
+           case stack of
+              (_, y):rest | Just x == lookup y table -> run next rest xs
+              _ -> return (NotOpened pos x)
+      | otherwise =
+           run next stack xs
+    where
+      next = updatePosChar pos x
+
+   (opens, closes) = unzip table
+
+data UnbalancedError = NotClosed SourcePos Char
+                     | NotOpened SourcePos Char
+
+instance Show UnbalancedError where
+   show (NotClosed pos c) =
+      show pos ++ ": Opening symbol " ++ [c] ++ " is not closed"
+   show (NotOpened pos c) =
+      show pos ++ ": Closing symbol " ++ [c] ++ " has no matching symbol"
+ src/Ideas/Text/UTF8.hs view
@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Support for the UTF8 encoding
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.UTF8
+   ( encode, encodeM, decode, decodeM
+   , isUTF8, allBytes, propEncoding
+   ) where
+
+import Control.Monad.Error
+import Data.Char
+import Data.Maybe
+import Test.QuickCheck
+
+------------------------------------------------------------------
+-- Interface
+
+-- | Encode a string to UTF8 format
+encode :: String -> String
+encode = either error id . encodeM
+
+-- | Decode an UTF8 format string to unicode points
+decode :: String -> String
+decode = either error id . decodeM
+
+-- | Encode a string to UTF8 format (monadic)
+encodeM :: Monad m => String -> m String
+encodeM = liftM (map chr . concat) . mapM (toUTF8 . ord)
+
+-- | Decode an UTF8 format string to unicode points (monadic)
+decodeM :: Monad m => String -> m String
+decodeM = liftM (map chr) . fromUTF8 . map ord
+
+-- | Test whether the argument is a proper UTF8 string
+isUTF8 :: String -> Bool
+isUTF8 = isJust . decodeM
+
+-- | Test whether all characters are in the range 0-255
+allBytes :: String -> Bool
+allBytes = all ((`between` (0, 255)) . ord)
+
+------------------------------------------------------------------
+-- Helper functions
+
+toUTF8 :: Monad m => Int -> m [Int]
+toUTF8 n
+   | n < 128 = -- one byte
+        return [n]
+   | n < 2048 = -- two bytes
+        let (a, d) = n `divMod` 64
+        in return [a+192, d+128]
+   | n < 65536 = -- three bytes
+        let (a, d1) = n  `divMod` 4096
+            (b, d2) = d1 `divMod` 64
+        in return [a+224, b+128, d2+128]
+   | n < 1114112 = -- four bytes
+        let (a, d1) = n  `divMod` 262144
+            (b, d2) = d1 `divMod` 4096
+            (c, d3) = d2 `divMod` 64
+        in return [a+240, b+128, c+128, d3+128]
+   | otherwise =
+        fail "invalid character in UTF8"
+
+fromUTF8 :: Monad m => [Int] -> m [Int]
+fromUTF8 xs
+   | null xs   = return []
+   | otherwise = do
+        (i, rest) <- f xs
+        is <- fromUTF8 rest
+        return (i:is)
+ where
+   f (a:rest) | a < 128 = -- one byte
+      return (a, rest)
+   f (a:b:rest) | a `between` (192, 223) = do -- two bytes
+      unless (isHigh b) $
+         fail "invalid UTF8 character (two bytes)"
+      return ((a-192)*64 + b-128, rest)
+   f (a:b:c:rest) | a `between` (224, 239) = do -- three bytes
+      unless (isHigh b && isHigh c) $
+         fail "invalid UTF8 character (three bytes)"
+      return ((a-224)*4096 + (b-128)*64 + c-128, rest)
+   f (a:b:c:d:rest) | a >= 240 && a < 248 = do -- four bytes
+      let value = (a-240)*262144 + (b-128)*4096 + (c-128)*64 + d-128
+      unless (isHigh b && isHigh c && isHigh d && value <= 1114111) $
+         fail "invalid UTF8 character (four bytes)"
+      return (value, rest)
+   f _ = fail "invalid character in UTF8"
+
+isHigh :: Int -> Bool
+isHigh i = i `between` (128, 191)
+
+between :: Ord a => a -> (a, a) -> Bool
+between a (low, high) = low <= a && a <= high
+
+------------------------------------------------------------------
+-- Test encoding
+
+-- | QuickCheck internal encoding/decoding functions
+propEncoding :: Property
+propEncoding = forAll (sized gen) valid
+ where
+   gen n = replicateM n someChar
+   someChar = liftM chr $ oneof
+      -- To get a nice distribution over the number of bytes used
+      -- in the encoding
+      [ choose (0, 127), choose (128, 2047)
+      , choose (2048, 65535), choose (65536, 1114111)
+      ]
+
+valid :: String -> Bool
+valid xs = fromMaybe False $
+   do us <- encodeM xs
+      bs <- decodeM us
+      return (xs == bs)
+ src/Ideas/Text/XML.hs view
@@ -0,0 +1,152 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A datatype, parser, and pretty printer for XML documents. Re-exports
+-- functions defined elsewhere.
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.XML
+   ( XML, Attr, AttrList, Element(..), InXML(..)
+   , XMLBuilder, makeXML
+   , parseXML, showXML, compactXML, findAttribute
+   , children, Attribute(..), fromBuilder, findChild, getData
+   , BuildXML(..)
+   , module Data.Monoid, munless, mwhen
+   ) where
+
+import Data.Char
+import Data.Foldable (toList)
+import Data.Monoid
+import Ideas.Text.XML.Interface hiding (parseXML)
+import qualified Data.Sequence as Seq
+import qualified Ideas.Text.XML.Interface as I
+
+----------------------------------------------------------------
+-- Datatype definitions
+
+-- two helper types for attributes
+type XML      = Element
+type Attr     = Attribute  -- (String, String)
+type AttrList = Attributes -- [Attr]
+
+class InXML a where
+   toXML       :: a -> XML
+   listToXML   :: [a] -> XML
+   fromXML     :: Monad m => XML -> m a
+   listFromXML :: Monad m => XML -> m [a]
+   -- default definitions
+   listToXML = Element "list" [] . map (Right . toXML)
+   listFromXML xml
+      | name xml == "list" && null (attributes xml) =
+           mapM fromXML (children xml)
+      | otherwise = fail "expecting a list tag"
+
+----------------------------------------------------------------
+-- XML parser (a scanner and a XML tree constructor)
+
+parseXML :: String -> Either String XML
+parseXML input = do
+   xml <- I.parseXML input
+   return (ignoreLayout xml)
+
+ignoreLayout :: XML -> XML
+ignoreLayout (Element n as xs) =
+   let f = either (Left . trim) (Right . ignoreLayout)
+   in Element n as (map f xs)
+
+indentXML :: XML -> XML
+indentXML = rec 0
+ where
+   rec i (Element n as xs) =
+      let ipl  = i+2
+          cd j = Left ('\n' : replicate j ' ')
+          f    = either (\x -> [cd ipl, Left x]) (\x -> [cd ipl, Right (rec ipl x)])
+          body | null xs   = xs
+               | otherwise = concatMap f xs ++ [cd i]
+      in Element n as body
+
+showXML :: XML -> String
+showXML = (++"\n") . show . indentXML . ignoreLayout
+
+compactXML :: XML -> String
+compactXML = show . ignoreLayout
+
+----------------------------------------------------------------
+-- XML builders
+
+infix 3 .=.
+
+class Monoid a => BuildXML a where
+   (.=.)     :: String -> String -> a   -- attribute
+   unescaped :: String -> a             -- parsed character data (unescaped!)
+   builder   :: Element -> a            -- (named) xml element
+   tag       :: String -> a -> a        -- tag (with content)
+   -- functions with a default
+   string   :: String -> a -- escaped text
+   text     :: Show s => s -> a -- escaped text with Show class
+   element  :: String -> [a] -> a
+   emptyTag :: String -> a
+   -- implementations
+   string     = unescaped . escape
+   text       = string . show
+   element s  = tag s . mconcat
+   emptyTag s = tag s mempty
+
+data XMLBuilder = BS (Seq.Seq Attr) (Seq.Seq (Either String Element))
+
+-- local helper
+fromBS :: XMLBuilder -> (AttrList, Content)
+fromBS (BS as elts) = (toList as, toList elts)
+
+instance Monoid XMLBuilder where
+   mempty = BS mempty mempty
+   mappend (BS as1 elts1) (BS as2 elts2) =
+      BS (as1 <> as2) (elts1 <> elts2)
+
+instance BuildXML XMLBuilder where
+   n .=. s   = BS (Seq.singleton (n := escapeAttr s)) mempty
+   unescaped = BS mempty . Seq.singleton . Left
+   builder   = BS mempty . Seq.singleton . Right
+   tag s     = builder . uncurry (Element s) . fromBS
+
+makeXML :: String -> XMLBuilder -> XML
+makeXML s = uncurry (Element s) . fromBS
+
+mwhen :: Monoid a => Bool -> a -> a
+mwhen True  a = a
+mwhen False _ = mempty
+
+munless :: Monoid a => Bool -> a -> a
+munless = mwhen . not
+
+escapeAttr :: String -> String
+escapeAttr = concatMap f
+ where
+   f '<' = "&lt;"
+   f '&' = "&amp;"
+   f '"' = "&quot;"
+   f c   = [c]
+
+fromBuilder :: XMLBuilder -> Maybe Element
+fromBuilder m =
+   case fromBS m of
+      ([], [Right a]) -> Just a
+      _               -> Nothing
+
+escape :: String -> String
+escape = concatMap f
+ where
+   f '<' = "&lt;"
+   f '>' = "&gt;"
+   f '&' = "&amp;"
+   f c   = [c]
+
+trim :: String -> String
+trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+ src/Ideas/Text/XML/Document.hs view
@@ -0,0 +1,234 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Datatype for representing XML documents
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.XML.Document
+   ( Name, Attributes, Attribute(..), Reference(..), Parameter(..)
+   , XMLDoc(..), XML(..), Element(..), Content, DTD(..), DocTypeDecl(..)
+   , ContentSpec(..), CP(..), AttType(..), DefaultDecl(..), AttDef
+   , EntityDef, AttValue, EntityValue, ExternalID(..), PublicID
+   , Conditional(..), TextDecl, External
+   ) where
+
+type Name = String
+
+type Attributes = [Attribute]
+data Attribute  = Name := AttValue
+
+data Reference = CharRef Int | EntityRef String
+
+data Parameter = Parameter String
+
+data XMLDoc = XMLDoc
+   { versionInfo :: Maybe String
+   , encoding    :: Maybe String
+   , standalone  :: Maybe Bool
+   , dtd         :: Maybe DTD
+   , externals   :: [(String, External)]
+   , root        :: Element
+   }
+
+data XML = Tagged Element
+         | CharData String
+         | CDATA String
+         | Reference Reference
+
+data Element = Element
+   { name       :: Name
+   , attributes :: Attributes
+   , content    :: Content
+   }
+
+type Content = [XML]
+
+data DTD = DTD Name (Maybe ExternalID) [DocTypeDecl]
+
+data DocTypeDecl = ElementDecl Name ContentSpec
+                 | AttListDecl Name [AttDef]
+                 | EntityDecl Bool Name EntityDef
+                 | NotationDecl Name (Either ExternalID PublicID)
+                 | DTDParameter Parameter
+                 | DTDConditional Conditional
+
+data ContentSpec = Empty | Any | Mixed Bool [Name] | Children CP
+
+-- content particles
+data CP = Choice [CP] | Sequence [CP] | QuestionMark CP | Star CP | Plus CP | CPName Name
+
+data AttType = IdType | IdRefType | IdRefsType | EntityType | EntitiesType | NmTokenType | NmTokensType
+             | StringType | EnumerationType [String] | NotationType [String]
+
+data DefaultDecl = Required | Implied | Value AttValue | Fixed AttValue
+
+type AttDef = (Name, AttType, DefaultDecl)
+type EntityDef = Either EntityValue (ExternalID, Maybe String)
+type AttValue    = [Either Char Reference]
+type EntityValue = [Either Char (Either Parameter Reference)]
+
+data ExternalID = System String | Public String String
+
+type PublicID = String
+
+data Conditional = Include [DocTypeDecl] | Ignore [String]
+
+type TextDecl = (Maybe String, String)
+
+type External = (Maybe TextDecl, Content)
+
+---
+{-
+instance Show XMLDoc where
+   show doc = showXMLDecl doc ++ maybe "" show (dtd doc) ++ show (root doc)
+-}
+instance Show Attribute where
+   show (n := v) = n ++ "=" ++ showAttValue v
+
+instance Show Element where
+   show (Element n as c)
+      | null c    = showOpenTag True n as
+      | otherwise = showOpenTag False n as ++ concatMap show c ++ showCloseTag n
+
+instance Show XML where
+   show xml =
+      case xml of
+         Tagged e    -> show e
+         CharData s  -> s
+         CDATA s     -> "<![CDATA[" ++ s ++ "]]>"
+         Reference r -> show r
+
+instance Show Reference where
+   show ref =
+      case ref of
+         CharRef n   -> "&#" ++ show n ++ ";"
+         EntityRef s -> "&" ++ s ++ ";"
+
+instance Show Parameter where
+   show (Parameter s) = "%" ++ s ++ ";"
+{-
+instance Show DTD where
+   show (DTD n mid ds) = "<!DOCTYPE " ++ unwords list ++ ">"
+    where
+      list = n : catMaybes [fmap show mid, showDecls ds]
+      showDecls xs
+         | null xs   = Nothing
+         | otherwise = Just $ "[" ++ concatMap show xs ++ "]"
+
+instance Show ExternalID where
+   show extID =
+      case extID of
+         System s   -> "SYSTEM " ++ doubleQuote s
+         Public p s -> unwords ["PUBLIC", doubleQuote p, doubleQuote s]
+
+instance Show DocTypeDecl where
+   show decl =
+      case decl of
+         ElementDecl n c  -> "<!ELEMENT " ++ n ++ " " ++ show c ++ ">"
+         AttListDecl n as -> "<!ATTLIST " ++ unwords (n:map showAttDef as) ++ ">"
+         EntityDecl b n e ->
+            let xs = ["%" | not b] ++ [n, showEntityDef e]
+            in "<!ENTITY " ++ unwords xs ++ ">"
+         NotationDecl n e ->
+            let f s = "PUBLIC " ++ doubleQuote s
+            in "<!NOTATION " ++ n ++ " " ++ either show f e ++ ">"
+         DTDParameter r   -> show r
+         DTDConditional c -> show c
+
+instance Show ContentSpec where
+   show cspec =
+      case cspec of
+         Empty -> "EMPTY"
+         Any   -> "ANY"
+         Mixed b ns ->
+            let txt = intercalate "|" ("#PCDATA":ns)
+            in parenthesize txt ++ (if b then "*" else "")
+         Children cp -> show cp
+
+instance Show CP where
+   show cp =
+      case cp of
+         Choice xs      -> parenthesize (intercalate "|" (map show xs))
+         Sequence xs    -> parenthesize (intercalate "," (map show xs))
+         QuestionMark c -> show c ++ "?"
+         Star c         -> show c ++ "*"
+         Plus c         -> show c ++ "+"
+         CPName n       -> n
+
+instance Show AttType where
+   show attType =
+      case attType of
+         IdType       -> "ID"
+         IdRefType    -> "IDREF"
+         IdRefsType   -> "IDREFS"
+         EntityType   -> "ENTITY"
+         EntitiesType -> "ENTITIES"
+         NmTokenType  -> "NMTOKEN"
+         NmTokensType -> "NMTOKENS"
+         StringType   -> "CDATA"
+         EnumerationType xs -> parenthesize (intercalate "|" xs)
+         NotationType xs    -> "NOTATION " ++ parenthesize (intercalate "|" xs)
+
+instance Show DefaultDecl where
+   show defaultDecl =
+      case defaultDecl of
+         Required -> "#REQUIRED"
+         Implied  -> "#IMPLIED"
+         Value v  -> showAttValue v
+         Fixed v  -> "#FIXED " ++ showAttValue v
+
+instance Show Conditional where
+   show conditional =
+      case conditional of
+         Include xs -> "<![INCLUDE[" ++ concatMap show xs ++ "]]>"
+         Ignore _ -> "" -- ToDO undefined -- [String]
+
+showXMLDecl :: XMLDoc -> String
+showXMLDecl doc
+   | isJust (versionInfo doc) = "<?xml " ++ unwords (catMaybes [s1,s2,s3]) ++ "?>"
+   | otherwise = ""
+ where
+   s1 = fmap (\s -> "version=" ++ doubleQuote s) (versionInfo doc)
+   s2 = fmap (\s -> "encoding=" ++ doubleQuote s) (encoding doc)
+   s3 = fmap (\b -> "standalone=" ++ doubleQuote (if b then "yes" else "no")) (standalone doc)
+-}
+showOpenTag :: Bool -> Name -> Attributes -> String
+showOpenTag close n as = "<" ++ unwords (n:map show as) ++
+   (if close then "/>" else ">")
+
+showCloseTag :: Name -> String
+showCloseTag n = "</" ++ n ++ ">"
+
+showAttValue :: AttValue -> String -- TODO: no double quotes allowed (should be escaped)
+showAttValue = doubleQuote . concatMap (either f show)
+ where
+   f '"' = []
+   f c   = [c]
+{-
+showEntityValue :: EntityValue -> String
+showEntityValue = doubleQuote . concatMap (either f (either show show))
+ where
+   f '"' = []
+   f c   = [c]
+
+showAttDef :: AttDef -> String
+showAttDef (s, tp, dd) = unwords [s, show tp, show dd]
+
+showEntityDef :: EntityDef -> String
+showEntityDef entityDef =
+   case entityDef of
+      Left ev -> showEntityValue ev
+      Right (eid, ms) -> show eid ++ maybe "" (" NDATA "++) ms
+-}
+doubleQuote :: String -> String
+doubleQuote s = "\"" ++ s ++ "\""
+{-
+parenthesize :: String -> String
+parenthesize s = "(" ++ s ++ ")" -}
+ src/Ideas/Text/XML/Interface.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Collection of common operation on XML documents
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.XML.Interface
+   ( Element(..), Content, Attribute(..), Attributes
+   , normalize, parseXML
+   , children, findAttribute, findChild, getData
+   ) where
+
+import Control.Arrow
+import Data.Char (chr, ord)
+import Data.Maybe
+import Ideas.Text.Parsing (parseSimple)
+import Ideas.Text.XML.Document (Name)
+import Ideas.Text.XML.Parser (document)
+import Ideas.Text.XML.Unicode (decoding)
+import qualified Ideas.Text.XML.Document as D
+
+data Element = Element
+   { name       :: Name
+   , attributes :: Attributes
+   , content    :: Content
+   }
+
+instance Show Element where
+   show = show . extend
+
+type Content = [Either String Element]
+
+type Attributes = [Attribute]
+data Attribute = Name := String
+
+normalize :: D.XMLDoc -> Element
+normalize doc = toElement (D.root doc)
+ where
+   toElement :: D.Element -> Element
+   toElement (D.Element n as c) =
+      Element n (map toAttribute as) (toContent c)
+
+   toAttribute :: D.Attribute -> Attribute
+   toAttribute (n D.:= v) =
+      n := concatMap (either return refToString) v
+
+   toContent :: D.Content -> Content
+   toContent = merge . concatMap f
+    where
+      f :: D.XML -> Content
+      f (D.Tagged e)    = [Right (toElement e)]
+      f (D.CharData s)  = [Left s]
+      f (D.CDATA s)     = [Left s]
+      f (D.Reference r) = refToContent r
+
+   refToString :: D.Reference -> String
+   refToString (D.CharRef i)   = [chr i]
+   refToString (D.EntityRef s) = maybe "" return (lookup s general)
+
+   refToContent :: D.Reference -> Content
+   refToContent (D.CharRef i)   = [Left [chr i]]
+   refToContent (D.EntityRef s) = fromMaybe [] (lookup s entities)
+
+   entities :: [(String, Content)]
+   entities =
+      [ (n, toContent (snd ext)) | (n, ext) <- D.externals doc ] ++
+      -- predefined entities
+      map (second (return . Left . return)) general
+
+   general :: [(String, Char)]
+   general = [("lt",'<'), ("gt",'>'), ("amp",'&'), ("apos",'\''), ("quot",'"')]
+
+   merge :: Content -> Content
+   merge (Left s:Left t:rest) = merge (Left (s++t) : rest)
+   merge (x:xs) = x:merge xs
+   merge []     = []
+
+extend :: Element -> D.Element
+extend (Element n as c) =
+   D.Element n (map toAttribute as) (concatMap toXML c)
+ where
+   toAttribute :: Attribute -> D.Attribute
+   toAttribute (m := s) = (D.:=) m (map Left s)
+
+   toXML :: Either String Element -> [D.XML]
+   toXML = either fromString (return . D.Tagged . extend)
+
+   fromString :: String -> [D.XML]
+   fromString [] = []
+   fromString xs@(hd:tl)
+      | null xs1  = D.Reference (D.CharRef (ord hd)) : fromString tl
+      | otherwise = D.CharData xs1 : fromString xs2
+    where
+      (xs1, xs2) = break ((> 127) . ord) xs
+
+-----------------------------------------------------
+
+parseXML :: String -> Either String Element
+parseXML xs = do
+   input <- decoding xs
+   doc   <- parseSimple document input
+   return (normalize doc)
+
+-----------------------------------------------------
+
+findAttribute :: Monad m => String -> Element -> m String
+findAttribute s (Element _ as _) =
+   case [ t | n := t <- as, s==n ] of
+      [hd] -> return hd
+      _    -> fail $ "Invalid attribute: " ++ show s
+
+findChild :: Monad m => String -> Element -> m Element
+findChild s e =
+   case filter ((==s) . name) (children e) of
+      [a] -> return a
+      _   -> fail $ "Child not found: " ++ show s
+
+children :: Element -> [Element]
+children e = [ c | Right c <- content e ]
+
+getData :: Element -> String
+getData e = concat [ s | Left s <- content e ]
+ src/Ideas/Text/XML/Parser.hs view
@@ -0,0 +1,687 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- A parser for XML documents, directly derived from the specification:
+
+--    http://www.w3.org/TR/2006/REC-xml-20060816
+
+-----------------------------------------------------------------------------
+module Ideas.Text.XML.Parser (document, extParsedEnt, extSubset) where
+
+import Control.Monad
+import Data.Char (toUpper, ord, isSpace)
+import Data.List (foldl') -- '
+import Data.Maybe (catMaybes)
+import Ideas.Text.Parsing hiding (digit, letter, space)
+import Ideas.Text.XML.Document hiding (versionInfo, name, content)
+import Ideas.Text.XML.Unicode
+import Prelude hiding (seq)
+import qualified Ideas.Text.XML.Document as D
+
+letter, digit, combiningChar, extender :: Parser Char
+letter        = ranges letterMap
+digit         = ranges digitMap
+combiningChar = ranges combiningCharMap
+extender      = ranges extenderMap
+
+-- combinators without lexing (no spaces are consumed)
+parens, brackets, singleQuoted, doubleQuoted :: Parser a -> Parser a
+parens       = between (char '(')  (char ')')
+brackets     = between (char '[')  (char ']')
+singleQuoted = between (char '\'') (char '\'')
+doubleQuoted = between (char '"')  (char '"')
+
+--------------------------------------------------
+-- * 2 Documents
+
+--------------------------------------------------
+-- ** 2.1 Well-Formed XML Documents
+
+-- [1]   	document	   ::=   	 prolog element Misc*
+document :: Parser XMLDoc
+document = do
+   (mxml, mdtd) <- prolog
+   rt <- element
+   miscs
+   let (ver, enc, sa) =
+          case mxml of
+             Just (a, b, c) -> (Just a, b, c)
+             Nothing        -> (Nothing, Nothing, Nothing)
+   return XMLDoc
+      { D.versionInfo = ver
+      , D.encoding    = enc
+      , D.standalone  = sa
+      , D.dtd         = mdtd
+      , D.externals   = []
+      , root        = rt
+      }
+
+--------------------------------------------------
+-- ** 2.2 Characters
+
+-- [2]   	Char	   ::=   	#x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
+{-
+char :: Parser Char
+char = ranges xs <|> oneOf "\x9\xA\xD"
+ where xs = [('\x20', '\xD7FF'), ('\xE000', '\xFFFD'), ('\x10000', '\x10FFFF')]
+-}
+
+--------------------------------------------------
+-- ** 2.3 Common Syntactic Constructs
+
+-- [3]   	S	   ::=   	(#x20 | #x9 | #xD | #xA)+
+space :: Parser ()
+space = void (many1 (oneOf "\x20\x9\xA\xD"))
+
+mspace :: Parser () -- for S?
+mspace = void (many (oneOf "\x20\x9\xA\xD"))
+
+-- [4]   	NameChar	   ::=   	 Letter | Digit | '.' | '-' | '_' | ':' | CombiningChar | Extender
+nameChar :: Parser Char
+nameChar = letter <|> digit <|> combiningChar <|> extender <|> oneOf ".-_:"
+
+-- [5]   	Name	   ::=   	(Letter | '_' | ':') (NameChar)*
+name :: Parser String
+name = do
+   c  <- letter <|> oneOf "_:"
+   cs <- many nameChar
+   return (c:cs)
+
+spacedName :: Parser String
+spacedName = space *> name <* space
+
+{-
+-- [6]   	Names	   ::=   	 Name (#x20 Name)*
+names :: Parser [String]
+names = sepBy1 name (char '\x20')
+-}
+
+-- [7]   	Nmtoken	   ::=   	(NameChar)+
+nmtoken :: Parser String
+nmtoken = many1 nameChar
+
+{-
+-- [8]   	Nmtokens	   ::=   	 Nmtoken (#x20 Nmtoken)*
+nmtokens :: Parser [String]
+nmtokens = sepBy1 nmtoken (char '\x20')
+-}
+
+-- [9]   	EntityValue	   ::=   	'"' ([^%&"] | PEReference | Reference)* '"'
+--                           |  "'" ([^%&'] | PEReference | Reference)* "'"
+entityValue :: Parser EntityValue
+entityValue = doubleQuoted (p "%&\"") <|> singleQuoted (p "%&'")
+ where
+   p s =  many (fmap Left (noneOf s)
+      <|> fmap Right (fmap Left peReference <|> fmap Right reference))
+
+-- [10]   	AttValue	   ::=   	'"' ([^<&"] | Reference)* '"'
+--                           |  "'" ([^<&'] | Reference)* "'"
+attValue :: Parser AttValue
+attValue = doubleQuoted (p "<&\"") <|> singleQuoted (p "<&'")
+ where p s = many (fmap Left (noneOf s) <|> fmap Right reference)
+
+-- [11]   	SystemLiteral	   ::=   	('"' [^"]* '"') | ("'" [^']* "'")
+systemLiteral :: Parser String
+systemLiteral = doubleQuoted (p "\"") <|> singleQuoted (p "'")
+ where p s = many (noneOf s)
+
+-- [12]   	PubidLiteral	   ::=   	'"' PubidChar* '"' | "'" (PubidChar - "'")* "'"
+pubidLiteral :: Parser String
+pubidLiteral = doubleQuoted (many (pubidChar True)) <|> singleQuoted (many (pubidChar False))
+
+-- [13]   	PubidChar	   ::=   	#x20 | #xD | #xA | [a-zA-Z0-9] | [-'()+,./:=?;!*#@$_%]
+pubidChar :: Bool -> Parser Char
+pubidChar withSingleQuote =
+   ranges xs <|> oneOf "\x20\xD\xA-()+,./:=?;!*#@$_%" <|> singleQuote
+ where
+   xs = [('a', 'z'), ('A', 'Z'), ('0', '9')]
+   singleQuote
+      | withSingleQuote = char '\'' >> return '\''
+      | otherwise       = fail "pubidChar"
+
+--------------------------------------------------
+-- ** 2.4 Character Data and Markup
+
+-- [14]   	CharData	   ::=   	[^<&]* - ([^<&]* ']]>' [^<&]*)
+charData :: Parser String -- This implementation is too liberal since it allows "]]>"
+charData = stopOn ["<", "&", "]]>"]
+
+--------------------------------------------------
+-- ** 2.5 Comments
+
+-- [15]   	Comment	   ::=   	'<!--' ((Char - '-') | ('-' (Char - '-')))* '-->'
+comment :: Parser String
+comment = between (string "<!--") (string "-->") (stopOn ["--"])
+
+--------------------------------------------------
+-- ** 2.6 Processing Instructions
+
+-- [16]   	PI	   ::=   	'<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>'
+pInstr :: Parser String
+pInstr = between (string "<?") (string "?>") p
+ where
+   p = piTarget >> option "" (space >> stopOn ["?>"])
+
+-- [17]   	PITarget	   ::=   	 Name - (('X' | 'x') ('M' | 'm') ('L' | 'l'))
+piTarget :: Parser String
+piTarget = do
+   n <- name
+   when (map toUpper n == "XML") $ fail "XML in piTarget"
+   return n
+
+--------------------------------------------------
+-- ** 2.7 CDATA Sections
+
+-- [18]   	CDSect	   ::=   	 CDStart CData CDEnd
+-- [19]   	CDStart	   ::=   	'<![CDATA['
+-- [20]   	CData	   ::=   	(Char* - (Char* ']]>' Char*))
+-- [21]   	CDEnd	   ::=   	']]>'
+cdSect :: Parser XML
+cdSect = between (string "<![CDATA[") (string "]]>") p
+ where
+   p = do
+      s <- stopOn ["]]>"]
+      return (CDATA s)
+
+--------------------------------------------------
+-- ** 2.8 Prolog and Document Type Declaration
+
+type XMLDecl = (String, Maybe String, Maybe Bool)
+
+-- [22]   	prolog	   ::=   	 XMLDecl? Misc* (doctypedecl Misc*)?
+prolog :: Parser (Maybe XMLDecl, Maybe DTD)
+prolog = do
+   ma <- optionMaybe (try xmlDecl)
+   miscs
+   mb <- optionMaybe $ try $ do
+      mb <- doctypedecl
+      miscs
+      return mb
+   return (ma, mb)
+
+-- [23]   	XMLDecl	   ::=   	'<?xml' VersionInfo EncodingDecl? SDDecl? S? '?>'
+xmlDecl :: Parser XMLDecl
+xmlDecl = do
+   skip (string "<?xml")
+   x <- versionInfo
+   y <- optionMaybe (try encodingDecl)
+   z <- optionMaybe (try sdDecl)
+   mspace
+   skip (string "?>")
+   return (x, y, z)
+
+-- [24]   	VersionInfo	   ::=   	 S 'version' Eq ("'" VersionNum "'" | '"' VersionNum '"')
+versionInfo :: Parser String
+versionInfo = space >> string "version" >> eq >> p
+ where p = singleQuoted versionNum <|> doubleQuoted versionNum
+
+-- [25]   	Eq	   ::=   	 S? '=' S?
+eq :: Parser ()
+eq = skip (mspace >> char '=' >> mspace)
+
+-- [26]   	VersionNum	   ::=   	'1.0'
+versionNum :: Parser String
+versionNum = do
+   skip (string "1.0")
+   return "1.0"
+
+-- [27]   	Misc	   ::=   	 Comment | PI | S
+misc :: Parser ()
+misc = try (skip comment) <|> try (skip pInstr) <|> skip space
+
+miscs :: Parser ()
+miscs = skip (many misc)
+
+-- [28]   	doctypedecl	   ::=   	'<!DOCTYPE' S Name (S ExternalID)? S? ('[' intSubset ']' S?)? '>'
+doctypedecl :: Parser DTD
+doctypedecl = do
+   skip (string "<!DOCTYPE")
+   space
+   x <- name
+   y <- optionMaybe (try (space >> externalID))
+   mspace
+   z <- option [] $ do
+      z <- brackets intSubset
+      mspace
+      return z
+   skip (char '>')
+   return (DTD x y z)
+
+-- [28a]   	DeclSep	   ::=   	 PEReference | S
+declSep :: Parser (Maybe DocTypeDecl)
+declSep =  fmap (Just . DTDParameter) peReference
+       <|> (space >> return Nothing)
+
+-- [28b]   	intSubset	   ::=   	(markupdecl | DeclSep)*
+intSubset :: Parser [DocTypeDecl]
+intSubset = fmap catMaybes (many (markupdecl <|> declSep))
+
+-- [29]   	markupdecl	   ::=   	 elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment
+markupdecl :: Parser (Maybe DocTypeDecl)
+markupdecl =  fmap Just (choice (map try list))
+          <|> ((try pInstr <|> comment) >> return Nothing)
+ where
+   list = [elementdecl, attlistDecl, entityDecl, notationDecl]
+
+-- [30]   	extSubset	   ::=   	 TextDecl? extSubsetDecl
+extSubset :: Parser (Maybe TextDecl, [DocTypeDecl])
+extSubset = do
+   m <- optionMaybe textDecl
+   e <- extSubsetDecl
+   return (m, e)
+
+-- [31]   	extSubsetDecl	   ::=   	( markupdecl | conditionalSect | DeclSep)*
+extSubsetDecl :: Parser [DocTypeDecl]
+extSubsetDecl = fmap catMaybes (many (choice [markupdecl, fmap (Just . DTDConditional) conditionalSect, declSep]))
+
+--------------------------------------------------
+-- ** 2.9 Standalone Document Declaration
+-- [32]   	SDDecl	   ::=   	 S 'standalone' Eq (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"'))
+sdDecl :: Parser Bool
+sdDecl = space >> string "standalone" >> eq >> (singleQuoted bool <|> doubleQuoted bool)
+ where bool =  (string "yes" >> return True)
+           <|> (string "no"  >> return False)
+
+--------------------------------------------------
+-- ** 2.10 White Space Handling
+
+--------------------------------------------------
+-- * 3 Logical Structures
+
+-- [39]   	element	   ::=   	 EmptyElemTag | STag content ETag
+element :: Parser Element
+element = do
+   (s1, as, closed) <- sTag
+   if closed
+     then return (Element s1 as [])
+     else do
+       c  <- content
+       s2 <- eTag
+       when (s1/=s2) $ fail "WFC: element"
+       return (Element s1 as c)
+
+--------------------------------------------------
+-- ** 3.1 Start-Tags, End-Tags, and Empty-Element Tags
+
+-- [40]   	STag	   ::=   	'<' Name (S Attribute)* S? '>'
+-- [44]   	EmptyElemTag	   ::=   	'<' Name (S Attribute)* S? '/>'
+-- The boolean indicates whether the tag was closed immediately (an EmptyElemTag)
+sTag :: Parser (Name, Attributes, Bool)
+sTag = do
+   skip (char '<')
+   n  <- name
+   as <- many (try (space >> attribute))
+   mspace
+   b  <- (char '>'  >> return False) <|>
+         (string "/>" >> return True)
+   return (n, as, b)
+
+-- [41]   	Attribute	   ::=   	NSAttName Eq AttValue
+--        | Name Eq AttValue
+attribute :: Parser Attribute
+attribute = do
+   n <- name
+   eq
+   a <- attValue
+   return (n := a)
+
+-- [42]   	ETag	   ::=   	'</' Name S? '>'
+eTag :: Parser Name
+eTag = do
+   skip (string "</")
+   n <- name
+   mspace
+   skip (char '>')
+   return n
+
+-- [43]   	content	   ::=   	 CharData? ((element | Reference | CDSect | PI | Comment) CharData?)*
+-- Note: since CharData accepts epsilon, there is no need to make it optional
+content :: Parser Content
+content = chainr1 (fmap g charData) (fmap f ps)
+ where
+   f ma l r = l ++ maybe [] return ma ++ r
+   g s = [ CharData s | any (not . isSpace) s ]  -- quick fix, ignores layout
+   ps  = try (fmap Just (choice (map try [fmap Tagged element, fmap Reference reference, cdSect]))
+      <|> ((try pInstr <|> comment) >> return Nothing))
+
+--------------------------------------------------
+-- ** 3.2 Element Type Declarations
+
+-- [45]   	elementdecl	   ::=   	'<!ELEMENT' S Name S contentspec S? '>'
+elementdecl :: Parser DocTypeDecl
+elementdecl = do
+   skip (string "<!ELEMENT")
+   n <- spacedName
+   cs <- contentspec
+   mspace
+   skip (char '>')
+   return (ElementDecl n cs)
+
+-- [46]   	contentspec	   ::=   	'EMPTY' | 'ANY' | Mixed | children
+contentspec :: Parser ContentSpec
+contentspec = choice
+   [ string "EMPTY" >> return Empty
+   , string "ANY"   >> return Any
+   , try mixed
+   , children
+   ]
+
+-- [47]   	children	   ::=   	(choice | seq) ('?' | '*' | '+')?
+children :: Parser ContentSpec
+children = do
+   a <- try cpChoice <|> cpSeq
+   f <- option id multi
+   return (Children (f a))
+
+multi :: Parser (CP -> CP)
+multi =  (char '?' >> return QuestionMark)
+     <|> (char '*' >> return Star)
+     <|> (char '+' >> return Plus)
+
+-- [48]   	cp	   ::=   	(Name | choice | seq) ('?' | '*' | '+')?
+cp :: Parser CP
+cp = do
+   a <- fmap CPName name <|> try cpChoice <|> cpSeq
+   f <- option id multi
+   return (f a)
+
+-- [49]   	choice	   ::=   	'(' S? cp ( S? '|' S? cp )+ S? ')'
+cpChoice :: Parser CP
+cpChoice = parens $ do
+   mspace
+   x  <- cp
+   xs <- many1 (try (mspace >> char '|' >> mspace >> cp))
+   mspace
+   return (Choice (x:xs))
+
+-- [50]   	seq	   ::=   	'(' S? cp ( S? ',' S? cp )* S? ')'
+cpSeq :: Parser CP
+cpSeq = parens $ do
+   mspace
+   x  <- cp
+   xs <- many (try (mspace >> char ',' >> mspace >> cp))
+   mspace
+   return (Sequence (x:xs))
+
+-- [51]   	Mixed	   ::=   	'(' S? '#PCDATA' (S? '|' S? Name)* S? ')*'
+--                  | '(' S? '#PCDATA' S? ')'
+mixed :: Parser ContentSpec
+mixed = char '(' >> mspace >> string "#PCDATA" >> (rest1 <|> rest2)
+ where
+   p = mspace >> char '|' >> mspace >> name
+   rest1 = try $ do
+       xs <- many (try p)
+       mspace
+       skip (string ")*")
+       return (Mixed True xs)
+   rest2 = mspace >> char ')' >> return (Mixed False [])
+
+--------------------------------------------------
+-- ** 3.3 Attribute-List Declarations
+
+-- [52]   	AttlistDecl	   ::=   	'<!ATTLIST' S Name AttDef* S? '>'
+attlistDecl :: Parser DocTypeDecl
+attlistDecl = do
+   skip (string "<!ATTLIST")
+   space
+   n  <- name
+   ds <- many (try attDef)
+   mspace
+   skip (char '>')
+   return (AttListDecl n ds)
+
+-- [53]   	AttDef	   ::=   	 S Name S AttType S DefaultDecl
+attDef :: Parser AttDef
+attDef = do
+   n  <- spacedName
+   tp <- attType
+   space
+   dd <- defaultDecl
+   return (n, tp, dd)
+
+-- [54]   	AttType	   ::=   	 StringType | TokenizedType | EnumeratedType
+attType :: Parser AttType
+attType = stringType <|> tokenizedType <|> enumeratedType
+
+-- [55]   	StringType	   ::=   	'CDATA'
+stringType :: Parser AttType
+stringType = string "CDATA" >> return StringType
+
+-- [56]   	TokenizedType	   ::=   	'ID' | 'IDREF' | 'IDREFS' | 'ENTITY' | 'ENTITIES' | 'NMTOKEN' | 'NMTOKENS'
+tokenizedType :: Parser AttType
+tokenizedType = choice (map f xs)
+ where
+   f (tp, s) = try (string s) >> return tp
+   xs = [ (IdRefsType, "IDREFS"), (IdRefType, "IDREF"), (IdType, "ID"), (EntityType, "ENTITY")
+        , (EntitiesType, "ENTITIES"), (NmTokensType, "NMTOKENS"), (NmTokenType, "NMTOKEN")
+        ]
+
+-- [57]   	EnumeratedType	   ::=   	 NotationType | Enumeration
+enumeratedType :: Parser AttType
+enumeratedType = notationType <|> enumeration
+
+-- [58]   	NotationType	   ::=   	'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')'
+notationType :: Parser AttType
+notationType = string "NOTATION" >> space >> parens p
+ where
+   p = do
+      mspace
+      n  <- name
+      ns <- many (try (mspace >> char '|' >> mspace >> name))
+      mspace
+      return (NotationType (n:ns))
+
+-- [59]   	Enumeration	   ::=   	'(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')'
+enumeration :: Parser AttType
+enumeration = parens $ do
+   mspace
+   x  <- nmtoken
+   xs <- many (try (mspace >> char '|' >> mspace >> nmtoken))
+   mspace
+   return (EnumerationType (x:xs))
+
+-- [60]   	DefaultDecl	   ::=   	'#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue)
+defaultDecl :: Parser DefaultDecl
+defaultDecl =  try (string "#REQUIRED" >> return Required)
+           <|> try (string "#IMPLIED"  >> return Implied)
+           <|> do f <- option Value (string "#FIXED" >> space >> return Fixed)
+                  a <- attValue
+                  return (f a)
+
+--------------------------------------------------
+-- ** 3.4 Conditional Sections
+
+-- [61]   	conditionalSect	   ::=   	 includeSect | ignoreSect
+conditionalSect :: Parser Conditional
+conditionalSect = try includeSect <|> ignoreSect
+
+-- [62]   	includeSect	   ::=   	'<![' S? 'INCLUDE' S? '[' extSubsetDecl ']]>'
+includeSect :: Parser Conditional
+includeSect = do
+   skip (string "<![")
+   mspace
+   skip (string "INCLUDE")
+   mspace
+   skip (char '[')
+   ds <- extSubsetDecl
+   skip (string "]]>")
+   return (Include ds)
+
+-- [63]   	ignoreSect	   ::=   	'<![' S? 'IGNORE' S? '[' ignoreSectContents* ']]>'
+ignoreSect :: Parser Conditional
+ignoreSect = do
+   skip (string "<![")
+   mspace
+   skip (string "IGNORE")
+   mspace
+   skip (char '[')
+   xss <- many ignoreSectContents
+   skip (string "]]>")
+   return (Ignore (concat xss))
+
+-- [64]   	ignoreSectContents	   ::=   	 Ignore ('<![' ignoreSectContents ']]>' Ignore)*
+ignoreSectContents :: Parser [String]
+ignoreSectContents =
+   do x   <- ignore
+      xss <- many $ do
+         skip (string "<![")
+         ys <- ignoreSectContents
+         skip (string "]]>")
+         y  <- ignore
+         return (ys++[y])
+      return (x:concat xss)
+
+-- [65]   	Ignore	   ::=   	 Char* - (Char* ('<![' | ']]>') Char*)
+ignore :: Parser String
+ignore = stopOn ["<![", "]]>"]
+
+--------------------------------------------------
+-- * 4 Physical Structures
+
+--------------------------------------------------
+-- ** 4.1 Character and Entity References
+
+-- [66]   	CharRef	   ::=   	'&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';'
+charRef :: Parser Reference
+charRef = do
+   skip (string "&#")
+   n <- p <|> (char 'x' >> q)
+   skip (char ';')
+   return (CharRef n)
+ where
+   p = fmap (foldl' (\a b -> a*10+ord b-48) 0) (many1 ('0' <..> '9'))
+   q = fmap hexa (many1 (ranges [('0', '9'), ('a', 'f'), ('A', 'F')]))
+
+hexa :: String -> Int
+hexa = rec 0
+ where
+   rec n []     = n
+   rec n (x:xs) = rec (16*n + ord x - correct) xs
+    where
+      correct
+         | x <= '9'  = ord '0'
+         | x <= 'F'  = ord 'A' - 10
+         | otherwise = ord 'a' - 10
+
+-- [67]   	Reference	   ::=   	 EntityRef | CharRef
+reference :: Parser Reference
+reference = try entityRef <|> charRef
+
+-- [68]   	EntityRef	   ::=   	'&' Name ';'
+entityRef :: Parser Reference
+entityRef = between (char '&') (char ';') (fmap EntityRef name)
+
+-- [69]   	PEReference	   ::=   	'%' Name ';'
+peReference :: Parser Parameter
+peReference = between (char '%') (char ';') (fmap Parameter name)
+
+--------------------------------------------------
+-- ** 4.2 Entity Declarations
+
+-- [70]   	EntityDecl	   ::=   	 GEDecl | PEDecl
+entityDecl :: Parser DocTypeDecl
+entityDecl = try geDecl <|> peDecl
+
+-- [71]   	GEDecl	   ::=   	'<!ENTITY' S Name S EntityDef S? '>'
+geDecl :: Parser DocTypeDecl
+geDecl = do
+   skip (string "<!ENTITY")
+   n  <- spacedName
+   ed <- entityDef
+   mspace
+   skip (char '>')
+   return (EntityDecl True n ed)
+
+-- [72]   	PEDecl	   ::=   	'<!ENTITY' S '%' S Name S PEDef S? '>'
+peDecl :: Parser DocTypeDecl
+peDecl = do
+   skip (string "<!ENTITY")
+   space
+   skip (char '%')
+   n <- spacedName
+   e <- peDef
+   mspace
+   skip (char '>')
+   return (EntityDecl False n (either Left (\a -> Right (a, Nothing)) e))
+
+-- [73]   	EntityDef	   ::=   	 EntityValue | (ExternalID NDataDecl?)
+entityDef :: Parser EntityDef
+entityDef = fmap Left entityValue <|> do
+   e  <- externalID
+   ms <- optionMaybe (try nDataDecl)
+   return (Right (e, ms))
+
+-- [74]   	PEDef	   ::=   	 EntityValue | ExternalID
+peDef :: Parser (Either EntityValue ExternalID)
+peDef = fmap Left entityValue <|> fmap Right externalID
+
+-- [75]   	ExternalID	   ::=   	'SYSTEM' S SystemLiteral | 'PUBLIC' S PubidLiteral S SystemLiteral
+externalID :: Parser ExternalID
+externalID =  (string "SYSTEM" >> space >> fmap System systemLiteral) <|> do
+   skip (string "PUBLIC")
+   space
+   x <- pubidLiteral
+   space
+   y <- systemLiteral
+   return (Public x y)
+
+-- [76]   	NDataDecl	   ::=   	 S 'NDATA' S Name
+nDataDecl :: Parser String
+nDataDecl = space >> string "NDATA" >> space >> name
+
+--------------------------------------------------
+-- ** 4.3 Parsed Entities
+
+-- [77]   	TextDecl	   ::=   	'<?xml' VersionInfo? EncodingDecl S? '?>'
+
+textDecl :: Parser TextDecl
+textDecl = do
+   skip (string "<?xml")
+   v <- optionMaybe versionInfo
+   e <- encodingDecl
+   mspace
+   skip (string "?>")
+   return (v, e)
+
+-- [78]   	extParsedEnt	   ::=   	 TextDecl? content
+extParsedEnt :: Parser (Maybe TextDecl, Content)
+extParsedEnt = do
+   td <- optionMaybe (try textDecl)
+   c  <- content
+   return (td, c)
+
+-- [80]   	EncodingDecl	   ::=   	 S 'encoding' Eq ('"' EncName '"' | "'" EncName "'" )
+encodingDecl :: Parser String
+encodingDecl = space >> string "encoding" >> eq >>
+   (singleQuoted encName <|> doubleQuoted encName)
+
+-- [81]   	EncName	   ::=   	[A-Za-z] ([A-Za-z0-9._] | '-')*
+encName :: Parser String
+encName = do
+   x  <- ranges [('A', 'Z'), ('a', 'z')]
+   xs <- many (ranges [('A', 'Z'), ('a', 'z'), ('0', '9')] <|> oneOf "._-")
+   return (x:xs)
+
+--------------------------------------------------
+-- ** 4.7 Notation Declarations
+
+-- [82]   	NotationDecl	   ::=   	'<!NOTATION' S Name S (ExternalID | PublicID) S? '>'
+notationDecl :: Parser DocTypeDecl
+notationDecl = do
+   skip (string "<!NOTATION")
+   n <- spacedName
+   e <- fmap Left (try externalID) <|> fmap Right publicID
+   mspace
+   skip (char '>')
+   return (NotationDecl n e)
+
+-- [83]   	PublicID	   ::=   	'PUBLIC' S PubidLiteral
+publicID :: Parser PublicID
+publicID = string "PUBLIC" >> space >> pubidLiteral
+ src/Ideas/Text/XML/Unicode.hs view
@@ -0,0 +1,194 @@+-----------------------------------------------------------------------------
+-- Copyright 2013, Open Universiteit Nederland. This file is distributed
+-- under the terms of the GNU General Public License. For more information,
+-- see the file "LICENSE.txt", which is included in the distribution.
+-----------------------------------------------------------------------------
+-- |
+-- Maintainer  :  bastiaan.heeren@ou.nl
+-- Stability   :  provisional
+-- Portability :  portable (depends on ghc)
+--
+-- Support for Unicode
+--
+-----------------------------------------------------------------------------
+module Ideas.Text.XML.Unicode
+   ( isExtender, isLetter, isDigit, isCombiningChar
+   , extenderMap, letterMap, digitMap, combiningCharMap
+   , decoding
+   ) where
+
+import Data.Char (chr, ord)
+import Data.List
+import qualified Ideas.Text.UTF8 as UTF8
+
+data Tree a = Node (Tree a) a (Tree a) | Leaf
+
+isLetter, isExtender, isDigit, isCombiningChar :: Char -> Bool
+isLetter        = checkTree $ makeTree letterMap
+isExtender      = checkTree $ makeTree extenderMap
+isDigit         = checkTree $ makeTree digitMap
+isCombiningChar = checkTree $ makeTree combiningCharMap
+
+checkTree :: Tree (Char, Char) -> Char -> Bool
+checkTree Leaf _ = False
+checkTree (Node l (c1, c2) r) c =
+   case compare c1 c of
+      LT -> case compare c c2 of
+               LT -> True
+               EQ -> True
+               GT -> checkTree r c
+      EQ -> True
+      GT -> checkTree l c
+
+makeTree :: [a] -> Tree a
+makeTree [] = Leaf
+makeTree xs = Node (makeTree ys) z (makeTree zs)
+ where (ys, z:zs) = splitAt n xs
+       n = length xs `div` 2
+
+f :: Char -> (Char, Char)
+f c = (c, c)
+
+letterMap :: [(Char, Char)]
+letterMap = baseCharMap `merge` ideographicMap `merge` controlMap `merge` extraMap
+
+merge :: [(Char, Char)] -> [(Char, Char)] -> [(Char, Char)]
+merge (x:xs) (y:ys)
+   | x <= y    = x:merge xs (y:ys)
+   | otherwise = y:merge (x:xs) ys
+merge xs ys = xs++ys
+
+extraMap :: [(Char, Char)]
+extraMap = map f "\161\170\184\185"
+
+controlMap :: [(Char, Char)]
+controlMap = [ ('\x7F', '\x84'), ('\x86', '\x9F'), ('\xFDD0', '\xFDDF'),
+   ('\x1FFFE', '\x1FFFF'), ('\x2FFFE', '\x2FFFF'), ('\x3FFFE', '\x3FFFF'),
+   ('\x4FFFE', '\x4FFFF'), ('\x5FFFE', '\x5FFFF'), ('\x6FFFE', '\x6FFFF'),
+   ('\x7FFFE', '\x7FFFF'), ('\x8FFFE', '\x8FFFF'), ('\x9FFFE', '\x9FFFF'),
+   ('\xAFFFE', '\xAFFFF'), ('\xBFFFE', '\xBFFFF'), ('\xCFFFE', '\xCFFFF'),
+   ('\xDFFFE', '\xDFFFF'), ('\xEFFFE', '\xEFFFF'), ('\xFFFFE', '\xFFFFF'),
+   ('\x10FFFE', '\x10FFFF')]
+
+baseCharMap :: [(Char, Char)]
+baseCharMap = [ ('\x0041','\x005A'), ('\x0061','\x007A'), ('\x00C0','\x00D6'),
+   ('\x00D8','\x00F6'), ('\x00F8','\x00FF'), ('\x0100','\x0131'),
+   ('\x0134','\x013E'), ('\x0141','\x0148'), ('\x014A','\x017E'),
+   ('\x0180','\x01C3'), ('\x01CD','\x01F0'), ('\x01F4','\x01F5'),
+   ('\x01FA','\x0217'), ('\x0250','\x02A8'), ('\x02BB','\x02C1'), f '\x0386' ,
+   ('\x0388','\x038A'), f '\x038C' , ('\x038E','\x03A1'), ('\x03A3','\x03CE'),
+   ('\x03D0','\x03D6'), f '\x03DA' , f '\x03DC' , f '\x03DE' , f '\x03E0' ,
+   ('\x03E2','\x03F3'), ('\x0401','\x040C'), ('\x040E','\x044F'),
+   ('\x0451','\x045C'), ('\x045E','\x0481'), ('\x0490','\x04C4'),
+   ('\x04C7','\x04C8'), ('\x04CB','\x04CC'), ('\x04D0','\x04EB'),
+   ('\x04EE','\x04F5'), ('\x04F8','\x04F9'), ('\x0531','\x0556'), f '\x0559' ,
+   ('\x0561','\x0586'), ('\x05D0','\x05EA'), ('\x05F0','\x05F2'),
+   ('\x0621','\x063A'), ('\x0641','\x064A'), ('\x0671','\x06B7'),
+   ('\x06BA','\x06BE'), ('\x06C0','\x06CE'), ('\x06D0','\x06D3'), f '\x06D5' ,
+   ('\x06E5','\x06E6'), ('\x0905','\x0939'), f '\x093D' , ('\x0958','\x0961'),
+   ('\x0985','\x098C'), ('\x098F','\x0990'), ('\x0993','\x09A8'),
+   ('\x09AA','\x09B0'), f '\x09B2' , ('\x09B6','\x09B9'), ('\x09DC','\x09DD'),
+   ('\x09DF','\x09E1'), ('\x09F0','\x09F1'), ('\x0A05','\x0A0A'),
+   ('\x0A0F','\x0A10'), ('\x0A13','\x0A28'), ('\x0A2A','\x0A30'),
+   ('\x0A32','\x0A33'), ('\x0A35','\x0A36'), ('\x0A38','\x0A39'),
+   ('\x0A59','\x0A5C'), f '\x0A5E' , ('\x0A72','\x0A74'), ('\x0A85','\x0A8B'),
+   f '\x0A8D' , ('\x0A8F','\x0A91'), ('\x0A93','\x0AA8'), ('\x0AAA','\x0AB0'),
+   ('\x0AB2','\x0AB3'), ('\x0AB5','\x0AB9'), f '\x0ABD' , f '\x0AE0' ,
+   ('\x0B05','\x0B0C'), ('\x0B0F','\x0B10'), ('\x0B13','\x0B28'),
+   ('\x0B2A','\x0B30'), ('\x0B32','\x0B33'), ('\x0B36','\x0B39'), f '\x0B3D' ,
+   ('\x0B5C','\x0B5D'), ('\x0B5F','\x0B61'), ('\x0B85','\x0B8A'),
+   ('\x0B8E','\x0B90'), ('\x0B92','\x0B95'), ('\x0B99','\x0B9A'), f '\x0B9C' ,
+   ('\x0B9E','\x0B9F'), ('\x0BA3','\x0BA4'), ('\x0BA8','\x0BAA'),
+   ('\x0BAE','\x0BB5'), ('\x0BB7','\x0BB9'), ('\x0C05','\x0C0C'),
+   ('\x0C0E','\x0C10'), ('\x0C12','\x0C28'), ('\x0C2A','\x0C33'),
+   ('\x0C35','\x0C39'), ('\x0C60','\x0C61'), ('\x0C85','\x0C8C'),
+   ('\x0C8E','\x0C90'), ('\x0C92','\x0CA8'), ('\x0CAA','\x0CB3'),
+   ('\x0CB5','\x0CB9'), f '\x0CDE' , ('\x0CE0','\x0CE1'), ('\x0D05','\x0D0C'),
+   ('\x0D0E','\x0D10'), ('\x0D12','\x0D28'), ('\x0D2A','\x0D39'),
+   ('\x0D60','\x0D61'), ('\x0E01','\x0E2E'), f '\x0E30' , ('\x0E32','\x0E33'),
+   ('\x0E40','\x0E45'), ('\x0E81','\x0E82'), f '\x0E84' , ('\x0E87','\x0E88'),
+   f '\x0E8A' , f '\x0E8D' , ('\x0E94','\x0E97'), ('\x0E99','\x0E9F'),
+   ('\x0EA1','\x0EA3'), f '\x0EA5' , f '\x0EA7' , ('\x0EAA','\x0EAB'),
+   ('\x0EAD','\x0EAE'), f '\x0EB0' , ('\x0EB2','\x0EB3'), f '\x0EBD' ,
+   ('\x0EC0','\x0EC4'), ('\x0F40','\x0F47'), ('\x0F49','\x0F69'),
+   ('\x10A0','\x10C5'), ('\x10D0','\x10F6'), f '\x1100' , ('\x1102','\x1103'),
+   ('\x1105','\x1107'), f '\x1109' , ('\x110B','\x110C'), ('\x110E','\x1112'),
+   f '\x113C' , f '\x113E' , f '\x1140' , f '\x114C' , f '\x114E' , f '\x1150' , ('\x1154','\x1155') ,
+   f '\x1159' , ('\x115F','\x1161'), f '\x1163' , f '\x1165' , f '\x1167' , f '\x1169' ,
+   ('\x116D','\x116E'), ('\x1172','\x1173'), f '\x1175' , f '\x119E' , f '\x11A8' ,
+   f '\x11AB' , ('\x11AE','\x11AF'), ('\x11B7','\x11B8'), f '\x11BA' ,
+   ('\x11BC','\x11C2'), f '\x11EB' , f '\x11F0' , f '\x11F9' , ('\x1E00','\x1E9B'),
+   ('\x1EA0','\x1EF9'), ('\x1F00','\x1F15'), ('\x1F18','\x1F1D'),
+   ('\x1F20','\x1F45'), ('\x1F48','\x1F4D'), ('\x1F50','\x1F57'), f '\x1F59' ,
+   f '\x1F5B' , f '\x1F5D' , ('\x1F5F','\x1F7D'), ('\x1F80','\x1FB4'),
+   ('\x1FB6','\x1FBC'), f '\x1FBE' , ('\x1FC2','\x1FC4'), ('\x1FC6','\x1FCC'),
+   ('\x1FD0','\x1FD3'), ('\x1FD6','\x1FDB'), ('\x1FE0','\x1FEC'),
+   ('\x1FF2','\x1FF4'), ('\x1FF6','\x1FFC'), f '\x2126' , ('\x212A','\x212B'),
+   f '\x212E' , ('\x2180','\x2182'), ('\x3041','\x3094'), ('\x30A1','\x30FA'),
+   ('\x3105','\x312C'), ('\xAC00','\xD7A3') ]
+
+ideographicMap :: [(Char, Char)]
+ideographicMap = [ ('\x4E00','\x9FA5'),
+   f '\x3007' , ('\x3021','\x3029') ]
+
+combiningCharMap :: [(Char, Char)]
+combiningCharMap = [('\x0300','\x0345'),
+   ('\x0360','\x0361'), ('\x0483','\x0486'), ('\x0591','\x05A1'),
+   ('\x05A3','\x05B9'), ('\x05BB','\x05BD'),  f '\x05BF' , ('\x05C1','\x05C2'),
+   f '\x05C4' , ('\x064B','\x0652'), f '\x0670' , ('\x06D6','\x06DC'),
+   ('\x06DD','\x06DF'), ('\x06E0','\x06E4'), ('\x06E7','\x06E8'),
+   ('\x06EA','\x06ED'), ('\x0901','\x0903'), f '\x093C' , ('\x093E','\x094C'),
+   f '\x094D' , ('\x0951','\x0954'), ('\x0962','\x0963'), ('\x0981','\x0983'),
+   f '\x09BC' , f '\x09BE' , f '\x09BF' , ('\x09C0','\x09C4'), ('\x09C7','\x09C8'),
+   ('\x09CB','\x09CD'), f '\x09D7' , ('\x09E2','\x09E3'), f '\x0A02' , f '\x0A3C' ,
+   f '\x0A3E' , f '\x0A3F' , ('\x0A40','\x0A42'), ('\x0A47','\x0A48'),
+   ('\x0A4B','\x0A4D'), ('\x0A70','\x0A71'), ('\x0A81','\x0A83'), f '\x0ABC' ,
+   ('\x0ABE','\x0AC5'), ('\x0AC7','\x0AC9'), ('\x0ACB','\x0ACD'),
+   ('\x0B01','\x0B03'), f '\x0B3C' , ('\x0B3E','\x0B43'), ('\x0B47','\x0B48'),
+   ('\x0B4B','\x0B4D'), ('\x0B56','\x0B57'), ('\x0B82','\x0B83'),
+   ('\x0BBE','\x0BC2'), ('\x0BC6','\x0BC8'), ('\x0BCA','\x0BCD'), f '\x0BD7' ,
+   ('\x0C01','\x0C03'), ('\x0C3E','\x0C44'), ('\x0C46','\x0C48'),
+   ('\x0C4A','\x0C4D'), ('\x0C55','\x0C56'), ('\x0C82','\x0C83'),
+   ('\x0CBE','\x0CC4'), ('\x0CC6','\x0CC8'), ('\x0CCA','\x0CCD'),
+   ('\x0CD5','\x0CD6'), ('\x0D02','\x0D03'), ('\x0D3E','\x0D43'),
+   ('\x0D46','\x0D48'), ('\x0D4A','\x0D4D'), f '\x0D57' , f '\x0E31' ,
+   ('\x0E34','\x0E3A'), ('\x0E47','\x0E4E'), f '\x0EB1' , ('\x0EB4','\x0EB9'),
+   ('\x0EBB','\x0EBC'), ('\x0EC8','\x0ECD'), ('\x0F18','\x0F19'), f '\x0F35' ,
+   f '\x0F37' , f '\x0F39' , f '\x0F3E' , f '\x0F3F' , ('\x0F71','\x0F84'),
+   ('\x0F86','\x0F8B'), ('\x0F90','\x0F95'), f '\x0F97' , ('\x0F99','\x0FAD'),
+   ('\x0FB1','\x0FB7'), f '\x0FB9' , ('\x20D0','\x20DC'), f '\x20E1' ,
+   ('\x302A','\x302F'), f '\x3099' , f '\x309A' ]
+
+digitMap :: [(Char, Char)]
+digitMap = [ ('\x0030','\x0039'),
+   ('\x0660','\x0669'), ('\x06F0','\x06F9'), ('\x0966','\x096F'),
+   ('\x09E6','\x09EF'), ('\x0A66','\x0A6F'), ('\x0AE6','\x0AEF'),
+   ('\x0B66','\x0B6F'), ('\x0BE7','\x0BEF'), ('\x0C66','\x0C6F'),
+   ('\x0CE6','\x0CEF'), ('\x0D66','\x0D6F'), ('\x0E50','\x0E59'),
+   ('\x0ED0','\x0ED9'), ('\x0F20','\x0F29')]
+
+extenderMap :: [(Char, Char)]
+extenderMap = [f '\x00B7' , f '\x02D0' ,
+   f '\x02D1' , f '\x0387' , f '\x0640' , f '\x0E46' , f '\x0EC6' , f '\x3005' , ('\x3031','\x3035')
+   , ('\x309D','\x309E'), ('\x30FC','\x30FE') ]
+
+decoding :: Monad m => String -> m String
+decoding xs
+   | "\255\254" `isPrefixOf` xs =
+        return (decode16 $ drop 2 xs)
+   | "\254\255" `isPrefixOf` xs =
+        return (decode16X $ drop 2 xs)
+   | "\239\187\191" `isPrefixOf` xs =
+        UTF8.decodeM (drop 3 xs)
+   | otherwise =
+        UTF8.decodeM xs
+
+decode16 :: String -> String
+decode16 []  = []
+decode16 [x] = [x]
+decode16 (a:b:rest) = chr (ord b * 256 + ord a) : decode16 rest
+
+decode16X :: String -> String
+decode16X []  = []
+decode16X [x] = [x]
+decode16X (a:b:rest) = chr (ord b + ord a * 256) : decode16X rest
− src/Main.hs 
@@ -1,82 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Main module for feedback services
---
------------------------------------------------------------------------------
-module Main (main) where
-
-import Common.Utils (useFixedStdGen)
-import Control.Monad
-import Data.IORef
-import Data.Time
-import Documentation.Make
-import Main.IDEAS
-import Main.LoggingDatabase
-import Main.Options
-import Network.CGI
-import Service.FeedbackScript.Analysis
-import Service.ModeJSON (processJSON)
-import Service.ModeXML (processXML)
-import Service.Request
-
-main :: IO ()
-main = do
-   startTime <- getCurrentTime
-   flags     <- serviceOptions
-   logRef    <- newIORef (return ())
-
-   case withInputFile flags of
-      -- from file
-      Just file -> do
-         when (FixRNG `elem` flags)
-            useFixedStdGen -- use a predictable "random" number generator
-         input    <- readFile file
-         (req, txt, _) <- process input
-         when (Logging True `elem` flags) $
-            writeIORef logRef $ -- save logging action for later
-               logMessage req input txt "local" startTime
-         putStrLn txt
-
-      -- documentation mode
-      _ | documentationMode flags ->
-             useIDEAS $
-                let f = makeDocumentation (docDir flags) (testDir flags)
-                in mapM_ f (docItems flags)
-
-      -- feedback script options
-        | scriptMode flags -> useIDEAS $
-             withScripts (Just (scriptDir flags))
-                         [ a | MakeScriptFor a <- flags ]
-                         [ a | AnalyzeScript a <- flags ]
-
-      -- cgi binary
-      Nothing -> runCGI $ do
-         addr  <- remoteAddr           -- the IP address of the remote host making the request
-         raw   <- getInput "input"     -- read input
-         input <- case raw of
-                     Nothing -> fail "Invalid request: environment variable \"input\" is empty"
-                     Just s  -> return s
-         (req, txt, ctp) <- liftIO $ process input
-         liftIO $ writeIORef logRef $ -- save logging action for later
-            logMessage req input txt addr startTime
-         setHeader "Content-type" ctp
-         output txt
-
-   -- log request to database
-   when (withLogging flags) $
-      join (readIORef logRef)
-
-process :: String -> IO (Request, String, String)
-process input = useIDEAS $
-   case discoverDataFormat input of
-      Just XML  -> processXML input
-      Just JSON -> processJSON input
-      _ -> fail "Invalid input"
− src/Main/IDEAS.hs 
@@ -1,106 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Main.IDEAS (useIDEAS) where
-
-import Common.Exercise
-import Common.Id
-import Common.Utils (Some(..))
-import Control.Arrow
-import Main.Options
-import Service.DomainReasoner
-import Service.ServiceList
-import qualified Domain.LinearAlgebra as LA
-import qualified Domain.LinearAlgebra.Checks as LA
-import qualified Domain.Logic as Logic
-import qualified Domain.Math.ExerciseList as Math
-import qualified Domain.RelationAlgebra as RA
-
-useIDEAS :: DomainReasoner a -> IO a
-useIDEAS action = runDomainReasoner $ do
-   -- version information
-   setVersion     shortVersion
-   setFullVersion fullVersion
-   -- exercises
-   addExercises   exercises
-   addAliases     aliases
-   -- services
-   addServices  serviceList
-   addExerciseService exerciselistS
-   -- views
-   addViews Math.viewList
-   -- feedback scripts
-   flags <- liftIO serviceOptions
-   setScriptDir (scriptDir flags)
-   addScripts scripts
-   -- domain checks
-   addTestSuite $ do
-      sequence_ Math.testSuiteList
-      LA.checks
-   -- do the rest
-   action
-
-exercises :: [Some Exercise]
-exercises =
-   [ -- logic and relation-algebra
-     Some Logic.dnfExercise
-   , Some Logic.dnfUnicodeExercise
-   -- , Some Logic.proofExercise
-   , Some RA.cnfExercise
-     -- linear algebra
-   , Some LA.gramSchmidtExercise
-   , Some LA.linearSystemExercise
-   , Some LA.gaussianElimExercise
-   , Some LA.systemWithMatrixExercise
-     -- regular expressions
-   -- , some RE.regexpExercise
-   ] ++ Math.exerciseList
-
-aliases :: [(Id, Id)]
-aliases = map (newId *** newId)
-   [ ("math.coverup",             "algebra.equations.coverup")
-   , ("math.lineq",               "algebra.equations.linear")
-   , ("math.lineq-mixed",         "algebra.equations.linear.mixed")
-   , ("math.quadreq",             "algebra.equations.quadratic")
-   , ("math.quadreq-no-abc",      "algebra.equations.quadratic.no-abc")
-   , ("math.quadreq-with-approx", "algebra.equations.quadratic.approximate")
-   , ("math.higherdegree",        "algebra.equations.polynomial")
-   , ("math.rationaleq",          "algebra.equations.rational")
-   , ("math.linineq",             "algebra.inequalities.linear")
-   , ("math.quadrineq",           "algebra.inequalities.quadratic")
-   , ("math.ineqhigherdegree",    "algebra.inequalities.polynomial")
-   , ("math.factor",              "algebra.manipulation.polynomial.factor")
-   , ("math.simplifyrational",    "algebra.manipulation.rational.simplify")
-   , ("math.simplifypower",       "algebra.manipulation.exponents.simplify")
-   , ("math.nonnegexp",           "algebra.manipulation.exponents.nonnegative")
-   , ("math.powerof",             "algebra.manipulation.exponents.powerof")
-   , ("math.derivative",          "calculus.differentiation")
-   , ("math.fraction",            "arithmetic.fractions")
-   , ("math.calcpower",           "arithmetic.exponents")
-   , ("linalg.gaussianelim",      "linearalgebra.gaussianelim")
-   , ("linalg.gramschmidt",       "linearalgebra.gramschmidt")
-   , ("linalg.linsystem",         "linearalgebra.linsystem")
-   , ("linalg.systemwithmatrix",  "linearalgebra.systemwithmatrix")
-   , ("logic.dnf",                "logic.propositional.dnf")
-   , ("logic.dnf-unicode",        "logic.propositional.dnf.unicode")
-   , ("relationalg.cnf",          "relationalgebra.cnf")
-   -- MathDox compatibility
-   , ("gaussianelimination"        , "linearalgebra.gaussianelim")
-   , ("gramschmidt"                , "linearalgebra.gramschmidt")
-   , ("solvelinearsystem"          , "linearalgebra.linsystem")
-   , ("solvelinearsystemwithmatrix", "linearalgebra.systemwithmatrix")
-   ]
-
-scripts :: [(Id, FilePath)]
-scripts =
-   [ (getId Logic.dnfExercise,         "logic.txt")
-   , (getId Logic.dnfUnicodeExercise,  "logic.txt")
-   ] ++ Math.scriptList
− src/Main/LoggingDatabase.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Facilities to create a log database
---
------------------------------------------------------------------------------
-module Main.LoggingDatabase (logMessage, logEnabled) where
-
-import Data.Time
-import Service.Request
-#ifdef DB
-import Data.Maybe
-import Database.HDBC
-import Database.HDBC.Sqlite3 (connectSqlite3)
-
-logEnabled :: Bool
-logEnabled = True
-
--- | Log a message to the database (a Sqlite database).
-logMessage :: Request -> String -> String -> String -> UTCTime -> IO ()
-logMessage req input output ipaddress begin = do
-     -- make a connection with the database
-     conn <- connectSqlite3 "service.db"
-
-     -- check if the database exists, if not make one
-     --tables <- getTables conn
-     --if not (elem "log" tables) then run conn createStmt [] else return 0
-
-     -- calculate duration
-     end <- getCurrentTime
-     let diff = diffUTCTime end begin
-
-     -- insert data into database
-     run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)"
-             [ toSql $ service req
-             , toSql $ maybe "unknown" show (exerciseId req)
-             , toSql $ fromMaybe "unknown" (source req)
-             , toSql $ show (dataformat req)
-             , toSql $ maybe "unknown" show (encoding req)
-             , toSql $ input
-             , toSql $ output
-             , toSql $ ipaddress
-             , toSql $ begin
-             , toSql $ diff
-             ]
-     commit conn
-
-     -- close the connection to the database
-     disconnect conn
-  `catch` \err -> do putStrLn $ "Error in logging to database: " ++ show err
-
-{-
--- | Log table schema
-createStmt =  "CREATE TABLE log ( service      VARCHAR(250)"
-           ++                  ", exerciseId   VARCHAR(250)"
-           ++                  ", source       VARCHAR(250)"
-           ++                  ", dataformat   VARCHAR(250)"
-           ++                  ", encoding     VARCHAR(250)"
-           ++                  ", input        VARCHAR(250)"
-           ++                  ", output       VARCHAR(250)"
-           ++                  ", ipaddress    VARCHAR(20)"
-           ++                  ", time         TIME"
-           ++                  ", responsetime TIME)"
--}
-#else
-logMessage :: Request -> String -> String -> String -> UTCTime -> IO ()
-logMessage _ _ _ _ _ = return ()
-
-logEnabled :: Bool
-logEnabled = False
-#endif
− src/Main/Options.hs 
@@ -1,117 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Options and command-line flags for services
---
------------------------------------------------------------------------------
-module Main.Options where
-
-import Documentation.Make
-import Main.LoggingDatabase (logEnabled)
-import Main.Revision
-import System.Console.GetOpt
-import System.Environment
-import System.Exit
-
-data Flag = Version | Help | Logging Bool | InputFile String
-          | FixRNG | DocItem DocItem
-          | DocDir String | TestDir String | ScriptDir String
-          | MakeScriptFor String | AnalyzeScript String
-   deriving Eq
-
-header :: String
-header =
-   "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++
-   "Copyright 2011, Open Universiteit Nederland\n" ++
-   versionText ++
-   "\n\nUsage: ideas [OPTION]     (by default, CGI protocol)\n" ++
-   "\nOptions:"
-
-versionText :: String
-versionText =
-  "version " ++ version ++ ", revision " ++ show revision ++
-  ", logging " ++ (if logEnabled then "enabled" else "disabled")
-
-fullVersion :: String
-fullVersion = "version " ++ version ++ " (revision "
-           ++ show revision ++ ", " ++ lastChanged ++ ")"
-
-shortVersion :: String
-shortVersion = version ++ " (" ++ show revision ++ ")"
-
-options :: [OptDescr Flag]
-options =
-     [ Option []  ["version"]     (NoArg Version)              "show version number"
-     , Option "?" ["help"]        (NoArg Help)                 "show options"
-     , Option "l" ["logging"]     (NoArg $ Logging True)       "enable logging"
-     , Option []  ["no-logging"]  (NoArg $ Logging False)      "disable logging (default on local machine)"
-     , Option "f" ["file"]        (ReqArg InputFile "FILE")    "use input FILE as request"
-     , Option ""  ["fixed-rng"]   (NoArg FixRNG)               "use a fixed random-number generator"
-     , Option ""  ["make-pages"]  (NoArg $ DocItem Pages)      "generate pages for exercises and services"
-     , Option ""  ["self-check"]  (NoArg $ DocItem SelfCheck)  "perform a self-check"
-     , Option ""  ["test"]        (OptArg testArg "DIR")       "run tests on directory (default: 'test')"
-     , Option ""  ["docs-dir"]    (ReqArg DocDir "DIR")        "directory for documentation (default: 'docs')"
-     , Option ""  ["test-dir"]    (ReqArg TestDir "DIR")       "directory with tests (default: 'test')"
-     , Option ""  ["script-dir"]  (ReqArg ScriptDir "DIR")     "directory with feedback scripts (default: 'scripts')"
-     , Option ""  ["make-script"] (ReqArg MakeScriptFor "ID")  "generate feedback script for exercise"
-     , Option ""  ["analyze-script"] (ReqArg AnalyzeScript "FILE") "analyze feedback script and report errors"
-     ]
-
-testArg :: Maybe String -> Flag
-testArg = DocItem . BlackBox
-
-serviceOptions :: IO [Flag]
-serviceOptions = do
-   args <- getArgs
-   case getOpt Permute options args of
-      (flags, [], [])
-         | flags == [Version] -> do
-              putStrLn ("IDEAS, " ++ versionText)
-              exitSuccess
-         | all (`notElem` flags) [Version, Help] ->
-              return flags
-      (_, _, errs) -> do
-         putStrLn (concat errs ++ usageInfo header options)
-         exitFailure
-
-docItems :: [Flag] -> [DocItem]
-docItems flags = [ x | DocItem x <- flags ]
-
-docDir :: [Flag] -> String
-docDir flags = case [ d | DocDir d <- flags ] of
-                  d:_ -> d
-                  _   -> "docs"
-
-testDir :: [Flag] -> String
-testDir flags = case [ d | TestDir d <- flags ] of
-                   d:_ -> d
-                   _   -> "test"
-
-scriptDir :: [Flag] -> String
-scriptDir flags = case [ d | ScriptDir d <- flags ] of
-                     d:_ -> d
-                     _   -> "scripts"
-
-documentationMode :: [Flag] -> Bool
-documentationMode = not . null . docItems
-
-scriptMode :: [Flag] -> Bool
-scriptMode flags = not $ null $
-   [ () | MakeScriptFor _ <- flags ] ++
-   [ () | AnalyzeScript _ <- flags ]
-
-withLogging :: [Flag] -> Bool
-withLogging flags = and [ b | Logging b <- flags ]
-
-withInputFile :: [Flag] -> Maybe String
-withInputFile flags =
-   case [ file | InputFile file <- flags ] of
-      [hd] -> Just hd
-      _    -> Nothing
− src/Main/Revision.hs 
@@ -1,8 +0,0 @@--- Automatically generated by Makefile.  Do not change.-module Main.Revision where-version :: String-version = "1.0"-revision :: Int-revision = 4677-lastChanged :: String -lastChanged = "Thu, 01 Sep 2011"
− src/Service/BasicServices.hs 
@@ -1,158 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.BasicServices
-   ( -- * Basic Services
-     stepsremaining, findbuggyrules, ready, allfirsts, derivation
-   , onefirst, applicable, allapplications, apply, generate
-   ) where
-
-import Common.Library hiding (derivation, applicable, apply, ready)
-import Common.Utils (fst3, safeHead)
-import Data.List
-import Data.Maybe
-import Service.State
-import System.Random (StdGen)
-import qualified Common.Classes as Apply
-
-generate :: StdGen -> Exercise a -> Difficulty -> State a
-generate rng ex dif =
-   emptyState ex (randomTermWith rng dif ex)
-
--- TODO: add a location to each step
-derivation :: Maybe StrategyConfiguration -> State a -> Either String (Derivation (Rule (Context a), ArgValues) (Context a))
-derivation mcfg state =
-   mapSecond (biMap (\(r, _, as) -> (r, as)) stateContext) $
-   case (statePrefix state, mcfg) of
-      (Nothing, _) -> Left "Prefix is required"
-      -- configuration is only allowed beforehand: hence, the prefix
-      -- should be empty (or else, the configuration is ignored). This
-      -- restriction should probably be relaxed later on.
-      (Just p, Just cfg) | null (prefixToSteps p) ->
-         let newStrategy = configure cfg (strategy ex)
-             newExercise = ex {strategy = newStrategy}
-         in rec timeout d0 (empyStateContext newExercise (stateContext state))
-      _ -> rec timeout d0 state
- where
-   d0 = emptyDerivation state
-   ex = exercise state
-   timeout = 50 :: Int
-
-   rec i acc st =
-      case onefirst st of
-         Left _         -> Right acc
-         Right (r, l, as, next)
-            | i <= 0    -> Left msg
-            | otherwise -> rec (i-1) (acc `extend` ((r, l, as), next)) next
-    where
-      msg = "Time out after " ++ show timeout ++ " steps. " ++
-            show (biMap fst3 (prettyPrinterContext ex . stateContext) acc)
-
--- Note that we have to inspect the last step of the prefix afterwards, because
--- the remaining part of the derivation could consist of minor rules only.
-allfirsts :: State a -> Either String [(Rule (Context a), Location, ArgValues, State a)]
-allfirsts state =
-   case statePrefix state of
-      Nothing ->
-         Left "Prefix is required"
-      Just p0 ->
-         let tree = cutOnStep (stop . lastStepInPrefix) (prefixTree p0 (stateContext state))
-             f (r1, _, _, _) (r2, _, _, _) =
-                ruleOrdering (exercise state) r1 r2
-         in Right $ noDuplicates $ sortBy f $ mapMaybe make $ derivations tree
- where
-   stop (Just (RuleStep r)) = isMajorRule r
-   stop _ = False
-
-   make d = do
-      prefixEnd <- lastStep d
-      let ca = lastTerm (withoutLast d)
-      case lastStepInPrefix prefixEnd of
-         Just (RuleStep r) | isMajorRule r -> return
-            ( r
-            , location (lastTerm d)
-            , fromMaybe [] (expectedArguments r ca)
-            , makeState (exercise state) (Just prefixEnd) (lastTerm d)
-            )
-         _ -> Nothing
-
-   noDuplicates []     = []
-   noDuplicates (x:xs) = x : noDuplicates (filter (not . eq x) xs)
-
-   eq (r1, l1, a1, s1) (r2, l2, a2, s2) =
-      r1==r2 && l1==l2 && a1==a2 && exercise s1 == exercise s2
-      && similarity (exercise s1) (stateContext s1) (stateContext s2)
-
-onefirst :: State a -> Either String (Rule (Context a), Location, ArgValues, State a)
-onefirst state =
-   case allfirsts state of
-      Right []     -> Left "No step possible"
-      Right (hd:_) -> Right hd
-      Left msg     -> Left msg
-
-applicable :: Location -> State a -> [Rule (Context a)]
-applicable loc state =
-   let p r = not (isBuggyRule r) && Apply.applicable r (setLocation loc (stateContext state))
-   in filter p (ruleset (exercise state))
-
-allapplications :: State a -> [(Rule (Context a), Location, State a)]
-allapplications state = sortBy cmp (xs ++ ys)
- where
-   ex = exercise state
-   xs = either (const []) (map (\(r, l, _, s) -> (r, l, s))) (allfirsts state)
-   ps = [ (r, loc) | (r, loc, _) <- xs ]
-   ys = maybe [] f (top (stateContext state))
-
-   f c = g c ++ concatMap f (allDowns c)
-   g c = [ (r, location new, makeState ex Nothing new)
-         | r   <- ruleset ex
-         , (r, location c) `notElem` ps
-         , new <- applyAll r c
-         ]
-
-   cmp (r1, loc1, _) (r2, loc2, _) =
-      case ruleOrdering ex r1 r2 of
-         EQ   -> loc1 `compare` loc2
-         this -> this
-
--- local helper
-setLocation :: Location -> Context a -> Context a
-setLocation loc c0 = fromMaybe c0 (navigateTo loc c0)
-
--- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the
--- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied
--- to the current term at the given location, in which case the request is invalid.
-apply :: Rule (Context a) -> Location -> State a -> Either String (State a)
-apply r loc state = maybe applyOff applyOn (statePrefix state)
- where
-   applyOn _ = -- scenario 1: on-strategy
-      maybe applyOff Right $ safeHead
-      [ s1 | Right xs <- [allfirsts state], (r1, loc1, _, s1) <- xs, r==r1, loc==loc1 ]
-
-   applyOff  = -- scenario 2: off-strategy
-      case Apply.apply r (setLocation loc (stateContext state)) of
-         Just new -> Right (makeState (exercise state) Nothing new)
-         Nothing  -> Left ("Cannot apply " ++ show r)
-
-ready :: State a -> Bool
-ready state = isReady (exercise state) (stateTerm state)
-
-stepsremaining :: State a -> Either String Int
-stepsremaining = mapSecond derivationLength . derivation Nothing
-
-findbuggyrules :: State a -> a -> [(Rule (Context a), Location, ArgValues)]
-findbuggyrules state a =
-   [ (r, loc, as)
-   | r         <- filter isBuggyRule (ruleset ex)
-   , (loc, as) <- recognizeRule ex r (stateContext state) (inContext ex a)
-   ]
- where
-   ex = exercise state
− src/Service/Diagnose.hs 
@@ -1,196 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Diagnose a term submitted by a student
---
------------------------------------------------------------------------------
-module Service.Diagnose
-   ( Diagnosis(..), diagnose, restartIfNeeded
-   , newState
-   , diagnosisType
-   ) where
-
-import Common.Library hiding (ready)
-import Common.Utils (safeHead)
-import Data.List (sortBy)
-import Data.Maybe
-import Service.BasicServices hiding (apply)
-import Service.State
-import Service.Types
-
-----------------------------------------------------------------
--- Result types for diagnose service
-
-data Diagnosis a
-   = Buggy          ArgValues (Rule (Context a))
---   | Missing
---   | IncorrectPart  [a]
-   | NotEquivalent
-   | Similar        Bool (State a)
-   | Expected       Bool (State a) (Rule (Context a))
-   | Detour         Bool (State a) ArgValues (Rule (Context a))
-   | Correct        Bool (State a)
-
-instance Show (Diagnosis a) where
-   show diagnosis =
-      case diagnosis of
-         Buggy _ r        -> "Buggy rule " ++ show (show r)
---         Missing          -> "Missing solutions"
---         IncorrectPart xs -> "Incorrect parts (" ++ show (length xs) ++ " items)"
-         NotEquivalent    -> "Unknown mistake"
-         Similar _ _      -> "Very similar"
-         Expected _ _ r   -> "Rule " ++ show (show r) ++ ", expected by strategy"
-         Detour _ _ _ r   -> "Rule " ++ show (show r) ++ ", not following strategy"
-         Correct _ _      -> "Unknown step"
-
-newState :: Diagnosis a -> Maybe (State a)
-newState diagnosis =
-   case diagnosis of
-      Buggy _ _        -> Nothing
-      NotEquivalent    -> Nothing
-      Similar  _ s     -> Just s
-      Expected _ s _   -> Just s
-      Detour   _ s _ _ -> Just s
-      Correct  _ s     -> Just s
-
-----------------------------------------------------------------
--- The diagnose service
-
-diagnose :: State a -> a -> Diagnosis a
-diagnose state new
-   -- Is the submitted term equivalent?
-   | not (equivalence ex (stateContext state) newc) =
-        -- Is the rule used discoverable by trying all known buggy rules?
-        case discovered True of
-           Just (r, as) -> Buggy as r -- report the buggy rule
-           Nothing      -> NotEquivalent -- compareParts state new
-
-   -- Is the submitted term (very) similar to the previous one?
-   | similar && not (isReady ex new) =
-        -- If yes, report this
-        Similar (ready state) state
-
-   -- Was the submitted term expected by the strategy?
-   | isJust expected =
-        -- If yes, return new state and rule
-        let (r, _, _, ns) = fromJust expected
-        in Expected (ready ns) ns r
-
-   | similar = Similar (ready state) state
-
-   -- Is the rule used discoverable by trying all known rules?
-   | otherwise =
-        case discovered False of
-           Just (r, as) ->  -- If yes, report the found rule as a detour
-              Detour (ready restarted) restarted as r
-           Nothing -> -- If not, we give up
-              Correct (ready restarted) restarted
- where
-   ex        = exercise state
-   newc      = inContext ex new
-   restarted = restartIfNeeded (makeState ex Nothing newc)
-   similar   = similarity ex (stateContext state) newc
-
-   expected = do
-      let xs = either (const []) id $ allfirsts (restartIfNeeded state)
-          p (_, _, _, ns) = similarity ex newc (stateContext ns)
-      safeHead (filter p xs)
-
-   discovered searchForBuggy = safeHead
-      [ (r, as)
-      | r <- sortBy (ruleOrdering ex) (ruleset ex)
-      , isBuggyRule r == searchForBuggy, not (isFinalRule r)
-      , (_, as) <- recognizeRule ex r sub1 sub2
-      ]
-    where
-      diff = if searchForBuggy then difference else differenceEqual
-      (sub1, sub2) =
-         case diff ex (stateTerm state) new of
-            Just (a, b) -> (inContext ex a, inContext ex b)
-            Nothing     -> (stateContext state, newc)
-
-----------------------------------------------------------------
--- Helpers
-
--- If possible (and if needed), restart the strategy
--- Make sure that the new state has a prefix
--- When resetting the prefix, also make sure that the context is refreshed
-restartIfNeeded :: State a -> State a
-restartIfNeeded state
-   | isNothing (statePrefix state) && canBeRestarted ex =
-        emptyState ex (stateTerm state)
-   | otherwise = state
- where
-   ex = exercise state
-
-diagnosisType :: Type a (Diagnosis a)
-diagnosisType = Iso (f <-> g) tp
- where
-   f (Left (Left (as, r))) = Buggy as r
---   f (Left (Right (Left ()))) = Missing
---   f (Left (Right (Right (Left xs)))) = IncorrectPart xs
-   f (Left (Right ())) = NotEquivalent
-   f (Right (Left (b, s))) = Similar b s
-   f (Right (Right (Left (b, s, r)))) = Expected b s r
-   f (Right (Right (Right (Left (b, s, as, r))))) = Detour b s as r
-   f (Right (Right (Right (Right (b, s))))) = Correct b s
-
-   g (Buggy as r)       = Left (Left (as, r))
---   g Missing            = Left (Right (Left ()))
---   g (IncorrectPart xs) = Left (Right (Right (Left xs)))
-   g NotEquivalent      = Left (Right ())
-   g (Similar b s)      = Right (Left (b, s))
-   g (Expected b s r)   = Right (Right (Left (b, s, r)))
-   g (Detour b s as r)  = Right (Right (Right (Left (b, s, as, r))))
-   g (Correct b s)      = Right (Right (Right (Right (b, s))))
-
-   tp  =
-       (  Tag "buggy"         (Pair (List ArgValueTp) Rule)
---      :|: Tag "missing"       Unit
---      :|: Tag "incorrectpart" (List Term)
-      :|: Tag "notequiv"      Unit
-       )
-      :|:
-       (  Tag "similar"  (Pair   readyBool stateType)
-      :|: Tag "expected" (tuple3 readyBool stateType Rule)
-      :|: Tag "detour"   (tuple4 readyBool stateType (List ArgValueTp) Rule)
-      :|: Tag "correct"  (Pair   readyBool stateType)
-       )
-
-   readyBool = Tag "ready" Bool
-
-----------------------------------------------------------------
--- Compare answer sets (and search for missing parts/incorrect parts)
-{-  splitParts     :: a -> [a]
-compareParts :: State a -> a -> Diagnosis a
-compareParts state = answerList eq split solve (stateTerm state)
- where
-   ex    = exercise (exercise state)
-   eq    = equivalence ex
-   split = splitParts ex
-   solve = \a -> fromMaybe a $
-                    apply (strategy ex) (inContext ex a) >>= fromContext
-
-answerList :: (a -> a -> Bool) -> (a -> [a]) -> (a -> a) -> a -> a -> Diagnosis a
-answerList eq split solve a b
-   | noSplit               = NotEquivalent
-   | present && null wrong = NotEquivalent -- error situation
-   | null wrong            = Missing
-   | partly                = IncorrectPart wrong
-   | otherwise             = NotEquivalent
- where
-   as = split (solve a) -- expected
-   ps = [ (x, split (solve x)) | x <- split b ] -- student (keep original parts)
-   bs = concatMap snd ps -- student answer, but then fully solved
-   wrong   = [ x | (x, xs) <- ps, any notInAs xs ] -- is a (student) part incorrect?
-   present = all (flip any bs . eq) as -- are all expected answers present
-   notInAs = not . flip any as . eq
-   partly  = length wrong < length ps
-   noSplit = length as < 2 && length bs < 2 -}
− src/Service/DomainReasoner.hs 
@@ -1,189 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.DomainReasoner
-   ( -- * Domain Reasoner data type
-     DomainReasoner, runDomainReasoner, runWithCurrent
-   , liftEither, MonadIO(..), catchError
-     -- * Update functions
-   , addExercises, addExercise, addExerciseService
-   , addServices, addService, addViews, addView
-   , addTestSuite
-   , addAliases, addScripts, setScriptDir
-   , setVersion, setFullVersion
-     -- * Accessor functions
-   , getExercises, getServices, getViews
-   , getVersion, getFullVersion, getTestSuite
-   , findExercise, findService
-   , readScript, defaultScript
-   ) where
-
-import Common.Library
-import Common.Utils (Some(..))
-import Common.Utils.TestSuite
-import Control.Monad.Error
-import Control.Monad.State
-import Data.Maybe
-import Service.FeedbackScript.Parser
-import Service.Types
-
------------------------------------------------------------------------
--- Domain Reasoner data type
-
-newtype DomainReasoner a = DR { unDR :: ErrorT String (StateT Content IO) a }
-
-data Content = Content
-   { exercises   :: [Some Exercise]
-   , services    :: [Some Exercise] -> [Service]
-   , views       :: [ViewPackage]
-   , aliases     :: [(Id, Id)]
-   , scriptDir   :: Maybe FilePath
-   , scripts     :: [(Id, FilePath)]
-   , testSuite   :: TestSuite
-   , version     :: String
-   , fullVersion :: Maybe String
-   }
-
-noContent :: Content
-noContent = Content [] (const []) [] [] Nothing [] (return ()) [] Nothing
-
-runDomainReasoner :: DomainReasoner a -> IO a
-runDomainReasoner m = do
-   result <- evalStateT (runErrorT (unDR m)) noContent
-   case result of
-      Left msg -> fail msg
-      Right a  -> return a
-
--- | Returns a run function, based on the current state, inside the monad
-runWithCurrent :: DomainReasoner (DomainReasoner a -> IO a)
-runWithCurrent =
-   get >>= \st -> return (runDomainReasoner . (put st >>))
-
-liftEither :: Either String a -> DomainReasoner a
-liftEither = either throwError return
-
------------------------------------------------------------------------
--- Instance declarations
-
-instance Monad DomainReasoner where
-   return a   = DR (return a)
-   DR m >>= f = DR (m >>= unDR . f)
-   fail s     = DR (throwError s)
-
-instance MonadError String DomainReasoner where
-   throwError s   = DR (throwError s)
-   catchError m f = DR (unDR m `catchError` (unDR . f))
-
-instance MonadPlus DomainReasoner where
-   mzero       = DR mzero
-   a `mplus` b = DR (unDR a `mplus` unDR b)
-
-instance MonadState Content DomainReasoner where
-   get   = DR get
-   put s = DR (put s)
-
-instance MonadIO DomainReasoner where
-   liftIO m = DR (liftIO m)
-
------------------------------------------------------------------------
--- Update functions
-
-addExercises :: [Some Exercise] -> DomainReasoner ()
-addExercises xs = modify $ \c -> c { exercises = xs ++ exercises c }
-
-addExercise :: Some Exercise -> DomainReasoner ()
-addExercise ex = addExercises [ex]
-
-addExerciseService :: ([Some Exercise] -> Service) -> DomainReasoner ()
-addExerciseService f = modify $ \c ->
-   c { services = \xs -> f xs : services c xs }
-
-addServices :: [Service] -> DomainReasoner ()
-addServices = mapM_ (addExerciseService . const)
-
-addService :: Service -> DomainReasoner ()
-addService s = addServices [s]
-
-addViews :: [ViewPackage] -> DomainReasoner ()
-addViews xs = modify $ \c -> c { views = xs ++ views c }
-
-addView :: ViewPackage -> DomainReasoner ()
-addView = addViews . return
-
-addTestSuite :: TestSuite -> DomainReasoner ()
-addTestSuite m = modify $ \c -> c { testSuite = testSuite c >> m }
-
-addAliases :: [(Id, Id)] -> DomainReasoner ()
-addAliases xs = modify $ \c -> c { aliases = xs ++ aliases c }
-
-setScriptDir :: FilePath -> DomainReasoner ()
-setScriptDir path = modify $ \c -> c { scriptDir = Just path }
-
-addScripts :: [(Id, FilePath)] -> DomainReasoner ()
-addScripts xs = modify $ \c -> c { scripts = xs ++ scripts c }
-
-setVersion :: String -> DomainReasoner ()
-setVersion s = modify $ \c -> c { version = s }
-
-setFullVersion :: String -> DomainReasoner ()
-setFullVersion s = modify $ \c -> c  { fullVersion = Just s }
-
------------------------------------------------------------------------
--- Accessor functions
-
-getExercises :: DomainReasoner [Some Exercise]
-getExercises = gets exercises
-
-getServices :: DomainReasoner [Service]
-getServices = gets (\c -> services c (exercises c))
-
-getViews :: DomainReasoner [ViewPackage]
-getViews = gets views
-
-getVersion :: DomainReasoner String
-getVersion = gets version
-
-getFullVersion :: DomainReasoner String
-getFullVersion = gets fullVersion >>= maybe getVersion return
-
-getTestSuite :: DomainReasoner TestSuite
-getTestSuite = gets testSuite
-
-findExercise :: Id -> DomainReasoner (Some Exercise)
-findExercise i = do
-   xs    <- getExercises
-   table <- gets aliases
-   let res = fromMaybe i (lookup i table)
-   case [ a | a@(Some ex) <- xs, getId ex == res ] of
-      [this] -> return this
-      _      -> throwError $ "Exercise " ++ show i ++ " not found"
-
-findService :: String -> DomainReasoner Service
-findService txt = do
-   srvs <- getServices
-   case filter ((==txt) . showId) srvs of
-      [hd] -> return hd
-      []   -> throwError $ "No service " ++ txt
-      _    -> throwError $ "Ambiguous service " ++ txt
-
-defaultScript :: Id -> DomainReasoner Script
-defaultScript a = do
-   list <- gets scripts
-   maybe (return mempty) readScript (lookup a list)
-
--- | Returns an empty script if the file does not exist
-readScript :: FilePath -> DomainReasoner Script
-readScript file = do
-   path <- gets scriptDir
-   liftIO $ parseScript path file
-    `catchError`
-      \_ -> return mempty
− src/Service/Evaluator.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE GADTs, Rank2Types #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.Evaluator where
-
-import Common.Library
-import Control.Monad
-import Service.DomainReasoner
-import Service.Types
-import System.Random
-
-evalService :: Evaluator inp out a -> Service -> inp -> DomainReasoner out
-evalService f = eval f . serviceFunction
-
-data Evaluator inp out a = Evaluator
-   { encoder :: Encoder out a
-   , decoder :: Decoder inp a
-   }
-
-data Encoder s a = Encoder
-   { encodeType    :: forall t . Type a t -> t -> DomainReasoner s
-   , encodeCtxTerm :: Context a -> DomainReasoner s
-   , encodeTerm    :: a -> DomainReasoner s
-   , encodeTuple   :: [s] -> s
-   }
-
-data Decoder s a = Decoder
-   { decodeType      :: forall t . Type a t -> s -> DomainReasoner (t, s)
-   , decodeTerm      :: s -> DomainReasoner a
-   , decoderExercise :: Exercise a
-   }
-
-eval :: Evaluator inp out a -> TypedValue a -> inp -> DomainReasoner out
-eval f (tv ::: tp) s =
-   case tp of
-      t1 :-> t2 -> do
-         (a, s1) <- decodeType (decoder f) t1 s
-         eval f (tv a ::: t2) s1
-      _ ->
-         encodeType (encoder f) tp tv
-
-decodeDefault :: Decoder s a -> Type a t -> s -> DomainReasoner (t, s)
-decodeDefault dec tp s =
-   case tp of
-      Iso p t  -> liftM (from (first p)) (decodeType dec t s)
-      Pair t1 t2 -> do
-         (a, s1) <- decodeType dec t1 s
-         (b, s2) <- decodeType dec t2 s1
-         return ((a, b), s2)
-      t1 :|: t2 ->
-         liftM (first Left)  (decodeType dec t1 s) `mplus`
-         liftM (first Right) (decodeType dec t2 s)
-      Unit ->
-         return ((), s)
-      Tag _ t1 ->
-         decodeType dec t1 s
-      Exercise ->
-         return (decoderExercise dec, s)
-      StdGen -> do
-         stdgen <- liftIO newStdGen
-         return (stdgen, s)
-      Script -> do
-         script <- defaultScript (getId (decoderExercise dec))
-         return (script, s)
-      _ ->
-         fail $ "No support for argument type: " ++ show tp
-
-encodeDefault :: Encoder s a -> Type a t -> t -> DomainReasoner s
-encodeDefault enc tp tv =
-   case tp of
-      Iso p t    -> encodeType enc t (to p tv)
-      Pair t1 t2 ->
-         case tv of
-            (a, b) -> do
-               x <- encodeType enc t1 a
-               y <- encodeType enc t2 b
-               return (encodeTuple enc [x, y])
-      List t        -> liftM (encodeTuple enc) (mapM (encodeType enc t) tv)
-      t1 :|: t2     -> case tv of
-                          Left  a -> encodeType enc t1 a
-                          Right b -> encodeType enc t2 b
-      Unit          -> return (encodeTuple enc [])
-      Tag _ t1      -> encodeType enc t1 tv
-      Rule          -> encodeType enc String (showId tv)
-      Term          -> encodeTerm enc tv
-      Context       -> fromContext tv >>= encodeType enc Term
-      Location      -> encodeAsString enc tv
-      Id            -> encodeAsString enc tv
-      Int           -> encodeAsString enc tv
-      Exercise      -> return (encodeTuple enc [])
-      IO t          -> do a <- liftIO tv
-                          encodeType enc t a
-      Exception     -> fail tv
-      _             -> fail ("No support for result type: " ++ show tp)
-
-encodeAsString :: Show b => Encoder s a -> b -> DomainReasoner s
-encodeAsString enc a = encodeType enc String (show a)
− src/Service/FeedbackScript/Analysis.hs 
@@ -1,101 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Analysis of a feedbackscript
---
------------------------------------------------------------------------------
-module Service.FeedbackScript.Analysis (withScripts) where
-
-import Common.Exercise
-import Common.Id
-import Common.Transformation
-import Common.Utils (Some(..))
-import Common.Utils.Uniplate
-import Control.Monad
-import Data.Either
-import Data.List
-import Service.DomainReasoner
-import Service.FeedbackScript.Parser
-import Service.FeedbackScript.Run
-import Service.FeedbackScript.Syntax
-
-withScripts :: Maybe FilePath -> [String] -> [FilePath] -> DomainReasoner ()
-withScripts path xs ys = do
-   -- generate scripts
-   forM_ xs $ \s -> do
-      Some ex <- findExercise (newId s)
-      liftIO $ print (generateScript ex)
-   -- analyze scripts
-   forM_ ys $ \file -> do
-      liftIO $ putStrLn $ "Parsing " ++ show file
-      script <- liftIO $ parseScript path file
-      let sups = [ a | Supports as <- scriptDecls script, a <- as ]
-      exs <- forM sups $ \a ->
-                liftM Right (findExercise a)
-              `catchError` \_ -> return $ Left $ UnknownExercise a
-
-      let ms = lefts exs ++ analyzeScript (rights exs) script
-      liftIO $ do
-         putStrLn $ unlines $ map show ms
-         putStrLn $ "(errors: " ++ show (length ms) ++ ")"
-
-generateScript :: Exercise a -> Script
-generateScript ex = makeScript $
-   Supports [getId ex] :
-   [ feedbackDecl s mempty | s <- feedbackIds ] ++
-   [ textForIdDecl r (makeText (description r)) | r <- nrs ] ++
-   [ textForIdDecl r (makeText (description r)) | r <- brs ]
- where
-   (brs, nrs) = partition isBuggyRule (ruleset ex)
-
-data Message = UnknownExercise   Id
-             | UnknownFeedback   Id
-             | FeedbackUndefined Id
-             | NoTextForRule Id Id
-             | UnknownAttribute Id
-             | UnknownCondAttr  Id
-
-instance Show Message where
-   show message =
-      case message of
-         UnknownExercise a   -> "Unknown exercise id " ++ show a
-         UnknownFeedback a   -> "Unknown feedback category " ++ show a
-         FeedbackUndefined a -> "Feedback category " ++ show a ++ " is not defined"
-         NoTextForRule a b   -> "No text for rule " ++ show a ++ " of exercise " ++ show b
-         UnknownAttribute a  -> "Unknown attribute @" ++ show a ++ " in text"
-         UnknownCondAttr a   -> "Unknown attribute @" ++ show a ++ " in condition"
-
-analyzeScript :: [Some Exercise] -> Script -> [Message]
-analyzeScript exs script =
-   map FeedbackUndefined (filter (`notElem` fbids) feedbackIds) ++
-   map UnknownFeedback   (filter (`notElem`feedbackIds ) fbids) ++
-   [ NoTextForRule (getId r) (getId ex)
-   | Some ex <- exs, r <- ruleset ex, noTextFor (getId r)
-   ] ++
-   [ UnknownAttribute a | a <- textRefs
-   , a `notElem` feedbackIds ++ attributeIds ++ strids ] ++
-   [ UnknownCondAttr a | a <- condRefs, a `notElem` conditionIds ]
- where
-   decls = scriptDecls script
-   fbids = [ a | Simple  Feedback as _ <- decls, a <- as ] ++
-           [ a | Guarded Feedback as _ <- decls, a <- as ]
-   txids = [ a | Simple  TextForId as _ <- decls, a <- as ] ++
-           [ a | Guarded TextForId as _ <- decls, a <- as ]
-   strids = [ a | Simple  StringDecl as _ <- decls, a <- as ] ++
-            [ a | Guarded StringDecl as _ <- decls, a <- as ]
-   namespaces = nub $ mempty : [ a | NameSpace as <- scriptDecls script, a <- as ]
-   noTextFor a = null [ () | n <- namespaces, b <- txids, n#b == a ]
-
-   texts = [ t | Simple  _ _ t <- decls ] ++
-           [ t | Guarded _ _ xs <- decls, (_, t) <- xs ]
-   textRefs = [ a | t <- texts, TextRef a <- universe t ]
-
-   conditions  = [ c | Guarded _ _ xs <- decls , (c, _) <- xs ]
-   condRefs = [ a | c <- conditions, CondRef a <- universe c ]
− src/Service/FeedbackScript/Parser.hs 
@@ -1,139 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Simple parser for feedback scripts
---
------------------------------------------------------------------------------
-module Service.FeedbackScript.Parser (parseScript, Script) where
-
-import Common.Id
-import Control.Monad.Error
-import Data.Char
-import Data.Monoid
-import Service.FeedbackScript.Syntax
-import Text.ParserCombinators.Parsec
-import Text.Parsing
-
--- chases all included script files
-parseScript :: Maybe FilePath -> FilePath -> IO Script
-parseScript path file = rec [] [file]
- where
-   rec _ [] = return mempty
-   rec hist (a:as)
-      | a `elem` hist = rec hist as
-      | otherwise = do
-           s1 <- parseOneScriptFile path a
-           let new = [ b | Include bs <- scriptDecls s1, b <- bs ]
-           s2 <- rec (a:hist) (new++as) -- depth-first
-           return (s1 <> s2) -- included parts are inserted at the end
-
-parseOneScriptFile :: Maybe FilePath -> FilePath -> IO Script
-parseOneScriptFile path file = do
-   result <- parseFromFile script full
-   case result of
-      Left e   -> print e >> return mempty
-      Right xs -> return xs
- where
-   full = maybe id (\p a -> p ++ "/" ++ a) path file
-
-script :: Parser Script
-script = makeScript <$> complete decls
-
-decls :: Parser [Decl]
-decls = many $ do
-   pos <- getPosition
-   guard (sourceColumn pos == 1)
-   decl
-
-decl :: Parser Decl
-decl = do
-   dt <- declType
-   a  <- identifiers
-   f  <- simpleDecl <|> guardedDecl
-   return (f dt a)
- <|>
-   NameSpace <$ lexString "namespace" <*>  identifiers
- <|>
-   Supports <$ lexString "supports" <*> identifiers
- <|>
-   Include <$ lexString "include" <*> filenames
- <?> "declaration"
-
-simpleDecl, guardedDecl :: Parser (DeclType -> [Id] -> Decl)
-simpleDecl  =  (\t dt a -> Simple dt a t)
-           <$> text
-guardedDecl =  (\xs dt a -> Guarded dt a xs)
-           <$> many1 ((,) <$> (lexChar '|' *> condition) <*> text)
-
-declType :: Parser DeclType
-declType =  (TextForId  <$ lexString "text")
-        <|> (StringDecl <$ lexString "string")
-        <|> (Feedback   <$ lexString "feedback")
-
-condition :: Parser Condition
-condition = choice
-   [ CondRef         <$> lexeme attribute
-   , RecognizedIs    <$  lexString "recognize" <*> identifier
-   , CondConst True  <$  lexString "true"
-   , CondConst False <$  lexString "false"
-   , CondNot         <$  lexString "not" <*> condition
-   ]
-
-text :: Parser Text
-text = lexChar '=' *> (singleLineText <|> multiLineText)
-
-singleLineText :: Parser Text
-singleLineText =
-   mconcat <$> manyTill textItem (lexeme (skip newline <|> comment))
-
-multiLineText :: Parser Text
-multiLineText =
-   mconcat <$  char '{'
-           <*> manyTill (textItem <|> (mempty <$ newline)) (lexChar '}')
-
-textItem :: Parser Text
-textItem = makeText <$> many1 (noneOf "@#{}\n" <|> try escaped)
-       <|> TextRef  <$> attribute
- where
-   escaped = char '@' *> satisfy (not . isAlphaNum)
-
-identifiers :: Parser [Id]
-identifiers = sepBy1 identifier (lexChar ',')
-
--- Lexical units
-identifier :: Parser Id
-identifier = lexeme (mconcat . map newId <$> idPart `sepBy1` char '.')
- <?> "identifier"
- where
-   idPart   = many1 idLetter
-   idLetter = alphaNum <|> oneOf "-_"
-
-attribute :: Parser Id
-attribute = newId <$ skip (char '@') <*>  many1 (alphaNum <|> oneOf "-_")
-   <?> "attribute"
-
-filenames :: Parser [FilePath]
-filenames = sepBy1 filename (lexChar ',')
-
-filename :: Parser FilePath
-filename = lexeme $ many1 (alphaNum <|> oneOf "+-_./\\:;|")
-
-lexChar :: Char -> Parser ()
-lexChar = skip . lexeme . char
-
-lexString :: String -> Parser ()
-lexString s = skip (lexeme (try (string s))) <?> "string " ++ show s
-
-comment :: Parser ()
-comment = skip (char '#' <* manyTill (noneOf "\n") (skip newline <|> eof))
-
--- parse white space and comments afterwards
-lexeme :: Parser a -> Parser a
-lexeme p = p <* skipMany (skip space <|> comment)
− src/Service/FeedbackScript/Run.hs 
@@ -1,161 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Run a feedbackscript
---
------------------------------------------------------------------------------
-module Service.FeedbackScript.Run
-   ( Script
-   , Environment(..), newEnvironment
-   , feedbackDiagnosis, feedbackHint
-   , ruleToString, feedbackIds, attributeIds, conditionIds
-   ) where
-
-import Common.Library hiding (ready, Environment)
-import Common.Utils (safeHead)
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Service.BasicServices
-import Service.Diagnose
-import Service.FeedbackScript.Syntax
-import Service.State
-
-data Environment a = Env
-   { oldReady   :: Bool
-   , expected   :: Maybe (Rule (Context a))
-   , recognized :: Maybe (Rule (Context a))
-   , diffPair   :: Maybe (String, String)
-   , before     :: Maybe Term
-   , after      :: Maybe Term
-   , afterText  :: Maybe String
-   }
-
-newEnvironment :: State a -> Environment a
-newEnvironment st = Env
-   { oldReady   = ready st
-   , expected   = fmap fst4 next
-   , recognized = Nothing
-   , diffPair   = Nothing
-   , before     = f st
-   , after      = liftM fth4 next >>= f
-   , afterText  = liftM fth4 next >>= g
-   }
- where
-   next = either (const Nothing) Just (onefirst st)
-   f s  = fmap (`build` stateTerm s) (hasTermView (exercise s))
-   g s  = return $ prettyPrinter (exercise s) (stateTerm s)
-   fst4 (a, _, _, _) = a
-   fth4 (_, _, _, a) = a
-
-toText :: Environment a -> Script -> Text -> Maybe Text
-toText env script = eval env script . Right
-
-ruleToString :: Environment a -> Script -> Rule b -> String
-ruleToString env script r =
-   let f = eval env script . Left . getId
-   in maybe (showId r) show (f r)
-
-eval :: Environment a -> Script -> Either Id Text -> Maybe Text
-eval env script = either (return . findIdRef) evalText
- where
-   evalText :: Text -> Maybe Text
-   evalText = liftM mconcat . mapM unref . textItems
-    where
-      unref (TextRef a)
-         | a == expectedId   = fmap (findIdRef . getId) (expected env)
-         | a == recognizedId = fmap (findIdRef . getId) (recognized env)
-         | a == diffbeforeId = fmap (TextString . fst) (diffPair env)
-         | a == diffafterId  = fmap (TextString . snd) (diffPair env)
-         | a == beforeId     = fmap TextTerm (before env)
-         | a == afterId      = fmap TextTerm (after env)
-         | a == afterTextId  = fmap TextString (afterText env)
-         | otherwise         = findRef (==a)
-      unref t = Just t
-
-   evalBool :: Condition -> Bool
-   evalBool (RecognizedIs a) = maybe False (eqId a . getId) (recognized env)
-   evalBool (CondNot c)      = not (evalBool c)
-   evalBool (CondConst b)    = b
-   evalBool (CondRef a)
-      | a == oldreadyId    = oldReady env
-      | a == hasexpectedId = isJust (expected env)
-      | otherwise          = False
-
-   namespaces = nub $ mempty : [ a | NameSpace as <- scriptDecls script, a <- as ]
-
-   -- equality with namespaces
-   eqId :: Id -> Id -> Bool
-   eqId a b = any (\n -> n#a == b) namespaces
-
-   findIdRef :: Id -> Text
-   findIdRef x = fromMaybe (TextString (showId x)) (findRef (`eqId` x))
-
-   findRef :: (Id -> Bool) -> Maybe Text
-   findRef p = safeHead $ catMaybes
-      [ evalText t
-      | (as, c, t) <- allDecls
-      , any p as && evalBool c
-      ]
-
-   allDecls =
-      let f (Simple _ as t)   = [ (as, CondConst True, t) ]
-          f (Guarded _ as xs) = [ (as, c, t) | (c, t) <- xs ]
-          f _ = []
-      in concatMap f (scriptDecls script)
-
-feedbackDiagnosis :: Diagnosis a -> Environment a -> Script -> Text
-feedbackDiagnosis diagnosis env =
-   fromMaybe (TextString "ERROR") .
-   case diagnosis of
-      Buggy _ r      -> make "buggy"   env {recognized = Just r}
-      NotEquivalent  -> make "noteq"   env
-      Expected _ _ r -> make "ok"      env {recognized = Just r}
-      Similar _ _    -> make "same"    env
-      Detour _ _ _ r -> make "detour"  env {recognized = Just r}
-      Correct _ _    -> make "unknown" env
-
-feedbackHint :: Bool -> Environment a -> Script -> Text
-feedbackHint b env script =
-   fromMaybe (defaultHint env script) $
-   make (if b then "hint" else "step") env script
-
-defaultHint :: Environment a -> Script -> Text
-defaultHint env script = makeText $
-   case expected env of
-      Just r  -> ruleToString env script r
-      Nothing -> "Sorry, not hint available."
-
-make :: String -> Environment a -> Script -> Maybe Text
-make s env script = toText env script (TextRef (newId s))
-
-feedbackIds :: [Id]
-feedbackIds = map newId
-   ["same", "noteq", "unknown", "ok", "buggy", "detour", "hint", "step"]
-
-attributeIds :: [Id]
-attributeIds =
-   [expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId]
-
-conditionIds :: [Id]
-conditionIds = [oldreadyId, hasexpectedId]
-
-expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId :: Id
-expectedId   = newId "expected"
-recognizedId = newId "recognized"
-diffbeforeId = newId "diffbefore"
-diffafterId  = newId "diffafter"
-beforeId     = newId "before"
-afterId      = newId "after"
-afterTextId  = newId "aftertext"
-
-oldreadyId, hasexpectedId :: Id
-oldreadyId    = newId "oldready"
-hasexpectedId = newId "hasexpected"
− src/Service/FeedbackScript/Syntax.hs 
@@ -1,134 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Abstract syntax for feedback scripts, and pretty-printer (Show instance)
---
------------------------------------------------------------------------------
-module Service.FeedbackScript.Syntax
-   ( Script, makeScript, scriptDecls, makeText, textItems
-   , Decl(..), DeclType(..), Text(..), Condition(..)
-   , feedbackDecl, textForIdDecl
-   , module Data.Monoid, (<>)
-   ) where
-
-import Common.Algebra.Group ((<>))
-import Common.Library
-import Common.Utils (commaList, safeHead)
-import Common.Utils.Uniplate
-import Data.Char
-import Data.Monoid
-
-newtype Script = S { scriptDecls :: [Decl] }
-
-makeScript :: [Decl] -> Script
-makeScript = S
-
-data Decl
-   = NameSpace [Id]
-   | Supports  [Id]
-   | Include [FilePath]
-   | Simple  DeclType [Id] Text
-   | Guarded DeclType [Id] [(Condition, Text)]
-
-data DeclType = TextForId | StringDecl | Feedback
-
-data Text
-   = TextString String
-   | TextTerm   Term
-   | TextRef Id
-   | TextEmpty
-   | Text :<>: Text
-
-data Condition
-   = RecognizedIs Id
-   | CondNot   Condition
-   | CondConst Bool
-   | CondRef Id
-
-makeText :: String -> Text
-makeText s = case words s of
-                [] -> TextEmpty
-                xs -> TextString (combineList xs)
-
-feedbackDecl, textForIdDecl :: HasId a => a -> Text -> Decl
-feedbackDecl  a = Simple Feedback  [getId a]
-textForIdDecl a = Simple TextForId [getId a]
-
-instance Show Script where
-   show = unlines . map show . scriptDecls
-
-instance Show Decl where
-   show decl =
-      let idList   = commaList . map show
-          f dt as  = unwords [show dt, idList as]
-          g (c, t) = "   | " ++ show c ++ " = " ++ nonEmpty (show t)
-          nonEmpty xs = if null xs then "{}" else xs
-      in case decl of
-            NameSpace as     -> "namespace " ++ idList as
-            Supports as      -> "supports "  ++ idList as
-            Include xs       -> "include "   ++ commaList xs
-            Simple dt as t   -> f dt as ++ " = " ++ nonEmpty (show t)
-            Guarded dt as xs -> unlines (f dt as : map g xs)
-
-instance Show DeclType where
-   show TextForId  = "text"
-   show StringDecl = "string"
-   show Feedback   = "feedback"
-
-instance Show Condition where
-   show (RecognizedIs a) = "recognize " ++ show a
-   show (CondNot c)      = "not " ++ show c
-   show (CondConst b)    = map toLower (show b)
-   show (CondRef a)      = '@' : show a
-
-instance Show Text where
-   show (TextString s) = s
-   show (TextTerm a)   = show a
-   show TextEmpty      = ""
-   show t@(_ :<>: _)   = show [t]
-   show (TextRef a)    = '@' : show a
-
-   showList xs ys =
-      foldr (combine . show) ys (concatMap textItems xs)
-
-instance Monoid Script where
-   mempty = makeScript []
-   mappend s t = makeScript (scriptDecls s ++ scriptDecls t)
-
-instance Monoid Text where
-   mempty  = TextEmpty
-   mappend = (:<>:)
-
-instance Uniplate Condition where
-   uniplate (CondNot a) = plate CondNot |* a
-   uniplate c           = plate c
-
-instance Uniplate Text where
-   uniplate (a :<>: b) = plate (:<>:) |* a |* b
-   uniplate t          = plate t
-
-textItems :: Text -> [Text]
-textItems t = rec t []
- where
-   rec (a :<>: b) = rec a . rec b
-   rec TextEmpty  = id
-   rec a          = (a:)
-
-combineList :: [String] -> String
-combineList = foldr combine []
-
-combine :: String -> String -> String
-combine a b
-   | null a    = b
-   | null b    = a
-   | maybe False special (safeHead b) = a ++ b
-   | otherwise = a ++ " " ++ b
- where
-    special = (`elem` ".,:;?!")
− src/Service/FeedbackText.hs 
@@ -1,76 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.FeedbackText
-   ( onefirsttext, submittext, derivationtext, feedbacktext
-   ) where
-
-import Common.Library hiding (derivation)
-import Service.BasicServices
-import Service.Diagnose
-import Service.FeedbackScript.Run
-import Service.FeedbackScript.Syntax
-import Service.State
-
-------------------------------------------------------------
--- Services
-
-derivationtext :: Script -> State a -> Either String (Derivation String (Context a))
-derivationtext script state =
-   let f = ruleToString (newEnvironment state) script . fst
-   in right (mapFirst f) (derivation Nothing state)
-
-onefirsttext :: Script -> State a -> Maybe String -> (Text, Maybe (State a))
-onefirsttext script old event =
-   ( feedbackHint (event == Just "hint button") env script
-   , fmap fth4 next
-   )
- where
-   ex   = exercise old
-   next = either (const Nothing) Just (onefirst old)
-   fth4 (_, _, _, a) = a
-   env  = (newEnvironment old)
-      { diffPair = do
-          new      <- fmap fth4 next
-          oldC     <- fromContext (stateContext old)
-          a        <- fromContext (stateContext new)
-          (d1, d2) <- difference ex oldC a
-          return (prettyPrinter ex d1, prettyPrinter ex d2)
-      }
-
--- Feedback messages for submit service (free student input). The boolean
--- indicates whether the student is allowed to continue (True), or forced
--- to go back to the previous state (False)
-submittext :: Script -> State a -> String -> (Bool, Text, State a)
-submittext script old input =
-   case parser (exercise old) input of
-      Left msg -> (False, TextString msg, old)
-      Right a  -> feedbacktext script old a
-
-feedbacktext :: Script -> State a -> a -> (Bool, Text, State a)
-feedbacktext script old a =
-   case diagnosis of
-      Buggy _ _      -> (False, output, old)
-      NotEquivalent  -> (False, output, old)
-      Expected _ s _ -> (True,  output, s)
-      Similar _ s    -> (True,  output, s)
-      Detour _ s _ _ -> (True,  output, s)
-      Correct _ s    -> (False, output, s)
- where
-   diagnosis = diagnose old a
-   output    = feedbackDiagnosis diagnosis env script
-   ex  = exercise old
-   env = (newEnvironment old)
-            { diffPair = do
-                 oldC     <- fromContext (stateContext old)
-                 (d1, d2) <- difference ex oldC a
-                 return (prettyPrinter ex d1, prettyPrinter ex d2)
-            }
− src/Service/ModeJSON.hs 
@@ -1,242 +0,0 @@-{-# LANGUAGE GADTs #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Services using JSON notation
---
------------------------------------------------------------------------------
-module Service.ModeJSON (processJSON, jsonTuple) where
-
-import Common.Library hiding (exerciseId)
-import Common.Utils (Some(..), distinct, readM)
-import Control.Monad.Error
-import Data.Char
-import Data.Maybe
-import Service.DomainReasoner
-import Service.Evaluator
-import Service.Request
-import Service.State
-import Service.Submit
-import Service.Types hiding (String)
-import Text.JSON
-import qualified Service.Types as Tp
-
--- TODO: Clean-up code
-extractExerciseId :: Monad m => JSON -> m Id
-extractExerciseId json =
-   case json of
-      String s -> return (newId s)
-      Array [String _, String _, a@(Array _)] -> extractExerciseId a
-      Array (String s:tl) | any p s -> extractExerciseId (Array tl)
-      Array (hd:_) -> extractExerciseId hd
-      _ -> fail "no code"
- where
-   p c = not (isAlphaNum c || isSpace c || c `elem` ".-")
-
-processJSON :: String -> DomainReasoner (Request, String, String)
-processJSON input = do
-   json <- either throwError return (parseJSON input)
-   req  <- jsonRequest json
-   vers <- getVersion
-   resp <- jsonRPC json myHandler
-   let out = show $ (if null vers then id else addVersion vers) (toJSON resp)
-   return (req, out, "application/json")
-
-addVersion :: String -> JSON -> JSON
-addVersion version json =
-   case json of
-      Object xs -> Object (xs ++ [info])
-      _         -> json
- where
-   info = ("version", String version)
-
-jsonRequest :: Monad m => JSON -> m Request
-jsonRequest json = do
-   srv  <- case lookupM "method" json of
-              Just (String s) -> return s
-              _               -> fail "Invalid method"
-   let a = lookupM "params" json >>= extractExerciseId
-   enc  <- case lookupM "encoding" json of
-              Nothing         -> return Nothing
-              Just (String s) -> liftM Just (readEncoding s)
-              _               -> fail "Invalid encoding"
-   src  <- case lookupM "source" json of
-              Nothing         -> return Nothing
-              Just (String s) -> return (Just s)
-              _               -> fail "Invalid source"
-   return Request
-      { service    = srv
-      , exerciseId = a
-      , source     = src
-      , dataformat = JSON
-      , encoding   = enc
-      }
-
-myHandler :: JSON_RPC_Handler DomainReasoner
-myHandler fun arg = do
-   ex   <- if fun == "exerciselist"
-           then return (Some emptyExercise)
-           else extractExerciseId arg >>= findExercise
-   srv  <- findService fun
-   case jsonConverter ex of
-      Some conv ->
-         evalService conv srv arg
-
-jsonConverter :: Some Exercise -> Some (Evaluator JSON JSON)
-jsonConverter (Some ex) =
-   Some (Evaluator (jsonEncoder ex) (jsonDecoder ex))
-
-jsonEncoder :: Exercise a -> Encoder JSON a
-jsonEncoder ex = Encoder
-   { encodeType    = encode (jsonEncoder ex)
-   , encodeCtxTerm = liftM (String . prettyPrinter ex) . fromContext
-   , encodeTerm    = return . String . prettyPrinter ex
-   , encodeTuple   = jsonTuple
-   }
- where
-   encode :: Encoder JSON a -> Type a t -> t -> DomainReasoner JSON
-   encode enc serviceType a
-      | length xs > 1 =
-           liftM jsonTuple (mapM (\(b ::: t) -> encode enc t b) xs)
-      | otherwise =
-           case serviceType of
-              Tp.Tag s t
-                 | s `elem` ["elem", "list"] ->
-                      encode enc t a
-                 | s == "Result" -> do
-                      conv <- equalM serviceType submitType
-                      encodeResult enc (conv a)
-                 | s == "state" -> do
-                      conv <- equalM serviceType stateType
-                      encodeState (encodeTerm enc) (conv a)
-
-              Tp.List t     -> liftM Array (mapM (encode enc t) a)
-              Tp.ArgValueTp -> case a of
-                                  ArgValue descr x -> return $
-                                     Object [(labelArgument descr, String (showArgument descr x))]
-              Tp.Text       -> return (toJSON (show a))
-              Tp.Tag s t    -> liftM (\b -> Object [(s, b)]) (encode enc t a)
-              Tp.Int        -> return (toJSON a)
-              Tp.Bool       -> return (toJSON a)
-              Tp.String     -> return (toJSON a)
-              _             -> encodeDefault enc serviceType a
-    where
-      xs = tupleList (a ::: serviceType)
-
-   tupleList :: TypedValue a -> [TypedValue a]
-   tupleList (a ::: Tp.Iso p t)   = tupleList (to p a ::: t)
-   tupleList (p ::: Tp.Pair t1 t2) =
-      tupleList (fst p ::: t1) ++ tupleList (snd p ::: t2)
-   tupleList (a ::: Tag s t)
-      | s `elem` ["ruletext", "message", "accept"] = tupleList (a ::: t)
-   tupleList tv = [tv]
-
-jsonDecoder :: Exercise a -> Decoder JSON a
-jsonDecoder ex = Decoder
-   { decodeType      = decode (jsonDecoder ex)
-   , decodeTerm      = reader (parser ex)
-   , decoderExercise = ex
-   }
- where
-   reader :: Monad m => (String -> Either String a) -> JSON -> m a
-   reader f (String s) = either (fail . show) return (f s)
-   reader _  _         = fail "Expecting a string when reading a term"
-
-   decode :: Decoder JSON a -> Type a t -> JSON -> DomainReasoner (t, JSON)
-   decode dec serviceType =
-      case serviceType of
-         Tp.Location -> useFirst decodeLocation
-         Tp.Term     -> useFirst $ decodeTerm dec
-         Tp.Rule     -> useFirst $ \x -> jsonToId x >>= getRule (decoderExercise dec)
-         Tp.Exercise -> \json -> case json of
-                                       Array (String _:rest) -> return (decoderExercise dec, Array rest)
-                                       _ -> return (decoderExercise dec, json)
-         Tp.Int      -> useFirst $ \json -> case json of
-                                               Number (I n) -> return (fromIntegral n)
-                                               _        -> fail "not an integer"
-         Tp.String   -> useFirst $ \json -> case json of
-                                               String s -> return s
-                                               _        -> fail "not a string"
-         Tp.Tag s _ | s == "state" -> do
-            f <- equalM stateType serviceType
-            useFirst (liftM f . decodeState (decoderExercise dec) (decodeTerm dec))
-         _ -> decodeDefault dec serviceType
-
-   useFirst :: Monad m => (JSON -> m a) -> JSON -> m (a, JSON)
-   useFirst f (Array (x:xs)) = do
-      a <- f x
-      return (a, Array xs)
-   useFirst _ _ = fail "expecting an argument"
-
-jsonToId :: Monad m => JSON -> m Id
-jsonToId = liftM (newId :: String -> Id) . fromJSON
-
-decodeLocation :: Monad m => JSON -> m [Int]
-decodeLocation (String s) = readM s
-decodeLocation _          = fail "expecting a string for a location"
-
---------------------------
-
-encodeState :: Monad m => (a -> m JSON) -> State a -> m JSON
-encodeState f st = do
-   theTerm <- f (stateTerm st)
-   return $ Array
-      [ String (showId (exercise st))
-      , String (maybe "NoPrefix" show (statePrefix st))
-      , theTerm
-      , encodeContext (getEnvironment (stateContext st))
-      ]
-
-encodeContext :: Environment -> JSON
-encodeContext env = Object (map f (keysEnv env))
- where
-   f k = (k, String $ fromMaybe "" $ lookupEnv k env)
-
-decodeState :: Monad m => Exercise a -> (JSON -> m a) -> JSON -> m (State a)
-decodeState ex f (Array [a]) = decodeState ex f a
-decodeState ex f (Array [String _code, String p, ce, jsonContext]) = do
-   let mpr = readM p >>= (`makePrefix` strategy ex)
-   a    <- f ce
-   env  <- decodeContext jsonContext
-   return $ makeState ex mpr (makeContext ex env a)
-decodeState _ _ s = fail $ "invalid state" ++ show s
-
-decodeContext :: Monad m => JSON -> m Environment
-decodeContext (String "") = decodeContext (Object []) -- Being backwards compatible (for now)
-decodeContext (Object xs) = foldM add emptyEnv xs
- where
-   add env (k, String s) = return (storeEnv k s env)
-   add _ _ = fail "invalid item in context"
-decodeContext json = fail $ "invalid context: " ++ show json
-
-encodeResult :: Encoder JSON a -> Result a -> DomainReasoner JSON
-encodeResult enc result =
-   case result of
-      -- SyntaxError _ -> [("result", String "SyntaxError")]
-      Buggy rs      -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . showId) rs)]
-      NotEquivalent -> return $ Object [("result", String "NotEquivalent")]
-      Ok rs st      -> do
-         json <- encodeType enc stateType st
-         return $ Object [("result", String "Ok"), ("rules", Array $ map (String . showId) rs), ("state", json)]
-      Detour rs st  -> do
-         json <- encodeType enc stateType st
-         return $ Object [("result", String "Detour"), ("rules", Array $ map (String . showId) rs), ("state", json)]
-      Unknown st    -> do
-         json <- encodeType enc stateType st
-         return $ Object [("result", String "Unknown"), ("state", json)]
-
-jsonTuple :: [JSON] -> JSON
-jsonTuple xs =
-   case mapM f xs of
-      Just ys | distinct (map fst ys) -> Object ys
-      _ -> Array xs
- where
-   f (Object [p]) = Just p
-   f _ = Nothing
− src/Service/ModeXML.hs 
@@ -1,335 +0,0 @@-{-# LANGUAGE GADTs #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Services using XML notation
---
------------------------------------------------------------------------------
-module Service.ModeXML
-   ( processXML, xmlRequest, openMathConverterTp, stringFormatConverterTp
-   , resultOk, resultError, addVersion
-   ) where
-
-import Common.Library hiding (exerciseId)
-import Common.Utils (Some(..), readM)
-import Common.Utils.Uniplate (transform)
-import Control.Monad
-import Data.Char
-import Data.List
-import Data.Maybe
-import Service.DomainReasoner
-import Service.Evaluator
-import Service.FeedbackScript.Syntax
-import Service.OpenMathSupport
-import Service.Request
-import Service.RulesInfo (rulesInfoXML)
-import Service.State
-import Service.StrategyInfo
-import Service.Types
-import Text.OpenMath.Object
-import Text.OpenMath.Symbol
-import Text.XML
-import qualified Service.Types as Tp
-
-processXML :: String -> DomainReasoner (Request, String, String)
-processXML input = do
-   xml  <- liftEither (parseXML input)
-   req  <- liftEither (xmlRequest xml)
-   resp <- xmlReply req xml
-              `catchError` (return . resultError)
-   vers <- getVersion
-   let out = showXML (if null vers then resp else addVersion vers resp)
-   return (req, out, "application/xml")
-
-addVersion :: String -> XML -> XML
-addVersion s xml =
-   let info = [ "version" := s ]
-   in xml { attributes = attributes xml ++ info }
-
-xmlRequest :: XML -> Either String Request
-xmlRequest xml = do
-   unless (name xml == "request") $
-      fail "expected xml tag request"
-   srv  <- findAttribute "service" xml
-   let a = extractExerciseId xml
-   enc  <- case findAttribute "encoding" xml of
-              Just s  -> liftM Just (readEncoding s)
-              Nothing -> return Nothing
-   return Request
-      { service    = srv
-      , exerciseId = a
-      , source     = findAttribute "source" xml
-      , dataformat = XML
-      , encoding   = enc
-      }
-
-xmlReply :: Request -> XML -> DomainReasoner XML
-xmlReply request xml = do
-   srv <- findService (service request)
-   ex  <-
-      case exerciseId request of
-         Just code -> findExercise code
-         Nothing
-            | service request == "exerciselist" ->
-                 return (Some emptyExercise)
-            | otherwise ->
-                 fail "unknown exercise code"
-   Some conv <-
-      case encoding request of
-         Just StringEncoding -> return (stringFormatConverter ex)
-         _                   -> return (openMathConverter ex)
-   res <- evalService conv srv xml
-   return (resultOk res)
-
-extractExerciseId :: Monad m => XML -> m Id
-extractExerciseId = liftM newId . findAttribute "exerciseid"
-
-resultOk :: XMLBuilder -> XML
-resultOk body = makeXML "reply" $ do
-   "result" .=. "ok"
-   body
-
-resultError :: String -> XML
-resultError txt = makeXML "reply" $ do
-   "result" .=. "error"
-   element "message" (text txt)
-
-------------------------------------------------------------
--- Mixing abstract syntax (OpenMath format) and concrete syntax (string)
-
-stringFormatConverter :: Some Exercise -> Some (Evaluator XML XMLBuilder)
-stringFormatConverter (Some ex) = Some (stringFormatConverterTp ex)
-
-stringFormatConverterTp :: Exercise a -> Evaluator XML XMLBuilder a
-stringFormatConverterTp ex =
-   Evaluator (xmlEncoder False f ex) (xmlDecoder False g ex)
- where
-   f  = liftM (element "expr" . text . prettyPrinter ex) . fromContext
-   g xml0 = do
-      xml <- findChild "expr" xml0 -- quick fix
-      -- guard (name xml == "expr")
-      let input = getData xml
-      either (fail . show) return (parser ex input)
-
-openMathConverter :: Some Exercise -> Some (Evaluator XML XMLBuilder)
-openMathConverter (Some ex) = Some (openMathConverterTp ex)
-
-openMathConverterTp :: Exercise a -> Evaluator XML XMLBuilder a
-openMathConverterTp ex =
-   Evaluator (xmlEncoder True f ex) (xmlDecoder True g ex)
- where
-   f ctx = liftM (builder . toXML) $
-      case changeT (return . markFocus) ctx >>= leaveT of
-         Just term | useFocus ->
-            return (toOMOBJ (term :: Term))
-         _ ->
-            fromContext ctx >>= toOpenMath ex
-   g xml = do
-      xob   <- findChild "OMOBJ" xml
-      omobj <- liftEither (xml2omobj xob)
-      case fromOpenMath ex (if useFocus then transform noFocus omobj else omobj) of
-         Just a  -> return a
-         Nothing -> fail "Invalid OpenMath object for this exercise"
-
-   markFocus :: Term -> Term
-   markFocus = unary (newSymbol focusSymbol)
-
-   noFocus :: OMOBJ -> OMOBJ
-   noFocus (OMA [OMS s, x]) | s == focusSymbol = x
-   noFocus a = a
-
-   focusSymbol = makeSymbol "ideas" "focus"
-   useFocus = False
-
-xmlEncoder :: Bool -> (Context a -> DomainReasoner XMLBuilder) -> Exercise a -> Encoder XMLBuilder a
-xmlEncoder isOM f ex = Encoder
-   { encodeType    = xmlEncodeType isOM (xmlEncoder isOM f ex) ex
-   , encodeCtxTerm = f
-   , encodeTerm    = f . inContext ex -- (not so nice)
-   , encodeTuple   = sequence_
-   }
-
-xmlEncodeType :: Bool -> Encoder XMLBuilder a -> Exercise a -> Type a t -> t -> DomainReasoner XMLBuilder
-xmlEncodeType b enc ex serviceType =
-   case serviceType of
-      Tp.Tag s t1
-         | s == "RulesInfo" -> \_ ->
-              rulesInfoXML ex (encodeTerm enc)
-         | otherwise ->
-              case useAttribute t1 of
-                 Just f | s /= "message" -> return . (s .=.) . f
-                 _  -> liftM (element s) . xmlEncodeType b enc ex t1
-      Tp.Strategy   -> return . builder . strategyToXML
-      Tp.Rule       -> return . ("ruleid" .=.) . showId
-      Tp.Term       -> encodeTerm enc
-      Tp.Context    -> encodeContext b (encodeCtxTerm enc)
-      Tp.Location   -> return . ("location" .=.) . show
-      Tp.ArgValueTp -> return . encodeArgValue b
-      Tp.Text       -> encodeText enc ex
-      Tp.Bool       -> return . text . map toLower . show
-      Tp.String     -> return . text
-      _             -> encodeDefault enc serviceType
-
-xmlDecoder :: Bool -> (XML -> DomainReasoner a) -> Exercise a -> Decoder XML a
-xmlDecoder b f ex = Decoder
-   { decodeType      = xmlDecodeType b (xmlDecoder b f ex)
-   , decodeTerm      = f
-   , decoderExercise = ex
-   }
-
-xmlDecodeType :: Bool -> Decoder XML a -> Type a t -> XML -> DomainReasoner (t, XML)
-xmlDecodeType b dec serviceType =
-   case serviceType of
-      Tp.Context     -> keep $ decodeContext b (decoderExercise dec) (decodeTerm dec)
-      Tp.Location    -> keep $ liftM (read . getData) . findChild "location"
-      Tp.Id          -> keep $ \xml -> do
-                           a <- findChild "location" xml
-                           return (newId (getData a))
-      Tp.Rule        -> keep $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . newId . getData) . findChild "ruleid"
-      Tp.Term        -> keep $ decodeTerm dec
-      Tp.StrategyCfg -> keep decodeConfiguration
-      Tp.Script      -> keep $ \xml ->
-                           case findAttribute "script" xml of
-                              Just s  -> readScript s
-                              Nothing ->
-                                 defaultScript (getId (decoderExercise dec))
-      Tp.Tag s t
-         | s == "state" -> keep $ \xml -> do
-              g  <- equalM stateType serviceType
-              st <- decodeState b (decoderExercise dec) (decodeTerm dec) xml
-              return (g st)
-         | s == "answer" -> keep $ \xml -> do
-              c <- findChild "answer" xml
-              (a, _) <- xmlDecodeType b dec t c
-              return a
-         | s == "difficulty" -> keep $ \xml -> do
-              g <- equalM difficultyType serviceType
-              a <- findAttribute "difficulty" xml
-              maybe (fail "unknown difficulty level") (return . g) (readDifficulty a)
-         {- s == "prefix" -> \xml -> do
-              f  <- equalM String t
-              mp <- decodePrefix (decoderExercise dec) xml
-              s  <- maybe (fail "no prefix") (return . show) mp
-              return (f s, xml) -}
-         | otherwise -> keep $ \xml ->
-              findChild s xml >>= liftM fst . xmlDecodeType b dec t
-
-      _ -> decodeDefault dec serviceType
- where
-   keep :: Monad m => (XML -> m a) -> XML -> m (a, XML)
-   keep f xml = liftM (\a -> (a, xml)) (f xml)
-
-useAttribute :: Type a t -> Maybe (t -> String)
-useAttribute String = Just id
-useAttribute Bool   = Just (map toLower . show)
-useAttribute _      = Nothing
-
-decodeState :: Monad m => Bool -> Exercise a -> (XML -> m a) -> XML -> m (State a)
-decodeState b ex f xmlTop = do
-   xml  <- findChild "state" xmlTop
-   mpr  <- decodePrefix ex xml
-   term <- decodeContext b ex f xml
-   return (makeState ex mpr term)
-
-decodePrefix :: Monad m => Exercise a -> XML -> m (Maybe (Prefix (Context a)))
-decodePrefix ex xml
-   | all isSpace prefixText =
-        return (Just (emptyPrefix str))
-   | prefixText ~= "no prefix" =
-        return Nothing
-   | otherwise = do
-        a  <- readM prefixText
-        pr <- makePrefix a str
-        return (Just pr)
- where
-   prefixText = maybe "" getData (findChild "prefix" xml)
-   str = strategy ex
-   a ~= b = g a == g b
-   g = map toLower . filter (not . isSpace)
-
-decodeContext :: Monad m => Bool -> Exercise a -> (XML -> m a) -> XML -> m (Context a)
-decodeContext b ex f xml = do
-   expr <- f xml
-   env  <- decodeEnvironment b xml
-   return (makeContext ex env expr)
-
-decodeEnvironment :: Monad m => Bool -> XML -> m Environment
-decodeEnvironment b xml =
-   case findChild "context" xml of
-      Just this -> foldM add emptyEnv (children this)
-      Nothing   -> return emptyEnv
- where
-   add env item = do
-      unless (name item == "item") $
-         fail $ "expecting item tag, found " ++ name item
-      n  <- findAttribute "name"  item
-      case findChild "OMOBJ" item of
-         -- OpenMath object found inside item tag
-         Just this | b ->
-            case xml2omobj this >>= fromOMOBJ of
-               Left err -> fail err
-               Right term ->
-                  return (storeEnv n (term :: Term) env)
-         -- Simple value in attribute
-         _ -> do
-            value <- findAttribute "value" item
-            return (storeEnv n value env)
-
-decodeConfiguration :: MonadPlus m => XML -> m StrategyConfiguration
-decodeConfiguration xml =
-   case findChild "configuration" xml of
-      Just this -> mapM decodeAction (children this)
-      Nothing   -> fail "no strategy configuration"
- where
-   decodeAction item = do
-      guard (null (children item))
-      action <-
-         case find (\a -> map toLower (show a) == name item) configActions of
-            Just a  -> return a
-            Nothing -> fail $ "unknown action " ++ show (name item)
-      cfgloc <- findAttribute "name" item
-      return (byName (newId cfgloc), action)
-
-encodeEnvironment :: Bool -> Location -> Environment -> XMLBuilder
-encodeEnvironment b loc env0
-   | nullEnv env = return ()
-   | otherwise   = element "context" $
-        forM_ (keysEnv env) $ \k ->
-           element "item" $ do
-              "name"  .=. k
-              case lookupEnv k env of
-                 Just term | b -> builder (omobj2xml (toOMOBJ (term :: Term)))
-                 _             -> "value" .=. fromMaybe "" (lookupEnv k env)
- where
-   env | null loc  = env0
-       | otherwise = storeEnv "location" loc env0
-
-encodeContext :: Monad m => Bool -> (Context a -> m XMLBuilder) -> Context a -> m XMLBuilder
-encodeContext b f ctx = do
-   xml <- f ctx
-   return (xml >> encodeEnvironment b (location ctx) (getEnvironment ctx))
-
-encodeArgValue :: Bool -> ArgValue -> XMLBuilder
-encodeArgValue b (ArgValue descr a) = element "argument" $ do
-   "description" .=. labelArgument descr
-   showValue a
- where
-   showValue
-      | b         = builder . omobj2xml . toOMOBJ . build (termViewArgument descr)
-      | otherwise = text . showArgument descr
-
-encodeText :: Encoder s a -> Exercise a -> Text -> DomainReasoner s
-encodeText enc ex = liftM (encodeTuple enc) . mapM f . textItems
- where
-   f (TextTerm a) = fromMaybe (encodeAsString enc a) $ do
-      v <- hasTermView ex
-      b <- match v a
-      return (encodeTerm enc b)
-   f a = encodeAsString enc a
− src/Service/OpenMathSupport.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE Rank2Types #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.OpenMathSupport
-   ( -- * Conversion functions to/from OpenMath
-     toOpenMath, fromOpenMath
-   , toOMOBJ, fromOMOBJ
-   ) where
-
-import Common.Library
-import Control.Monad
-import Data.Char
-import Data.List
-import Text.OpenMath.Dictionary.Arith1
-import Text.OpenMath.Dictionary.Fns1
-import Text.OpenMath.Object
-import qualified Text.OpenMath.Symbol as OM
-
------------------------------------------------------------------------------
--- Utility functions for conversion to/from OpenMath
-
-toOpenMath :: Monad m => Exercise a -> a -> m OMOBJ
-toOpenMath ex a = do
-   v <- hasTermViewM ex
-   return (toOMOBJ (build v a))
-
-fromOpenMath :: MonadPlus m => Exercise a -> OMOBJ -> m a
-fromOpenMath ex omobj = do
-   v <- hasTermViewM ex
-   a <- fromOMOBJ omobj
-   matchM v a
-
-toOMOBJ :: IsTerm a => a -> OMOBJ
-toOMOBJ = rec . toTerm
- where
-   rec term =
-      case term of
-         TVar s    -> OMV s
-         TCon s    -> OMS (idToSymbol (getId s))
-         TMeta i   -> OMV ('$' : show i)
-         TNum n    -> OMI n
-         TFloat d  -> OMF d
-         TApp _ _  -> let (f, xs) = getSpine term
-                      in make (map rec (f:xs))
-
-   make [OMS s, OMV x, body] | s == lambdaSymbol =
-      OMBIND (OMS s) [x] body
-   make [OMS s, a, b, c] | s == mfSymbol = -- special for mixed fraction symbol
-      OMA [OMS plusSymbol, a, OMA [OMS divideSymbol, b, c]]
-   make xs = OMA xs
-
-fromOMOBJ :: (MonadPlus m, IsTerm a) => OMOBJ -> m a
-fromOMOBJ = (>>= fromTerm) . rec
- where
-   rec omobj =
-      case omobj of
-         OMV x -> case isMeta x of
-                     Just n  -> return (TMeta n)
-                     Nothing -> return (TVar x)
-         OMS s -> return (symbol (newSymbol (OM.dictionary s # OM.symbolName s)))
-         OMI n -> return (TNum n)
-         OMF a -> return (TFloat a)
-         OMA (x:xs) -> liftM2 makeTerm (rec x) (mapM rec xs)
-         OMBIND binder xs body ->
-            rec (OMA (binder:map OMV xs++[body]))
-         _ -> fail "Invalid OpenMath object"
-
-   isMeta ('$':xs) = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- '
-   isMeta _        = Nothing
-
-idToSymbol :: Id -> OM.Symbol
-idToSymbol a
-   | null (qualifiers a) =
-        OM.extraSymbol (unqualified a)
-   | otherwise =
-        OM.makeSymbol (qualification a) (unqualified a)
-
-hasTermViewM  :: Monad m => Exercise a -> m (View Term a)
-hasTermViewM = maybe (fail "No support for terms") return . hasTermView
-
-mfSymbol :: OM.Symbol
-mfSymbol = OM.makeSymbol "extra" "mixedfraction"
− src/Service/ProblemDecomposition.hs 
@@ -1,132 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.ProblemDecomposition
-   ( problemDecomposition, replyType
-   ) where
-
-import Common.Library
-import Common.Utils
-import Data.Maybe
-import Service.State
-import Service.Types
-
-problemDecomposition :: Maybe Id -> State a -> Maybe a -> Either String (Reply a)
-problemDecomposition msloc state answer
-   | isNothing $ subStrategy sloc (strategy ex) =
-        Left "request error: invalid location for strategy"
-   | otherwise =
-   let pr = fromMaybe (emptyPrefix $ strategy ex) (statePrefix state) in
-         case (runPrefixLocation sloc pr requestedTerm, fmap (inContext ex) answer) of
-            ([], _) -> Left "strategy error: not able to compute an expected answer"
-            (answers, Just answeredTerm)
-               | not (null witnesses) -> Right $
-                    Ok newLocation newState
-                  where
-                    witnesses   = filter (similarity ex answeredTerm . fst) $ take 1 answers
-                    (newCtx, newPrefix) = head witnesses
-                    newLocation = nextTaskLocation (strategy ex) sloc $
-                                     fromMaybe topId $ nextMajorForPrefix newPrefix newCtx
-                    newState    = makeState ex (Just newPrefix) newCtx
-            ((expected, pref):_, maybeAnswer) -> Right $
-                    Incorrect isEquiv newLocation expState arguments
-             where
-               newLocation = subTaskLocation (strategy ex) sloc loc
-               expState = makeState ex (Just pref) expected
-               isEquiv  = maybe False (equivalence ex expected) maybeAnswer
-               (loc, arguments) = fromMaybe (topId, []) $
-                                     firstMajorInPrefix pr pref requestedTerm
- where
-   ex    = exercise state
-   topId = getId (strategy ex)
-   sloc  = fromMaybe topId msloc
-   requestedTerm = stateContext state
-
--- | Continue with a prefix until a certain strategy location is reached. At least one
--- major rule should have been executed
-runPrefixLocation :: Id -> Prefix a -> a -> [(a, Prefix a)]
-runPrefixLocation loc p0 =
-   concatMap (checkPair . f) . derivations .
-   cutOnStep (stop . lastStepInPrefix) . prefixTree p0
- where
-   f d = (lastTerm d, fromMaybe p0 (lastStep d))
-   stop (Just (Exit info)) = getId info == loc
-   stop _ = False
-
-   checkPair result@(a, p)
-      | null rules            = [result]
-      | all isMinorRule rules = runPrefixLocation loc p a
-      | otherwise             = [result]
-    where
-      rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p
-
-firstMajorInPrefix :: Prefix a -> Prefix a -> a -> Maybe (Id, ArgValues)
-firstMajorInPrefix p0 p a = do
-   let newSteps = drop (length $ prefixToSteps p0) (prefixToSteps p)
-   is <- firstLocation newSteps
-   return (is, argumentsForSteps a newSteps)
- where
-   firstLocation :: HasId l => [Step l a] -> Maybe Id
-   firstLocation [] = Nothing
-   firstLocation (Enter info:RuleStep r:_) | isMajorRule r = Just (getId info)
-   firstLocation (_:rest) = firstLocation rest
-
-argumentsForSteps :: a -> [Step l a] -> ArgValues
-argumentsForSteps a0 = flip rec a0 . stepsToRules
- where
-   rec [] _ = []
-   rec (r:rs) a
-      | isMinorRule r  = concatMap (rec rs) (applyAll r a)
-      | applicable r a = fromMaybe [] (expectedArguments r a)
-      | otherwise      = []
-
-nextMajorForPrefix :: Prefix a -> a -> Maybe Id
-nextMajorForPrefix p0 a = do
-   (_, p1)  <- safeHead $ runPrefixMajor p0 a
-   rec (reverse (prefixToSteps p1))
- where
-   rec [] = Nothing
-   rec (Enter info:_) = Just (getId info)
-   rec (Exit  info:_) = Just (getId info)
-   rec (_:rest)       = rec rest
-
--- Copied from TypedAbstractService: clean me up
-runPrefixMajor :: Prefix a -> a -> [(a, Prefix a)]
-runPrefixMajor p0 =
-   map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree p0
- where
-   f d = (lastTerm d, fromMaybe p0 (lastStep d))
-   stop (Just (RuleStep r)) = isMajorRule r
-   stop _ = False
-
-------------------------------------------------------------------------
--- Data types for replies
-
-data Reply a = Ok Id (State a)
-             | Incorrect Bool Id (State a) ArgValues
-
-------------------------------------------------------------------------
--- Type definition
-
-replyType :: Type a (Reply a)
-replyType = Iso (f <-> g) tp
- where
-   f (Left (a, b))        = Ok a b
-   f (Right (a, b, c, d)) = Incorrect a b c d
-
-   g (Ok a b)            = Left (a, b)
-   g (Incorrect a b c d) = Right (a, b, c, d)
-
-   tp  =  Tag "correct"   (tuple2 locType stateType)
-      :|: Tag "incorrect" (tuple4 (Tag "equivalent" Bool) locType stateType argsType)
-
-   locType  = Tag "location" Id
-   argsType = List ArgValueTp
− src/Service/Request.hs 
@@ -1,43 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.Request where
-
-import Common.Library hiding (exerciseId)
-import Data.Char
-
-data Request = Request
-   { service    :: String
-   , exerciseId :: Maybe Id
-   , source     :: Maybe String
-   , dataformat :: DataFormat
-   , encoding   :: Maybe Encoding
-   }
-
-data DataFormat = XML | JSON
-   deriving Show -- needed for LoggingDatabase
-
-data Encoding = OpenMath | StringEncoding
-   deriving Show -- needed for LoggingDatabase
-
-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 xs =
-   case map toLower xs of
-      "openmath" -> return OpenMath
-      "string"   -> return StringEncoding
-      _          -> fail $ "Invalid encoding: " ++ xs
− src/Service/RulesInfo.hs 
@@ -1,81 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.RulesInfo
-   ( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap, rulesInfoType
-   ) where
-
-import Common.Library
-import Common.Utils (Some(..))
-import Control.Monad
-import Data.Char
-import Service.OpenMathSupport (toOMOBJ)
-import Service.Types
-import Text.OpenMath.FMP
-import Text.OpenMath.Object
-import Text.XML hiding (name)
-import qualified Data.Map as M
-
-rulesInfoXML :: Monad m => Exercise a -> (a -> m XMLBuilder) -> m XMLBuilder
-rulesInfoXML ex enc = combine $ forM (ruleset ex) $ \r -> do
-
-   let pairs = M.findWithDefault [] (getId r) exampleMap
-   xs <- forM (take 3 pairs) $ \(a, b) ->
-            liftM2 (,) (enc a) (enc b)
-
-   return $ element "rule" $ do
-      "name"        .=. showId r
-      "buggy"       .=. f (isBuggyRule r)
-      "rewriterule" .=. f (isRewriteRule r)
-      -- More information
-      let descr = description r
-          -- to do: rules should carry descriptions
-          txt   = if null descr then showId r else descr
-      unless (null txt) $
-         element "description" $ text txt
-      forM_ (ruleSiblings r) $ \s ->
-         element "sibling" $ text $ showId s
-      -- FMPs and CMPs
-      forM_ (getRewriteRules r) $ \(Some rr, b) -> do
-         let fmp = rewriteRuleToFMP b rr
-         case showRewriteRule b rr of
-            Nothing -> return ()
-            Just s  -> element "CMP" (text s)
-         element "FMP" $
-            builder (omobj2xml (toObject fmp))
-      -- Examples
-      forM_ xs $ \(a, b) ->
-         element "example" (a >> b)
- where
-   f          = map toLower . show
-   exampleMap = collectExamples ex
-   combine    = liftM sequence_
-
-rewriteRuleToFMP :: Bool -> RewriteRule a -> FMP
-rewriteRuleToFMP sound r
-   | sound     = eqFMP    a b
-   | otherwise = buggyFMP a b
- where
-   a :~> b = fmap toOMOBJ (ruleSpecTerm r)
-
-type ExampleMap a = M.Map Id [(a, a)]
-
-collectExamples :: Exercise a -> ExampleMap a
-collectExamples ex = foldr (add . snd) M.empty (examples ex)
- where
-   add a m = let tree = derivationTree (strategy ex) (inContext ex a)
-                 f Nothing = m
-                 f (Just d) = foldr g m (triples d)
-                 g (x, r, y) = M.insertWith (++) (getId r) (liftM2 (,) (fromContext x) (fromContext y))
-             in f (derivation tree)
-
-rulesInfoType :: Type a ()
-rulesInfoType = Tag "RulesInfo" Unit
− src/Service/ServiceList.hs 
@@ -1,237 +0,0 @@-{-# LANGUAGE RankNTypes #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.ServiceList (serviceList, exerciselistS) where
-
-import Common.Library hiding (apply, applicable, derivation, ready)
-import Common.Utils (Some(..))
-import Data.List (sortBy)
-import Data.Ord
-import Service.BasicServices
-import Service.FeedbackScript.Syntax
-import Service.FeedbackText
-import Service.ProblemDecomposition (problemDecomposition, replyType)
-import Service.RulesInfo
-import Service.State
-import Service.Types
-import qualified Service.Diagnose as Diagnose
-import qualified Service.Submit as Submit
-
-------------------------------------------------------
--- Querying a service
-
-serviceList :: [Service]
-serviceList =
-   [ derivationS, allfirstsS, onefirstS, readyS
-   , stepsremainingS, applicableS, allapplicationsS
-   , applyS, generateS
-   , examplesS, submitS, diagnoseS
-   , onefirsttextS, findbuggyrulesS
-   , submittextS, derivationtextS
-   , feedbacktextS
-   , problemdecompositionS
-   , rulelistS, rulesinfoS, strategyinfoS
-   ]
-
-------------------------------------------------------
--- Basic services
-
-derivationS :: Service
-derivationS = makeService "derivation"
-   "Returns one possible derivation (or: worked-out example) starting with the \
-   \current expression. The first optional argument lets you configure the \
-   \strategy, i.e., make some minor modifications to it. Rules used and \
-   \intermediate expressions are returned in a list." $
-   -- derivationTemp ::: maybeType StrategyCfg :-> stateType :-> errorType (derivationType Rule Context)
-   derivation ::: maybeType StrategyCfg :-> stateType :-> errorType (derivationType (tuple2 Rule (List ArgValueTp)) Context)
-
-allfirstsS :: Service
-allfirstsS = makeService "allfirsts"
-   "Returns all next steps that are suggested by the strategy. See the \
-   \onefirst service to get only one suggestion. For each suggestion, a new \
-   \state, the rule used, and the location where the rule was applied are \
-   \returned." $
-   allfirsts ::: stateType :-> errorType (listType (tuple4 Rule Location (List ArgValueTp) stateType))
-
-onefirstS :: Service
-onefirstS = makeService "onefirst"
-   "Returns a possible next step according to the strategy. Use the allfirsts \
-   \service to get all possible steps that are allowed by the strategy. In \
-   \addition to a new state, the rule used and the location where to apply \
-   \this rule are returned." $
-   onefirst ::: stateType :-> elemType (errorType (tuple4 Rule Location (List ArgValueTp) stateType))
-
-readyS :: Service
-readyS = makeService "ready"
-   "Test if the current expression is in a form accepted as a final answer. \
-   \For this, the strategy is not used." $
-   ready ::: stateType :-> Bool
-
-stepsremainingS :: Service
-stepsremainingS = makeService "stepsremaining"
-   "Computes how many steps are remaining to be done, according to the \
-   \strategy. For this, only the first derivation is considered, which \
-   \corresponds to the one returned by the derivation service." $
-   stepsremaining ::: stateType :-> errorType Int
-
-applicableS :: Service
-applicableS = makeService "applicable"
-   "Given a current expression and a location in this expression, this service \
-   \yields all rules that can be applied at this location, regardless of the \
-   \strategy." $
-   applicable ::: Location :-> stateType :-> listType Rule
-
-allapplicationsS :: Service
-allapplicationsS = makeService "allapplications"
-   "Given a current expression, this service yields all rules that can be \
-   \applied at a certain location, regardless wether the rule used is buggy \
-   \or not. Some results are within the strategy, others are not." $
-   allapplications ::: stateType :-> listType (tuple3 Rule Location stateType)
-
-applyS :: Service
-applyS = makeService "apply"
-   "Apply a rule at a certain location to the current expression. If this rule \
-   \was not expected by the strategy, we deviate from it. If the rule cannot \
-   \be applied, this service call results in an error." $
-   apply ::: Rule :-> Location :-> stateType :-> errorType stateType
-
-generateS :: Service
-generateS = makeService "generate"
-   "Given an exercise code and a difficulty level (optional), this service \
-   \returns an initial state with a freshly generated expression." $
-   generate ::: StdGen :-> Exercise :-> optionType Medium difficultyType :-> stateType
-
-examplesS :: Service
-examplesS = makeService "examples"
-   "This services returns a list of example expresssions that can be solved \
-   \with an exercise. These are the examples that appear at the page generated \
-   \for each exercise. Also see the generate service, which returns a random \
-   \start term." $
-   (map snd . examples) ::: Exercise :-> listType Term
-
-findbuggyrulesS :: Service
-findbuggyrulesS = makeService "findbuggyrules"
-   "Search for common misconceptions (buggy rules) in an expression (compared \
-   \to the current state). It is assumed that the expression is indeed not \
-   \correct. This service has been superseded by the diagnose service." $
-   findbuggyrules ::: stateType :-> Term :-> listType (tuple3 Rule Location (List ArgValueTp))
-
-submitS :: Service
-submitS = deprecate $ makeService "submit"
-   "Analyze an expression submitted by a student. Possible answers are Buggy, \
-   \NotEquivalent, Ok, Detour, and Unknown. This service has been superseded \
-   \by the diagnose service." $
-   Submit.submit ::: stateType :-> Term :-> Submit.submitType
-
-diagnoseS :: Service
-diagnoseS = makeService "diagnose"
-   "Diagnose an expression submitted by a student. Possible diagnosis are \
-   \Buggy (a common misconception was detected), NotEquivalent (something is \
-   \wrong, but we don't know what), Similar (the expression is pretty similar \
-   \to the last expression in the derivation), Expected (the submitted \
-   \expression was anticipated by the strategy), Detour (the submitted \
-   \expression was not expected by the strategy, but the applied rule was \
-   \detected), and Correct (it is correct, but we don't know which rule was \
-   \applied)." $
-   Diagnose.diagnose ::: stateType :-> Term :-> Diagnose.diagnosisType
-
-------------------------------------------------------
--- Services with a feedback component
-
-onefirsttextS :: Service
-onefirsttextS = makeService "onefirsttext"
-   "Similar to the onefirst service, except that the result is now returned as \
-   \a formatted text message. The optional string is for announcing the event \
-   \leading to this service call (which can influence the returned result)." $
-   onefirsttext ::: Script :-> stateType :-> maybeType String
-                :-> tuple2 (messageType Text) (maybeType stateType)
-
-derivationtextS :: Service
-derivationtextS = makeService "derivationtext"
-   "Similar to the derivation service, but the rules appearing in the derivation \
-   \have been replaced by a short description of the rule." $
-   derivationtext ::: Script :-> stateType :-> errorType (derivationType (Tag "ruletext" String) Context)
-
-submittextS :: Service
-submittextS = deprecate $ makeService "submittext"
-   "Similar to the submit service, except that the result is now returned as \
-   \a formatted text message. The expression 'submitted' by the student is sent \
-   \in plain text (and parsed by the exercise's parser). \
-   \The boolean in the \
-   \result specifies whether the submitted term is accepted and incorporated \
-   \in the new state." $
-   submittext ::: Script :-> stateType :-> String :-> messageAndState
-
-feedbacktextS :: Service
-feedbacktextS = makeService "feedbacktext"
-   "Textual feedback for diagnose service. Experimental." $
-   feedbacktext ::: Script :-> stateType :-> Term :-> messageAndState
-
--- Helper type for submittext and feedbacktext: reorders elements, and inserts
--- some extra tags
-messageAndState :: Type a (Bool, Text, State a)
-messageAndState = Iso (f <-> g) tp
- where
-   f ((a, b), c) = (a, b, c)
-   g (a, b, c)   = ((a, b), c)
-   tp  = tuple2 (messageType (tuple2 (Tag "accept" Bool) Text)) stateType
-
-------------------------------------------------------
--- Problem decomposition service
-
-problemdecompositionS :: Service
-problemdecompositionS = makeService "problemdecomposition"
-   "Strategy service developed for the SURF project Intelligent Feedback for a \
-   \binding with the MathDox system on linear algebra exercises. This is a \
-   \composite service, and available for backwards compatibility." $
-   problemDecomposition ::: maybeType Id  :-> stateType :-> maybeType (Tag "answer" Term) :-> errorType replyType
-
-------------------------------------------------------
--- Reflective services
-
-exerciselistS :: [Some Exercise] -> Service
-exerciselistS list = makeService "exerciselist"
-   "Returns all exercises known to the system. For each exercise, its domain, \
-   \identifier, a short description, and its current status are returned." $
-   allExercises list ::: listType (tuple3 (Tag "exerciseid" String) (Tag "description" String) (Tag "status" String))
-
-rulelistS :: Service
-rulelistS = makeService "rulelist"
-   "Returns all rules of a particular exercise. For each rule, we return its \
-   \name (or identifier), whether the rule is buggy, and whether the rule was \
-   \expressed as an observable rewrite rule. See rulesinfo for more details \
-   \about the rules." $
-   allRules ::: Exercise :-> listType (tuple3 (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool))
-
-rulesinfoS :: Service
-rulesinfoS = makeService "rulesinfo"
-   "Returns a list of all rules of a particular exercise, with many details \
-   \including Formal Mathematical Properties (FMPs) and example applications." $
-   () ::: rulesInfoType
-
-strategyinfoS :: Service
-strategyinfoS = makeService "strategyinfo"
-   "Returns the representation of the strategy of a particular exercise." $
-   (toStrategy . strategy) ::: Exercise :-> Strategy
-
-allExercises :: [Some Exercise] -> [(String, String, String)]
-allExercises = map make . sortBy (comparing f)
- where
-   f :: Some Exercise -> String
-   f (Some ex) = showId ex
-   make (Some ex) =
-      (showId ex, description ex, show (status ex))
-
-allRules :: Exercise a -> [(String, Bool, Bool)]
-allRules = map make . ruleset
- where
-   make r  = (showId r, isBuggyRule r, isRewriteRule r)
− src/Service/State.hs 
@@ -1,80 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- The information maintained for a learner trying to complete a
--- derivation.
---
------------------------------------------------------------------------------
-module Service.State
-   ( -- * Exercise state
-     State, makeState, empyStateContext, emptyState
-   , exercise, statePrefix, stateContext, stateTerm
-     -- * Types
-   , stateType
-   ) where
-
-import Common.Library
-import Common.Utils (readM)
-import Data.Maybe
-import Service.Types
-
-data State a = State
-   { exercise     :: Exercise a
-   , statePrefix  :: Maybe (Prefix (Context a))
-   , stateContext :: Context a
-   }
-
-instance Show (State a) where
-   show s = unlines $ "State {" : map ("   "++) xs ++ ["}"]
-    where
-      xs = [ "exercise = " ++ showId s
-           , "prefix   = " ++ maybe "no prefix" show (statePrefix s)
-           , "steps    = " ++ maybe "no prefix" (show . prefixToSteps) (statePrefix s)
-           , "term     = " ++ prettyPrinterContext (exercise s) (stateContext s)
-           ]
-
-instance HasId (State a) where
-   getId = getId . exercise
-   changeId f s = s { exercise = changeId f (exercise s) }
-
-stateTerm :: State a -> a
-stateTerm = fromMaybe (error "invalid term") . fromContext . stateContext
-
------------------------------------------------------------
-
-makeState :: Exercise a -> Maybe (Prefix (Context a)) -> Context a -> State a
-makeState = State
-
-empyStateContext :: Exercise a -> Context a -> State a
-empyStateContext ex = makeState ex (Just pr)
- where
-   pr = emptyPrefix (strategy ex)
-
-emptyState :: Exercise a -> a -> State a
-emptyState ex = empyStateContext ex . inContext ex
-
---------------------------------------------------------------
-
-stateType :: Type a (State a)
-stateType = Tag "state" (Iso (f <-> g) tp)
- where
-   f (ex, mp, ctx) =
-      let str = strategy ex
-          h   = fromMaybe [] . readM
-      in makeState ex (mp >>= flip makePrefix str . h) ctx
-   g st =
-      ( exercise st
-      , fmap show (statePrefix st)
-      , stateContext st
-      )
-   tp = tuple3 Exercise prefixType Context
-
-   -- iso prevents that prefix is turned into an (XML) attribute
-   prefixType = maybeType (Tag "prefix" (Iso identity String))
− src/Service/StrategyInfo.hs 
@@ -1,177 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Converting a strategy to XML, and the other way around.
---
------------------------------------------------------------------------------
-module Service.StrategyInfo (strategyToXML, xmlToStrategy) where
-
-import Common.Library
-import Common.Strategy.Abstract
-import Common.Strategy.Core
-import Common.Utils (readInt)
-import Control.Monad
-import Data.Char
-import Data.Maybe
-import Text.XML
-
------------------------------------------------------------------------
--- Strategy to XML
-
-strategyToXML :: IsStrategy f => f a -> XML
-strategyToXML = coreToXML . toCore . toStrategy
-
-infoToXML :: LabelInfo -> XMLBuilder
-infoToXML info = do
-   "name" .=. showId info
-   when (removed   info) ("removed"   .=. "true")
-   when (collapsed info) ("collapsed" .=. "true")
-   when (hidden    info) ("hidden"    .=. "true")
-
-coreToXML :: Core LabelInfo a -> XML
-coreToXML core = makeXML "label" $
-   case core of
-      Label l a -> infoToXML l >> coreBuilder infoToXML a
-      _         -> coreBuilder infoToXML core
-
-coreBuilder :: HasId l => (l -> XMLBuilder) -> Core l a -> XMLBuilder
-coreBuilder f = rec
- where
-   rec core =
-      case core of
-         _ :*:  _  -> asList  "sequence"   isSequence
-         _ :|:  _  -> asList  "choice"     isChoice
-         _ :|>: _  -> asList  "orelse"     isOrElse
-         _ :%: _   -> asList  "interleave" isInterleave
-         a :!%: b  -> element "interleft"  (rec a >> rec b)
-         Many a    -> element "many"     (rec a)
-         Repeat a  -> element "repeat"   (rec a)
-         Label l (Rule r) | getId l == getId r -> element "rule"     (f l)
-         Label l a -> element "label"    (f l >> rec a)
-         Atomic a  -> element "atomic"   (rec a)
-         Rec n a   -> element "rec"      (("var" .=. show n) >> rec a)
-         Not a     -> element "not"      (recNot a)
-         Rule r    -> element "rule"     ("name" .=. show r)
-         Var n     -> element "var"      ("var" .=. show n)
-         Succeed   -> tag     "succeed"
-         Fail      -> tag     "fail"
-    where
-      asList s g = element s (mapM_ rec (collect g core))
-      recNot = coreBuilder (const (return ()))
-
-collect :: (a -> Maybe (a, a)) -> a -> [a]
-collect f = ($ []) . rec
- where rec a = maybe (a:) (\(x, y) -> rec x . rec y) (f a)
-
-isSequence :: Core l a -> Maybe (Core l a, Core l a)
-isSequence (a :*: b) = Just (a, b)
-isSequence _ = Nothing
-
-isChoice :: Core l a -> Maybe (Core l a, Core l a)
-isChoice (a :|: b) = Just (a, b)
-isChoice _ = Nothing
-
-isOrElse :: Core l a -> Maybe (Core l a, Core l a)
-isOrElse (a :|>: b) = Just (a, b)
-isOrElse _ = Nothing
-
-isInterleave :: Core l a -> Maybe (Core l a, Core l a)
-isInterleave (a :%: b) = Just (a, b)
-isInterleave _ = Nothing
-
------------------------------------------------------------------------
--- XML to strategy
-
-xmlToStrategy :: Monad m => (String -> Maybe (Rule a)) ->  XML -> m (Strategy a)
-xmlToStrategy f = liftM fromCore . readStrategy xmlToInfo g
- where
-   g info = case f (showId info) of
-               Just r  -> return r
-               Nothing -> fail $ "Unknown rule: " ++ showId info
-
-xmlToInfo :: Monad m => XML -> m LabelInfo
-xmlToInfo xml = do
-   n <- findAttribute "name" xml
-   let boolAttr s = fromMaybe False (findBool s xml)
-   return (makeInfo n)
-      { removed   = boolAttr "removed"
-      , collapsed = boolAttr "collapsed"
-      , hidden    = boolAttr "hidden"
-      }
-
-findBool :: Monad m => String -> XML -> m Bool
-findBool attr xml = do
-   s <- findAttribute attr xml
-   case map toLower s of
-      "true"  -> return True
-      "false" -> return False
-      _       -> fail "not a boolean"
-
-readStrategy :: Monad m => (XML -> m l) -> (l -> m (Rule a)) -> XML -> m (Core l a)
-readStrategy toLabel findRule xml = do
-   xs <- mapM (readStrategy toLabel findRule) (children xml)
-   let s = name xml
-   case lookup s table of
-      Just f  -> f s xs
-      Nothing ->
-         fail $ "Unknown strategy combinator " ++ show s
- where
-   buildSequence _ xs
-      | null xs   = return Succeed
-      | otherwise = return (foldr1 (:*:) xs)
-   buildChoice _ xs
-      | null xs   = return Fail
-      | otherwise = return (foldr1 (:|:) xs)
-   buildOrElse _ xs
-      | null xs   = return Fail
-      | otherwise = return (foldr1 (:|>:) xs)
-   buildInterleave _ xs
-      | null xs   = return Succeed
-      | otherwise = return (foldr1 (:%:) xs)
-   buildLabel x = do
-      info <- toLabel xml
-      return (Label info x)
-   buildRule = do
-      info <- toLabel xml
-      r    <- findRule info
-      return (Label info (Rule r))
-   buildRec x = do
-      s <- findAttribute "var" xml
-      i <- maybe (fail "var: not an int") return (readInt s)
-      return (Rec i x)
-   buildVar = do
-      s <- findAttribute "var" xml
-      i <- maybe (fail "var: not an int") return (readInt s)
-      return (Var i)
-
-   comb0 a _ [] = return a
-   comb0 _ s _  = fail $ "Strategy combinator " ++ s ++ "expects 0 args"
-
-   comb1 f _ [x] = return (f x)
-   comb1 _ s _   = fail $ "Strategy combinator " ++ s ++ "expects 1 arg"
-
-   join2 f g a b = join (f g a b)
-
-   table =
-      [ ("sequence",   buildSequence)
-      , ("choice",     buildChoice)
-      , ("orelse",     buildOrElse)
-      , ("interleave", buildInterleave)
-      , ("many",       comb1 Many)
-      , ("repeat",     comb1 Repeat)
-      , ("label",      join2 comb1 buildLabel)
-      , ("atomic",     comb1 Atomic)
-      , ("rec",        join2 comb1 buildRec)
-      , ("not",        comb1 (Not . noLabels))
-      , ("rule",       join2 comb0 buildRule)
-      , ("var",        join2 comb0 buildVar)
-      , ("succeed",    comb0 Succeed)
-      , ("fail",       comb0 Fail)
-      ]
− src/Service/Submit.hs 
@@ -1,66 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Diagnose a term submitted by a student. Deprecated (see diagnose service).
---
------------------------------------------------------------------------------
-module Service.Submit
-   ( submit, Result(..)
-   , submitType
-   ) where
-
-import Common.Library
-import Service.Diagnose (Diagnosis, diagnose)
-import Service.State
-import Service.Types
-import qualified Service.Diagnose as Diagnose
-
--- Note that in the typed setting there is no syntax error
-data Result a = Buggy  [Rule (Context a)]
-              | NotEquivalent
-              | Ok     [Rule (Context a)] (State a)  -- equivalent
-              | Detour [Rule (Context a)] (State a)  -- equivalent
-              | Unknown                   (State a)  -- equivalent
-
-fromDiagnose :: Diagnosis a -> Result a
-fromDiagnose diagnosis =
-   case diagnosis of
-      Diagnose.Buggy _ r       -> Buggy [r]
-      Diagnose.NotEquivalent   -> NotEquivalent
-      Diagnose.Similar _ s     -> Ok [] s
-      Diagnose.Expected _ s r  -> Ok [r] s
-      Diagnose.Detour _ s _ r  -> Detour [r] s
-      Diagnose.Correct _ s     -> Unknown s
---      Diagnose.Missing         -> NotEquivalent
---      Diagnose.IncorrectPart _ -> NotEquivalent
-
-submit :: State a -> a -> Result a
-submit state = fromDiagnose . diagnose state
-
-submitType :: Type a (Result a)
-submitType = Tag "Result" (Iso (f <-> g) tp)
- where
-   f (Left rs) = Buggy rs
-   f (Right (Left ())) = NotEquivalent
-   f (Right (Right (Left (rs, s)))) = Ok rs s
-   f (Right (Right (Right (Left (rs, s))))) = Detour rs s
-   f (Right (Right (Right (Right s)))) = Unknown s
-
-   g (Buggy rs)      = Left rs
-   g (NotEquivalent) = Right (Left ())
-   g (Ok rs s)       = Right (Right (Left (rs, s)))
-   g (Detour rs s)   = Right (Right (Right (Left (rs, s))))
-   g (Unknown s)     = Right (Right (Right (Right s)))
-
-   tp  =  List Rule
-      :|: Unit
-      :|: Pair (List Rule) stateType
-      :|: Pair (List Rule) stateType
-      :|: stateType
− src/Service/TypedExample.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE GADTs #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.TypedExample (typedExample) where
-
-import Common.Library
-import Data.Char
-import Data.Maybe
-import Service.DomainReasoner
-import Service.Evaluator
-import Service.ModeXML
-import Service.Types
-import Text.XML
-
-typedExample :: Exercise a -> Service -> [TypedValue a] -> DomainReasoner (XML, XML, Bool)
-typedExample ex service args = do
-   -- Construct a request in xml
-   request <-
-      case makeArgType args of
-         Nothing -> return $
-            stdReply (showId service) enc ex (return ())
-         Just (reqTuple ::: reqTp) -> do
-            xml <- encodeType (encoder evaluator) reqTp reqTuple
-            return $
-               stdReply (showId service) enc ex xml
-   -- Construct a reply in xml
-   reply <-
-      case foldl dynamicApply (serviceFunction service) args of
-         reply ::: replyTp -> do
-            xml <- encodeType (encoder evaluator) replyTp reply
-            return (resultOk xml)
-    `catchError`
-      (return . resultError)
-   -- Check request/reply pair
-   vers <- getVersion
-   xmlTest <- do
-      (_, txt, _) <- processXML (show request)
-      let p   = filter (not . isSpace)
-          out = showXML (if null vers then reply else addVersion vers reply)
-      return (p txt == p out)
-     `catchError`
-      const (return False)
-   return (request, reply, xmlTest)
- where
-   (evaluator, enc)
-      | isJust (hasTermView ex) = (openMathConverterTp ex, "openmath")
-      | otherwise               = (stringFormatConverterTp ex, "string")
-
-stdReply :: String -> String -> Exercise a -> XMLBuilder -> XML
-stdReply s enc ex body = makeXML "request" $ do
-   "service"    .=. s
-   "exerciseid" .=. showId ex
-   "source"     .=. "test"
-   "encoding"   .=. enc
-   body
-
-makeArgType :: [TypedValue a] -> Maybe (TypedValue a)
-makeArgType []   = fail "makeArgType: empty list"
-makeArgType [_ ::: Exercise] = fail "makeArgType: empty list"
-makeArgType [tv] = return tv
-makeArgType ((a1 ::: t1) : rest) = do
-   a2 ::: t2 <- makeArgType rest
-   return $ (a1, a2) ::: Pair t1 t2
-
-dynamicApply :: TypedValue a -> TypedValue a -> TypedValue a
-dynamicApply fun arg =
-   case (fun, arg) of
-      (f ::: t1 :-> t2, a ::: t3) ->
-         case equal t3 t1 of
-            Just eq -> f (eq a) ::: t2
-            Nothing -> error $ "mismatch (argument type): " ++ show t3 ++ " does not match " ++ show t1
-      _ -> error "mismatch (not a function)"
− src/Service/Types.hs 
@@ -1,210 +0,0 @@-{-# LANGUAGE GADTs, Rank2Types #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Service.Types
-   ( -- * Services
-     Service, makeService, deprecate
-   , serviceDeprecated, serviceFunction
-     -- * Types
-   , Type(..), TypedValue(..), tuple2, tuple3, tuple4
-   , maybeType, optionType
-   , errorType, difficultyType, listType, elemType
-   , derivationType, messageType
-   , equal, equalM
-   ) where
-
-import Common.Library
-import Common.Utils (commaList)
-import Control.Monad
-import Data.Maybe
-import Service.FeedbackScript.Syntax
-import System.Random
-
------------------------------------------------------------------------------
--- Services
-
-data Service = Service
-   { serviceId         :: Id
-   , serviceDeprecated :: Bool
-   , serviceFunction   :: forall a . TypedValue a
-   }
-
-instance HasId Service where
-   getId = serviceId
-   changeId f a = a { serviceId = f (serviceId a) }
-
-makeService :: String -> String -> (forall a . TypedValue a) -> Service
-makeService s descr f = describe descr (Service (newId s) False f)
-
-deprecate :: Service -> Service
-deprecate s = s { serviceDeprecated = True }
-
-equalM :: Monad m => Type a t1 -> Type a t2 -> m (t1 -> t2)
-equalM t1 t2 = maybe (fail msg) return (equal t1 t2)
- where msg = "Types not equal: " ++ show t1 ++ " and " ++ show t2
-
-equal :: Type a t1 -> Type a t2 -> Maybe (t1 -> t2)
-equal type1 type2 =
-   case (type1, type2) of
-      (Pair a b,    Pair c d   ) -> liftM2 (\f g (x, y) -> (f x, g y)) (equal a c) (equal b d)
-      (a :|: b,     c :|: d    ) -> liftM2 biMap (equal a c) (equal b d)
-      (List a,      List b     ) -> fmap map (equal a b)
-      (Rule,        Rule       ) -> Just id
-      (Unit,        Unit       ) -> Just id
-      (StrategyCfg, StrategyCfg) -> Just id
-      (Location,    Location   ) -> Just id
-      (Id,          Id         ) -> Just id
-      (Term,        Term       ) -> Just id
-      (Exercise,    Exercise   ) -> Just id
-      (Script,      Script     ) -> Just id
-      (Context,     Context    ) -> Just id
-      (ArgValueTp,  ArgValueTp ) -> Just id
-      (Text,        Text       ) -> Just id
-      (StdGen,      StdGen     ) -> Just id
-      (IO a,        IO b       ) -> fmap liftM (equal a b)
-      (Exception,   Exception  ) -> Just id
-      (Bool,        Bool       ) -> Just id
-      (String,      String     ) -> Just id
-      (Int,         Int        ) -> Just id
-      (Iso p a,     _          ) -> fmap (. to p) (equal a type2)
-      (_,           Iso p b    ) -> fmap (from p .) (equal type1 b)
-      (Tag s1 a,    Tag s2 b   ) -> guard (s1==s2) >> equal a b
-      _                          -> Nothing
-
-infixr 5 :|:
-
------------------------------------------------------------------------------
--- Types
-
-infix  2 :::
-infixr 3 :->
-
-data TypedValue a = forall t . t ::: Type a t
-
-tuple2 :: Type a t1 -> Type a t2 -> Type a (t1, t2)
-tuple2 = Pair
-
-tuple3 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a (t1, t2, t3)
-tuple3 t1 t2 t3 = Iso (f <-> g) (Pair t1 (Pair t2 t3))
- where
-   f (a, (b, c)) = (a, b, c)
-   g (a, b, c)   = (a, (b, c))
-
-tuple4 :: Type a t1 -> Type a t2 -> Type a t3 -> Type a t4 -> Type a (t1, t2, t3, t4)
-tuple4 t1 t2 t3 t4 = Iso (f <-> g) (Pair t1 (Pair t2 (Pair t3 t4)))
- where
-   f (a, (b, (c, d))) = (a, b, c, d)
-   g (a, b, c, d)     = (a, (b, (c, d)))
-
-maybeType :: Type a t1 -> Type a (Maybe t1)
-maybeType t = Iso (f <-> g) (t :|: Unit)
- where
-   f = either Just (const Nothing)
-   g = maybe (Right ()) Left
-
-optionType :: t1 -> Type a t1 -> Type a t1
-optionType a t = Iso (fromMaybe a <-> Just) (maybeType t)
-
-errorType :: Type a t -> Type a (Either String t)
-errorType t = Exception :|: t
-
-listType :: Type a t -> Type a [t] -- with list "tag"
-listType = Tag "list" . List . elemType
-
-elemType :: Type a t -> Type a t
-elemType = Tag "elem"
-
-messageType :: Type a t -> Type a t
-messageType = Tag "message"
-
-difficultyType :: Type a Difficulty
-difficultyType = Tag "difficulty" (Iso (f <-> show) String)
- where
-   f = fromMaybe Medium . readDifficulty
-
-derivationType :: Type a t1 -> Type a t2 -> Type a (Derivation t1 t2)
-derivationType t1 t2 = Iso (f <-> g) (listType (tuple2 t1 t2))
- where
-   f = foldl extend (emptyDerivation (error "derivationType") )
-   g = map (\(_, s, a) -> (s, a)) . triples
-
-data Type a t where
-   -- Type isomorphisms (for defining type synonyms)
-   Iso          :: Isomorphism t1 t2 -> Type a t1 -> Type a t2
-   -- Function type
-   (:->)        :: Type a t1 -> Type a t2 -> Type a (t1 -> t2)
-   -- Special annotations
-   Tag          :: String -> Type a t1 -> Type a t1
-   -- Type constructors
-   List         :: Type a t -> Type a [t]
-   Pair         :: Type a t1 -> Type a t2 -> Type a (t1, t2)
-   (:|:)        :: Type a t1 -> Type a t2 -> Type a (Either t1 t2)
-   Unit         :: Type a ()
-   StdGen       :: Type a StdGen
-   IO           :: Type a t -> Type a (IO t)
-   Exception    :: Type a String
-   -- Exercise-specific types
-   Exercise     :: Type a (Exercise a)
-   Script       :: Type a Script
-   Strategy     :: Type a (Strategy (Context a))
-   Rule         :: Type a (Rule (Context a))
-   Term         :: Type a a
-   Context      :: Type a (Context a)
-   Location     :: Type a Location
-   Id           :: Type a Id
-   StrategyCfg  :: Type a StrategyConfiguration
-   ArgValueTp   :: Type a ArgValue
-   Text         :: Type a Text
-   -- Basic types
-   Bool         :: Type a Bool
-   Int          :: Type a Int
-   String       :: Type a String
-
-instance Show (Type a t) where
-   show (Iso _ t)      = show t
-   show (t1 :-> t2)    = show t1 ++ " -> " ++ show t2
-   show t@(Pair _ _)   = showTuple t
-   show (t1 :|: t2)    = show t1 ++ " | " ++ show t2
-   show (Tag s _)      = s -- ++ "@(" ++ show t ++ ")"
-   show (List t)       = "[" ++ show t ++ "]"
-   show (IO t)         = show t
-   show t              = fromMaybe "unknown" (showGroundType t)
-
-showTuple :: Type a t -> String
-showTuple tp = "(" ++ commaList (collect tp) ++ ")"
- where
-   collect :: Type a t -> [String]
-   collect (Pair t1 t2) = collect t1 ++ collect t2
-   collect (Iso _ t)    = collect t
-   collect t            = [show t]
-
-showGroundType :: Type a t -> Maybe String
-showGroundType tp =
-   case tp of
-      Exercise     -> Just "Exercise"
-      Script       -> Just "Script"
-      Strategy     -> Just "Strategy"
-      Rule         -> Just "Rule"
-      Term         -> Just "Term"
-      Context      -> Just "Context"
-      Unit         -> Just "()"
-      Bool         -> Just "Bool"
-      Int          -> Just "Int"
-      String       -> Just "String"
-      Location     -> Just "Location"
-      Id           -> Just "Id"
-      StrategyCfg  -> Just "StrategyConfiguration"
-      ArgValueTp   -> Just "ArgumentValue"
-      Text         -> Just "TextMessage"
-      StdGen       -> Just "StdGen"
-      Exception    -> Just "Exception"
-      _            -> Nothing
− src/Text/HTML.hs 
@@ -1,187 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A minimal interface for constructing simple HTML pages
--- See http://www.w3.org/TR/html4/
---
------------------------------------------------------------------------------
-module Text.HTML
-   ( HTML, HTMLBuilder, showHTML
-   , htmlPage, link
-   , h1, h2, h3, h4, h5, h6
-   , preText, ul, table
-   , text, image, space, spaces, highlightXML
-   , para, ttText, hr, br, pre, bullet
-   , divClass, spanClass
-     -- HTML generic attributes
-   , idA, classA, styleA, titleA
-     -- Font style elements
-   , tt, italic, bold, big, small
-   ) where
-
-import Control.Monad
-import Data.Char
-import Data.List
-import Prelude hiding (div)
-import Text.XML hiding (text)
-import qualified Text.XML as XML
-
-type HTML = XML
-
-type HTMLBuilder = XMLBuilder
-
-showHTML :: HTML -> String
-showHTML = compactXML
-
--- html helper functions
-htmlPage :: String -> Maybe String -> HTMLBuilder -> HTML
-htmlPage title css body = makeXML "html" $ do
-   element "head" $ do
-      unless (null title) $
-         element "title" (text title)
-      case css of
-         Nothing -> return ()
-         Just n  -> element "link" $ do
-            "rel"  .=. "STYLESHEET"
-            "href" .=. n
-            "type" .=. "text/css"
-   element "body" body
-
-link :: String -> HTMLBuilder -> HTMLBuilder
-link url body = element "a" $
-   ("href" .=. url) >> body
-
-h1, h2, h3, h4, h5, h6 :: String -> HTMLBuilder
-h1 = element "h1" . text
-h2 = element "h2" . text
-h3 = element "h3" . text
-h4 = element "h4" . text
-h5 = element "h5" . text
-h6 = element "h6" . text
-
-para :: HTMLBuilder -> HTMLBuilder
-para = element "p"
-
-preText :: String -> HTMLBuilder
-preText = pre . text
-
-pre :: HTMLBuilder -> HTMLBuilder
-pre = element "pre"
-
-hr :: HTMLBuilder
-hr = tag "hr"
-
-br :: HTMLBuilder
-br = tag "br"
-
-ttText :: String -> HTMLBuilder
-ttText = tt . text
-
-ul :: [HTMLBuilder] -> HTMLBuilder
-ul = element "ul" . mapM_ (element "li")
-
--- | First argument indicates whether the table has a header or not
-table :: Bool -> [[HTMLBuilder]] -> HTMLBuilder
-table b rows = element "table" $ do
-   "border" .=. "1"
-   forM_ (zip [0::Int ..] rows) $ \(i, r) ->
-      element "tr" $ do
-         "class" .=. getClass i
-         mapM_ ((if i==0 then classA "topCell" else id) . element "td") r
- where
-   getClass i
-      | i == 0 && b = "topRow"
-      | even i      = "evenRow"
-      | otherwise   = "oddRow"
-
-spaces :: Int -> HTMLBuilder
-spaces n = replicateM_ n space
-
-space, bullet :: HTMLBuilder
-space  = XML.unescaped "&nbsp;"
-bullet = XML.unescaped "&#8226;"
-
-image :: String -> HTMLBuilder
-image n = element "img" ("src" .=. n)
-
-text :: String -> HTMLBuilder
-text = XML.text
-
-divClass :: String -> HTMLBuilder -> HTMLBuilder
-divClass n = classA n . element "div"
-
-spanClass :: String -> HTMLBuilder -> HTMLBuilder
-spanClass n = classA n . element "span"
-
--- A simple XML highlighter
-highlightXML :: Bool -> XML -> HTMLBuilder
-highlightXML nice
-   | nice      = builder . highlight . makeXML "pre" . text . showXML
-   | otherwise = builder . highlight . makeXML "tt"  . text . compactXML
- where
-   highlight :: HTML -> HTML
-   highlight html = html {content = map (either (Left . f) Right) (content html)}
-
-   -- find <
-   f :: String -> String
-   f [] = []
-   f list@(x:xs)
-      | "&lt;/" `isPrefixOf` list = -- close tag
-           let (as, bs) = span isAlphaNum (drop 5 list)
-           in "<font color='blue'>&lt;/" ++ as ++ "<font color='green'>" ++ g bs
-      | "&lt;" `isPrefixOf` list = -- open tag
-           let (as, bs) = span isAlphaNum (drop 4 list)
-           in "<font color='blue'>&lt;" ++ as ++ "<font color='green'>" ++ g bs
-      | otherwise = x : f xs
-   -- find >
-   g [] = []
-   g list@(x:xs)
-      | "/&gt;" `isPrefixOf` list =
-           "</font>/&gt;</font>" ++ f (drop 5 list)
-      | "&gt;" `isPrefixOf` list =
-           "</font>&gt;</font>" ++ f (drop 4 list)
-      | x=='=' = "<font color='orange'>=</font>" ++ g xs
-      | otherwise = x : g xs
-
------------------------------------------------------------
--- * HTML generic attributes
-
-idA, classA, styleA, titleA :: String -> HTMLBuilder -> HTMLBuilder
-idA    = setA "id"     -- document-wide unique id
-classA = setA "class"  -- space-separated list of classes
-styleA = setA "style"  -- associated style info
-titleA = setA "title"  -- advisory title
-
-setA :: String -> String -> HTMLBuilder -> HTMLBuilder
-setA attr value = updateLast $ \e ->
-   e { attributes = (attr := value) : attributes e }
-
------------------------------------------------------------
--- * Font style elements
-
--- | Renders as teletype or monospaced text.
-tt :: HTMLBuilder -> HTMLBuilder
-tt = element "tt"
-
--- | Renders as italic text style.
-italic :: HTMLBuilder -> HTMLBuilder
-italic = element "i"
-
--- | Renders as bold text style.
-bold :: HTMLBuilder -> HTMLBuilder
-bold = element "b"
-
--- BIG: Renders text in a "large" font.
-big :: HTMLBuilder -> HTMLBuilder
-big = element "big"
-
--- SMALL: Renders text in a "small" font.
-small :: HTMLBuilder -> HTMLBuilder
-small = element "small"
− src/Text/JSON.hs 
@@ -1,287 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Support for JavaScript Object Notation (JSON) and remote procedure calls using
--- JSON. JSON is a lightweight alternative for XML.
---
------------------------------------------------------------------------------
-module Text.JSON
-   ( JSON(..), Key, Number(..)            -- types
-   , InJSON(..)                           -- type class"
-   , lookupM
-   , parseJSON, showCompact, showPretty   -- parser and pretty-printers
-   , jsonRPC, JSON_RPC_Handler, propEncoding
-   ) where
-
-import Control.Monad.Error
-import Data.List (intercalate)
-import Data.Maybe
-import Test.QuickCheck
-import Text.Parsing
-import qualified Text.ParserCombinators.Parsec.Token as P
-import qualified Text.UTF8 as UTF8
-
-data JSON
-   = Number  Number        -- integer, real, or floating point
-   | String  String        -- double-quoted Unicode with backslash escapement
-   | Boolean Bool          -- true and false
-   | Array   [JSON]        -- ordered sequence (comma-separated, square brackets)
-   | Object  [(Key, JSON)] -- collection of key/value pairs (comma-separated, curly brackets
-   | Null
- deriving Eq
-
-type Key = String
-
-data Number = I Integer | D Double deriving Eq
-
-instance Show JSON where
-   show = showPretty
-
-showCompact :: JSON -> String
-showCompact json =
-   case json of
-      Number n  -> show n
-      String s  -> "\"" ++ escape s ++ "\""
-      Boolean b -> if b then "true" else "false"
-      Array xs  -> squareBrackets $ intercalate ", " $ map showCompact xs
-      Object xs -> let f (k, v) = show k ++ ": " ++ showCompact v
-                   in curlyBrackets  $ intercalate ", " $ map f xs
-      Null      -> "null"
-
--- Escape double quote and backslash, and convert to UTF8 encoding
-escape :: String -> String
-escape = concatMap f . fromMaybe "invalid UTF8 string" . UTF8.encodeM
- where
-   f '\n' = "\\\\n"
-   f '"'  = "\\\""
-   f '\\' = "\\\\"
-   f c    = [c]
-
-showPretty :: JSON -> String
-showPretty json =
-   case json of
-      Array xs  -> squareBrackets $ '\n' : indent 3 (commas (map showPretty xs))
-      Object xs -> let f (k, v) = show k ++ ": " ++ showPretty v
-                   in curlyBrackets $ '\n' : indent 3 (commas (map f xs))
-      _         -> showCompact json
- where
-   commas []     = []
-   commas [x]    = x
-   commas (x:xs) = x ++ ",\n" ++ commas xs
-
-squareBrackets, curlyBrackets :: String -> String
-squareBrackets s = "[" ++ s ++ "]"
-curlyBrackets  s = "{" ++ s ++ "}"
-
-instance Show Number where
-   show (I n) = show n
-   show (D d) = show d
-
-class InJSON a where
-   toJSON       :: a -> JSON
-   listToJSON   :: [a] -> JSON
-   fromJSON     :: Monad m => JSON -> m a
-   listFromJSON :: Monad m => JSON -> m [a]
-   -- default definitions
-   listToJSON   = Array . map toJSON
-   listFromJSON (Array xs) = mapM fromJSON xs
-   listFromJSON _          = fail "expecting an array"
-
-instance InJSON Int where
-   toJSON   = toJSON . toInteger
-   fromJSON = liftM fromInteger . fromJSON
-
-instance InJSON Integer where
-   toJSON                  = Number . I
-   fromJSON (Number (I n)) = return n
-   fromJSON _              = fail "expecting a number"
-
-instance InJSON Double where
-   toJSON = Number . D
-   fromJSON (Number (D n)) = return n
-   fromJSON _              = fail "expecting a number"
-
-instance InJSON Char where
-   toJSON c   = String [c]
-   listToJSON = String
-   fromJSON (String [c]) = return c
-   fromJSON _ = fail "expecting a string"
-   listFromJSON (String s) = return s
-   listFromJSON _ = fail "expecting a string"
-
-instance InJSON Bool where
-   toJSON = Boolean
-   fromJSON (Boolean b) = return b
-   fromJSON _           = fail "expecting a boolean"
-
-instance InJSON a => InJSON [a] where
-   toJSON   = listToJSON
-   fromJSON = listFromJSON
-
-instance (InJSON a, InJSON b) => InJSON (a, b) where
-   toJSON (a, b)           = Array [toJSON a, toJSON b]
-   fromJSON (Array [a, b]) = liftM2 (,) (fromJSON a) (fromJSON b)
-   fromJSON _              = fail "expecting an array with 2 elements"
-
-instance (InJSON a, InJSON b, InJSON c) => InJSON (a, b, c) where
-   toJSON (a, b, c)           = Array [toJSON a, toJSON b, toJSON c]
-   fromJSON (Array [a, b, c]) = liftM3 (,,) (fromJSON a) (fromJSON b) (fromJSON c)
-   fromJSON _                 = fail "expecting an array with 3 elements"
-
-instance (InJSON a, InJSON b, InJSON c, InJSON d) => InJSON (a, b, c, d) where
-   toJSON (a, b, c, d)           = Array [toJSON a, toJSON b, toJSON c, toJSON d]
-   fromJSON (Array [a, b, c, d]) = liftM4 (,,,) (fromJSON a) (fromJSON b) (fromJSON c) (fromJSON d)
-   fromJSON _                    = fail "expecting an array with 4 elements"
-
---------------------------------------------------------
--- Parser
-
-parseJSON :: String -> Either String JSON
-parseJSON = parseSimple json
- where
-   json :: Parser JSON
-   json = choice
-      [ Null          <$ P.reserved lexer "null"
-      , Boolean True  <$ P.reserved lexer "true"
-      , Boolean False <$ P.reserved lexer "false"
-      , Number . either I D <$> naturalOrFloat -- redefined in Text.Parsing
-      , String . fromMaybe [] . UTF8.decodeM <$> P.stringLiteral lexer
-      , Array  <$> P.brackets lexer (sepBy json (P.comma lexer))
-      , Object <$> P.braces lexer (sepBy keyValue (P.comma lexer))
-      ]
-
-   keyValue :: Parser (String, JSON)
-   keyValue = (,) <$> P.stringLiteral lexer <* P.colon lexer <*> json
-
-   lexer :: P.TokenParser a
-   lexer = P.makeTokenParser $ emptyDef
-      { reservedNames = ["true", "false", "null"] }
-
---------------------------------------------------------
--- JSON-RPC
-
-data JSON_RPC_Request = Request
-   { requestMethod :: String
-   , requestParams :: JSON
-   , requestId     :: JSON
-   }
-
-data JSON_RPC_Response = Response
-   { responseResult :: JSON
-   , responseError  :: JSON
-   , responseId     :: JSON
-   }
-
-instance Show JSON_RPC_Request where
-   show = show . toJSON
-
-instance Show JSON_RPC_Response where
-   show = show . toJSON
-
-instance InJSON JSON_RPC_Request where
-   toJSON req = Object
-      [ ("method", String $ requestMethod req)
-      , ("params", requestParams req)
-      , ("id"    , requestId req)
-      ]
-   fromJSON obj = do
-      mj <- lookupM "method" obj
-      pj <- lookupM "params" obj
-      ij <- lookupM "id"     obj
-      case mj of
-         String s -> return (Request s pj ij)
-         _        -> fail "expecting a string"
-
-instance InJSON JSON_RPC_Response where
-   toJSON resp = Object
-      [ ("result", responseResult resp)
-      , ("error" , responseError resp)
-      , ("id"    , responseId resp)
-      ]
-   fromJSON obj = do
-      rj <- lookupM "result" obj
-      ej <- lookupM "error"  obj
-      ij <- lookupM "id"     obj
-      return (Response rj ej ij)
-
-okResponse :: JSON -> JSON -> JSON_RPC_Response
-okResponse x y = Response
-   { responseResult = x
-   , responseError  = Null
-   , responseId     = y
-   }
-
-errorResponse :: JSON -> JSON -> JSON_RPC_Response
-errorResponse x y = Response
-   { responseResult = Null
-   , responseError  = x
-   , responseId     = y
-   }
-
-lookupM :: Monad m => String -> JSON -> m JSON
-lookupM x (Object xs) = maybe (fail $ "field " ++ x ++ " not found") return (lookup x xs)
-lookupM _ _ = fail "expecting a JSON object"
-
-indent :: Int -> String -> String
-indent n = unlines . map (replicate n ' ' ++) . lines
-
---------------------------------------------------------
--- JSON-RPC over HTTP
-
-type JSON_RPC_Handler m = String -> JSON -> m JSON
-
-jsonRPC :: (MonadError a m, InJSON a)
-        => JSON -> JSON_RPC_Handler m -> m JSON_RPC_Response
-jsonRPC input handler =
-   case fromJSON input of
-      Nothing  -> return (errorResponse (String "Invalid request") Null)
-      Just req -> do
-         json <- handler (requestMethod req) (requestParams req)
-         return (okResponse json (requestId req))
-       `catchError` \msg ->
-          return (errorResponse (toJSON msg) (requestId req))
-
---------------------------------------------------------
--- Testing parser/pretty-printer
-
-instance Arbitrary JSON where
-   arbitrary = sized arbJSON
-
-instance Arbitrary Number where
-   arbitrary = oneof [liftM I arbitrary, liftM (D . fromInteger) arbitrary]
-
-arbJSON :: Int -> Gen JSON
-arbJSON n
-   | n == 0 = oneof
-        [ liftM Number arbitrary, liftM String myStringGen
-        , liftM Boolean arbitrary, return Null
-        ]
-   | otherwise = oneof
-        [ arbJSON 0
-        , do i  <- choose (0, 6)
-             xs <- replicateM i rec
-             return (Array xs)
-        , do i  <- choose (0, 6)
-             xs <- replicateM i myStringGen
-             ys <- replicateM i rec
-             return (Object (zip xs ys))
-        ]
- where
-   rec = arbJSON (n `div` 2)
-
-myStringGen :: Gen String
-myStringGen = do
-   n <- choose (1, 10)
-   replicateM n $ elements $
-      ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9']
-
-propEncoding :: Property
-propEncoding = property $ \a ->
-   parseJSON (show a) == Right a
− src/Text/OpenMath/Dictionary/Arith1.hs 
@@ -1,79 +0,0 @@--- Automatically generated from content dictionary arith1.ocd.  Do not change.
-module Text.OpenMath.Dictionary.Arith1 where
-
-import Text.OpenMath.Symbol
-
--- | List of symbols defined in arith1 dictionary
-arith1List :: [Symbol]
-arith1List = [lcmSymbol, gcdSymbol, plusSymbol, unaryMinusSymbol, minusSymbol, timesSymbol, divideSymbol, powerSymbol, absSymbol, rootSymbol, sumSymbol, productSymbol]
-
-{-| The symbol to represent the n-ary function to return the least common
-multiple of its arguments. -}
-lcmSymbol :: Symbol
-lcmSymbol = makeSymbol "arith1" "lcm"
-
-{-| The symbol to represent the n-ary function to return the gcd (greatest
-common divisor) of its arguments. -}
-gcdSymbol :: Symbol
-gcdSymbol = makeSymbol "arith1" "gcd"
-
-{-| The symbol representing an n-ary commutative function plus. -}
-plusSymbol :: Symbol
-plusSymbol = makeSymbol "arith1" "plus"
-
-{-| This symbol denotes unary minus, i.e. the additive inverse. -}
-unaryMinusSymbol :: Symbol
-unaryMinusSymbol = makeSymbol "arith1" "unary_minus"
-
-{-| The symbol representing a binary minus function. This is equivalent to
-adding the additive inverse. -}
-minusSymbol :: Symbol
-minusSymbol = makeSymbol "arith1" "minus"
-
-{-| The symbol representing an n-ary multiplication function. -}
-timesSymbol :: Symbol
-timesSymbol = makeSymbol "arith1" "times"
-
-{-| This symbol represents a (binary) division function denoting the first
-argument right-divided by the second, i.e. divide(a,b)=a*inverse(b). It is the
-inverse of the multiplication function defined by the symbol times in this CD.
--}
-divideSymbol :: Symbol
-divideSymbol = makeSymbol "arith1" "divide"
-
-{-| This symbol represents a power function. The first argument is raised to
-the power of the second argument. When the second argument is not an integer,
-powering is defined in terms of exponentials and logarithms for the complex
-and real numbers. This operator can represent general powering. -}
-powerSymbol :: Symbol
-powerSymbol = makeSymbol "arith1" "power"
-
-{-| A unary operator which represents the absolute value of its argument. The
-argument should be numerically valued. In the complex case this is often
-referred to as the modulus. -}
-absSymbol :: Symbol
-absSymbol = makeSymbol "arith1" "abs"
-
-{-| A binary operator which represents its first argument "lowered" to its
-n'th root where n is the second argument. This is the inverse of the operation
-represented by the power symbol defined in this CD. Care should be taken as to
-the precise meaning of this operator, in particular which root is represented,
-however it is here to represent the general notion of taking n'th roots. As
-inferred by the signature relevant to this symbol, the function represented by
-this symbol is the single valued function, the specific root returned is the
-one indicated by the first CMP. Note also that the converse of the second CMP
-is not valid in general. -}
-rootSymbol :: Symbol
-rootSymbol = makeSymbol "arith1" "root"
-
-{-| An operator taking two arguments, the first being the range of summation,
-e.g. an integral interval, the second being the function to be summed. Note
-that the sum may be over an infinite interval. -}
-sumSymbol :: Symbol
-sumSymbol = makeSymbol "arith1" "sum"
-
-{-| An operator taking two arguments, the first being the range of
-multiplication e.g. an integral interval, the second being the function to be
-multiplied. Note that the product may be over an infinite interval. -}
-productSymbol :: Symbol
-productSymbol = makeSymbol "arith1" "product"
− src/Text/OpenMath/Dictionary/Calculus1.hs 
@@ -1,36 +0,0 @@--- Automatically generated from content dictionary calculus1.ocd.  Do not change.
-module Text.OpenMath.Dictionary.Calculus1 where
-
-import Text.OpenMath.Symbol
-
--- | List of symbols defined in calculus1 dictionary
-calculus1List :: [Symbol]
-calculus1List = [diffSymbol, nthdiffSymbol, partialdiffSymbol, intSymbol, defintSymbol]
-
-{-| This symbol is used to express ordinary differentiation of a unary
-function. The single argument is the unary function. -}
-diffSymbol :: Symbol
-diffSymbol = makeSymbol "calculus1" "diff"
-
-{-| This symbol is used to express the nth-iterated ordinary differentiation
-of a unary function. The first argument is n, and the second the unary
-function. -}
-nthdiffSymbol :: Symbol
-nthdiffSymbol = makeSymbol "calculus1" "nthdiff"
-
-{-| This symbol is used to express partial differentiation of a function of
-more than one variable. It has two arguments, the first is a list of integers
-which index the variables of the function, the second is the function. -}
-partialdiffSymbol :: Symbol
-partialdiffSymbol = makeSymbol "calculus1" "partialdiff"
-
-{-| This symbol is used to represent indefinite integration of unary
-functions. The argument is the unary function. -}
-intSymbol :: Symbol
-intSymbol = makeSymbol "calculus1" "int"
-
-{-| This symbol is used to represent definite integration of unary functions.
-It takes two arguments; the first being the range (e.g. a set) of integration,
-and the second the function. -}
-defintSymbol :: Symbol
-defintSymbol = makeSymbol "calculus1" "defint"
− src/Text/OpenMath/Dictionary/Fns1.hs 
@@ -1,73 +0,0 @@--- Automatically generated from content dictionary fns1.ocd.  Do not change.
-module Text.OpenMath.Dictionary.Fns1 where
-
-import Text.OpenMath.Symbol
-
--- | List of symbols defined in fns1 dictionary
-fns1List :: [Symbol]
-fns1List = [domainofapplicationSymbol, domainSymbol, rangeSymbol, imageSymbol, identitySymbol, leftInverseSymbol, rightInverseSymbol, inverseSymbol, leftComposeSymbol, lambdaSymbol]
-
-{-| The domainofapplication element denotes the domain over which a given
-function is being applied. It is intended in MathML to be a more general
-alternative to specification of this domain using such quantifier elements as
-bvar, lowlimit or condition. -}
-domainofapplicationSymbol :: Symbol
-domainofapplicationSymbol = makeSymbol "fns1" "domainofapplication"
-
-{-| This symbol denotes the domain of a given function, which is the set of
-values it is defined over. -}
-domainSymbol :: Symbol
-domainSymbol = makeSymbol "fns1" "domain"
-
-{-| This symbol denotes the range of a function, that is a set that the
-function will map to. The single argument should be the function whos range is
-being queried. It should be noted that this is not necessarily equal to the
-image, it is merely required to contain the image. -}
-rangeSymbol :: Symbol
-rangeSymbol = makeSymbol "fns1" "range"
-
-{-| This symbol denotes the image of a given function, which is the set of
-values the domain of the given function maps to. -}
-imageSymbol :: Symbol
-imageSymbol = makeSymbol "fns1" "image"
-
-{-| The identity function, it takes one argument and returns the same value.
--}
-identitySymbol :: Symbol
-identitySymbol = makeSymbol "fns1" "identity"
-
-{-| This symbol is used to describe the left inverse of its argument (a
-function). This inverse may only be partially defined because the function may
-not have been surjective. If the function is not surjective the left inverse
-function is ill-defined without further stipulations. No other assumptions are
-made on the semantics of this left inverse. -}
-leftInverseSymbol :: Symbol
-leftInverseSymbol = makeSymbol "fns1" "left_inverse"
-
-{-| This symbol is used to describe the right inverse of its argument (a
-function). This inverse may only be partially defined because the function may
-not have been surjective. If the function is not surjective the right inverse
-function is ill-defined without further stipulations. No other assumptions are
-made on the semantics of this right inverse. -}
-rightInverseSymbol :: Symbol
-rightInverseSymbol = makeSymbol "fns1" "right_inverse"
-
-{-| This symbol is used to describe the inverse of its argument (a function).
-This inverse may only be partially defined because the function may not have
-been surjective. If the function is not surjective the inverse function is
-ill-defined without further stipulations. No assumptions are made on the
-semantics of this inverse. -}
-inverseSymbol :: Symbol
-inverseSymbol = makeSymbol "fns1" "inverse"
-
-{-| This symbol represents the function which forms the left-composition of
-its two (function) arguments. -}
-leftComposeSymbol :: Symbol
-leftComposeSymbol = makeSymbol "fns1" "left_compose"
-
-{-| This symbol is used to represent anonymous functions as lambda expansions.
-It is used in a binder that takes two further arguments, the first of which is
-a list of variables, and the second of which is an expression, and it forms
-the function which is the lambda extraction of the expression -}
-lambdaSymbol :: Symbol
-lambdaSymbol = makeSymbol "fns1" "lambda"
− src/Text/OpenMath/Dictionary/Linalg2.hs 
@@ -1,24 +0,0 @@--- Automatically generated from content dictionary linalg2.ocd.  Do not change.
-module Text.OpenMath.Dictionary.Linalg2 where
-
-import Text.OpenMath.Symbol
-
--- | List of symbols defined in linalg2 dictionary
-linalg2List :: [Symbol]
-linalg2List = [vectorSymbol, matrixrowSymbol, matrixSymbol]
-
-{-| This symbol represents an n-ary function used to construct (or describe)
-vectors. Vectors in this CD are considered to be row vectors and must
-therefore be transposed to be considered as column vectors. -}
-vectorSymbol :: Symbol
-vectorSymbol = makeSymbol "linalg2" "vector"
-
-{-| This symbol is an n-ary constructor used to represent rows of matrices.
-Its arguments should be members of a ring. -}
-matrixrowSymbol :: Symbol
-matrixrowSymbol = makeSymbol "linalg2" "matrixrow"
-
-{-| This symbol is an n-ary matrix constructor which requires matrixrow's as
-arguments. It is used to represent matrices. -}
-matrixSymbol :: Symbol
-matrixSymbol = makeSymbol "linalg2" "matrix"
− src/Text/OpenMath/Dictionary/List1.hs 
@@ -1,28 +0,0 @@--- Automatically generated from content dictionary list1.ocd.  Do not change.
-module Text.OpenMath.Dictionary.List1 where
-
-import Text.OpenMath.Symbol
-
--- | List of symbols defined in list1 dictionary
-list1List :: [Symbol]
-list1List = [mapSymbol, suchthatSymbol, listSymbol]
-
-{-| This symbol represents a mapping function which may be used to construct
-lists, it takes as arguments a function from X to Y and a list over X in that
-order. The value that is returned is a list of values in Y. The argument list
-may be a set or an integer_interval. -}
-mapSymbol :: Symbol
-mapSymbol = makeSymbol "list1" "map"
-
-{-| This symbol represents the suchthat function which may be used to
-construct lists, it takes two arguments. The first argument should be the set
-which contains the elements of the list, the second argument should be a
-predicate, that is a function from the set to the booleans which describes if
-an element is to be in the list returned. -}
-suchthatSymbol :: Symbol
-suchthatSymbol = makeSymbol "list1" "suchthat"
-
-{-| This symbol denotes the list construct which is an n-ary function. The
-list entries must be given explicitly. -}
-listSymbol :: Symbol
-listSymbol = makeSymbol "list1" "list"
− src/Text/OpenMath/Dictionary/Logic1.hs 
@@ -1,50 +0,0 @@--- Automatically generated from content dictionary logic1.ocd.  Do not change.
-module Text.OpenMath.Dictionary.Logic1 where
-
-import Text.OpenMath.Symbol
-
--- | List of symbols defined in logic1 dictionary
-logic1List :: [Symbol]
-logic1List = [equivalentSymbol, notSymbol, andSymbol, xorSymbol, orSymbol, impliesSymbol, trueSymbol, falseSymbol]
-
-{-| This symbol is used to show that two boolean expressions are logically
-equivalent, that is have the same boolean value for any inputs. -}
-equivalentSymbol :: Symbol
-equivalentSymbol = makeSymbol "logic1" "equivalent"
-
-{-| This symbol represents the logical not function which takes one boolean
-argument, and returns the opposite boolean value. -}
-notSymbol :: Symbol
-notSymbol = makeSymbol "logic1" "not"
-
-{-| This symbol represents the logical and function which is an n-ary function
-taking boolean arguments and returning a boolean value. It is true if all
-arguments are true or false otherwise. -}
-andSymbol :: Symbol
-andSymbol = makeSymbol "logic1" "and"
-
-{-| This symbol represents the logical xor function which is an n-ary function
-taking boolean arguments and returning a boolean value. It is true if there
-are an odd number of true arguments or false otherwise. -}
-xorSymbol :: Symbol
-xorSymbol = makeSymbol "logic1" "xor"
-
-{-| This symbol represents the logical or function which is an n-ary function
-taking boolean arguments and returning a boolean value. It is true if any of
-the arguments are true or false otherwise. -}
-orSymbol :: Symbol
-orSymbol = makeSymbol "logic1" "or"
-
-{-| This symbol represents the logical implies function which takes two
-boolean expressions as arguments. It evaluates to false if the first argument
-is true and the second argument is false, otherwise it evaluates to true. -}
-impliesSymbol :: Symbol
-impliesSymbol = makeSymbol "logic1" "implies"
-
-{-| This symbol represents the boolean value true. -}
-trueSymbol :: Symbol
-trueSymbol = makeSymbol "logic1" "true"
-
-{-| This symbol represents the boolean value false. -}
-falseSymbol :: Symbol
-falseSymbol = makeSymbol "logic1" "false"
− src/Text/OpenMath/Dictionary/Nums1.hs 
@@ -1,54 +0,0 @@--- Automatically generated from content dictionary nums1.ocd.  Do not change.
-module Text.OpenMath.Dictionary.Nums1 where
-
-import Text.OpenMath.Symbol
-
--- | List of symbols defined in nums1 dictionary
-nums1List :: [Symbol]
-nums1List = [basedIntegerSymbol, rationalSymbol, infinitySymbol, eSymbol, iSymbol, piSymbol, gammaSymbol, naNSymbol]
-
-{-| This symbol represents the constructor function for integers, specifying
-the base. It takes two arguments, the first is a positive integer to denote
-the base to which the number is represented, the second argument is a string
-which contains an optional sign and the digits of the integer, using 0-9a-z
-(as a consequence of this no radix greater than 35 is supported). Base 16 and
-base 10 are already covered in the encodings of integers. -}
-basedIntegerSymbol :: Symbol
-basedIntegerSymbol = makeSymbol "nums1" "based_integer"
-
-{-| This symbol represents the constructor function for rational numbers. It
-takes two arguments, the first is an integer p to denote the numerator and the
-second a nonzero integer q to denote the denominator of the rational p/q. -}
-rationalSymbol :: Symbol
-rationalSymbol = makeSymbol "nums1" "rational"
-
-{-| A symbol to represent the notion of infinity. -}
-infinitySymbol :: Symbol
-infinitySymbol = makeSymbol "nums1" "infinity"
-
-{-| This symbol represents the base of the natural logarithm, approximately
-2.718. See Abramowitz and Stegun, Handbook of Mathematical Functions, section
-4.1. -}
-eSymbol :: Symbol
-eSymbol = makeSymbol "nums1" "e"
-
-{-| This symbol represents the square root of -1. -}
-iSymbol :: Symbol
-iSymbol = makeSymbol "nums1" "i"
-
-{-| A symbol to convey the notion of pi, approximately 3.142. The ratio of the
-circumference of a circle to its diameter. -}
-piSymbol :: Symbol
-piSymbol = makeSymbol "nums1" "pi"
-
-{-| A symbol to convey the notion of the gamma constant as defined in
-Abramowitz and Stegun, Handbook of Mathematical Functions, section 6.1.3. It
-is the limit of 1 + 1/2 + 1/3 + ... + 1/m - ln m as m tends to infinity, this
-is approximately 0.5772 15664. -}
-gammaSymbol :: Symbol
-gammaSymbol = makeSymbol "nums1" "gamma"
-
-{-| A symbol to convey the notion of not-a-number. The result of an ill-posed
-floating computation. See IEEE standard for floating point representations. -}
-naNSymbol :: Symbol
-naNSymbol = makeSymbol "nums1" "NaN"
− src/Text/OpenMath/Dictionary/Quant1.hs 
@@ -1,22 +0,0 @@--- Automatically generated from content dictionary quant1.ocd.  Do not change.
-module Text.OpenMath.Dictionary.Quant1 where
-
-import Text.OpenMath.Symbol
-
--- | List of symbols defined in quant1 dictionary
-quant1List :: [Symbol]
-quant1List = [forallSymbol, existsSymbol]
-
-{-| This symbol represents the universal ("for all") quantifier which takes
-two arguments. It must be placed within an OMBIND element. The first argument
-is the bound variables (placed within an OMBVAR element), and the second is an
-expression. -}
-forallSymbol :: Symbol
-forallSymbol = makeSymbol "quant1" "forall"
-
-{-| This symbol represents the existential ("there exists") quantifier which
-takes two arguments. It must be placed within an OMBIND element. The first
-argument is the bound variables (placed within an OMBVAR element), and the
-second is an expression. -}
-existsSymbol :: Symbol
-existsSymbol = makeSymbol "quant1" "exists"
− src/Text/OpenMath/Dictionary/Relation1.hs 
@@ -1,44 +0,0 @@--- Automatically generated from content dictionary relation1.ocd.  Do not change.
-module Text.OpenMath.Dictionary.Relation1 where
-
-import Text.OpenMath.Symbol
-
--- | List of symbols defined in relation1 dictionary
-relation1List :: [Symbol]
-relation1List = [eqSymbol, ltSymbol, gtSymbol, neqSymbol, leqSymbol, geqSymbol, approxSymbol]
-
-{-| This symbol represents the binary equality function. -}
-eqSymbol :: Symbol
-eqSymbol = makeSymbol "relation1" "eq"
-
-{-| This symbol represents the binary less than function which returns true if
-the first argument is less than the second, it returns false otherwise. -}
-ltSymbol :: Symbol
-ltSymbol = makeSymbol "relation1" "lt"
-
-{-| This symbol represents the binary greater than function which returns true
-if the first argument is greater than the second, it returns false otherwise.
--}
-gtSymbol :: Symbol
-gtSymbol = makeSymbol "relation1" "gt"
-
-{-| This symbol represents the binary inequality function. -}
-neqSymbol :: Symbol
-neqSymbol = makeSymbol "relation1" "neq"
-
-{-| This symbol represents the binary less than or equal to function which
-returns true if the first argument is less than or equal to the second, it
-returns false otherwise. -}
-leqSymbol :: Symbol
-leqSymbol = makeSymbol "relation1" "leq"
-
-{-| This symbol represents the binary greater than or equal to function which
-returns true if the first argument is greater than or equal to the second, it
-returns false otherwise. -}
-geqSymbol :: Symbol
-geqSymbol = makeSymbol "relation1" "geq"
-
-{-| This symbol is used to denote the approximate equality of its two
-arguments. -}
-approxSymbol :: Symbol
-approxSymbol = makeSymbol "relation1" "approx"
− src/Text/OpenMath/Dictionary/Transc1.hs 
@@ -1,149 +0,0 @@--- Automatically generated from content dictionary transc1.ocd.  Do not change.
-module Text.OpenMath.Dictionary.Transc1 where
-
-import Text.OpenMath.Symbol
-
--- | List of symbols defined in transc1 dictionary
-transc1List :: [Symbol]
-transc1List = [logSymbol, lnSymbol, expSymbol, sinSymbol, cosSymbol, tanSymbol, secSymbol, cscSymbol, cotSymbol, sinhSymbol, coshSymbol, tanhSymbol, sechSymbol, cschSymbol, cothSymbol, arcsinSymbol, arccosSymbol, arctanSymbol, arcsecSymbol, arccscSymbol, arccotSymbol, arcsinhSymbol, arccoshSymbol, arctanhSymbol, arcsechSymbol, arccschSymbol, arccothSymbol]
-
-{-| This symbol represents a binary log function; the first argument is the
-base, to which the second argument is log'ed. It is defined in Abramowitz and
-Stegun, Handbook of Mathematical Functions, section 4.1 -}
-logSymbol :: Symbol
-logSymbol = makeSymbol "transc1" "log"
-
-{-| This symbol represents the ln function (natural logarithm) as described in
-Abramowitz and Stegun, section 4.1. It takes one argument. Note the
-description in the CMP/FMP of the branch cut. If signed zeros are in use, the
-inequality needs to be non-strict. -}
-lnSymbol :: Symbol
-lnSymbol = makeSymbol "transc1" "ln"
-
-{-| This symbol represents the exponentiation function as described in
-Abramowitz and Stegun, section 4.2. It takes one argument. -}
-expSymbol :: Symbol
-expSymbol = makeSymbol "transc1" "exp"
-
-{-| This symbol represents the sin function as described in Abramowitz and
-Stegun, section 4.3. It takes one argument. -}
-sinSymbol :: Symbol
-sinSymbol = makeSymbol "transc1" "sin"
-
-{-| This symbol represents the cos function as described in Abramowitz and
-Stegun, section 4.3. It takes one argument. -}
-cosSymbol :: Symbol
-cosSymbol = makeSymbol "transc1" "cos"
-
-{-| This symbol represents the tan function as described in Abramowitz and
-Stegun, section 4.3. It takes one argument. -}
-tanSymbol :: Symbol
-tanSymbol = makeSymbol "transc1" "tan"
-
-{-| This symbol represents the sec function as described in Abramowitz and
-Stegun, section 4.3. It takes one argument. -}
-secSymbol :: Symbol
-secSymbol = makeSymbol "transc1" "sec"
-
-{-| This symbol represents the csc function as described in Abramowitz and
-Stegun, section 4.3. It takes one argument. -}
-cscSymbol :: Symbol
-cscSymbol = makeSymbol "transc1" "csc"
-
-{-| This symbol represents the cot function as described in Abramowitz and
-Stegun, section 4.3. It takes one argument. -}
-cotSymbol :: Symbol
-cotSymbol = makeSymbol "transc1" "cot"
-
-{-| This symbol represents the sinh function as described in Abramowitz and
-Stegun, section 4.5. It takes one argument. -}
-sinhSymbol :: Symbol
-sinhSymbol = makeSymbol "transc1" "sinh"
-
-{-| This symbol represents the cosh function as described in Abramowitz and
-Stegun, section 4.5. It takes one argument. -}
-coshSymbol :: Symbol
-coshSymbol = makeSymbol "transc1" "cosh"
-
-{-| This symbol represents the tanh function as described in Abramowitz and
-Stegun, section 4.5. It takes one argument. -}
-tanhSymbol :: Symbol
-tanhSymbol = makeSymbol "transc1" "tanh"
-
-{-| This symbol represents the sech function as described in Abramowitz and
-Stegun, section 4.5. It takes one argument. -}
-sechSymbol :: Symbol
-sechSymbol = makeSymbol "transc1" "sech"
-
-{-| This symbol represents the csch function as described in Abramowitz and
-Stegun, section 4.5. It takes one argument. -}
-cschSymbol :: Symbol
-cschSymbol = makeSymbol "transc1" "csch"
-
-{-| This symbol represents the coth function as described in Abramowitz and
-Stegun, section 4.5. It takes one argument. -}
-cothSymbol :: Symbol
-cothSymbol = makeSymbol "transc1" "coth"
-
-{-| This symbol represents the arcsin function. This is the inverse of the sin
-function as described in Abramowitz and Stegun, section 4.4. It takes one
-argument. -}
-arcsinSymbol :: Symbol
-arcsinSymbol = makeSymbol "transc1" "arcsin"
-
-{-| This symbol represents the arccos function. This is the inverse of the cos
-function as described in Abramowitz and Stegun, section 4.4. It takes one
-argument. -}
-arccosSymbol :: Symbol
-arccosSymbol = makeSymbol "transc1" "arccos"
-
-{-| This symbol represents the arctan function. This is the inverse of the tan
-function as described in Abramowitz and Stegun, section 4.4. It takes one
-argument. -}
-arctanSymbol :: Symbol
-arctanSymbol = makeSymbol "transc1" "arctan"
-
-{-| This symbol represents the arcsec function as described in Abramowitz and
-Stegun, section 4.4. -}
-arcsecSymbol :: Symbol
-arcsecSymbol = makeSymbol "transc1" "arcsec"
-
-{-| This symbol represents the arccsc function as described in Abramowitz and
-Stegun, section 4.4. -}
-arccscSymbol :: Symbol
-arccscSymbol = makeSymbol "transc1" "arccsc"
-
-{-| This symbol represents the arccot function as described in Abramowitz and
-Stegun, section 4.4. -}
-arccotSymbol :: Symbol
-arccotSymbol = makeSymbol "transc1" "arccot"
-
-{-| This symbol represents the arcsinh function as described in Abramowitz and
-Stegun, section 4.6. -}
-arcsinhSymbol :: Symbol
-arcsinhSymbol = makeSymbol "transc1" "arcsinh"
-
-{-| This symbol represents the arccosh function as described in Abramowitz and
-Stegun, section 4.6. -}
-arccoshSymbol :: Symbol
-arccoshSymbol = makeSymbol "transc1" "arccosh"
-
-{-| This symbol represents the arctanh function as described in Abramowitz and
-Stegun, section 4.6. -}
-arctanhSymbol :: Symbol
-arctanhSymbol = makeSymbol "transc1" "arctanh"
-
-{-| This symbol represents the arcsech function as described in Abramowitz and
-Stegun, section 4.6. -}
-arcsechSymbol :: Symbol
-arcsechSymbol = makeSymbol "transc1" "arcsech"
-
-{-| This symbol represents the arccsch function as described in Abramowitz and
-Stegun, section 4.6. -}
-arccschSymbol :: Symbol
-arccschSymbol = makeSymbol "transc1" "arccsch"
-
-{-| This symbol represents the arccoth function as described in Abramowitz and
-Stegun, section 4.6. -}
-arccothSymbol :: Symbol
-arccothSymbol = makeSymbol "transc1" "arccoth"
− src/Text/OpenMath/FMP.hs 
@@ -1,53 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Formal mathematical properties (FMP)
---
------------------------------------------------------------------------------
-module Text.OpenMath.FMP where
-
-import Data.List (union)
-import Text.OpenMath.Dictionary.Quant1 (forallSymbol, existsSymbol)
-import Text.OpenMath.Dictionary.Relation1 (eqSymbol, neqSymbol)
-import Text.OpenMath.Object
-import Text.OpenMath.Symbol
-
-data FMP = FMP
-   { quantor       :: Symbol
-   , metaVariables :: [String]
-   , leftHandSide  :: OMOBJ
-   , relation      :: Symbol
-   , rightHandSide :: OMOBJ
-   }
-
-toObject :: FMP -> OMOBJ
-toObject fmp
-   | null (metaVariables fmp) = body
-   | otherwise =
-        OMBIND (OMS (quantor fmp)) (metaVariables fmp) body
- where
-   body = OMA [OMS (relation fmp), leftHandSide fmp, rightHandSide fmp]
-
-eqFMP :: OMOBJ -> OMOBJ -> FMP
-eqFMP lhs rhs = FMP
-   { quantor       = forallSymbol
-   , metaVariables = getOMVs lhs `union` getOMVs rhs
-   , leftHandSide  = lhs
-   , relation      = eqSymbol
-   , rightHandSide = rhs
-   }
-
--- | Represents a common misconception. In certain (most) situations,
--- the two objects are not the same.
-buggyFMP :: OMOBJ -> OMOBJ -> FMP
-buggyFMP lhs rhs = (eqFMP lhs rhs)
-   { quantor  = existsSymbol
-   , relation = neqSymbol
-   }
− src/Text/OpenMath/MakeSymbols.hs 
@@ -1,93 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Create symbol definitions from OpenMath content dictionary (ocd)
---
------------------------------------------------------------------------------
-module Text.OpenMath.MakeSymbols where
-
-import Control.Monad
-import Data.Char
-import Data.List
-import Text.OpenMath.ContentDictionary hiding (main)
-
-main :: IO ()
-main = do
-   let base   = "lib/Dictionaries"
-       target = "src/Text/Openmath/Dictionary"
-   ocds <- findOCDs base
-   forM_ ocds $ \s -> do
-      let modn = target ++ "/" ++ moduleName s ++ ".hs"
-      txt <- makeSymbols (base ++ "/" ++ s)
-      putStrLn $ "  writing " ++ modn
-      writeFile modn txt
-
-moduleName :: String -> String
-moduleName s = dropSuffix (map toUpper (take 1 s) ++ drop 1 s)
-
-dropDir :: String -> String
-dropDir s
-   | '/' `elem` s = dropDir $ drop 1  $dropWhile (/='/') s
-   | otherwise    = s
-
-dropSuffix :: String -> String
-dropSuffix = takeWhile (/='.')
-
-makeSymbols :: String -> IO String
-makeSymbols file = do
-   cd <- readContentDictionary file
-   let cdname = dropDir file
-   return $ unlines $
-      [ "-- Automatically generated from content dictionary " ++ cdname ++ ". \
-        \ Do not change."
-      , "module Text.OpenMath.Dictionary." ++ moduleName cdname ++ " where\n"
-      , "import Text.OpenMath.Symbol\n"
-      , makeSymbolList cd
-      ] ++
-      map (makeSymbol (dropSuffix cdname)) (definitions cd)
-
-symbolIdentifier :: Definition -> String
-symbolIdentifier d = f (symbolName d) ++ "Symbol"
- where f xs = map toLower (take 1 xs) ++ camelCase (drop 1 xs)
-
-camelCase :: String -> String
-camelCase []         = []
-camelCase ('_':x:xs) = toUpper x : camelCase xs
-camelCase (x:xs)     = x : camelCase xs
-
-makeSymbolList :: ContentDictionary -> String
-makeSymbolList cd = unlines
-   [ "-- | List of symbols defined in " ++ dictionaryName cd ++ " dictionary"
-   , name ++ " :: [Symbol]"
-   , name ++ " = [" ++ intercalate ", " list ++ "]"
-   ]
- where
-   name = dictionaryName cd ++ "List"
-   list = map symbolIdentifier (definitions cd)
-
-makeSymbol :: String -> Definition -> String
-makeSymbol dict def = unlines $
-   makeComment 80 (symbolDescription def) ++
-   [ name ++ " :: Symbol"
-   , name ++ " = makeSymbol " ++ show dict ++ " " ++ show (symbolName def)
-   ]
- where
-    name = symbolIdentifier def
-
-makeComment :: Int -> String -> [String]
-makeComment n = breaks . comment . words
- where
-   comment xs = ["{-|"] ++ xs ++ ["-}"]
-   accLength  = scanl (\n -> (+n) . succ . length) 0
-   breaks xs
-      | null xs   = []
-      | otherwise =
-           case break ((>=n) . fst) (zip (drop 1 (accLength xs)) xs) of
-              (as, bs) -> unwords (map snd as) : breaks (map snd bs)
− src/Text/OpenMath/Object.hs 
@@ -1,129 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}
------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Text.OpenMath.Object
-   ( OMOBJ(..), getOMVs, xml2omobj, omobj2xml
-   ) where
-
-import Data.Char
-import Data.Generics.Uniplate.Direct hiding (children)
-import Data.List (nub)
-import Data.Maybe
-import Data.Typeable
-import Text.OpenMath.Symbol
-import Text.XML
-
--- internal representation for OpenMath objects
-data OMOBJ = OMI Integer
-           | OMF Double
-           | OMV String
-           | OMS Symbol
-           | OMA [OMOBJ]
-           | OMBIND OMOBJ [String] OMOBJ
-   deriving (Show, Eq, Typeable)
-
-instance InXML OMOBJ where
-   toXML   = omobj2xml
-   fromXML = either fail return . xml2omobj
-
-instance Uniplate OMOBJ where
-   uniplate omobj =
-      case omobj of
-         OMA xs        -> plate OMA ||* xs
-         OMBIND a ss b -> plate OMBIND |* a |- ss |* b
-         _             -> plate omobj
-
-getOMVs :: OMOBJ -> [String]
-getOMVs omobj = nub [ x | OMV x <- universe omobj ]
-
-----------------------------------------------------------
--- conversion functions: XML <-> OMOBJ
-
-xml2omobj :: XML -> Either String OMOBJ
-xml2omobj xmlTop =
-   case xmlTop of
-      Element "OMOBJ" _ [Right e] -> rec e
-      _ -> fail $ "expected an OMOBJ tag" ++ show xmlTop
- where
-   rec xml =
-      case content xml of
-
-         _ | name xml == "OMA" -> do
-            ys <- mapM rec (children xml)
-            return (OMA ys)
-
-         [] | name xml == "OMS" -> do
-            let mcd = findAttribute "cd" xml
-            n <- findAttribute "name" xml
-            return (OMS (mcd, n))
-
-         [Left s] | name xml == "OMI" ->
-            case readInt s of
-               Just i -> return (OMI (toInteger i))
-               _      -> fail "invalid integer in OMI"
-
-         [] | name xml == "OMF" -> do
-            s <- findAttribute "dec" xml
-            case readDouble s of
-               Just nr -> return (OMF nr)
-               _       -> fail "invalid floating-point in OMF"
-
-         [] | name xml == "OMV" -> do
-            s <- findAttribute "name" xml
-            return (OMV s)
-
-         [Right x1, Right x2, Right x3] | name xml == "OMBIND" -> do
-            y1 <- rec x1
-            y2 <- recOMBVAR x2
-            y3 <- rec x3
-            return (OMBIND y1 y2 y3)
-
-         _ -> fail ("invalid tag " ++ show (name xml))
-
-   recOMBVAR xml
-      | name xml == "OMBVAR" =
-           let f (Right (OMV s)) = return s
-               f this = fail $ "expected tag OMV in OMBVAR, but found " ++ show this
-           in mapM (f . rec) (children xml)
-      | otherwise =
-           fail ("expected tag OMVAR, but found " ++ show (name xml))
-
-omobj2xml :: OMOBJ -> XML
-omobj2xml object = makeXML "OMOBJ" $ do
-   "xmlns"   .=. "http://www.openmath.org/OpenMath"
-   "version" .=. "2.0"
-   "cdbase"  .=. "http://www.openmath.org/cd"
-   rec object
- where
-   rec omobj =
-      case omobj of
-         OMI i  -> element "OMI" (text (show i))
-         OMF f  -> element "OMF" ("dec" .=. show f)
-         OMV v  -> element "OMV" ("name" .=. v)
-         OMA xs -> element "OMA" (mapM_ rec xs)
-         OMS s  -> element "OMS" $ do
-            "cd"   .=. fromMaybe "unknown" (dictionary s)
-            "name" .=. symbolName s
-         OMBIND x ys z -> element "OMBIND" $ do
-            rec x
-            element "OMBVAR" (mapM_ (rec . OMV) ys)
-            rec z
-
-readInt :: String -> Maybe Integer
-readInt s = case reads s of
-               [(n, xs)] | all isSpace xs -> Just n
-               _ -> Nothing
-
-readDouble :: String -> Maybe Double
-readDouble s = case reads s of
-                  [(n, xs)] | all isSpace xs -> Just n
-                  _ -> Nothing
− src/Text/OpenMath/Symbol.hs 
@@ -1,35 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Text.OpenMath.Symbol where
-
-type Symbol = (Maybe String, String)
-
--- * Constructor functions
-
-makeSymbol :: String -> String -> Symbol
-makeSymbol = (,) . Just
-
-extraSymbol :: String -> Symbol
-extraSymbol = (,) Nothing
-
--- * Selector functions
-
-dictionary :: Symbol -> Maybe String
-dictionary = fst
-
-symbolName :: Symbol -> String
-symbolName = snd
-
--- * Utility function
-
-showSymbol :: Symbol -> String
-showSymbol s = maybe "" (++".") (dictionary s) ++ symbolName s
− src/Text/OpenMath/Tests.hs 
@@ -1,50 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Text.OpenMath.Tests (propEncoding) where
-
-import Control.Monad
-import Test.QuickCheck
-import Text.OpenMath.Dictionary.Arith1
-import Text.OpenMath.Dictionary.Calculus1
-import Text.OpenMath.Dictionary.Fns1
-import Text.OpenMath.Dictionary.Linalg2
-import Text.OpenMath.Dictionary.List1
-import Text.OpenMath.Dictionary.Logic1
-import Text.OpenMath.Dictionary.Nums1
-import Text.OpenMath.Dictionary.Quant1
-import Text.OpenMath.Dictionary.Relation1
-import Text.OpenMath.Dictionary.Transc1
-import Text.OpenMath.Object
-
-arbOMOBJ :: Gen OMOBJ
-arbOMOBJ = sized rec
- where
-   symbols = arith1List ++ calculus1List ++ fns1List ++ linalg2List ++
-      list1List ++ logic1List ++ nums1List ++ quant1List ++
-      relation1List ++ transc1List
-
-   rec 0 = frequency
-      [ (1, liftM OMI arbitrary)
-      , (1, liftM (\n -> OMF (fromInteger n / 1000)) arbitrary)
-      , (1, liftM OMV arbitrary)
-      , (5, elements $ map OMS symbols)
-      ]
-   rec n = frequency
-      [ (1, rec 0)
-      , (3, choose (1,4) >>= liftM OMA . (`replicateM` f))
-      , (1, liftM3 OMBIND f arbitrary f)
-      ]
-    where
-      f = rec (n `div` 2)
-
-propEncoding :: Property
-propEncoding = forAll arbOMOBJ $ \x -> xml2omobj (omobj2xml x) == Right x
− src/Text/Parsing.hs 
@@ -1,118 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Utility functions for parsing with Parsec library
---
------------------------------------------------------------------------------
-module Text.Parsing
-   ( module Export
-   , (<*>), (*>), (<*), (<$>), (<$), (<**>)
-   , parseSimple, complete, skip, (<..>), ranges, stopOn
-   , naturalOrFloat, float
-   , UnbalancedError(..), balanced
-   ) where
-
-import Control.Applicative hiding ((<|>))
-import Control.Arrow
-import Data.Char
-import Data.List
-import Text.ParserCombinators.Parsec as Export
-import Text.ParserCombinators.Parsec.Expr as Export
-import Text.ParserCombinators.Parsec.Language as Export
-import Text.ParserCombinators.Parsec.Pos
-
-parseSimple :: Parser a -> String -> Either String a
-parseSimple p = left show . runParser (complete p) () ""
-
-complete :: Parser a -> Parser a
-complete p = spaces *> (p <* eof)
-
-skip :: Parser a -> Parser ()
-skip p = p >> return ()
-
--- Like the combinator from parser, except that for doubles
--- the read instance is used. This is a more precies representation
--- of the double (e.g., 1.413 is not 1.413000000001).
-naturalOrFloat :: Parser (Either Integer Double)
-naturalOrFloat = do
-   a <- num
-   b <- option "" ((:) <$> char '.' <*> nat)
-   c <- option "" ((:) <$> oneOf "eE" <*> num)
-   spaces
-   case reads (a++b++c) of
-      _ | null b && null c ->
-         case a of
-            '-':xs -> return (Left (negate (readInt xs)))
-            xs     -> return (Left (readInt xs))
-      [(d, [])] -> return (Right d)
-      _         -> fail "not a float"
- where
-   nat = many1 digit
-   num = maybe id (:) <$> optionMaybe (char '-') <*> nat
-   readInt = foldl' op 0 -- '
-   op a b  = a*10+fromIntegral (ord b)-48
-
-float :: Parser Double
-float = do
-   a <- nat
-   b <- option "" ((:) <$> char '.' <*> nat)
-   c <- option "" ((:) <$> oneOf "eE" <*> num)
-   case reads (a++b++c) of
-      [(d, [])] -> return d
-      _         -> fail "not a float"
- where
-   nat = many1 digit
-   num = (:) <$> char '-' <*> nat
-
-infix  6 <..>
-
-(<..>) :: Char -> Char -> Parser Char
-x <..> y = satisfy (\c -> c >= x && c <= y)
-
-ranges :: [(Char, Char)] -> Parser Char
-ranges xs = choice [ a <..> b | (a, b) <- xs ]
-
--- return in local function f needed for backwards compatibility
-stopOn :: [String] -> Parser String
-stopOn ys = rec
- where
-   stop = choice (map f ys)
-   f x  = try (string x >> return ' ')
-   rec  =  (:) <$ notFollowedBy stop <*> anyChar <*> rec
-       <|> return []
-
--- simple function for finding unbalanced pairs (e.g. parentheses)
-balanced :: [(Char, Char)] -> String -> Maybe UnbalancedError
-balanced table = run (initialPos "") []
- where
-   run _ [] [] = Nothing
-   run _ ((pos, c):_) [] = return (NotClosed pos c)
-   run pos stack (x:xs)
-      | x `elem` opens  =
-           run next ((pos, x):stack) xs
-      | x `elem` closes =
-           case stack of
-              (_, y):rest | Just x == lookup y table -> run next rest xs
-              _ -> return (NotOpened pos x)
-      | otherwise =
-           run next stack xs
-    where
-      next = updatePosChar pos x
-
-   (opens, closes) = unzip table
-
-data UnbalancedError = NotClosed SourcePos Char
-                     | NotOpened SourcePos Char
-
-instance Show UnbalancedError where
-   show (NotClosed pos c) =
-      show pos ++ ": Opening symbol " ++ [c] ++ " is not closed"
-   show (NotOpened pos c) =
-      show pos ++ ": Closing symbol " ++ [c] ++ " has no matching symbol"
− src/Text/UTF8.hs 
@@ -1,123 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Support for the UTF8 encoding
---
------------------------------------------------------------------------------
-module Text.UTF8
-   ( encode, encodeM, decode, decodeM
-   , isUTF8, allBytes, propEncoding
-   ) where
-
-import Control.Monad.Error
-import Data.Char
-import Data.Maybe
-import Test.QuickCheck
-
-------------------------------------------------------------------
--- Interface
-
--- | Encode a string to UTF8 format
-encode :: String -> String
-encode = either error id . encodeM
-
--- | Decode an UTF8 format string to unicode points
-decode :: String -> String
-decode = either error id . decodeM
-
--- | Encode a string to UTF8 format (monadic)
-encodeM :: Monad m => String -> m String
-encodeM = liftM (map chr . concat) . mapM (toUTF8 . ord)
-
--- | Decode an UTF8 format string to unicode points (monadic)
-decodeM :: Monad m => String -> m String
-decodeM = liftM (map chr) . fromUTF8 . map ord
-
--- | Test whether the argument is a proper UTF8 string
-isUTF8 :: String -> Bool
-isUTF8 = isJust . decodeM
-
--- | Test whether all characters are in the range 0-255
-allBytes :: String -> Bool
-allBytes = all ((`between` (0, 255)) . ord)
-
-------------------------------------------------------------------
--- Helper functions
-
-toUTF8 :: Monad m => Int -> m [Int]
-toUTF8 n
-   | n < 128 = -- one byte
-        return [n]
-   | n < 2048 = -- two bytes
-        let (a, d) = n `divMod` 64
-        in return [a+192, d+128]
-   | n < 65536 = -- three bytes
-        let (a, d1) = n  `divMod` 4096
-            (b, d2) = d1 `divMod` 64
-        in return [a+224, b+128, d2+128]
-   | n < 1114112 = -- four bytes
-        let (a, d1) = n  `divMod` 262144
-            (b, d2) = d1 `divMod` 4096
-            (c, d3) = d2 `divMod` 64
-        in return [a+240, b+128, c+128, d3+128]
-   | otherwise =
-        fail "invalid character in UTF8"
-
-fromUTF8 :: Monad m => [Int] -> m [Int]
-fromUTF8 xs
-   | null xs   = return []
-   | otherwise = do
-        (i, rest) <- f xs
-        is <- fromUTF8 rest
-        return (i:is)
- where
-   f (a:rest) | a < 128 = -- one byte
-      return (a, rest)
-   f (a:b:rest) | a `between` (192, 223) = do -- two bytes
-      unless (isHigh b) $
-         fail "invalid UTF8 character (two bytes)"
-      return ((a-192)*64 + b-128, rest)
-   f (a:b:c:rest) | a `between` (224, 239) = do -- three bytes
-      unless (isHigh b && isHigh c) $
-         fail "invalid UTF8 character (three bytes)"
-      return ((a-224)*4096 + (b-128)*64 + c-128, rest)
-   f (a:b:c:d:rest) | a >= 240 && a < 248 = do -- four bytes
-      let value = (a-240)*262144 + (b-128)*4096 + (c-128)*64 + d-128
-      unless (isHigh b && isHigh c && isHigh d && value <= 1114111) $
-         fail "invalid UTF8 character (four bytes)"
-      return (value, rest)
-   f _ = fail "invalid character in UTF8"
-
-isHigh :: Int -> Bool
-isHigh i = i `between` (128, 191)
-
-between :: Ord a => a -> (a, a) -> Bool
-between a (low, high) = low <= a && a <= high
-
-------------------------------------------------------------------
--- Test encoding
-
--- | QuickCheck internal encoding/decoding functions
-propEncoding :: Property
-propEncoding = forAll (sized gen) valid
- where
-   gen n = replicateM n someChar
-   someChar = liftM chr $ oneof
-      -- To get a nice distribution over the number of bytes used
-      -- in the encoding
-      [ choose (0, 127), choose (128, 2047)
-      , choose (2048, 65535), choose (65536, 1114111)
-      ]
-
-valid :: String -> Bool
-valid xs = fromMaybe False $
-   do us <- encodeM xs
-      bs <- decodeM us
-      return (xs == bs)
− src/Text/XML.hs 
@@ -1,153 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A datatype, parser, and pretty printer for XML documents. Re-exports
--- functions defined elsewhere.
---
------------------------------------------------------------------------------
-module Text.XML
-   ( XML, Attr, AttrList, InXML(..), Element(..)
-   , XMLBuilder, makeXML, text, unescaped, element, tag, attribute
-   , parseXML, showXML, compactXML, (.=.), findAttribute, updateLast
-   , children, Attribute(..), builder, findChild, getData
-   ) where
-
-import Control.Monad.State
-import Data.Char
-import Data.Monoid
-import Text.XML.Interface hiding (parseXML)
-import qualified Text.XML.Interface as I
-
-----------------------------------------------------------------
--- Datatype definitions
-
--- two helper types for attributes
-type XML      = Element
-type Attr     = Attribute  -- (String, String)
-type AttrList = Attributes -- [Attr]
-
-class InXML a where
-   toXML       :: a -> XML
-   listToXML   :: [a] -> XML
-   fromXML     :: Monad m => XML -> m a
-   listFromXML :: Monad m => XML -> m [a]
-   -- default definitions
-   listToXML = Element "list" [] . map (Right . toXML)
-   listFromXML xml
-      | name xml == "list" && null (attributes xml) =
-           mapM fromXML (children xml)
-      | otherwise = fail "expecting a list tag"
-
-----------------------------------------------------------------
--- XML parser (a scanner and a XML tree constructor)
-
-parseXML :: String -> Either String XML
-parseXML input = do
-   xml <- I.parseXML input
-   return (ignoreLayout xml)
-
-ignoreLayout :: XML -> XML
-ignoreLayout (Element n as xs) =
-   let f = either (Left . trim) (Right . ignoreLayout)
-   in Element n as (map f xs)
-
-indentXML :: XML -> XML
-indentXML = rec 0
- where
-   rec i (Element n as xs) =
-      let ipl  = i+2
-          cd j = Left ('\n' : replicate j ' ')
-          f    = either (\x -> [cd ipl, Left x]) (\x -> [cd ipl, Right (rec ipl x)])
-          body | null xs   = xs
-               | otherwise = concatMap f xs ++ [cd i]
-      in Element n as body
-
-showXML :: XML -> String
-showXML = (++"\n") . show . indentXML . ignoreLayout
-
-compactXML :: XML -> String
-compactXML = show . ignoreLayout
-
-----------------------------------------------------------------
--- Monadic XML builder
-
--- Uses the fast-append trick on lists
-data BuilderState = BS { bsAttributes :: AttrList -> AttrList, bsElements :: Content -> Content }
-
--- local helper
-emptyBS :: BuilderState
-emptyBS = BS id id
-
-appendAttrBS :: Attr -> BuilderState -> BuilderState
-appendAttrBS a bs = bs { bsAttributes = bsAttributes bs . (a:) }
-
-appendElemBS :: Either String Element -> BuilderState -> BuilderState
-appendElemBS e bs = bs { bsElements = bsElements bs . (e:) }
-
-type XMLBuilder = XMLBuilderM ()
-
-newtype XMLBuilderM a = XMLBuilder { unBuild :: State BuilderState a }
-
-instance Monoid a => Monoid (XMLBuilderM a) where
-   mempty  = return mempty
-   mappend = (>>)
-
-instance Monad XMLBuilderM where
-   return  = XMLBuilder . return
-   m >>= f = XMLBuilder (unBuild m >>= (unBuild . f))
-
-makeXML :: String -> XMLBuilder -> XML
-makeXML s m =
-   let bs = execState (unBuild m) emptyBS
-   in Element s (bsAttributes bs []) (bsElements bs [])
-
-text :: String -> XMLBuilder
-text = unescaped . escape
-
-updateLast :: (Element -> Element) -> XMLBuilderM a -> XMLBuilderM a
-updateLast f m = XMLBuilder $ do
-   a <- unBuild m
-   modify $ \s -> s {bsElements = (++) (rec (bsElements s []))}
-   return a
- where
-   rec []     = []
-   rec [x]    = [fmap f x]
-   rec (x:xs) = x:rec xs
-
--- Should be used with care: the argument String is not escaped, and
--- therefore may contain xml tags or xml entities
-unescaped :: String -> XMLBuilder
-unescaped = XMLBuilder . modify . appendElemBS . Left
-
-element :: String -> XMLBuilder -> XMLBuilder
-element s = XMLBuilder . modify . appendElemBS . Right . makeXML s
-
-tag :: String -> XMLBuilder
-tag s = element s (return ())
-
-attribute :: Attr -> XMLBuilder
-attribute = XMLBuilder . modify . appendAttrBS
-
-(.=.) :: String -> String -> XMLBuilder
-n .=. s = attribute (n := s)
-
-builder :: Element -> XMLBuilder
-builder = XMLBuilder . modify . appendElemBS . Right
-
-escape :: String -> String
-escape = concatMap f
- where
-   f '<' = "&lt;"
-   f '>' = "&gt;"
-   f '&' = "&amp;"
-   f c   = [c]
-
-trim :: String -> String
-trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
− src/Text/XML/Document.hs 
@@ -1,234 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Datatype for representing XML documents
---
------------------------------------------------------------------------------
-module Text.XML.Document
-   ( Name, Attributes, Attribute(..), Reference(..), Parameter(..)
-   , XMLDoc(..), XML(..), Element(..), Content, DTD(..), DocTypeDecl(..)
-   , ContentSpec(..), CP(..), AttType(..), DefaultDecl(..), AttDef
-   , EntityDef, AttValue, EntityValue, ExternalID(..), PublicID
-   , Conditional(..), TextDecl, External
-   ) where
-
-type Name = String
-
-type Attributes = [Attribute]
-data Attribute  = Name := AttValue
-
-data Reference = CharRef Int | EntityRef String
-
-data Parameter = Parameter String
-
-data XMLDoc = XMLDoc
-   { versionInfo :: Maybe String
-   , encoding    :: Maybe String
-   , standalone  :: Maybe Bool
-   , dtd         :: Maybe DTD
-   , externals   :: [(String, External)]
-   , root        :: Element
-   }
-
-data XML = Tagged Element
-         | CharData String
-         | CDATA String
-         | Reference Reference
-
-data Element = Element
-   { name       :: Name
-   , attributes :: Attributes
-   , content    :: Content
-   }
-
-type Content = [XML]
-
-data DTD = DTD Name (Maybe ExternalID) [DocTypeDecl]
-
-data DocTypeDecl = ElementDecl Name ContentSpec
-                 | AttListDecl Name [AttDef]
-                 | EntityDecl Bool Name EntityDef
-                 | NotationDecl Name (Either ExternalID PublicID)
-                 | DTDParameter Parameter
-                 | DTDConditional Conditional
-
-data ContentSpec = Empty | Any | Mixed Bool [Name] | Children CP
-
--- content particles
-data CP = Choice [CP] | Sequence [CP] | QuestionMark CP | Star CP | Plus CP | CPName Name
-
-data AttType = IdType | IdRefType | IdRefsType | EntityType | EntitiesType | NmTokenType | NmTokensType
-             | StringType | EnumerationType [String] | NotationType [String]
-
-data DefaultDecl = Required | Implied | Value AttValue | Fixed AttValue
-
-type AttDef = (Name, AttType, DefaultDecl)
-type EntityDef = Either EntityValue (ExternalID, Maybe String)
-type AttValue    = [Either Char Reference]
-type EntityValue = [Either Char (Either Parameter Reference)]
-
-data ExternalID = System String | Public String String
-
-type PublicID = String
-
-data Conditional = Include [DocTypeDecl] | Ignore [String]
-
-type TextDecl = (Maybe String, String)
-
-type External = (Maybe TextDecl, Content)
-
----
-{-
-instance Show XMLDoc where
-   show doc = showXMLDecl doc ++ maybe "" show (dtd doc) ++ show (root doc)
--}
-instance Show Attribute where
-   show (n := v) = n ++ "=" ++ showAttValue v
-
-instance Show Element where
-   show (Element n as c)
-      | null c    = showOpenTag True n as
-      | otherwise = showOpenTag False n as ++ concatMap show c ++ showCloseTag n
-
-instance Show XML where
-   show xml =
-      case xml of
-         Tagged e    -> show e
-         CharData s  -> s
-         CDATA s     -> "<![CDATA[" ++ s ++ "]]>"
-         Reference r -> show r
-
-instance Show Reference where
-   show ref =
-      case ref of
-         CharRef n   -> "&#" ++ show n ++ ";"
-         EntityRef s -> "&" ++ s ++ ";"
-
-instance Show Parameter where
-   show (Parameter s) = "%" ++ s ++ ";"
-{-
-instance Show DTD where
-   show (DTD n mid ds) = "<!DOCTYPE " ++ unwords list ++ ">"
-    where
-      list = n : catMaybes [fmap show mid, showDecls ds]
-      showDecls xs
-         | null xs   = Nothing
-         | otherwise = Just $ "[" ++ concatMap show xs ++ "]"
-
-instance Show ExternalID where
-   show extID =
-      case extID of
-         System s   -> "SYSTEM " ++ doubleQuote s
-         Public p s -> unwords ["PUBLIC", doubleQuote p, doubleQuote s]
-
-instance Show DocTypeDecl where
-   show decl =
-      case decl of
-         ElementDecl n c  -> "<!ELEMENT " ++ n ++ " " ++ show c ++ ">"
-         AttListDecl n as -> "<!ATTLIST " ++ unwords (n:map showAttDef as) ++ ">"
-         EntityDecl b n e ->
-            let xs = ["%" | not b] ++ [n, showEntityDef e]
-            in "<!ENTITY " ++ unwords xs ++ ">"
-         NotationDecl n e ->
-            let f s = "PUBLIC " ++ doubleQuote s
-            in "<!NOTATION " ++ n ++ " " ++ either show f e ++ ">"
-         DTDParameter r   -> show r
-         DTDConditional c -> show c
-
-instance Show ContentSpec where
-   show cspec =
-      case cspec of
-         Empty -> "EMPTY"
-         Any   -> "ANY"
-         Mixed b ns ->
-            let txt = intercalate "|" ("#PCDATA":ns)
-            in parenthesize txt ++ (if b then "*" else "")
-         Children cp -> show cp
-
-instance Show CP where
-   show cp =
-      case cp of
-         Choice xs      -> parenthesize (intercalate "|" (map show xs))
-         Sequence xs    -> parenthesize (intercalate "," (map show xs))
-         QuestionMark c -> show c ++ "?"
-         Star c         -> show c ++ "*"
-         Plus c         -> show c ++ "+"
-         CPName n       -> n
-
-instance Show AttType where
-   show attType =
-      case attType of
-         IdType       -> "ID"
-         IdRefType    -> "IDREF"
-         IdRefsType   -> "IDREFS"
-         EntityType   -> "ENTITY"
-         EntitiesType -> "ENTITIES"
-         NmTokenType  -> "NMTOKEN"
-         NmTokensType -> "NMTOKENS"
-         StringType   -> "CDATA"
-         EnumerationType xs -> parenthesize (intercalate "|" xs)
-         NotationType xs    -> "NOTATION " ++ parenthesize (intercalate "|" xs)
-
-instance Show DefaultDecl where
-   show defaultDecl =
-      case defaultDecl of
-         Required -> "#REQUIRED"
-         Implied  -> "#IMPLIED"
-         Value v  -> showAttValue v
-         Fixed v  -> "#FIXED " ++ showAttValue v
-
-instance Show Conditional where
-   show conditional =
-      case conditional of
-         Include xs -> "<![INCLUDE[" ++ concatMap show xs ++ "]]>"
-         Ignore _ -> "" -- ToDO undefined -- [String]
-
-showXMLDecl :: XMLDoc -> String
-showXMLDecl doc
-   | isJust (versionInfo doc) = "<?xml " ++ unwords (catMaybes [s1,s2,s3]) ++ "?>"
-   | otherwise = ""
- where
-   s1 = fmap (\s -> "version=" ++ doubleQuote s) (versionInfo doc)
-   s2 = fmap (\s -> "encoding=" ++ doubleQuote s) (encoding doc)
-   s3 = fmap (\b -> "standalone=" ++ doubleQuote (if b then "yes" else "no")) (standalone doc)
--}
-showOpenTag :: Bool -> Name -> Attributes -> String
-showOpenTag close n as = "<" ++ unwords (n:map show as) ++
-   (if close then "/>" else ">")
-
-showCloseTag :: Name -> String
-showCloseTag n = "</" ++ n ++ ">"
-
-showAttValue :: AttValue -> String -- TODO: no double quotes allowed (should be escaped)
-showAttValue = doubleQuote . concatMap (either f show)
- where
-   f '"' = []
-   f c   = [c]
-{-
-showEntityValue :: EntityValue -> String
-showEntityValue = doubleQuote . concatMap (either f (either show show))
- where
-   f '"' = []
-   f c   = [c]
-
-showAttDef :: AttDef -> String
-showAttDef (s, tp, dd) = unwords [s, show tp, show dd]
-
-showEntityDef :: EntityDef -> String
-showEntityDef entityDef =
-   case entityDef of
-      Left ev -> showEntityValue ev
-      Right (eid, ms) -> show eid ++ maybe "" (" NDATA "++) ms
--}
-doubleQuote :: String -> String
-doubleQuote s = "\"" ++ s ++ "\""
-{-
-parenthesize :: String -> String
-parenthesize s = "(" ++ s ++ ")" -}
− src/Text/XML/Interface.hs 
@@ -1,128 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Collection of common operation on XML documents
---
------------------------------------------------------------------------------
-module Text.XML.Interface
-   ( Element(..), Content, Attribute(..), Attributes
-   , normalize, parseXML
-   , children, findAttribute, findChild, getData
-   ) where
-
-import Control.Arrow
-import Data.Char (chr, ord)
-import Data.Maybe
-import Text.Parsing (parseSimple)
-import Text.XML.Document (Name)
-import Text.XML.Parser (document)
-import Text.XML.Unicode (decoding)
-import qualified Text.XML.Document as D
-
-data Element = Element
-   { name       :: Name
-   , attributes :: Attributes
-   , content    :: Content
-   }
-
-instance Show Element where
-   show = show . extend
-
-type Content = [Either String Element]
-
-type Attributes = [Attribute]
-data Attribute = Name := String
-
-normalize :: D.XMLDoc -> Element
-normalize doc = toElement (D.root doc)
- where
-   toElement :: D.Element -> Element
-   toElement (D.Element n as c) =
-      Element n (map toAttribute as) (toContent c)
-
-   toAttribute :: D.Attribute -> Attribute
-   toAttribute (n D.:= v) =
-      n := concatMap (either return refToString) v
-
-   toContent :: D.Content -> Content
-   toContent = merge . concatMap f
-    where
-      f :: D.XML -> Content
-      f (D.Tagged e)    = [Right (toElement e)]
-      f (D.CharData s)  = [Left s]
-      f (D.CDATA s)     = [Left s]
-      f (D.Reference r) = refToContent r
-
-   refToString :: D.Reference -> String
-   refToString (D.CharRef i)   = [chr i]
-   refToString (D.EntityRef _) = "" -- error
-
-   refToContent :: D.Reference -> Content
-   refToContent (D.CharRef i)   = [Left [chr i]]
-   refToContent (D.EntityRef s) =
-      fromJust (lookup s entities)
-
-   entities :: [(String, Content)]
-   entities =
-      [ (n, toContent (snd ext)) | (n, ext) <- D.externals doc ] ++
-      -- predefined entities
-      map (second (return . Left . return))
-         [("lt",'<'), ("gt",'>'), ("amp",'&'), ("apos",'\''), ("quot",'"')]
-
-   merge :: Content -> Content
-   merge (Left s:Left t:rest) = merge (Left (s++t) : rest)
-   merge (x:xs) = x:merge xs
-   merge []     = []
-
-extend :: Element -> D.Element
-extend (Element n as c) =
-   D.Element n (map toAttribute as) (concatMap toXML c)
- where
-   toAttribute :: Attribute -> D.Attribute
-   toAttribute (m := s) = (D.:=) m (map Left s)
-
-   toXML :: Either String Element -> [D.XML]
-   toXML = either fromString (return . D.Tagged . extend)
-
-   fromString :: String -> [D.XML]
-   fromString [] = []
-   fromString xs@(hd:tl)
-      | null xs1  = D.Reference (D.CharRef (ord hd)) : fromString tl
-      | otherwise = D.CharData xs1 : fromString xs2
-    where
-      (xs1, xs2) = break ((> 127) . ord) xs
-
------------------------------------------------------
-
-parseXML :: String -> Either String Element
-parseXML xs = do
-   input <- decoding xs
-   doc   <- parseSimple document input
-   return (normalize doc)
-
------------------------------------------------------
-
-findAttribute :: Monad m => String -> Element -> m String
-findAttribute s (Element _ as _) =
-   case [ t | n := t <- as, s==n ] of
-      [hd] -> return hd
-      _    -> fail $ "Invalid attribute: " ++ show s
-
-findChild :: Monad m => String -> Element -> m Element
-findChild s e =
-   case filter ((==s) . name) (children e) of
-      [a] -> return a
-      _   -> fail $ "Child not found: " ++ show s
-
-children :: Element -> [Element]
-children e = [ c | Right c <- content e ]
-
-getData :: Element -> String
-getData e = concat [ s | Left s <- content e ]
− src/Text/XML/Parser.hs 
@@ -1,694 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- A parser for XML documents, directly derived from the specification:
-
---    http://www.w3.org/TR/2006/REC-xml-20060816
-
------------------------------------------------------------------------------
-module Text.XML.Parser (document, extParsedEnt, extSubset) where
-
-import Control.Monad
-import Data.Char (toUpper, ord, isSpace)
-import Data.List (foldl') -- '
-import Data.Maybe (catMaybes)
-import Prelude hiding (seq)
-import Text.Parsing hiding (digit, letter, space)
-import Text.XML.Document hiding (versionInfo, name, content)
-import Text.XML.Unicode
-import qualified Text.XML.Document as D
-
-letter, digit, combiningChar, extender :: Parser Char
-letter        = ranges letterMap
-digit         = ranges digitMap
-combiningChar = ranges combiningCharMap
-extender      = ranges extenderMap
-
--- combinators without lexing (no spaces are consumed)
-parens, brackets, singleQuoted, doubleQuoted :: Parser a -> Parser a
-parens       = between (char '(')  (char ')')
-brackets     = between (char '[')  (char ']')
-singleQuoted = between (char '\'') (char '\'')
-doubleQuoted = between (char '"')  (char '"')
-
---------------------------------------------------
--- * 2 Documents
-
---------------------------------------------------
--- ** 2.1 Well-Formed XML Documents
-
--- [1]   	document	   ::=   	 prolog element Misc*
-document :: Parser XMLDoc
-document = do
-   (mxml, mdtd) <- prolog
-   rt <- element
-   miscs
-   let (ver, enc, sa) =
-          case mxml of
-             Just (a, b, c) -> (Just a, b, c)
-             Nothing        -> (Nothing, Nothing, Nothing)
-   return XMLDoc
-      { D.versionInfo = ver
-      , D.encoding    = enc
-      , D.standalone  = sa
-      , D.dtd         = mdtd
-      , D.externals   = []
-      , root        = rt
-      }
-
---------------------------------------------------
--- ** 2.2 Characters
-
--- [2]   	Char	   ::=   	#x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]
-{-
-char :: Parser Char
-char = ranges xs <|> oneOf "\x9\xA\xD"
- where xs = [('\x20', '\xD7FF'), ('\xE000', '\xFFFD'), ('\x10000', '\x10FFFF')]
--}
-
---------------------------------------------------
--- ** 2.3 Common Syntactic Constructs
-
--- [3]   	S	   ::=   	(#x20 | #x9 | #xD | #xA)+
-space :: Parser ()
-space = many1 (oneOf "\x20\x9\xA\xD") >> return ()
-
-mspace :: Parser () -- for S?
-mspace = many (oneOf "\x20\x9\xA\xD") >> return ()
-
--- [4]   	NameChar	   ::=   	 Letter | Digit | '.' | '-' | '_' | ':' | CombiningChar | Extender
-nameChar :: Parser Char
-nameChar = letter <|> digit <|> combiningChar <|> extender <|> oneOf ".-_:"
-
--- [5]   	Name	   ::=   	(Letter | '_' | ':') (NameChar)*
-name :: Parser String
-name = do
-   c  <- letter <|> oneOf "_:"
-   cs <- many nameChar
-   return (c:cs)
-
-{-
--- [6]   	Names	   ::=   	 Name (#x20 Name)*
-names :: Parser [String]
-names = sepBy1 name (char '\x20')
--}
-
--- [7]   	Nmtoken	   ::=   	(NameChar)+
-nmtoken :: Parser String
-nmtoken = many1 nameChar
-
-{-
--- [8]   	Nmtokens	   ::=   	 Nmtoken (#x20 Nmtoken)*
-nmtokens :: Parser [String]
-nmtokens = sepBy1 nmtoken (char '\x20')
--}
-
--- [9]   	EntityValue	   ::=   	'"' ([^%&"] | PEReference | Reference)* '"'
---                           |  "'" ([^%&'] | PEReference | Reference)* "'"
-entityValue :: Parser EntityValue
-entityValue = doubleQuoted (p "%&\"") <|> singleQuoted (p "%&'")
- where
-   p s =  many (fmap Left (noneOf s)
-      <|> fmap Right (fmap Left peReference <|> fmap Right reference))
-
--- [10]   	AttValue	   ::=   	'"' ([^<&"] | Reference)* '"'
---                           |  "'" ([^<&'] | Reference)* "'"
-attValue :: Parser AttValue
-attValue = doubleQuoted (p "<&\"") <|> singleQuoted (p "<&'")
- where p s = many (fmap Left (noneOf s) <|> fmap Right reference)
-
--- [11]   	SystemLiteral	   ::=   	('"' [^"]* '"') | ("'" [^']* "'")
-systemLiteral :: Parser String
-systemLiteral = doubleQuoted (p "\"") <|> singleQuoted (p "'")
- where p s = many (noneOf s)
-
--- [12]   	PubidLiteral	   ::=   	'"' PubidChar* '"' | "'" (PubidChar - "'")* "'"
-pubidLiteral :: Parser String
-pubidLiteral = doubleQuoted (many (pubidChar True)) <|> singleQuoted (many (pubidChar False))
-
--- [13]   	PubidChar	   ::=   	#x20 | #xD | #xA | [a-zA-Z0-9] | [-'()+,./:=?;!*#@$_%]
-pubidChar :: Bool -> Parser Char
-pubidChar withSingleQuote =
-   ranges xs <|> oneOf "\x20\xD\xA-()+,./:=?;!*#@$_%" <|> singleQuote
- where
-   xs = [('a', 'z'), ('A', 'Z'), ('0', '9')]
-   singleQuote
-      | withSingleQuote = char '\'' >> return '\''
-      | otherwise       = fail "pubidChar"
-
---------------------------------------------------
--- ** 2.4 Character Data and Markup
-
--- [14]   	CharData	   ::=   	[^<&]* - ([^<&]* ']]>' [^<&]*)
-charData :: Parser String -- This implementation is too liberal since it allows "]]>"
-charData = stopOn ["<", "&", "]]>"]
-
---------------------------------------------------
--- ** 2.5 Comments
-
--- [15]   	Comment	   ::=   	'<!--' ((Char - '-') | ('-' (Char - '-')))* '-->'
-comment :: Parser String
-comment = between (string "<!--") (string "-->") (stopOn ["--"])
-
---------------------------------------------------
--- ** 2.6 Processing Instructions
-
--- [16]   	PI	   ::=   	'<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>'
-pInstr :: Parser String
-pInstr = between (string "<?") (string "?>") p
- where
-   p = piTarget >> option "" (space >> stopOn ["?>"])
-
--- [17]   	PITarget	   ::=   	 Name - (('X' | 'x') ('M' | 'm') ('L' | 'l'))
-piTarget :: Parser String
-piTarget = do
-   n <- name
-   when (map toUpper n == "XML") $ fail "XML in piTarget"
-   return n
-
---------------------------------------------------
--- ** 2.7 CDATA Sections
-
--- [18]   	CDSect	   ::=   	 CDStart CData CDEnd
--- [19]   	CDStart	   ::=   	'<![CDATA['
--- [20]   	CData	   ::=   	(Char* - (Char* ']]>' Char*))
--- [21]   	CDEnd	   ::=   	']]>'
-cdSect :: Parser XML
-cdSect = between (string "<![CDATA[") (string "]]>") p
- where
-   p = do
-      s <- stopOn ["]]>"]
-      return (CDATA s)
-
---------------------------------------------------
--- ** 2.8 Prolog and Document Type Declaration
-
-type XMLDecl = (String, Maybe String, Maybe Bool)
-
--- [22]   	prolog	   ::=   	 XMLDecl? Misc* (doctypedecl Misc*)?
-prolog :: Parser (Maybe XMLDecl, Maybe DTD)
-prolog = do
-   ma <- optionMaybe (try xmlDecl)
-   miscs
-   mb <- optionMaybe $ try $ do
-      mb <- doctypedecl
-      miscs
-      return mb
-   return (ma, mb)
-
--- [23]   	XMLDecl	   ::=   	'<?xml' VersionInfo EncodingDecl? SDDecl? S? '?>'
-xmlDecl :: Parser XMLDecl
-xmlDecl = do
-   skip (string "<?xml")
-   x <- versionInfo
-   y <- optionMaybe (try encodingDecl)
-   z <- optionMaybe (try sdDecl)
-   mspace
-   skip (string "?>")
-   return (x, y, z)
-
--- [24]   	VersionInfo	   ::=   	 S 'version' Eq ("'" VersionNum "'" | '"' VersionNum '"')
-versionInfo :: Parser String
-versionInfo = space >> string "version" >> eq >> p
- where p = singleQuoted versionNum <|> doubleQuoted versionNum
-
--- [25]   	Eq	   ::=   	 S? '=' S?
-eq :: Parser ()
-eq = skip (mspace >> char '=' >> mspace)
-
--- [26]   	VersionNum	   ::=   	'1.0'
-versionNum :: Parser String
-versionNum = do
-   skip (string "1.0")
-   return "1.0"
-
--- [27]   	Misc	   ::=   	 Comment | PI | S
-misc :: Parser ()
-misc = try (skip comment) <|> try (skip pInstr) <|> skip space
-
-miscs :: Parser ()
-miscs = skip (many misc)
-
--- [28]   	doctypedecl	   ::=   	'<!DOCTYPE' S Name (S ExternalID)? S? ('[' intSubset ']' S?)? '>'
-doctypedecl :: Parser DTD
-doctypedecl = do
-   skip (string "<!DOCTYPE")
-   space
-   x <- name
-   y <- optionMaybe (try (space >> externalID))
-   mspace
-   z <- option [] $ do
-      z <- brackets intSubset
-      mspace
-      return z
-   skip (char '>')
-   return (DTD x y z)
-
--- [28a]   	DeclSep	   ::=   	 PEReference | S
-declSep :: Parser (Maybe DocTypeDecl)
-declSep =  fmap (Just . DTDParameter) peReference
-       <|> (space >> return Nothing)
-
--- [28b]   	intSubset	   ::=   	(markupdecl | DeclSep)*
-intSubset :: Parser [DocTypeDecl]
-intSubset = fmap catMaybes (many (markupdecl <|> declSep))
-
--- [29]   	markupdecl	   ::=   	 elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment
-markupdecl :: Parser (Maybe DocTypeDecl)
-markupdecl =  fmap Just (choice (map try list))
-          <|> ((try pInstr <|> comment) >> return Nothing)
- where
-   list = [elementdecl, attlistDecl, entityDecl, notationDecl]
-
--- [30]   	extSubset	   ::=   	 TextDecl? extSubsetDecl
-extSubset :: Parser (Maybe TextDecl, [DocTypeDecl])
-extSubset = do
-   m <- optionMaybe textDecl
-   e <- extSubsetDecl
-   return (m, e)
-
--- [31]   	extSubsetDecl	   ::=   	( markupdecl | conditionalSect | DeclSep)*
-extSubsetDecl :: Parser [DocTypeDecl]
-extSubsetDecl = fmap catMaybes (many (choice [markupdecl, fmap (Just . DTDConditional) conditionalSect, declSep]))
-
---------------------------------------------------
--- ** 2.9 Standalone Document Declaration
--- [32]   	SDDecl	   ::=   	 S 'standalone' Eq (("'" ('yes' | 'no') "'") | ('"' ('yes' | 'no') '"'))
-sdDecl :: Parser Bool
-sdDecl = space >> string "standalone" >> eq >> (singleQuoted bool <|> doubleQuoted bool)
- where bool =  (string "yes" >> return True)
-           <|> (string "no"  >> return False)
-
---------------------------------------------------
--- ** 2.10 White Space Handling
-
---------------------------------------------------
--- * 3 Logical Structures
-
--- [39]   	element	   ::=   	 EmptyElemTag | STag content ETag
-element :: Parser Element
-element = do
-   (s1, as, closed) <- sTag
-   if closed
-     then return (Element s1 as [])
-     else do
-       c  <- content
-       s2 <- eTag
-       when (s1/=s2) $ fail "WFC: element"
-       return (Element s1 as c)
-
---------------------------------------------------
--- ** 3.1 Start-Tags, End-Tags, and Empty-Element Tags
-
--- [40]   	STag	   ::=   	'<' Name (S Attribute)* S? '>'
--- [44]   	EmptyElemTag	   ::=   	'<' Name (S Attribute)* S? '/>'
--- The boolean indicates whether the tag was closed immediately (an EmptyElemTag)
-sTag :: Parser (Name, Attributes, Bool)
-sTag = do
-   skip (char '<')
-   n  <- name
-   as <- many (try (space >> attribute))
-   mspace
-   b  <- (char '>'  >> return False) <|>
-         (string "/>" >> return True)
-   return (n, as, b)
-
--- [41]   	Attribute	   ::=   	NSAttName Eq AttValue
---        | Name Eq AttValue
-attribute :: Parser Attribute
-attribute = do
-   n <- name
-   eq
-   a <- attValue
-   return (n := a)
-
--- [42]   	ETag	   ::=   	'</' Name S? '>'
-eTag :: Parser Name
-eTag = do
-   skip (string "</")
-   n <- name
-   mspace
-   skip (char '>')
-   return n
-
--- [43]   	content	   ::=   	 CharData? ((element | Reference | CDSect | PI | Comment) CharData?)*
--- Note: since CharData accepts epsilon, there is no need to make it optional
-content :: Parser Content
-content = chainr1 (fmap g charData) (fmap f ps)
- where
-   f ma l r = l ++ maybe [] return ma ++ r
-   g s = [ CharData s | any (not . isSpace) s ]  -- quick fix, ignores layout
-   ps  = try (fmap Just (choice (map try [fmap Tagged element, fmap Reference reference, cdSect]))
-      <|> ((try pInstr <|> comment) >> return Nothing))
-
---------------------------------------------------
--- ** 3.2 Element Type Declarations
-
--- [45]   	elementdecl	   ::=   	'<!ELEMENT' S Name S contentspec S? '>'
-elementdecl :: Parser DocTypeDecl
-elementdecl = do
-   skip (string "<!ELEMENT")
-   space
-   n <- name
-   space
-   cs <- contentspec
-   mspace
-   skip (char '>')
-   return (ElementDecl n cs)
-
--- [46]   	contentspec	   ::=   	'EMPTY' | 'ANY' | Mixed | children
-contentspec :: Parser ContentSpec
-contentspec = choice
-   [ string "EMPTY" >> return Empty
-   , string "ANY"   >> return Any
-   , try mixed
-   , children
-   ]
-
--- [47]   	children	   ::=   	(choice | seq) ('?' | '*' | '+')?
-children :: Parser ContentSpec
-children = do
-   a <- try cpChoice <|> cpSeq
-   f <- option id multi
-   return (Children (f a))
-
-multi :: Parser (CP -> CP)
-multi =  (char '?' >> return QuestionMark)
-     <|> (char '*' >> return Star)
-     <|> (char '+' >> return Plus)
-
--- [48]   	cp	   ::=   	(Name | choice | seq) ('?' | '*' | '+')?
-cp :: Parser CP
-cp = do
-   a <- fmap CPName name <|> try cpChoice <|> cpSeq
-   f <- option id multi
-   return (f a)
-
--- [49]   	choice	   ::=   	'(' S? cp ( S? '|' S? cp )+ S? ')'
-cpChoice :: Parser CP
-cpChoice = parens $ do
-   mspace
-   x  <- cp
-   xs <- many1 (try (mspace >> char '|' >> mspace >> cp))
-   mspace
-   return (Choice (x:xs))
-
--- [50]   	seq	   ::=   	'(' S? cp ( S? ',' S? cp )* S? ')'
-cpSeq :: Parser CP
-cpSeq = parens $ do
-   mspace
-   x  <- cp
-   xs <- many (try (mspace >> char ',' >> mspace >> cp))
-   mspace
-   return (Sequence (x:xs))
-
--- [51]   	Mixed	   ::=   	'(' S? '#PCDATA' (S? '|' S? Name)* S? ')*'
---                  | '(' S? '#PCDATA' S? ')'
-mixed :: Parser ContentSpec
-mixed = char '(' >> mspace >> string "#PCDATA" >> (rest1 <|> rest2)
- where
-   p = mspace >> char '|' >> mspace >> name
-   rest1 = try $ do
-       xs <- many (try p)
-       mspace
-       skip (string ")*")
-       return (Mixed True xs)
-   rest2 = mspace >> char ')' >> return (Mixed False [])
-
---------------------------------------------------
--- ** 3.3 Attribute-List Declarations
-
--- [52]   	AttlistDecl	   ::=   	'<!ATTLIST' S Name AttDef* S? '>'
-attlistDecl :: Parser DocTypeDecl
-attlistDecl = do
-   skip (string "<!ATTLIST")
-   space
-   n  <- name
-   ds <- many (try attDef)
-   mspace
-   skip (char '>')
-   return (AttListDecl n ds)
-
--- [53]   	AttDef	   ::=   	 S Name S AttType S DefaultDecl
-attDef :: Parser AttDef
-attDef = do
-   space
-   n  <- name
-   space
-   tp <- attType
-   space
-   dd <- defaultDecl
-   return (n, tp, dd)
-
--- [54]   	AttType	   ::=   	 StringType | TokenizedType | EnumeratedType
-attType :: Parser AttType
-attType = stringType <|> tokenizedType <|> enumeratedType
-
--- [55]   	StringType	   ::=   	'CDATA'
-stringType :: Parser AttType
-stringType = string "CDATA" >> return StringType
-
--- [56]   	TokenizedType	   ::=   	'ID' | 'IDREF' | 'IDREFS' | 'ENTITY' | 'ENTITIES' | 'NMTOKEN' | 'NMTOKENS'
-tokenizedType :: Parser AttType
-tokenizedType = choice (map f xs)
- where
-   f (tp, s) = try (string s) >> return tp
-   xs = [ (IdRefsType, "IDREFS"), (IdRefType, "IDREF"), (IdType, "ID"), (EntityType, "ENTITY")
-        , (EntitiesType, "ENTITIES"), (NmTokensType, "NMTOKENS"), (NmTokenType, "NMTOKEN")
-        ]
-
--- [57]   	EnumeratedType	   ::=   	 NotationType | Enumeration
-enumeratedType :: Parser AttType
-enumeratedType = notationType <|> enumeration
-
--- [58]   	NotationType	   ::=   	'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')'
-notationType :: Parser AttType
-notationType = string "NOTATION" >> space >> parens p
- where
-   p = do
-      mspace
-      n  <- name
-      ns <- many (try (mspace >> char '|' >> mspace >> name))
-      mspace
-      return (NotationType (n:ns))
-
--- [59]   	Enumeration	   ::=   	'(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')'
-enumeration :: Parser AttType
-enumeration = parens $ do
-   mspace
-   x  <- nmtoken
-   xs <- many (try (mspace >> char '|' >> mspace >> nmtoken))
-   mspace
-   return (EnumerationType (x:xs))
-
--- [60]   	DefaultDecl	   ::=   	'#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue)
-defaultDecl :: Parser DefaultDecl
-defaultDecl =  try (string "#REQUIRED" >> return Required)
-           <|> try (string "#IMPLIED"  >> return Implied)
-           <|> do f <- option Value (string "#FIXED" >> space >> return Fixed)
-                  a <- attValue
-                  return (f a)
-
---------------------------------------------------
--- ** 3.4 Conditional Sections
-
--- [61]   	conditionalSect	   ::=   	 includeSect | ignoreSect
-conditionalSect :: Parser Conditional
-conditionalSect = try includeSect <|> ignoreSect
-
--- [62]   	includeSect	   ::=   	'<![' S? 'INCLUDE' S? '[' extSubsetDecl ']]>'
-includeSect :: Parser Conditional
-includeSect = do
-   skip (string "<![")
-   mspace
-   skip (string "INCLUDE")
-   mspace
-   skip (char '[')
-   ds <- extSubsetDecl
-   skip (string "]]>")
-   return (Include ds)
-
--- [63]   	ignoreSect	   ::=   	'<![' S? 'IGNORE' S? '[' ignoreSectContents* ']]>'
-ignoreSect :: Parser Conditional
-ignoreSect = do
-   skip (string "<![")
-   mspace
-   skip (string "IGNORE")
-   mspace
-   skip (char '[')
-   xss <- many ignoreSectContents
-   skip (string "]]>")
-   return (Ignore (concat xss))
-
--- [64]   	ignoreSectContents	   ::=   	 Ignore ('<![' ignoreSectContents ']]>' Ignore)*
-ignoreSectContents :: Parser [String]
-ignoreSectContents =
-   do x   <- ignore
-      xss <- many $ do
-         skip (string "<![")
-         ys <- ignoreSectContents
-         skip (string "]]>")
-         y  <- ignore
-         return (ys++[y])
-      return (x:concat xss)
-
--- [65]   	Ignore	   ::=   	 Char* - (Char* ('<![' | ']]>') Char*)
-ignore :: Parser String
-ignore = stopOn ["<![", "]]>"]
-
---------------------------------------------------
--- * 4 Physical Structures
-
---------------------------------------------------
--- ** 4.1 Character and Entity References
-
--- [66]   	CharRef	   ::=   	'&#' [0-9]+ ';' | '&#x' [0-9a-fA-F]+ ';'
-charRef :: Parser Reference
-charRef = do
-   skip (string "&#")
-   n <- p <|> (char 'x' >> q)
-   skip (char ';')
-   return (CharRef n)
- where
-   p = fmap (foldl' (\a b -> a*10+ord b-48) 0) (many1 ('0' <..> '9'))
-   q = fmap hexa (many1 (ranges [('0', '9'), ('a', 'f'), ('A', 'F')]))
-
-hexa :: String -> Int
-hexa = rec 0
- where
-   rec n []     = n
-   rec n (x:xs) = rec (16*n + ord x - correct) xs
-    where
-      correct
-         | x <= '9'  = ord '0'
-         | x <= 'F'  = ord 'A' - 10
-         | otherwise = ord 'a' - 10
-
--- [67]   	Reference	   ::=   	 EntityRef | CharRef
-reference :: Parser Reference
-reference = try entityRef <|> charRef
-
--- [68]   	EntityRef	   ::=   	'&' Name ';'
-entityRef :: Parser Reference
-entityRef = between (char '&') (char ';') (fmap EntityRef name)
-
--- [69]   	PEReference	   ::=   	'%' Name ';'
-peReference :: Parser Parameter
-peReference = between (char '%') (char ';') (fmap Parameter name)
-
---------------------------------------------------
--- ** 4.2 Entity Declarations
-
--- [70]   	EntityDecl	   ::=   	 GEDecl | PEDecl
-entityDecl :: Parser DocTypeDecl
-entityDecl = try geDecl <|> peDecl
-
--- [71]   	GEDecl	   ::=   	'<!ENTITY' S Name S EntityDef S? '>'
-geDecl :: Parser DocTypeDecl
-geDecl = do
-   skip (string "<!ENTITY")
-   space
-   n <- name
-   space
-   ed <- entityDef
-   mspace
-   skip (char '>')
-   return (EntityDecl True n ed)
-
--- [72]   	PEDecl	   ::=   	'<!ENTITY' S '%' S Name S PEDef S? '>'
-peDecl :: Parser DocTypeDecl
-peDecl = do
-   skip (string "<!ENTITY")
-   space
-   skip (char '%')
-   space
-   n <- name
-   space
-   e <- peDef
-   mspace
-   skip (char '>')
-   return (EntityDecl False n (either Left (\a -> Right (a, Nothing)) e))
-
--- [73]   	EntityDef	   ::=   	 EntityValue | (ExternalID NDataDecl?)
-entityDef :: Parser EntityDef
-entityDef = fmap Left entityValue <|> do
-   e  <- externalID
-   ms <- optionMaybe (try nDataDecl)
-   return (Right (e, ms))
-
--- [74]   	PEDef	   ::=   	 EntityValue | ExternalID
-peDef :: Parser (Either EntityValue ExternalID)
-peDef = fmap Left entityValue <|> fmap Right externalID
-
--- [75]   	ExternalID	   ::=   	'SYSTEM' S SystemLiteral | 'PUBLIC' S PubidLiteral S SystemLiteral
-externalID :: Parser ExternalID
-externalID =  (string "SYSTEM" >> space >> fmap System systemLiteral) <|> do
-   skip (string "PUBLIC")
-   space
-   x <- pubidLiteral
-   space
-   y <- systemLiteral
-   return (Public x y)
-
--- [76]   	NDataDecl	   ::=   	 S 'NDATA' S Name
-nDataDecl :: Parser String
-nDataDecl = space >> string "NDATA" >> space >> name
-
---------------------------------------------------
--- ** 4.3 Parsed Entities
-
--- [77]   	TextDecl	   ::=   	'<?xml' VersionInfo? EncodingDecl S? '?>'
-
-textDecl :: Parser TextDecl
-textDecl = do
-   skip (string "<?xml")
-   v <- optionMaybe versionInfo
-   e <- encodingDecl
-   mspace
-   skip (string "?>")
-   return (v, e)
-
--- [78]   	extParsedEnt	   ::=   	 TextDecl? content
-extParsedEnt :: Parser (Maybe TextDecl, Content)
-extParsedEnt = do
-   td <- optionMaybe (try textDecl)
-   c  <- content
-   return (td, c)
-
--- [80]   	EncodingDecl	   ::=   	 S 'encoding' Eq ('"' EncName '"' | "'" EncName "'" )
-encodingDecl :: Parser String
-encodingDecl = space >> string "encoding" >> eq >>
-   (singleQuoted encName <|> doubleQuoted encName)
-
--- [81]   	EncName	   ::=   	[A-Za-z] ([A-Za-z0-9._] | '-')*
-encName :: Parser String
-encName = do
-   x  <- ranges [('A', 'Z'), ('a', 'z')]
-   xs <- many (ranges [('A', 'Z'), ('a', 'z'), ('0', '9')] <|> oneOf "._-")
-   return (x:xs)
-
---------------------------------------------------
--- ** 4.7 Notation Declarations
-
--- [82]   	NotationDecl	   ::=   	'<!NOTATION' S Name S (ExternalID | PublicID) S? '>'
-notationDecl :: Parser DocTypeDecl
-notationDecl = do
-   skip (string "<!NOTATION")
-   space
-   n <- name
-   space
-   e <- fmap Left (try externalID) <|> fmap Right publicID
-   mspace
-   skip (char '>')
-   return (NotationDecl n e)
-
--- [83]   	PublicID	   ::=   	'PUBLIC' S PubidLiteral
-publicID :: Parser PublicID
-publicID = string "PUBLIC" >> space >> pubidLiteral
− src/Text/XML/Unicode.hs 
@@ -1,193 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2011, Open Universiteit Nederland. This file is distributed
--- under the terms of the GNU General Public License. For more information,
--- see the file "LICENSE.txt", which is included in the distribution.
------------------------------------------------------------------------------
--- |
--- Maintainer  :  bastiaan.heeren@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Support for Unicode
---
------------------------------------------------------------------------------
-module Text.XML.Unicode
-   ( isExtender, isLetter, isDigit, isCombiningChar
-   , extenderMap, letterMap, digitMap, combiningCharMap
-   , decoding
-   ) where
-
-import Data.Char (chr, ord)
-import qualified Text.UTF8 as UTF8
-
-data Tree a = Node (Tree a) a (Tree a) | Leaf
-
-isLetter, isExtender, isDigit, isCombiningChar :: Char -> Bool
-isLetter        = checkTree $ makeTree letterMap
-isExtender      = checkTree $ makeTree extenderMap
-isDigit         = checkTree $ makeTree digitMap
-isCombiningChar = checkTree $ makeTree combiningCharMap
-
-checkTree :: Tree (Char, Char) -> Char -> Bool
-checkTree Leaf _ = False
-checkTree (Node l (c1, c2) r) c =
-   case compare c1 c of
-      LT -> case compare c c2 of
-               LT -> True
-               EQ -> True
-               GT -> checkTree r c
-      EQ -> True
-      GT -> checkTree l c
-
-makeTree :: [a] -> Tree a
-makeTree [] = Leaf
-makeTree xs = Node (makeTree ys) z (makeTree zs)
- where (ys, z:zs) = splitAt n xs
-       n = length xs `div` 2
-
-f :: Char -> (Char, Char)
-f c = (c, c)
-
-letterMap :: [(Char, Char)]
-letterMap = baseCharMap `merge` ideographicMap `merge` controlMap `merge` extraMap
-
-merge :: [(Char, Char)] -> [(Char, Char)] -> [(Char, Char)]
-merge (x:xs) (y:ys)
-   | x <= y    = x:merge xs (y:ys)
-   | otherwise = y:merge (x:xs) ys
-merge xs ys = xs++ys
-
-extraMap :: [(Char, Char)]
-extraMap = map f "\161\170\184\185"
-
-controlMap :: [(Char, Char)]
-controlMap = [ ('\x7F', '\x84'), ('\x86', '\x9F'), ('\xFDD0', '\xFDDF'),
-   ('\x1FFFE', '\x1FFFF'), ('\x2FFFE', '\x2FFFF'), ('\x3FFFE', '\x3FFFF'),
-   ('\x4FFFE', '\x4FFFF'), ('\x5FFFE', '\x5FFFF'), ('\x6FFFE', '\x6FFFF'),
-   ('\x7FFFE', '\x7FFFF'), ('\x8FFFE', '\x8FFFF'), ('\x9FFFE', '\x9FFFF'),
-   ('\xAFFFE', '\xAFFFF'), ('\xBFFFE', '\xBFFFF'), ('\xCFFFE', '\xCFFFF'),
-   ('\xDFFFE', '\xDFFFF'), ('\xEFFFE', '\xEFFFF'), ('\xFFFFE', '\xFFFFF'),
-   ('\x10FFFE', '\x10FFFF')]
-
-baseCharMap :: [(Char, Char)]
-baseCharMap = [ ('\x0041','\x005A'), ('\x0061','\x007A'), ('\x00C0','\x00D6'),
-   ('\x00D8','\x00F6'), ('\x00F8','\x00FF'), ('\x0100','\x0131'),
-   ('\x0134','\x013E'), ('\x0141','\x0148'), ('\x014A','\x017E'),
-   ('\x0180','\x01C3'), ('\x01CD','\x01F0'), ('\x01F4','\x01F5'),
-   ('\x01FA','\x0217'), ('\x0250','\x02A8'), ('\x02BB','\x02C1'), f '\x0386' ,
-   ('\x0388','\x038A'), f '\x038C' , ('\x038E','\x03A1'), ('\x03A3','\x03CE'),
-   ('\x03D0','\x03D6'), f '\x03DA' , f '\x03DC' , f '\x03DE' , f '\x03E0' ,
-   ('\x03E2','\x03F3'), ('\x0401','\x040C'), ('\x040E','\x044F'),
-   ('\x0451','\x045C'), ('\x045E','\x0481'), ('\x0490','\x04C4'),
-   ('\x04C7','\x04C8'), ('\x04CB','\x04CC'), ('\x04D0','\x04EB'),
-   ('\x04EE','\x04F5'), ('\x04F8','\x04F9'), ('\x0531','\x0556'), f '\x0559' ,
-   ('\x0561','\x0586'), ('\x05D0','\x05EA'), ('\x05F0','\x05F2'),
-   ('\x0621','\x063A'), ('\x0641','\x064A'), ('\x0671','\x06B7'),
-   ('\x06BA','\x06BE'), ('\x06C0','\x06CE'), ('\x06D0','\x06D3'), f '\x06D5' ,
-   ('\x06E5','\x06E6'), ('\x0905','\x0939'), f '\x093D' , ('\x0958','\x0961'),
-   ('\x0985','\x098C'), ('\x098F','\x0990'), ('\x0993','\x09A8'),
-   ('\x09AA','\x09B0'), f '\x09B2' , ('\x09B6','\x09B9'), ('\x09DC','\x09DD'),
-   ('\x09DF','\x09E1'), ('\x09F0','\x09F1'), ('\x0A05','\x0A0A'),
-   ('\x0A0F','\x0A10'), ('\x0A13','\x0A28'), ('\x0A2A','\x0A30'),
-   ('\x0A32','\x0A33'), ('\x0A35','\x0A36'), ('\x0A38','\x0A39'),
-   ('\x0A59','\x0A5C'), f '\x0A5E' , ('\x0A72','\x0A74'), ('\x0A85','\x0A8B'),
-   f '\x0A8D' , ('\x0A8F','\x0A91'), ('\x0A93','\x0AA8'), ('\x0AAA','\x0AB0'),
-   ('\x0AB2','\x0AB3'), ('\x0AB5','\x0AB9'), f '\x0ABD' , f '\x0AE0' ,
-   ('\x0B05','\x0B0C'), ('\x0B0F','\x0B10'), ('\x0B13','\x0B28'),
-   ('\x0B2A','\x0B30'), ('\x0B32','\x0B33'), ('\x0B36','\x0B39'), f '\x0B3D' ,
-   ('\x0B5C','\x0B5D'), ('\x0B5F','\x0B61'), ('\x0B85','\x0B8A'),
-   ('\x0B8E','\x0B90'), ('\x0B92','\x0B95'), ('\x0B99','\x0B9A'), f '\x0B9C' ,
-   ('\x0B9E','\x0B9F'), ('\x0BA3','\x0BA4'), ('\x0BA8','\x0BAA'),
-   ('\x0BAE','\x0BB5'), ('\x0BB7','\x0BB9'), ('\x0C05','\x0C0C'),
-   ('\x0C0E','\x0C10'), ('\x0C12','\x0C28'), ('\x0C2A','\x0C33'),
-   ('\x0C35','\x0C39'), ('\x0C60','\x0C61'), ('\x0C85','\x0C8C'),
-   ('\x0C8E','\x0C90'), ('\x0C92','\x0CA8'), ('\x0CAA','\x0CB3'),
-   ('\x0CB5','\x0CB9'), f '\x0CDE' , ('\x0CE0','\x0CE1'), ('\x0D05','\x0D0C'),
-   ('\x0D0E','\x0D10'), ('\x0D12','\x0D28'), ('\x0D2A','\x0D39'),
-   ('\x0D60','\x0D61'), ('\x0E01','\x0E2E'), f '\x0E30' , ('\x0E32','\x0E33'),
-   ('\x0E40','\x0E45'), ('\x0E81','\x0E82'), f '\x0E84' , ('\x0E87','\x0E88'),
-   f '\x0E8A' , f '\x0E8D' , ('\x0E94','\x0E97'), ('\x0E99','\x0E9F'),
-   ('\x0EA1','\x0EA3'), f '\x0EA5' , f '\x0EA7' , ('\x0EAA','\x0EAB'),
-   ('\x0EAD','\x0EAE'), f '\x0EB0' , ('\x0EB2','\x0EB3'), f '\x0EBD' ,
-   ('\x0EC0','\x0EC4'), ('\x0F40','\x0F47'), ('\x0F49','\x0F69'),
-   ('\x10A0','\x10C5'), ('\x10D0','\x10F6'), f '\x1100' , ('\x1102','\x1103'),
-   ('\x1105','\x1107'), f '\x1109' , ('\x110B','\x110C'), ('\x110E','\x1112'),
-   f '\x113C' , f '\x113E' , f '\x1140' , f '\x114C' , f '\x114E' , f '\x1150' , ('\x1154','\x1155') ,
-   f '\x1159' , ('\x115F','\x1161'), f '\x1163' , f '\x1165' , f '\x1167' , f '\x1169' ,
-   ('\x116D','\x116E'), ('\x1172','\x1173'), f '\x1175' , f '\x119E' , f '\x11A8' ,
-   f '\x11AB' , ('\x11AE','\x11AF'), ('\x11B7','\x11B8'), f '\x11BA' ,
-   ('\x11BC','\x11C2'), f '\x11EB' , f '\x11F0' , f '\x11F9' , ('\x1E00','\x1E9B'),
-   ('\x1EA0','\x1EF9'), ('\x1F00','\x1F15'), ('\x1F18','\x1F1D'),
-   ('\x1F20','\x1F45'), ('\x1F48','\x1F4D'), ('\x1F50','\x1F57'), f '\x1F59' ,
-   f '\x1F5B' , f '\x1F5D' , ('\x1F5F','\x1F7D'), ('\x1F80','\x1FB4'),
-   ('\x1FB6','\x1FBC'), f '\x1FBE' , ('\x1FC2','\x1FC4'), ('\x1FC6','\x1FCC'),
-   ('\x1FD0','\x1FD3'), ('\x1FD6','\x1FDB'), ('\x1FE0','\x1FEC'),
-   ('\x1FF2','\x1FF4'), ('\x1FF6','\x1FFC'), f '\x2126' , ('\x212A','\x212B'),
-   f '\x212E' , ('\x2180','\x2182'), ('\x3041','\x3094'), ('\x30A1','\x30FA'),
-   ('\x3105','\x312C'), ('\xAC00','\xD7A3') ]
-
-ideographicMap :: [(Char, Char)]
-ideographicMap = [ ('\x4E00','\x9FA5'),
-   f '\x3007' , ('\x3021','\x3029') ]
-
-combiningCharMap :: [(Char, Char)]
-combiningCharMap = [('\x0300','\x0345'),
-   ('\x0360','\x0361'), ('\x0483','\x0486'), ('\x0591','\x05A1'),
-   ('\x05A3','\x05B9'), ('\x05BB','\x05BD'),  f '\x05BF' , ('\x05C1','\x05C2'),
-   f '\x05C4' , ('\x064B','\x0652'), f '\x0670' , ('\x06D6','\x06DC'),
-   ('\x06DD','\x06DF'), ('\x06E0','\x06E4'), ('\x06E7','\x06E8'),
-   ('\x06EA','\x06ED'), ('\x0901','\x0903'), f '\x093C' , ('\x093E','\x094C'),
-   f '\x094D' , ('\x0951','\x0954'), ('\x0962','\x0963'), ('\x0981','\x0983'),
-   f '\x09BC' , f '\x09BE' , f '\x09BF' , ('\x09C0','\x09C4'), ('\x09C7','\x09C8'),
-   ('\x09CB','\x09CD'), f '\x09D7' , ('\x09E2','\x09E3'), f '\x0A02' , f '\x0A3C' ,
-   f '\x0A3E' , f '\x0A3F' , ('\x0A40','\x0A42'), ('\x0A47','\x0A48'),
-   ('\x0A4B','\x0A4D'), ('\x0A70','\x0A71'), ('\x0A81','\x0A83'), f '\x0ABC' ,
-   ('\x0ABE','\x0AC5'), ('\x0AC7','\x0AC9'), ('\x0ACB','\x0ACD'),
-   ('\x0B01','\x0B03'), f '\x0B3C' , ('\x0B3E','\x0B43'), ('\x0B47','\x0B48'),
-   ('\x0B4B','\x0B4D'), ('\x0B56','\x0B57'), ('\x0B82','\x0B83'),
-   ('\x0BBE','\x0BC2'), ('\x0BC6','\x0BC8'), ('\x0BCA','\x0BCD'), f '\x0BD7' ,
-   ('\x0C01','\x0C03'), ('\x0C3E','\x0C44'), ('\x0C46','\x0C48'),
-   ('\x0C4A','\x0C4D'), ('\x0C55','\x0C56'), ('\x0C82','\x0C83'),
-   ('\x0CBE','\x0CC4'), ('\x0CC6','\x0CC8'), ('\x0CCA','\x0CCD'),
-   ('\x0CD5','\x0CD6'), ('\x0D02','\x0D03'), ('\x0D3E','\x0D43'),
-   ('\x0D46','\x0D48'), ('\x0D4A','\x0D4D'), f '\x0D57' , f '\x0E31' ,
-   ('\x0E34','\x0E3A'), ('\x0E47','\x0E4E'), f '\x0EB1' , ('\x0EB4','\x0EB9'),
-   ('\x0EBB','\x0EBC'), ('\x0EC8','\x0ECD'), ('\x0F18','\x0F19'), f '\x0F35' ,
-   f '\x0F37' , f '\x0F39' , f '\x0F3E' , f '\x0F3F' , ('\x0F71','\x0F84'),
-   ('\x0F86','\x0F8B'), ('\x0F90','\x0F95'), f '\x0F97' , ('\x0F99','\x0FAD'),
-   ('\x0FB1','\x0FB7'), f '\x0FB9' , ('\x20D0','\x20DC'), f '\x20E1' ,
-   ('\x302A','\x302F'), f '\x3099' , f '\x309A' ]
-
-digitMap :: [(Char, Char)]
-digitMap = [ ('\x0030','\x0039'),
-   ('\x0660','\x0669'), ('\x06F0','\x06F9'), ('\x0966','\x096F'),
-   ('\x09E6','\x09EF'), ('\x0A66','\x0A6F'), ('\x0AE6','\x0AEF'),
-   ('\x0B66','\x0B6F'), ('\x0BE7','\x0BEF'), ('\x0C66','\x0C6F'),
-   ('\x0CE6','\x0CEF'), ('\x0D66','\x0D6F'), ('\x0E50','\x0E59'),
-   ('\x0ED0','\x0ED9'), ('\x0F20','\x0F29')]
-
-extenderMap :: [(Char, Char)]
-extenderMap = [f '\x00B7' , f '\x02D0' ,
-   f '\x02D1' , f '\x0387' , f '\x0640' , f '\x0E46' , f '\x0EC6' , f '\x3005' , ('\x3031','\x3035')
-   , ('\x309D','\x309E'), ('\x30FC','\x30FE') ]
-
-decoding :: Monad m => String -> m String
-decoding xs
-   | take 2 xs == "\255\254" =
-        return (decode16 $ drop 2 xs)
-   | take 2 xs == "\254\255" =
-        return (decode16X $ drop 2 xs)
-   | take 3 xs == "\239\187\191" =
-        UTF8.decodeM (drop 3 xs)
-   | otherwise =
-        UTF8.decodeM xs
-
-decode16 :: [Char] -> [Char]
-decode16 []  = []
-decode16 [x] = [x]
-decode16 (a:b:rest) = chr (ord b * 256 + ord a) : decode16 rest
-
-decode16X :: [Char] -> [Char]
-decode16X []  = []
-decode16X [x] = [x]
-decode16X (a:b:rest) = chr (ord b + ord a * 256) : decode16X rest