packages feed

ideas 0.7 → 1.0

raw patch · 223 files changed

+25753/−24758 lines, 223 filesdep −old-timedep −uulibdep ~QuickCheck

Dependencies removed: old-time, uulib

Dependency ranges changed: QuickCheck

Files

ideas.cabal view
@@ -1,5 +1,5 @@ name:                   ideas-version:                0.7+version:                1.0 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) 2010+copyright:              (c) 2011 license:                GPL license-file:           LICENSE.txt author:                 Bastiaan Heeren, Alex Gerdes, Johan Jeuring@@ -18,8 +18,12 @@ extra-source-files:     CREDITS.txt build-type:             Simple cabal-version:          >= 1.8.0.2-tested-with:            GHC == 6.10.1, GHC == 6.12.1+tested-with:            GHC == 6.10.1, GHC == 7.0.2 +source-repository head+  type:     svn+  location: https://ideas.cs.uu.nl/svn/Feedback/trunk/+ --------------------------------------------------------------------------------  Executable              ideas@@ -27,24 +31,32 @@   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.Axioms     Common.Rewriting.Confluence     Common.Rewriting.Difference-    Common.Rewriting.Group-    Common.Rewriting.Operator     Common.Rewriting.RewriteRule     Common.Rewriting.Substitution     Common.Rewriting.Term     Common.Rewriting.Unification-    Common.Rewriting+    Common.Strategy     Common.Strategy.Abstract     Common.Strategy.Combinators     Common.Strategy.Configuration@@ -52,23 +64,27 @@     Common.Strategy.Location     Common.Strategy.Parsing     Common.Strategy.Prefix-    Common.Strategy-    Common.StringRef-    Common.TestSuite+    Common.Strategy.Tests     Common.Transformation-    Common.Uniplate     Common.Utils+    Common.Utils.QuickCheck+    Common.Utils.StringRef+    Common.Utils.TestSuite+    Common.Utils.Uniplate     Common.View     Documentation.DefaultPage-    Documentation.DerivationUnitTests+    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@@ -80,69 +96,73 @@     Domain.LinearAlgebra.Parser     Domain.LinearAlgebra.Strategies     Domain.LinearAlgebra.Vector-    Domain.LinearAlgebra+    Domain.Logic     Domain.Logic.BuggyRules     Domain.Logic.Examples     Domain.Logic.Exercises-    Domain.Logic.FeedbackText     Domain.Logic.Formula     Domain.Logic.GeneralizedRules     Domain.Logic.Generator     Domain.Logic.Parser-    Domain.Logic.Proofs     Domain.Logic.Rules     Domain.Logic.Strategies     Domain.Logic.Views-    Domain.Logic     Domain.Math.Approximation-    Domain.Math.Clipboard+    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.Examples.DWO1-    Domain.Math.Examples.DWO2-    Domain.Math.Examples.DWO3-    Domain.Math.Examples.DWO4-    Domain.Math.Examples.DWO5+    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.Expr     Domain.Math.Numeric.Exercises     Domain.Math.Numeric.Generators-    Domain.Math.Numeric.Laws     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.CleanUp     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@@ -150,29 +170,34 @@     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-    Domain.RelationAlgebra+    Main     Main.IDEAS     Main.LoggingDatabase     Main.Options     Main.Revision-    Main     Service.BasicServices     Service.Diagnose     Service.DomainReasoner     Service.Evaluator-    Service.ExercisePackage+    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@@ -184,7 +209,6 @@     Service.Types     Text.HTML     Text.JSON-    Text.OpenMath.ContentDictionary     Text.OpenMath.Dictionary.Arith1     Text.OpenMath.Dictionary.Calculus1     Text.OpenMath.Dictionary.Fns1@@ -201,27 +225,22 @@     Text.OpenMath.Symbol     Text.OpenMath.Tests     Text.Parsing-    Text.Scanning     Text.UTF8+    Text.XML     Text.XML.Document     Text.XML.Interface-    Text.XML.ParseLib     Text.XML.Parser-    Text.XML.TestSuite     Text.XML.Unicode-    Text.XML   build-depends:        base >= 4.2 && < 5,                         directory,                         time,                         mtl,                         cgi,                         containers,-                        QuickCheck >= 2.1.0.3,+                        QuickCheck >= 2.4.1,                         random,-                        uulib,                         filepath,                         parsec,-                        old-time,                         uniplate  --------------------------------------------------------------------------------
+ src/Common/Algebra/Boolean.hs view
@@ -0,0 +1,203 @@+{-# 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 view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,133 @@+{-# 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 view
@@ -0,0 +1,148 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,243 @@+{-# 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 view
@@ -0,0 +1,186 @@+{-# 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 view
@@ -0,0 +1,67 @@+{-# 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 view
@@ -0,0 +1,95 @@+{-# 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 view
@@ -1,112 +1,108 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 -   ( Apply(..), applicable, applyD, applyM-   , Switch(..), Crush(..), Zip(..)-   ) where--import Common.Utils (safeHead)-import Data.Maybe-import Control.Monad.Identity-import qualified Data.IntMap as IM -import qualified Data.Map as M---------------------------------------------------------------- * 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. Minimal complete definition: only one of--- the two member functions should be defined.-class Apply t where-   apply    :: t a -> a -> Maybe a     -- ^ Returns zero or one results-   applyAll :: t a -> a -> [a]         -- ^ Returns zero or more results-   -- default definitions-   apply    ta = safeHead . applyAll ta-   applyAll ta = maybe [] return . apply 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 |Switch|--class Functor f => Switch f where-   switch :: Monad m => f (m a) -> m (f a)-         -instance Switch [] where-   switch = sequence--instance Switch Maybe where-   switch = maybe (return Nothing) (liftM Just)--instance Switch Identity where-   switch (Identity m) = liftM Identity m--instance Eq a => Switch (M.Map a) where-   switch m = do-      let (ns, ms) = unzip (M.toList m)-      as <- sequence ms -      return $ M.fromAscList $ zip ns as--instance Switch IM.IntMap where-   switch m = do-      let (ns, ms) = unzip (IM.toList m)-      as <- sequence ms -      return $ IM.fromAscList $ zip ns as---------------------------------------------------------------- * Type class |Crush|--class Functor f => Crush f where-   crush :: f a -> [a]--instance Crush [] where-   crush = id--instance Crush Maybe where-   crush = maybe [] return--instance Crush Identity where-   crush = return . runIdentity--instance Crush (M.Map a) where-   crush = M.elems--instance Crush IM.IntMap where-   crush = IM.elems---------------------------------------------------------------- * Type class |Zip|-   -class Functor f => Zip f where-   fzip     :: f a -> f b -> f (a, b)-   fzipWith :: (a -> b -> c) -> f a -> f b -> f c-   -- default implementation-   fzip = fzipWith (,)-   fzipWith f a b = fmap (uncurry f) (fzip a b)--instance Zip [] where-   fzipWith = zipWith--instance Zip Maybe where-   fzipWith = liftM2+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,250 +1,261 @@-{-# LANGUAGE DeriveDataTypeable #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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, newContext, getEnvironment-     -- * 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.Navigator-import Common.Rewriting-import Common.Transformation-import Common.Utils (commaList, readM)-import Common.View-import Control.Monad-import Data.Maybe-import Data.Dynamic-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--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--------------------------------------------------------------- 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 = newView "views.contextView" 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+{-# 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 view
@@ -1,238 +1,105 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Derivation -   ( -- * Data types -     DerivationTree, Derivations, Derivation-     -- * Constructors-   , singleNode, addBranch, addBranches, newDerivation-     -- * Query -   , root, endpoint, branches, annotations, subtrees-   , results, lengthMax-     -- * Adapters-   , restrictHeight, restrictWidth, commit-   , mergeSteps, cutOnStep, mapSteps, mergeMaybeSteps-   , changeLabel, sortTree-     -- * Query a derivation-   , isEmpty, derivationLength, terms, steps, triples, filterDerivation-   , mapStepsDerivation, derivationM-     -- * Conversions-   , derivation, randomDerivation, derivations-   ) where--import Common.Utils (safeHead)-import Control.Arrow-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--type Derivations s a = [Derivation s a]--data Derivation s a = D a [(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]) xs--instance Functor (DerivationTree s) where-   fmap f (DT a b xs) = DT (f a) b (map (second (fmap f)) xs)--instance Functor (Derivation s) where-   fmap f (D a xs) = D (f a) (map (second f) 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 []---- | Add a single branch-addBranch :: (s, DerivationTree s a) -> DerivationTree s a -> DerivationTree s a-addBranch = addBranches . return---- | 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)---------------------------------------------------------------------------------- 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 final terms-results :: DerivationTree s a -> [a]-results = map f . derivations- where f (D a xs) = last (a:map snd xs)---- | 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---------------------------------------------------------------------------------- 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 = second (restrictHeight (n-1))---- | Restrict the width of the tree (by cuttin off branches). -restrictWidth :: Int -> DerivationTree s a -> DerivationTree s a-restrictWidth n = rec - where-   rec t = t {branches = map (second 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)---- Change the annotation-mapSteps :: (s -> t) -> DerivationTree s a -> DerivationTree t a-mapSteps f t = t {branches = map g (branches t)}- where g (s, st) = (f s, mapSteps f st)--changeLabel :: (l -> m) -> DerivationTree l a -> DerivationTree m a-changeLabel f = rec- where-   rec t = t {branches = map (f *** rec) (branches t)}--sortTree :: (l -> l -> Ordering) -> DerivationTree l a -> DerivationTree l a-sortTree f t = t {branches = change (branches t) }- where-   change = map (second (sortTree f)) . sortBy cmp-   cmp (l1, _) (l2, _) = f l1 l2--mergeMaybeSteps :: DerivationTree (Maybe s) a -> DerivationTree s a-mergeMaybeSteps = mapSteps 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)---------------------------------------------------------------------------------- Inspecting a derivation--newDerivation :: a -> [(s, a)] -> Derivation s a-newDerivation = D---- | Tests whether the derivation is empty-isEmpty :: Derivation s a -> Bool-isEmpty (D _ xs) = null xs--mapStepsDerivation :: (s -> t) -> Derivation s a -> Derivation t a-mapStepsDerivation f (D a xs) = D a (map (first f) xs)---- | Returns the number of steps in a derivation-derivationLength :: Derivation s a -> Int-derivationLength (D _ xs) = length xs---- | All terms in a derivation-terms :: Derivation s a -> [a]-terms (D a xs) = a:map snd xs---- | All steps in a derivation-steps :: Derivation s a -> [s]-steps (D _ xs) = map fst 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))---- | Filter steps from a derivation-filterDerivation :: (s -> a -> Bool) -> Derivation s a -> Derivation s a-filterDerivation p (D a xs) = D a (filter (uncurry p) 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) xs---------------------------------------------------------------------------------- Conversions from a derivation tree---- | All possible derivations (returned in a list)-derivations :: DerivationTree s a -> Derivations s a-derivations t = map (D (root t)) $-   [ [] | endpoint t ] ++-   [ (r,a2):ys | (r, st) <- branches t, D a2 ys <- 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     = map (fmap (D (root t))) $ -                [ Just [] | endpoint t ] ++ map make (branches t)-   make (r, st) = do -      D a2 ys <- randomDerivation g0 st-      return ((r,a2):ys)-      -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+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,188 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,447 +1,496 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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, testableExercise, makeExercise, emptyExercise-   , exerciseId, status, parser, prettyPrinter-   , equivalence, similarity, isReady, isSuitable, eqWithContext-   , strategy, navigation, canBeRestarted, extraRules, ruleOrdering-   , difference, ordering, testGenerator, randomExercise, examples, getRule-   , simpleGenerator, useGenerator-   , randomTerm, randomTermWith, ruleset-   , makeContext, inContext, recognizeRule, ruleIsRecognized-   , ruleOrderingWith, ruleOrderingWithId-     -- * Exercise status-   , Status(..), isPublic, isPrivate-     -- * Miscellaneous-   , prettyPrinterContext-   , equivalenceContext, restrictGenerator-   , showDerivation, printDerivation-   , ExerciseDerivation, defaultDerivation, derivationDiffEnv-   , checkExercise, checkParserPretty-   , checkExamples, exerciseTestSuite-   , module Common.Id -- for backwards compatibility-   ) where--import Common.Classes-import Common.Context-import Common.Strategy hiding (not, fail, replicate)-import qualified Common.Strategy as S-import Common.Derivation-import Common.Id-import Common.Navigator-import Common.TestSuite-import Common.Transformation-import Common.Utils (ShowString(..))-import Common.View (makeView)-import Control.Monad.Error-import Data.List-import Data.Maybe-import Data.Ord-import System.Random-import Test.QuickCheck hiding (label)-import Test.QuickCheck.Gen--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    :: a -> a -> Bool-   , similarity     :: a -> a -> Bool      -- possibly more liberal than syntactic equality-   , ordering       :: a -> a -> Ordering  -- syntactic comparison-   , isReady        :: a -> Bool-   , isSuitable     :: a -> Bool-   , difference     :: Bool -> a -> a -> Maybe (a, a)-   , eqWithContext  :: Maybe (Context a -> Context a -> Bool) -- special equivalence with context info-     -- 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 -> Int -> a)-   , examples       :: [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) }--testableExercise :: (Arbitrary a, Show a, Ord a) => Exercise a-testableExercise = makeExercise-   { testGenerator = Just arbitrary-   }--makeExercise :: (Show a, Ord a) => Exercise a-makeExercise = emptyExercise-   { prettyPrinter = show-   , similarity    = (==)-   , ordering      = compare-   }-   -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-   , ordering       = \_ _ -> EQ-   , isReady        = const True-   , isSuitable     = const True-   , difference     = \_ _ _ -> Nothing-   , eqWithContext  = 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-------------------------------------------------------------------- Exercise generators---- returns a sorted list of rules (no duplicates)-ruleset :: Exercise a -> [Rule (Context a)]-ruleset ex = nub (sortBy compareId list)- where -   list = rulesInStrategy (strategy ex) ++ extraRules ex- -simpleGenerator :: Gen a -> Maybe (StdGen -> Int -> a) -simpleGenerator = useGenerator (const True) . const--useGenerator :: (a -> Bool) -> (Int -> Gen a) -> Maybe (StdGen -> Int -> 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 :: Int -> Exercise a -> IO a-randomTerm level ex = do-   rng <- newStdGen-   return (randomTermWith rng level ex)--randomTermWith :: StdGen -> Int -> Exercise a -> a-randomTermWith rng level ex = -   case randomExercise ex of-      Just f  -> f rng level-      Nothing-         | null xs   -> error "randomTermWith: no generator" -         | otherwise -> -              xs !! fst (randomR (0, length xs - 1) rng)-       where xs = examples ex--ruleIsRecognized :: Exercise a -> Rule (Context a) -> Context a -> Context a -> Bool-ruleIsRecognized ex r ca = not . null . recognizeRule ex r ca---- Recognize a rule at (possibly multiple) locations-recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [Location]-recognizeRule ex r ca cb = rec (fromMaybe ca (top ca))- where-   rec x = [ location x | here r x cb ] ++ concatMap rec (allDowns x)-   here  = ruleRecognizer $ \cx cy -> fromMaybe False $-      liftM2 (similarity ex) (fromContext cx) (fromContext cy)--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-------------------------------------------------------------------- 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-     -equivalenceContext :: Exercise a -> Context a -> Context a -> Bool-equivalenceContext ex a b = -   case eqWithContext ex of-      Just f  -> f a b -      Nothing -> fromMaybe False $ -         liftM2 (equivalence ex) (fromContext a) (fromContext b)-    -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 (last (terms der)) of-         Nothing               -> "<<invalid term>>"-         Just b | isReady ex b -> ""-                | otherwise    -> "<<not ready>>"-   present = mapStepsDerivation (ShowString . uncurry f) -           . fmap (ShowString . prettyPrinterContext ex)-   f b env | nullEnv env = showId b-           | otherwise   = showId b ++ "\n      " ++ 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 = newDerivation ca []-   in fromMaybe single (derivation tree)--derivationDiffEnv :: Derivation s (Context a) -> Derivation (s, Environment) (Context a)-derivationDiffEnv d =-   -- A bit of hack to show the delta between two environments, not including-   -- the location variable-   let t:ts = terms d-       xs   = zipWith3 f (steps d) (drop 1 (terms d)) (terms d)-       f b x y = (b, deleteEnv "location" (diffEnv (getEnvironment x) (getEnvironment y))) -- ShowString (show a ++ extra)-   in newDerivation t (zip xs ts)--printDerivation :: Exercise a -> a -> IO ()-printDerivation ex = putStrLn . showDerivation ex-         ------------------------------------------------------------------- Checks for an exercise-{--checkExercise :: Exercise a -> IO ()-checkExercise ex = do -   putStrLn ("** " ++ show (exerciseCode ex))-   -- Derivations for examples-   checkExamples ex-   -- Derivations for test generator-   case testGenerator ex of-      Nothing  -> return ()-      Just gen -> do -         putStrLn "Checking with test generator"-         forM_ [0 .. 100] $ \i -> do -            -- putChar '.'-            g <- newStdGen-            checksForTerm False ex (generate i g gen)-            return ()-   -- Derivations for random exercise generator-   case randomExercise ex of-      Nothing  -> return ()-      Just f -> do -         putStrLn "Checking with random exercise generator"-         forM_ [0 .. 109] $ \i -> do -            -- putChar '.'-            g <- newStdGen-            checksForTerm False ex (f g (i `div` 10))-            return ()-   -- Soundness of rules-   case testGenerator ex of-      Nothing  -> return ()-      Just gen -> do-         putStrLn "Soundness of rules with test generator"-         forM_ (filter (not . isBuggyRule) (ruleset ex)) $ \r -> do-            putStr ("[" ++ show r ++ "]   ")-            xs <- generateIO 300 (smartGen r (liftM (inContext ex) gen))-            let list = [ (x, y) | x <- xs, y <- applyAll r x ]-                p (x, y) = not (equivalenceContext ex x y)               -            case filter p list of-               [] | null list -> putStrLn "Warning: no applications found" -                  | otherwise -> putStrLn "Ok"-               (x, y):_ -> report $ -                  "counter example: " ++ prettyPrinterContext ex x-                  ++ "  =>  " ++ prettyPrinterContext ex y -}--checkExercise :: Exercise a -> IO ()-checkExercise = runTestSuite . exerciseTestSuite--exerciseTestSuite :: Exercise a -> TestSuite-exerciseTestSuite ex = suite ("Exercise " ++ show (exerciseId ex)) $ do-   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 . from--         suite "Soundness non-buggy rules" $-            forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r -> -               let eq a b = equivalenceContext ex (from a) (from b)-                   myGen  = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen)-                   myView = makeView (return . from) (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 . from--data ShowAs a = S {showS :: a -> String, from :: a}--instance Show (ShowAs a) where-   show a = showS a (from 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 b a) -> (a -> String) -> a -> Bool-checkParserPretty eq p pretty a = -   either (const False) (eq a) (p (pretty a))--checkParserPrettyEx :: Exercise a -> a -> Bool-checkParserPrettyEx ex = -   checkParserPretty (similarity ex) (parser ex) (prettyPrinter ex)--checkExamples :: Exercise a -> TestSuite-checkExamples ex = do-   let xs = 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 = head (terms d)-   assertTrueMsg "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 = last (terms 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 -}-   assertTrueMsg "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  = maybe False (not . checkParserPrettyEx ex) . fromContext-   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 (equivalenceContext 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) = fromMaybe False $ -                        liftM2 (similarity ex) (fromContext x) (fromContext 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 | cx <- terms d, x <- fromContext cx, not (similarity ex x x) ]-   assertNull "self similarity" $ take 1 $ flip map xs $ \hd -> -      "term not similar to itself: " ++ prettyPrinter ex hd+{-# 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 view
@@ -1,163 +1,184 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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(..), ( # ), sameId-   , unqualified, qualifiers, qualification-   , describe, description, showId, compareId-   ) where--import Data.Char-import Data.List-import Data.Monoid-import Data.Ord-import Common.StringRef-import Common.Utils (splitsWithElem)-------------------------------------------------------------------------- Abstract data type and its instances--data Id = Id -   { idList        :: [String]-   , idDescription :: String-   , idRef         :: !StringRef-   }-   -instance Show Id where-   show = concat . intersperse "." . idList--instance Eq Id where-   a == b = idRef a == idRef b--instance Ord Id where -   compare = comparing idRef--instance Monoid Id where-   mempty  = stringId ""-   mappend = ( # )-------------------------------------------------------------------------- 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 mempty--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 mempty 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 = either (Left . changeId f) (Right . changeId f)-   ------------------------------------------------------------------------- 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` ".-_"-------------------------------------------------------------------------- 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 = concat . intersperse "." . 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--describe :: HasId a => String -> a -> a-describe = changeId . describeId- where-   describeId s a-      | null (idDescription a) = -           a {idDescription = s}-      | otherwise =+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,54 +1,56 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Common.Classes, module Common.Transformation-   , module Common.Context, module Common.Navigator-   , module Common.Derivation-   , module Common.Rewriting, module Common.Exercise-   , module Common.Strategy, module Common.View-   , failS, notS, repeatS, replicateS, sequenceS-   ) where--import Common.Classes-import Common.Context-import Common.Derivation-import Common.Exercise-import Common.Navigator hiding (left, right)-import Common.Rewriting hiding (difference)-import Common.Strategy  hiding (fail, not, repeat, replicate, sequence)-import Common.Transformation-import Common.View --import qualified Common.Strategy as S-import Prelude (Int)---- | 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,277 +1,272 @@-{-# LANGUAGE ExistentialQuantification #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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, leafs, downFirst, downLast, left, right-   , replaceT-   ) where--import Common.Uniplate hiding (leafs)-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 []--leafs :: IsNavigator f => f a -> [f a]-leafs a -   | isLeaf a  = [a]-   | otherwise = concatMap leafs (allDowns a)--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+{-# 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 view
@@ -0,0 +1,82 @@+{-# 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 view
@@ -1,25 +1,18 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Group-   , module Common.Rewriting.Operator-   , module Common.Rewriting.Difference-   , module Common.Rewriting.RewriteRule-   ) where--import Common.Rewriting.Difference-import Common.Rewriting.Group hiding (identity)-import Common.Rewriting.Operator hiding (unary, binary, isUnary, isBinary)-import Common.Rewriting.RewriteRule-import Common.Rewriting.Term hiding (Term(..))-import Common.Rewriting.Term (Term)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,120 +1,116 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 with operator-   , pairings, pairingsMatch-     -- * Primitive pairings functions-   , pairingsNone, pairingsA-   , pairingsC, pairingsAC-   ) where--import Common.View-import Common.Rewriting.Group-import Control.Monad-import Data.Maybe--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)+-----------------------------------------------------------------------------
+-- 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/Axioms.hs 
@@ -1,147 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)------ Group axioms specified as rewrite rules (directed).----------------------------------------------------------------------------------module Common.Rewriting.Axioms -   ( -- Semigroup-     leftAssociative, rightAssociative, associative-     -- Monoid-   , leftIdentity, rightIdentity-     -- Group-   , leftInverse, rightInverse-   , inverseIdentity, inverseTwice-   , flippedInverseDistribution-   , groupAxioms-     -- Abelian group-   , commutative, inverseDistribution-   ) where--import Common.Id-import Common.Rewriting.Group-import Common.Rewriting.RewriteRule---- helper-rule :: (IsMagma m, IsId n, RuleBuilder f a, Rewrite a) => m a -> n -> f -> RewriteRule a-rule m s = rewriteRule (getId (toMagma m), s)------------------------------------------------------------------------ * SemiGroup--leftAssociative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a-leftAssociative m = rule m "associative.left" $ -   \x y z -> x.(y.z) :~> (x.y).z- where -   (.) = operation m--rightAssociative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a-rightAssociative m = rule m "associative.right" $ -   \x y z -> (x.y).z :~> x.(y.z)- where -   (.) = operation m--associative :: (IsSemiGroup m, Different a, Rewrite a) => m a -> RewriteRule a-associative m-   | leftIsPreferred m = leftAssociative m-   | otherwise         = rightAssociative m------------------------------------------------------------------------ * Monoid--leftIdentity :: (IsMonoid m, Different a, Rewrite a) => m a -> RewriteRule a-leftIdentity m = rule m "identity.left" $ -   \x -> e.x :~> x- where -   (.) = operation m-   e   = identity m--rightIdentity :: (IsMonoid m, Different a, Rewrite a) => m a -> RewriteRule a-rightIdentity m = rule m "identity.right" $ -   \x -> x.e :~> x- where -   (.) = operation m-   e   = identity m------------------------------------------------------------------------ * Group--leftInverse :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a-leftInverse m = rule m "inverse.left" $ -   \x -> f x.x :~> e- where -   (.) = operation m-   e   = identity m-   f   = inverse m--rightInverse :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a-rightInverse m = rule m "inverse.right" $ -   \x -> x.f x :~> e- where -   (.) = operation m-   e   = identity m-   f   = inverse m--inverseIdentity :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a-inverseIdentity m = rule m "inverse.identity" $ -   f e :~> e- where-   e = identity m-   f = inverse m--inverseTwice :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a-inverseTwice m = rule m "inverse.twice" $ -   \x -> f (f x) :~> x- where -   f = inverse m--flippedInverseDistribution :: (IsGroup m, Different a, Rewrite a) => m a -> RewriteRule a-flippedInverseDistribution m = rule m "inverse.distribution.flipped" $ -   \x y -> f (x.y) :~> f y.f x- where -   (.) = operation m-   f   = inverse m--groupAxioms :: (IsGroup m, Different a, Rewrite a) => m a -> [RewriteRule a]-groupAxioms g = map ($ g)-   [ associative, leftIdentity, rightIdentity-   , leftInverse, rightInverse-   , inverseIdentity, inverseTwice, flippedInverseDistribution-   ] ++ extra- where-   extra -      | leftIsPreferred g =-           [ rule g "group1" $ \x y -> (y.x).f x :~> y-           , rule g "group2" $ \x y -> (y.f x).x :~> y-           ]-      | otherwise = -           [ rule g "group3" $ \x y -> f x.(x.y) :~> y-           , rule g "group4" $ \x y -> x.(f x.y) :~> y-           ]-   (.) = operation g-   f   = inverse g------------------------------------------------------------------------ * Abelian Group---- The type class constraint IsAbelianGroup could be relaxed to --- IsCommutative (or something similar)-commutative :: (IsAbelianGroup m, Different a, Rewrite a) => m a -> RewriteRule a-commutative m = rule m "commutative" $ -   \x y -> x.y :~> y.x- where -   (.) = operation m-   -inverseDistribution :: (IsAbelianGroup m, Different a, Rewrite a) => m a -> RewriteRule a-inverseDistribution m = rule m "inverse.distribution" $ -   \x y -> f (x.y) :~> f x.f y- where -   (.) = operation m-   f   = inverse m
src/Common/Rewriting/Confluence.hs view
@@ -1,163 +1,153 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Unification-import Common.Rewriting.Term-import Common.Uniplate hiding (rewriteM)-import Data.Char-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 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 (Meta _) -> []-                Just a -> [ subTop s ca | s <- unifyM a lhs2 ] ++ concatMap rec (allDowns ca)-                Nothing -> []-    -    subTop s ca = fromMaybe ca $ -       fmap (change (freeze . (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 = -   [ (freeze a, (r1, freeze b1), (r2, freeze 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 . unfreeze-   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-      ]--freeze :: Term -> Term-freeze (Meta n) = Con (newId ('m' : show n))-freeze term = descend freeze term--unfreeze :: Term -> Term-unfreeze (Con s) = case showId s of -                      'm':is | all isDigit is -> -- && not (null is) -> -                         Meta (read is)-                      _ -> Con s-unfreeze term = descend unfreeze term---------------------------------------------------------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]+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,91 +1,86 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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, differenceMode-   ) where--import Common.Rewriting.Group-import Common.Rewriting.Term-import Common.Rewriting.RewriteRule-import Common.View-import Common.Utils (safeHead)-import Control.Monad-import Common.Uniplate-import Data.Maybe--differenceMode :: (Rewrite a, Uniplate a) -               => (a -> a -> Bool) -> Bool -> a -> a -> Maybe (a, a)-differenceMode eq b =-   if b then differenceEqual eq else difference---- | 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 :: (Rewrite a, Uniplate a) -                => (a -> a -> Bool) -> a -> a -> Maybe (a, a)-differenceEqual eq p q = do-   guard (eq p q)-   diff eq p q--difference :: (Rewrite a, Uniplate a) => a -> a -> Maybe (a, a)-difference = diff (\_ _ -> True)--shallowEq :: IsTerm a => a -> a -> Bool-shallowEq a b = -   let f  = liftM fst . getFunction-       ta = toTerm a-       tb = toTerm b -   in fromMaybe (ta == tb) $ liftM2 (==) (f ta) (f tb)--findOperator :: [Magma a] -> a -> Maybe (Magma a)-findOperator ops a = safeHead $ filter (`isOperator` a) ops- where isOperator op = isJust . match (magmaView op)---- local implementation function-diff :: (Rewrite a, Uniplate a) => (a -> a -> Bool) -> a -> a -> Maybe (a, a)-diff eq = rec- where-   rec p q-      | shallowEq p q =-           case findOperator operators p of-              Just op | isAssociative op && not (isCommutative op) -> do-                 ps <- match (magmaListView op) p-                 qs <- match (magmaListView op) q-                 diffA op ps qs-              _ -> diffList (children p) (children q)-      | 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 op = curry (make . uncurry rev . f . uncurry 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 ps qs = builder ps `eq` builder qs-      rev   ps qs = (reverse ps, reverse qs)-      builder     = build (magmaListView op)-      make pair   = -         case pair of -            ([p], [q]) -> rec p q+-----------------------------------------------------------------------------
+-- 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/Group.hs 
@@ -1,247 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 hierarchy of magma's (binary operators) and groups, up to Abelian groups.----------------------------------------------------------------------------------module Common.Rewriting.Group -   ( -- Magma-     IsMagma(..), Magma, magma, magmaView, magmaListView-   , withMatch, findMagma-   , isAssociative, isCommutative, isIdempotent-   , makeAssociative, makeCommutative, makeIdempotent-     -- Semigroup-   , IsSemiGroup(..), SemiGroup, semiGroup-   , leftIsPreferred, rightIsPreferred-   , preferLeft, preferRight-     -- Monoid-   , IsMonoid(..), Monoid, monoid-     -- Group-   , IsGroup(..), Group, group-     -- Abelian group-   , IsAbelianGroup(..), AbelianGroup, abelianGroup-   ) where--import Control.Arrow-import Common.Id-import Common.View hiding (identity)-import Common.Rewriting.Operator------------------------------------------------------------------------ * Magma--class IsMagma f where -   operation   :: f a -> a -> a -> a-   hasMagma    :: f a -> (Magma a, Magma a -> f a)-   toMagma     :: f a -> Magma a-   changeMagma :: (Magma a -> Magma a) -> f a -> f a-   -- default definitions-   operation     = binary . magmaBinaryOp . toMagma-   toMagma       = fst . hasMagma-   changeMagma f = uncurry (flip ($)) . first f . hasMagma--data Magma a = Magma-   { magmaBinaryOp   :: BinaryOp a-   , magmaProperties :: [MagmaProperty]-   }--data MagmaProperty = Associative | Commutative | Idempotent | PreferLeft-   deriving Eq--instance Show (Magma a) where-   show m = "Magma " ++ showId m--instance HasId (Magma a) where-   getId = getId . magmaBinaryOp-   changeId f m = m {magmaBinaryOp = changeId f (magmaBinaryOp m)}--instance IsMagma Magma where-   hasMagma a = (a, id)--magma :: BinaryOp a -> Magma a-magma op = Magma op []--magmaView :: IsMagma m => m a -> View a (a, a)-magmaView = binaryView . magmaBinaryOp . toMagma---- The list can (and should) only contain more than two elements if the magma --- is associative-magmaListView :: IsMagma m => m a -> View a [a]-magmaListView m = makeView (Just . toList) fromList- where-   toList = if isAssociative m then ($ []) . rec else f- -   f a = maybe [a] (\(x, y) -> [x, y]) (match (magmaView m) a)- -   rec a = case match (magmaView m) a of-            Just (b, c) -> rec b . rec c-            Nothing     -> (a:)--   fromList xs-      | null xs =-           error "semiGroupView.build: empty list"-      | n>2 && not (isAssociative m) =-           error $ "semiGroupView.build: not associativity for " -                   ++ showId (toMagma m)-      | otherwise = fold (operation m) xs-    where-      n    = length xs-      fold = if hasProperty PreferLeft m then foldl1 else foldr1--withMatch :: IsMagma m => (a -> Maybe (a, a)) -> m a -> m a-withMatch f = changeMagma $ \m -> m {magmaBinaryOp = g (magmaBinaryOp m)}- where-   g op = makeBinary (getId op) (binary op) f--isAssociative, isCommutative, isIdempotent :: IsMagma m => m a -> Bool-isAssociative = hasProperty Associative-isCommutative = hasProperty Commutative-isIdempotent  = hasProperty Idempotent--makeAssociative, makeCommutative, makeIdempotent :: IsMagma m => m a -> m a-makeAssociative = giveProperty Associative-makeCommutative = giveProperty Commutative-makeIdempotent  = giveProperty Idempotent--findMagma :: IsMagma m => (m a -> b) -> m a -> (Magma a, Magma a -> b)-findMagma f = second (f .) . hasMagma---- helper functions-hasProperty :: IsMagma m => MagmaProperty -> m a -> Bool-hasProperty p = elem p . magmaProperties . toMagma--giveProperty :: IsMagma m => MagmaProperty -> m a -> m a-giveProperty p = changeMagma $ \m -> -   m {magmaProperties = p:magmaProperties m}--removeProperty :: IsMagma m => MagmaProperty -> m a -> m a-removeProperty p = changeMagma $ \m -> -   m {magmaProperties = filter (/=p) (magmaProperties m)}------------------------------------------------------------------------ * SemiGroup--class IsMagma f => IsSemiGroup f where-   toSemiGroup :: f a -> SemiGroup a-   -- default definition-   toSemiGroup m = SemiGroup (rightIsPreferred m) (toMagma m)--data SemiGroup a = SemiGroup Bool (Magma a)--instance Show (SemiGroup a) where-   show m = "Semigroup " ++ showId m--instance HasId (SemiGroup a) where-   getId    = getId . toMagma-   changeId = changeMagma . changeId--instance IsMagma SemiGroup where-   hasMagma (SemiGroup b m) = findMagma (SemiGroup b) m--instance IsSemiGroup SemiGroup where-   toSemiGroup = id--semiGroup :: BinaryOp a -> SemiGroup a-semiGroup op = makeAssociative $ SemiGroup True (magma op)--leftIsPreferred, rightIsPreferred :: IsSemiGroup m => m a -> Bool-leftIsPreferred  = hasProperty PreferLeft-rightIsPreferred = not . leftIsPreferred--preferLeft, preferRight :: IsSemiGroup m => m a -> m a-preferLeft  = giveProperty PreferLeft-preferRight = removeProperty PreferLeft------------------------------------------------------------------------ * Monoid--class IsSemiGroup f => IsMonoid f where-   identity    :: f a -> a-   identityCon :: f a -> Constant a-   toMonoid    :: f a -> Monoid a-   -- default definition-   identity   = constant . identityCon-   toMonoid m = Monoid (identityCon m) (toSemiGroup m)--data Monoid a = Monoid (Constant a) (SemiGroup a)--instance Show (Monoid a) where-   show m = "Monoid " ++ showId m--instance HasId (Monoid a) where-   getId    = getId . toMagma-   changeId = changeMagma . changeId--instance IsMagma Monoid where-   hasMagma (Monoid e g) = findMagma (Monoid e) g--instance IsSemiGroup Monoid--instance IsMonoid Monoid where-   identityCon (Monoid e _) = e-   toMonoid = id--monoid :: BinaryOp a -> Constant a -> Monoid a-monoid op e = Monoid e (semiGroup op)------------------------------------------------------------------------ * Group--class IsMonoid f => IsGroup f where-   inverse   :: f a -> a -> a-   inverseOp :: f a -> UnaryOp a-   toGroup   :: f a -> Group a-   -- default definition-   inverse   = unary . inverseOp-   toGroup g = Group (inverseOp g) (toMonoid g)--data Group a = Group (UnaryOp a) (Monoid a)--instance Show (Group a) where-   show m = "Group " ++ showId m--instance HasId (Group a) where-   getId    = getId . toMagma-   changeId = changeMagma . changeId--instance IsMagma Group where-   hasMagma (Group inv m) = findMagma (Group inv) m--instance IsSemiGroup Group--instance IsMonoid Group where-   identityCon (Group _ m) = identityCon m--instance IsGroup Group where-   inverseOp (Group inv _) = inv-   toGroup = id--group :: BinaryOp a -> Constant a -> UnaryOp a -> Group a-group op e inv = Group inv (monoid op e)------------------------------------------------------------------------ * Abelian Group--class IsGroup f => IsAbelianGroup f where-   toAbelianGroup :: f a -> AbelianGroup a-   -- default definition-   toAbelianGroup = AbelianGroup . toGroup--newtype AbelianGroup a = AbelianGroup (Group a)-   deriving (HasId, IsMagma, IsSemiGroup, IsMonoid, IsGroup)--abelianGroup :: BinaryOp a -> Constant a -> UnaryOp a -> AbelianGroup a-abelianGroup op e inv = makeCommutative $ AbelianGroup (group op e inv)--instance Show (AbelianGroup a) where-   show m = "Abelian group " ++ showId m-   -instance IsAbelianGroup AbelianGroup
− src/Common/Rewriting/Operator.hs 
@@ -1,117 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Operator-   ( -- * Constants-     Constant, makeConstant, simpleConstant-   , constant, isConstant, constantView-     -- * Unary operators-   , UnaryOp, makeUnary, simpleUnary-   , unary, isUnary, unaryMatch, unaryView-     -- * Binary operators-   , BinaryOp, makeBinary, simpleBinary-   , binary, isBinary, binaryMatch, binaryView-   ) where--import Common.Id-import Common.Uniplate-import Common.View-import Data.Maybe-import Control.Monad--------------------------------------------------------------------------- Constants--data Constant a = C-   { constantId :: Id-   , constant   :: a-   , isConstant :: a -> Bool-   }--instance Show (Constant a) where-   show = showId--instance HasId (Constant a) where-   getId = constantId-   changeId f op = op {constantId = f (constantId op)}--makeConstant :: IsId n => n -> a -> (a -> Bool) -> Constant a-makeConstant = C . newId--simpleConstant :: (IsId n, Eq a) => n -> a -> Constant a-simpleConstant n a = makeConstant n a (==a)--constantView :: Constant a -> View a ()-constantView (C i a p) = newView i (guard . p) (const a)--------------------------------------------------------------------------- Unary operators--data UnaryOp a = U-   { unaryId    :: Id-   , unary      :: a -> a-   , unaryMatch :: a -> Maybe a-   }--instance Show (UnaryOp a) where-   show = showId--instance HasId (UnaryOp a) where-   getId = unaryId-   changeId f op = op {unaryId = f (unaryId op)}--makeUnary :: IsId n => n -> (a -> a) -> (a -> Maybe a) -> UnaryOp a-makeUnary = U . newId--simpleUnary :: (IsId n, Uniplate a, Eq a) => n -> (a -> a) -> UnaryOp a-simpleUnary n op = makeUnary n op f- where-   f a = case children a of-            [x] | op x == a -> Just x-            _ -> Nothing--isUnary :: UnaryOp a -> a -> Bool-isUnary op = isJust . unaryMatch op--unaryView :: UnaryOp a -> View a a-unaryView (U i op m) = newView i m op--------------------------------------------------------------------------- Binary operators--data BinaryOp a = B -   { binaryId    :: Id-   , binary      :: a -> a -> a-   , binaryMatch :: a -> Maybe (a, a)-   }--instance Show (BinaryOp a) where-   show = showId--instance HasId (BinaryOp a) where-   getId = binaryId-   changeId f op = op {binaryId = f (binaryId op)}--makeBinary :: IsId n => n -> (a -> a -> a) -> (a -> Maybe (a, a)) -> BinaryOp a-makeBinary = B . newId--simpleBinary :: (IsId n, Uniplate a, Eq a) => n -> (a -> a -> a) -> BinaryOp a-simpleBinary n op = makeBinary n op f- where-   f a = case children a of-            [x, y] | op x y == a -> Just (x, y)-            _ -> Nothing--isBinary :: BinaryOp a -> a -> Bool-isBinary op = isJust . binaryMatch op--binaryView :: BinaryOp a -> View a (a, a)-binaryView (B n op m) = newView n m (uncurry op)
src/Common/Rewriting/RewriteRule.hs view
@@ -1,196 +1,155 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, -       FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 classes-     Rewrite(..), Different(..)-     -- * Rewrite rules and specs-   , RewriteRule, ruleSpecTerm, RuleSpec(..)-     -- * Compiling rewrite rules-   , rewriteRule, RuleBuilder-     -- * Using rewrite rules-   , rewrite, rewriteM, showRewriteRule, smartGenerator-   , metaInRewriteRule, renumberRewriteRule, inverseRule-   , useOperators-   ) where--import Common.Classes-import Common.Id-import Common.View hiding (match)-import Common.Rewriting.Substitution-import Common.Rewriting.Term-import Common.Rewriting.Group-import Common.Rewriting.Unification hiding (match)-import Common.Uniplate (descend, leafs)-import Control.Monad-import Data.Maybe-import Test.QuickCheck-import qualified Common.Rewriting.Unification as Unification-import qualified Data.IntSet as IS-   ---------------------------------------------------------- Supporting type classes---- The arbitrary type class is a quick solution to have smart generators--- (in combination with lifting rules). The function in the RewriteRule module--- cannot have a type class for this reason--- The show type class is added for pretty-printing rules-class (IsTerm a, Arbitrary a, Show a) => Rewrite a where-   operators :: [Magma a]-   -- default definition: no special operators-   operators = []----------------------------------------------------------- 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--instance Crush RuleSpec where-   crush (a :~> b) = [a, b]--instance Zip RuleSpec where -   fzipWith f (a :~> b) (c :~> d) = f a c :~> f b d--data RewriteRule a = R-   { ruleId        :: Id-   , ruleSpecTerm  :: RuleSpec Term-   , ruleOperators :: [Magma a]-   , ruleShow      :: a -> String-   , ruleTermView  :: View Term a-   , ruleGenerator :: 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)--class RuleBuilder t a | t -> a where-   buildRuleSpec :: t -> Int -> RuleSpec Term--instance IsTerm a => RuleBuilder (RuleSpec a) a where-   buildRuleSpec = const . fmap toTerm--instance (Different a, RuleBuilder t b) => RuleBuilder (a -> t) b where-   buildRuleSpec f i = buildFunction i (\a -> buildRuleSpec (f a) (i+1))--buildFunction :: (Zip f, Different a) => Int -> (a -> f Term) -> f Term-buildFunction n f = fzipWith (fill n) (f a) (f b)- where (a, b) = different- -fill :: Int -> Term -> Term -> Term-fill i = rec- where-   rec (Apply f a) (Apply g b) = Apply (rec f g) (rec a b)-   rec a b -      | a == b    = a-      | otherwise = Meta i--buildSpec :: [Symbol] -> RuleSpec Term -> Term -> [Term]-buildSpec ops (lhs :~> rhs) a = do-   s <- Unification.match ops lhs a-   let (b1, b2) = (specialLeft `elem` dom s, specialRight `elem` dom s)-       sym      = maybe (error "buildSpec") fst (getFunction lhs)-       extLeft  x = if b1 then binary sym (Meta specialLeft) x else x-       extRight x = if b2 then binary sym x (Meta specialRight) else x-   return (s |-> extLeft (extRight rhs))--rewriteRule :: (IsId n, RuleBuilder f a, Rewrite a) => n -> f -> RewriteRule a-rewriteRule s f = R (newId s) (buildRuleSpec f 0) operators show termView arbitrary----------------------------------------------------------- Using a rewrite rule--instance Apply RewriteRule where -   applyAll = rewrite--rewrite :: RewriteRule a -> a -> [a]-rewrite r a = -   let term = toTermRR r a-       syms = mapMaybe (operatorSymbol r a) (ruleOperators r)-   in concatMap (fromTermRR r) (buildSpec syms (ruleSpecTerm r) term)--operatorSymbol :: IsMagma m => RewriteRule a -> a -> m a -> Maybe Symbol-operatorSymbol r a op = -   case getFunction (toTermRR r (operation op a a)) of-      Just (s, [_, _]) -> Just s-      _                -> Nothing- -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 [ Var [c] | c <- ['a' ..] ]---------------------------------------------------------------- Smart generator that creates instantiations of the left-hand side--smartGenerator :: RewriteRule a -> Gen a-smartGenerator r = do -   let a :~> _ = ruleSpecTerm r-   let vs = IS.toList (metaVarSet a)-   list <- replicateM (length vs) (ruleGenerator r)-   let sub = listToSubst (zip vs (map (toTermRR r) list))-   case fromTermRR r (sub |-> a) of-      Just x  -> return x-      Nothing -> ruleGenerator r----------------------------------------------------------inverseRule :: RewriteRule a -> RewriteRule a-inverseRule r = r {ruleSpecTerm = b :~> a}- where a :~> b = ruleSpecTerm r--useOperators :: [Magma a] -> RewriteRule a -> RewriteRule a-useOperators xs r = r {ruleOperators = xs ++ ruleOperators r}---- some helpers-metaInRewriteRule :: RewriteRule a -> [Int]-metaInRewriteRule r =-   [ n | a <- crush (ruleSpecTerm r), Meta n <- leafs a ]--renumberRewriteRule :: Int -> RewriteRule a -> RewriteRule a-renumberRewriteRule n r = r {ruleSpecTerm = fmap f (ruleSpecTerm r)}- where-   f (Meta i) = Meta (i+n)-   f term     = descend f term-   -toTermRR :: RewriteRule a -> a -> Term-toTermRR = build . ruleTermView--fromTermRR :: Monad m => RewriteRule a -> Term -> m a+{-# 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 view
@@ -1,73 +1,116 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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----------------------------------------------------------------------------------module Common.Rewriting.Substitution -   ( Substitution, emptySubst, singletonSubst, dom-   , (@@), (@@@), (|->), listToSubst-   ) where--import Common.Uniplate-import Common.Rewriting.Term-import qualified Data.IntMap as IM-import Data.Maybe----------------------------------------------------------------- Substitution---- | Abstract data type for substitutions-newtype Substitution = S { unS :: IM.IntMap Term }-   -infixr 4 |->-infixr 5 @@, @@@--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 = S (IM.singleton i a)---- | Turns a list into a substitution-listToSubst :: [(Int, Term)] -> Substitution-listToSubst = S . IM.fromListWith (error "Substitution: keys are not unique")---- | Combines two substitutions. The left-hand side substitution is first applied to--- the co-domain of the right-hand side substitution-(@@) :: Substitution -> Substitution -> Substitution-S a @@ S b = S $ a `IM.union` IM.map (S a |->) b---- | Combines two substitutions with disjoint domains. If the domains are not disjoint,--- an error is reported-(@@@) :: Substitution -> Substitution -> Substitution-S a @@@ S b = S (IM.unionWith err a b)- where err _ _ = error "Unification.(@@@): domains of substitutions are not disjoint"---- | 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 list)-dom :: Substitution -> [Int]-dom = IM.keys . unS---- | Apply the substitution-(|->) :: Substitution -> Term -> Term-s |-> term = -   case term of-      Meta i -> fromMaybe term (lookupVar i s)-      _      -> descend (s |->) term+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,223 +1,267 @@-{-# LANGUAGE DeriveDataTypeable #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 -   ( Term(..), IsTerm(..)-   , Symbol, newSymbol-   , fromTermM, fromTermWith-   , getSpine, makeTerm-     -- * Functions and symbols-   , WithFunctions(..), isSymbol, isFunction-   , unary, binary, isUnary, isBinary-     -- * Variables-   , WithVars(..), isVariable-   , vars, varSet, hasVar, withoutVar, hasSomeVar, hasNoVar-     -- * Meta variables-   , WithMetaVars(..), isMetaVar-   , metaVars, metaVarSet, hasMetaVar-   ) where--import Common.Id-import Common.Utils (ShowString(..))-import Common.Uniplate-import Common.View-import Control.Monad-import Data.Maybe-import Data.Typeable-import qualified Data.IntSet as IS-import qualified Data.Set as S---------------------------------------------------------------- * Data type for terms--data Term = Var   String -          | Con   Symbol -          | Apply Term Term-          | Num   Integer -          | Float Double-          | Meta  Int- deriving (Show, Eq, Ord, Typeable)- -instance Uniplate Term where-   uniplate (Apply f a) = ([f, a], \[g, b] -> Apply g b)-   uniplate term        = ([], \_ -> term)--newtype Symbol = S Id-   deriving (Eq, Ord)--instance Show Symbol where-   show = showId--instance HasId Symbol where-   getId (S a) = a-   changeId f (S a) = S (f a)--newSymbol :: IsId a => a -> Symbol-newSymbol = S . newId---------------------------------------------------------------- * Type class for conversion to/from terms--class IsTerm a where-   toTerm   :: a -> Term-   fromTerm :: MonadPlus m => Term -> m a-   termView :: View Term a-   -- default definitions-   toTerm   = build termView-   fromTerm = matchM termView-   termView = makeView fromTerm toTerm--instance IsTerm Term where-   toTerm   = id-   fromTerm = return--instance IsTerm ShowString where -   toTerm = Var . fromShowString-   fromTerm (Var 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) --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 . Con-   getFunction a = -      case getSpine a of-         (Con 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    = Var-   getVariable (Var 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 . leafs--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---------------------------------------------------------------- * Meta variables--class WithMetaVars a where-   metaVar    :: Int -> a-   getMetaVar :: Monad m => a -> m Int --instance WithMetaVars Term where-   metaVar = Meta-   getMetaVar (Meta 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 . leafs--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 (Apply f a) = rec (a:xs) f-   rec xs a           = (a, xs)--makeTerm :: Term -> [Term] -> Term-makeTerm = foldl Apply+{-# 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 view
@@ -1,138 +1,141 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 -   ( match, unifyM, specialLeft, specialRight-   ) where--import Common.Rewriting.Term-import Common.Rewriting.AC-import Common.Rewriting.Substitution-import Control.Monad---------------------------------------------------------------- Unification (in both ways)--unifyM :: Monad m => Term -> Term -> m Substitution-unifyM term1 term2 = -   case (term1, term2) of-      (Meta i, Meta j) | i == j -> -         return emptySubst-      (Meta i, _) | not (i `hasMetaVar` term2) -> -         return (singletonSubst i term2)-      (_, Meta j) | not (j `hasMetaVar` term1) -> -         return (singletonSubst j term1)-      (Apply f a, Apply g b) -> do-         s1 <- unifyM f g-         s2 <- unifyM (s1 |-> a) (s1 |-> b)-         return (s1 @@ s2)-      _ | term1 == term2 -> -         return emptySubst-      _ -> fail "unifyM: no unifier"--{--class ShallowEq a where -   shallowEq :: a -> a -> Bool---- The arbitrary type class is a quick solution to have smart generators--- (in combination with lifting rules). The function in the RewriteRule module--- cannot have a type class for this reason--- The show type class is added for pretty-printing rules-class (MetaVar a, Uniplate a, ShallowEq a, Arbitrary a, Show a) => Rewrite a where-   operators :: [Operator a]-   -- default definition: no associative/commutative operators-   operators = []--unify :: Rewrite a => a -> a -> [Substitution a]-unify = unifyWith operators--unifyM :: (MonadPlus m, Rewrite a) => a -> a -> m (Substitution a)-unifyM x y = msum $ map return $ unify x y--unifyWith :: Rewrite a => [Operator a] -> a -> a -> [Substitution a]-unifyWith ops = rec- where-   rec x y =-      case (isMetaVar x, isMetaVar y) of-         (Just i, Just j) | i==j -> return emptySubst-         (Just i, _) | not (hasMetaVar i y) -> return $ singletonSubst i y-         (_, Just j) | not (hasMetaVar j x) -> return $ singletonSubst j x-         _ -> do-            guard (shallowEq x y) -            case findOperator ops x of-               Just op -> -                  concatMap (uncurry recList . unzip) (pairings op x y)-               Nothing -> -                  recList (children x) (children y)    --   recList [] []    = return emptySubst-   recList (x:xs) (y:ys) = do-      s1 <- rec x y-      s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys)-      return (s2 @@ s1)-   recList _ _ = []--}--------------------------------------------------------------- Matching (or: one-way unification)---- second term should not have meta variables--match :: [Symbol] -> Term -> Term -> [Substitution]-match assocSymbols = rec True- where-   rec _ (Meta i) y = -      return (singletonSubst i y)--   rec isTop x y =-      case getSpine x of-         (Con s, [a1, a2]) | s `elem` assocSymbols ->-            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 (Apply (Apply (Con 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  = (Meta specialLeft:)-   extRight = (++[Meta specialRight])-   extBoth  = extLeft . extRight-   -   result   = concatMap (\zs -> pairingsA True zs bs) list-   make (a, b) = (construct a, construct b)-   -   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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,52 +1,54 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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, label, sequence, alternatives-     -- ** 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, rulesInStrategy, mapRules, mapRulesS-   ) where--import Common.Strategy.Abstract-import Common.Strategy.Combinators-import Common.Strategy.Prefix-import Common.Strategy.Location-import Common.Strategy.Configuration-import Common.Strategy.Parsing+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,214 +1,236 @@-{-# LANGUAGE FlexibleInstances #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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, cleanUpStrategy-     -- Accessors to the underlying representation-   , toCore, fromCore, liftCore, liftCore2, makeLabeledStrategy-   , toLabeledStrategy-   , LabelInfo, processLabelInfo, changeInfo, makeInfo-   , removed, collapsed, hidden, IsLabeled(..)-   ) where--import Common.Id-import Common.Utils (commaList)-import Common.Strategy.Core-import Common.Classes-import Common.Rewriting (RewriteRule)-import Common.Transformation-import Common.Derivation-import Common.Uniplate hiding (rewriteM)-import Common.Strategy.Parsing----------------------------------------------------------------- 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----------------------------------------------------------------- The information used as label in a strategy--data LabelInfo = Info -   { labelId   :: Id -   , removed   :: Bool-   , collapsed :: Bool-   , hidden    :: Bool-   }--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) }-   -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 (Core LabelInfo) where-   toStrategy = S--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 (showId r)) (S (Rule r))--instance IsLabeled RewriteRule where-   toLabeled r = toLabeled (makeRule (showId 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 emptyCoreEnv- where-   rec env core = -      case core of -         Rec n a   -> Rec n (rec (insertCoreEnv 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 = mapRule minorRule (Label l c)-          | otherwise   = Label l c-      info   = getInfo l-      asRule = makeSimpleRuleList (showId info{- ++ " (collapsed)"-}) -                  (runCoreWith env new)----------------------------------------------------------------- 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 . mapSteps 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 . mapRule f . toCore---- | Use a function as do-after hook for all rules in a labeled strategy-cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a-cleanUpStrategy f (LS n s) = mapRules g (LS n (S core))- where-   core = Rule (doAfter f idRule) :*: toCore s-   g r | isMajorRule r = doAfter f r  -       | otherwise     = r-       ---------------------------------------------------------------- Functions to lift the core combinators--fromCore :: Core LabelInfo a -> Strategy a-fromCore = toStrategy--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+{-# 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 view
@@ -1,176 +1,183 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 qualified Prelude-import Prelude hiding (not, repeat, fail, sequence)-import Common.Id-import Common.Context-import Common.Navigator-import Common.Transformation-import Common.Strategy.Core-import Common.Strategy.Abstract-import Common.Strategy.Configuration-import Data.Maybe----------------------------------------------------------------- Strategy combinators---- Basic combinators ----------------------------------------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 $ \x y -> -   case (x, y) of-      (Succeed, _) -> y-      (_, Succeed) -> x-      (Fail, _)    -> Fail-      (_, Fail)    -> Fail-      _            -> x :*: y---- | Choose between the two strategies (either do this or do that)-(<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a-(<|>) = liftCore2 $ \x y ->-   case (x, y) of-      (Fail, _) -> y-      (_, Fail) -> x-      _         -> x :|: y---- | 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---- | 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---- 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)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,108 +1,109 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.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 . toStrategy-       err      = error "configureNow: label disappeared"-   in coreToLS . processLabelInfo id . lsToCore--configure :: StrategyConfiguration -> LabeledStrategy a -> LabeledStrategy a-configure cfg ls = -   label (showId ls) (configureCore cfg (toCore (unlabel ls)))--configureCore :: StrategyConfiguration -> Core LabelInfo a -> Core LabelInfo a-configureCore cfg = mapLabel (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}+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,151 +1,199 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 -   ( Core(..)-   , mapRule, mapLabel, noLabels-   , coreMany, coreRepeat, coreOrElse, coreFix-   , CoreEnv, emptyCoreEnv, insertCoreEnv, lookupCoreEnv, substCoreEnv-   ) where--import Common.Transformation-import Common.Uniplate-import Data.Maybe-import qualified Data.IntMap as IM---------------------------------------------------------------------- Strategy (internal) data structure, containing a selection--- of combinators--infixr 3 :|:, :|>:-infixr 5 :*:---- Some rules receive label (but not all)-data Core l a-   = Core l a :*:  Core l a-   | Core l a :|:  Core l a-   | Core l a :|>: Core l a-   | Many   (Core l a)-   | Repeat (Core l a)-   | Not (Core l a)-   | Label l (Core l a)-   | Succeed-   | Fail-   | Rule (Rule a)-   | Var Int-   | Rec Int (Core l a)- deriving Show---------------------------------------------------------------------- Useful instances--instance Uniplate (Core l a) where-   uniplate core =-      case core of-         a :*: b   -> ([a,b], \[x,y] -> x :*: y)-         a :|: b   -> ([a,b], \[x,y] -> x :|: y)-         a :|>: b  -> ([a,b], \[x,y] -> x :|>: y)-         Many a    -> ([a],   \[x]   -> Many x)-         Repeat a  -> ([a],   \[x]   -> Repeat x)-         Label l a -> ([a],   \[x]   -> Label l x)-         Rec n a   -> ([a],   \[x]   -> Rec n x)-         Not a     -> ([a],   \[x]   -> Not x)-         _         -> ([],    \_     -> core)---------------------------------------------------------------------- Core environment--newtype CoreEnv l a = CE (IM.IntMap (Core l a)) --emptyCoreEnv :: CoreEnv l a-emptyCoreEnv = CE IM.empty-  -insertCoreEnv :: Int -> Core l a -> CoreEnv l a -> CoreEnv l a-insertCoreEnv n a (CE m) = CE (IM.insert n a m)--deleteCoreEnv :: Int -> CoreEnv l a -> CoreEnv l a-deleteCoreEnv n (CE m) = CE (IM.delete n m)--lookupCoreEnv :: Int -> CoreEnv l a -> Maybe (Core l a)-lookupCoreEnv n (CE m) = IM.lookup n m--substCoreEnv :: CoreEnv l a -> Core l a -> Core l a-substCoreEnv env core = -   case core of-      Var i   -> fromMaybe core (lookupCoreEnv i env)-      Rec i a -> Rec i (substCoreEnv (deleteCoreEnv i env) a)-      _       -> descend (substCoreEnv env) core---------------------------------------------------------------------- Definitions--coreMany :: Core l a -> Core l a-coreMany a = Rec n (Succeed :|: (a :*: Var n))- where n = nextVar a--coreRepeat :: Core l a -> Core l a-coreRepeat a = Many a :*: Not a--coreOrElse :: Core l a -> Core l a -> Core l a-coreOrElse a b = a :|: (Not a :*: b)--coreFix :: (Core l a -> Core l a) -> Core l a-coreFix f = -- disadvantage: function f is applied twice-   let i = nextVar (f (Var (-1)))-   in Rec i (f (Var i))--nextVar :: Core l a -> Int-nextVar p-   | null xs   = 0-   | otherwise = maximum xs + 1- where xs = coreVars p--coreVars :: Core l a -> [Int]-coreVars core = -   case core of-      Var n   -> [n]-      Rec n a -> n : coreVars a-      _       -> concatMap coreVars (children core)---------------------------------------------------------------------- Utility functions--mapLabel :: (l -> m) -> Core l a -> Core m a-mapLabel f = mapCore (Label . f) Rule--mapRule :: (Rule a -> Rule b) -> Core l a -> Core l b-mapRule f = mapCore Label (Rule . f)--noLabels :: Core l a -> Core m a-noLabels = mapCore (const id) Rule-   -mapCore :: (l -> Core m b -> Core m b) -> (Rule a -> Core m b) -        -> Core l a -> Core m b-mapCore 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-         Many a    -> Many   (rec a)-         Repeat a  -> Repeat (rec a)-         Succeed   -> Succeed-         Fail      -> Fail-         Label l a -> f l (rec a)-         Rule r    -> g r-         Var n     -> Var n-         Rec n a   -> Rec n (rec a)-         Not a     -> Not (rec a)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,80 +1,80 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Uniplate-import Common.Utils (safeHead)-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 (toStrategy 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 = +-----------------------------------------------------------------------------
+-- 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 view
@@ -1,191 +1,281 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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, runCoreWith-   ) where--import Common.Classes-import Common.Derivation-import Common.Strategy.Core-import Common.Transformation-import Control.Monad--------------------------------------------------------------------------- Step data type--data Step l a = Enter l | Exit l | RuleStep (Rule a)-   deriving Show--instance Apply (Step l) where-   applyAll (RuleStep r) = applyAll r-   applyAll _            = return--------------------------------------------------------------------------- State data type--data State l a = S-   { stack   :: [Either l (Core l a)]-   , choices :: [Bool]-   , trace   :: [Step l a]-   , value   :: a-   }--makeState :: Core l a -> a -> State l a-makeState core a = push core (S [] [] [] a)--------------------------------------------------------------------------- Parse derivation tree--parseDerivationTree :: State l a -> DerivationTree (Step l a) (State l a)-parseDerivationTree state = addBranches list node- where-   xs    = firsts state-   empty = not (null [ () | (Ready, _) <- xs ])-   node  = singleNode state empty-   list  = [ (step, parseDerivationTree 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 (Left l, s)     -> [(Result (Exit l), traceExit l s)]-      Just (Right 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-         Rec i a   -> firstsStep (substCoreVar i core a) state-         Var _     -> freeCoreVar "firsts"-         Rule r    -> hasStep (RuleStep r) (useRule r state)-         Label l a -> hasStep (Enter l) [push a (pushExit l 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 xs = [ (Result step, traceStep step s) | s <- xs ]---- helper datatype-data Result a = Result a | Ready--------------------------------------------------------------------------- Running the parser--runCore :: Core l a -> a -> [a]-runCore core = runState . makeState core--runCoreWith :: CoreEnv l a -> Core l a -> a -> [a]-runCoreWith env = runCore . substCoreEnv env--runState :: State l a -> [a]-runState st =-   case pop st of-      Nothing              -> [value st]-      Just (Left _, s)     -> runState s-      Just (Right 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-         Rec i a   -> runStep (substCoreVar i core a) state-         Var _     -> freeCoreVar "runState"-         Rule  r   -> concatMap runState (useRule r state)-         Label _ a -> runStep a 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 (Left l, s)     -> replayState (n-1) bs (traceExit l s)-         Just (Right 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)-         Rec i a   -> replayStep n bs (substCoreVar i core a) state-         Var _     -> freeCoreVar "replay"-         Rule r    -> replayState (n-1) bs (traceRule r state)-         Label l a -> replayStep (n-1) bs a (pushExit l (traceEnter l 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--------------------------------------------------------------------------- Local helper functions and instances-   -push :: Core l a -> State l a -> State l a-push core s = s {stack = Right core : stack s}--pushExit :: l -> State l a -> State l a-pushExit l s = s {stack = Left l : stack s}--pop :: State l a -> Maybe (Either l (Core l a), State l a)-pop s = case stack s of-           []   -> Nothing-           x:xs -> Just (x, s {stack = xs})-   -makeChoice :: Bool -> State l a -> State l a-makeChoice b s = s {choices = b : choices s}--checkNot :: Core l a -> State l a -> Bool-checkNot core = null . runCore core . value--useRule :: Rule a -> State l a -> [State l a]-useRule r state = [ state {value = b} | b <- applyAll r (value state) ]--traceEnter, traceExit :: l -> State l a -> State l a-traceEnter = traceStep . Enter-traceExit  = traceStep . Exit--traceRule :: Rule a -> State l a -> State l a-traceRule = traceStep . RuleStep--traceStep :: Step l a -> State l a -> State l a-traceStep step s = s {trace = step : trace s}--substCoreVar :: Int -> Core l a -> Core l a -> Core l a-substCoreVar i a = substCoreEnv (insertCoreEnv i a emptyCoreEnv)--freeCoreVar :: String -> a-freeCoreVar caller = error $ "Free var in core expression: " ++ caller+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,82 +1,78 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Utils-import Common.Strategy.Abstract-import Common.Strategy.Parsing-import Common.Transformation-import Common.Derivation-import Data.Maybe-import Control.Monad----------------------------------------------------------------- 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 = f (parseDerivationTree s {value = a})- where-   f t = addBranches list (singleNode (value $ root t) (endpoint t))-    where-      list = map g (branches t)-      g (_, st) = (P (root st), f st)--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)+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,175 @@+{-# 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/StringRef.hs 
@@ -1,128 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more 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.StringRef (StringRef, stringRef, toString) where
-
-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)
-
-instance Show StringRef where
-   show s@(S i) = '#' : show i ++ toString s
-
-----------------------------------------------------------------
--- 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 
-
-{-
-printTable :: IO ()
-printTable = readIORef tableRef >>= print
-
-test1 _ = toString (stringRef "bas") == "bas"
-test2 _ = stringRef "bas" == stringRef "bas"
-test3 _ = stringRef "bas" /= stringRef "je"
-test4 _ = stringRef "arith1.unary_minus" /= stringRef "distribute power"
--}
− src/Common/TestSuite.hs 
@@ -1,385 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.TestSuite -   ( -- * Test Suite Monad-     TestSuite, MonadIO(..)-     -- * Test suite constructors-   , suite, addProperty, addPropertyWith-   , assertTrue, assertTrueMsg, assertNull, assertEquals-   , assertIO, warn-     -- * Running a test suite-   , runTestSuite, runTestSuiteResult-     -- * Test Suite Result-   , TestSuiteResult, subResults-   , makeSummary, printSummary-   , makeTestLog, makeTestLogWith, printTestLog-     -- * Formatting-   , FormatLog(..), formatLog, formatTimeDiff-   ) where--import Control.Arrow-import Data.List-import Data.Monoid-import qualified Data.Sequence as S-import Data.Foldable (toList)-import Test.QuickCheck-import Control.Monad.State-import System.Time hiding (formatTimeDiff)--------------------------------------------------------------------- Test Suite Monad---- Integer corresponds to the number of characters on the current line, and--- is used for formatting-newtype TestSuiteM a = TSM { unTSM :: M a }--type M a = StateT (Int, ResultTree) IO a-type TestSuite = TestSuiteM ()--instance Monad TestSuiteM where-   return  = TSM . return-   m >>= f = TSM (unTSM m >>= unTSM . f)-   fail s  = do assertTrueMsg "" 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, td) <- getDiff (withEmptyTree (unTSM m))-   addTree (labeled (s, td) 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-   addResult s (toTestResult (maxSuccess args) r)--assertTrue :: String -> Bool -> TestSuite-assertTrue msg = assertIO msg . return--assertTrueMsg :: String -> String -> Bool -> TestSuite-assertTrueMsg s msg = addAssertion (Error msg) s . return--assertNull :: Show a => String -> [a] -> TestSuite-assertNull s xs = addAssertion (f xs) s (return (null xs))- where f = Error . concat . intersperse "\n" . map show- -assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite-assertEquals s x y = addAssertion msg s (return (x==y))- where msg = Error ("Not equal: " ++ show x ++ " and " ++ show y)--assertIO :: String -> IO Bool -> TestSuite-assertIO = addAssertion (Error "Assertion failed")--warn :: String -> TestSuite-warn msg = addAssertion (Warning msg) "" (return False)---- local helpers-addAssertion :: TestResult -> String -> IO Bool -> TestSuite-addAssertion msg s io = TSM $ do-   b <- liftIO (io `catch` \_ -> return False)-   if b then do -      dot-      addResult s (Ok 1)-    else do-      newlineIndent-      liftIO $ putStrLn (s ++ ": " ++ show msg)-      reset-      addResult s msg--addResult :: String -> TestResult -> M ()-addResult s r = addTree (single (s, r))--addTree :: ResultTree -> M ()-addTree t = modify (second (`mappend` t))--withEmptyTree :: M () -> M ResultTree-withEmptyTree m = do-   t0 <- gets snd-   modify (second (const mempty))-   m-   tr <- gets snd-   modify (second (const t0))-   return tr---- formatting helpers-newline :: M ()-newline = do-   i <- gets fst-   when (i>0) (liftIO $ putChar '\n')-   reset--newlineIndent :: M ()-newlineIndent = do-   newline-   liftIO $ putStr "   "-   modify (first (const 3))--dot :: M ()-dot = do-   i <- gets fst-   unless (i>0 && i<60) newlineIndent-   liftIO $ putChar '.'-   modify (first (+1))--reset :: M ()-reset = modify (first (const 0))--------------------------------------------------------------------- Running a test suite--runTestSuite :: TestSuite -> IO ()-runTestSuite s = runTestSuiteResult s >> return ()--runTestSuiteResult :: TestSuite -> IO TestSuiteResult-runTestSuiteResult s = liftM TSR $ getDiff $ liftM snd $-   execStateT (unTSM s >> newline) (0, mempty)--------------------------------------------------------------------- Test Suite Result--newtype TestSuiteResult = TSR (ResultTree, TimeDiff)--type ResultTree = Tree (String, TimeDiff) (String, TestResult)--data TestResult = Ok !Int | Error String | Warning String--instance Show TestResult where-   show (Ok _)        = "Ok"-   show (Error msg)   = "Error: "   ++ msg-   show (Warning msg) = "Warning: " ++ msg---- one-line summary-instance Show TestSuiteResult where-   show (TSR (tree, diff)) = -      let (n, nf, nw) = collectInfo tree-      in "(tests: " ++ show n ++ ", failures: " ++ show nf ++-         ", warnings: " ++ show nw ++ ", " ++ formatTimeDiff diff ++ ")"--subResults :: TestSuiteResult -> [(String, TestSuiteResult)]-subResults (TSR (tree, _)) = -   let f ((s, diff), t) = (s, TSR (t, diff))-   in map f (subtrees tree)--printSummary :: TestSuiteResult -> IO ()-printSummary = putStrLn . makeSummary--makeSummary :: TestSuiteResult -> String-makeSummary result@(TSR (tree, diff)) = unlines $-   [ line-   , "Tests    : " ++ show n-   , "Failures : " ++ show nf-   , "Warnings : " ++ show nw-   , "\nTime     : " ++ formatTimeDiff diff-   , "\nSuites: "-   ] ++ map f (subResults result) -     ++ [line]- where-   line        = replicate 75 '-'-   (n, nf, nw) = collectInfo tree-   f (name, r) = "   " ++ name ++ "   " ++ show r--printTestLog :: TestSuiteResult -> IO ()-printTestLog = putStrLn . makeTestLog--makeTestLog :: TestSuiteResult -> String-makeTestLog = unlines . makeTestLogWith formatLog--makeTestLogWith :: Monoid a => FormatLog a -> TestSuiteResult -> a-makeTestLogWith fm (TSR (tree, diff)) = formatRoot fm diff (make [] tree)- where-   make loc = mconcat . map (either forTests forSuite) . treeToList-    where-      treeToList = -         let op (i, ys) y = -                case y of -                   Left b  -> (i, Left b:ys)-                   Right p -> (i+1, Right (loc ++ [i], p):ys)-         in reverse . snd . foldl op (1, []) . collectLevel--      forSuite (nl, ((s, d), t)) = -         formatSuite fm nl s (collectInfo t) d (make nl t)-      -      forTests [] = mempty-      forTests list@((s, result) : rest) = -         case result of            -            Warning msg -> next (formatWarning fm s msg)-            Error msg   -> next (formatFailure fm s msg)-            Ok _        ->-               let (ys, zs) = span (isOk . snd) list-                   sucs     = [ (x, n) | (x, Ok n) <- ys ]-               in formatSuccesses fm sucs `mappend` forTests zs-       where-         next a = a `mappend` forTests rest--data FormatLog a = FormatLog-   { formatRoot      :: TimeDiff -> a -> a-   , formatSuite     :: [Int] -> String -> (Int, Int, Int) -> TimeDiff -> a -> a-   , formatSuccesses :: [(String, Int)] -> a-   , formatFailure   :: String -> String -> a-   , formatWarning   :: String -> String -> a-   }--formatLog :: FormatLog [String]-formatLog = FormatLog-   { formatRoot = \td a -> -        a ++ ["\n(Total time: " ++ formatTimeDiff td ++ ")"]-   , formatSuite = \loc s _ td a -> -        [showLoc loc ++ ". " ++ s] ++ a ++ -        ["  (" ++ formatTimeDiff td ++ " for " ++ s ++ ")"]-   , formatSuccesses = \xs -> -        let f (_, n) = if n==1 then "." else "(" ++ show n ++ " tests)"-        in ["   " ++ concatMap f xs]-   , formatFailure = \s msg ->-        ["   " ++ putLabel s ++ "Error: " ++ msg]-   , formatWarning = \s msg ->-        ["   " ++ putLabel s ++ "Warning: " ++ msg]-   }- where -   putLabel s = if null s then "" else s ++ ": "--formatTimeDiff :: TimeDiff -> String-formatTimeDiff d@(TimeDiff z1 z2 z3 h m s p)-   | any (/=0) [z1,z2,z3] = timeDiffToString d-   | s >= 60      = formatTimeDiff (timeDiff ((h*60+m)*60+s) p)-   | h==0 && m==0 = show inSec ++ " secs"-   | otherwise    = show (60*h+m) ++ ":" ++ digSec ++ " mins" - where-   milSec = 1000*toInteger s + p `div` 1000000000-   inSec  = fromIntegral milSec / 1000 :: Double-   digSec = (if s < 10 then ('0' :) else id) (show s)-   timeDiff n pc = -      let (rest, sn) = n `divMod` 60-          (hr, mr)   = rest `divMod` 60-      in TimeDiff 0 0 0 hr mr sn pc---------------------------------------------------------- Utility functions---- A sequence of leafs (Left) or labeled items (Right)-newtype Tree a b = T { unT :: S.Seq (Either b (a, Tree a b)) }--instance Monoid (Tree a b) where-   mempty = T mempty-   mappend (T a) (T b) = T (mappend a b)-  -single :: b -> Tree a b-single = T . S.singleton . Left--labeled :: a -> Tree a b -> Tree a b-labeled a t = T (S.singleton (Right (a, t)))-  -toTestResult :: Int -> Result -> TestResult-toTestResult n result = -   case result of-      Success _           -> Ok n-      Failure _ _ msg _   -> Error msg-      NoExpectedFailure _ -> Error "no expected failure"-      GaveUp i _          -> Warning ("passed only " ++ show i ++ " tests")-            -showLoc :: [Int] -> String-showLoc = concat . intersperse "." . map show--collectInfo :: Tree a (String, TestResult) -> (Int, Int, Int)-collectInfo tree = (length tests, length failures, length warnings)- where-   tests    = flatten tree-   failures = [ msg | (_, Error msg)   <- tests ]-   warnings = [ msg | (_, Warning msg) <- tests ]--isOk :: TestResult -> Bool-isOk (Ok _) = True-isOk _      = False--subtrees :: Tree a b -> [(a, Tree a b)]-subtrees t = [ p | Right p <- collectLevel t ]--flatten :: Tree a b -> [b]-flatten t = [ b | x <- collectLevel t, b <- either id (flatten . snd) x ]--collectLevel :: Tree a b -> [Either [b] (a, Tree a b)]-collectLevel = combine [] . toList . unT- where-   combine acc []             = f acc-   combine acc (Left a:rest)  = combine (a:acc) rest-   combine acc (Right b:rest) = f acc ++ (Right b : combine [] rest)-   -   f acc = [ Left (reverse acc) | not (null acc) ] --getDiff :: MonadIO m => m a -> m (a, TimeDiff)-getDiff action = do-   t0 <- liftIO getClockTime-   a  <- action-   t1 <- liftIO getClockTime-   return (a, diffClockTimes t1 t0)---- Example-{--main :: IO ()-main = do-   r <- runTestSuiteResult $ do-      suite "A" $ do-         addProperty "p1" p1-         addProperty "p1" p1-         suite "A1" $ addProperty "p2" p2-         suite "A2" $ return ()-         addProperty "p3" p3-      suite "B" $ do-         addProperty "p4" p4-         addProperty "W" (\xs -> length (xs::[Int]) > 100 ==> True)-      suite "C" $ do-         addProperty "p5" p5-         assertTrue "sorted" (sort [3,2,1] == [1,2,3])-         fail "This is a failure"-         warn "This is a warning"-         assertEquals "eq" (sort [1,2,2]) (nub [1,2,2]) -         assertTrue "yes" True-         -   printSummary r-   printTestLog r-   --print r-   --print (subResults r)- where      -   p1 xs = sort (xs::[Int]) == sort (sort xs)-   p2 xs = reverse (reverse xs) == (xs::[Int])-   p3 xs = head (sort xs) == minimum (xs::[Int])-   p4 xs = sort (nub xs) == nub (sort (xs::[Int]))-   p5 xs = reverse (sort xs) == sort (reverse (xs :: [Int]))--main = runTestSuite $ suite "A" $ assertIO "B" (return True) >> -   assertIO "D" (fail "boe") >> assertIO "C" (return True) -}
src/Common/Transformation.hs view
@@ -1,471 +1,433 @@-{-# LANGUAGE ExistentialQuantification #-} --------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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(..)-   , supply1, supply2, supply3, supplyLabeled1, supplyLabeled2, supplyLabeled3, supplyWith1-   , hasArguments, expectedArguments, getDescriptors, useArguments-     -- * Rules-   , Rule, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule-   , ruleGroups, ruleSiblings, addRuleToGroup-   , rule, ruleList-   , makeRule, makeRuleList, makeSimpleRule, makeSimpleRuleList-   , idRule, checkRule, emptyRule, minorRule, buggyRule, doBefore, doAfter-   , siblingOf, transformations, getRewriteRules, doBeforeTrans-   , ruleRecognizer, useRecognizer-     -- * Lifting-   , liftRule, liftTrans, liftRuleIn, liftTransIn-     -- * QuickCheck-   , testRule, propRuleSmart-   ) where--import Common.Rewriting-import Common.Classes-import Common.Utils-import Common.View-import Control.Monad-import Data.Char-import Data.Maybe-import Data.Ratio-import Test.QuickCheck-import Common.Id----------------------------------------------------------------- Transformations---- | Abstract data type for representing transformations-data Transformation a-   = Function (a -> [a])-   | RewriteRule (RewriteRule a) (a -> [a])-   | Transformation a :*: Transformation a -- sequence-   | forall b . Abstraction (ArgumentList b) (a -> Maybe b) (b -> Transformation a)-   | forall b c . LiftView (ViewList a (b, c)) (Transformation b)-   | Recognizer (a -> a -> Bool) (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) <- match v a, b <- applyAll t b0  ]-   applyAll (s :*: t)           = \a -> applyAll s a >>= applyAll t-   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-   , genArgument     :: Gen a                -- ^ An arbitrary argument generator-   }---- | Constructor function for an argument descriptor that uses the Show and Read type classes-defaultArgDescr :: (Show a, Read a, Arbitrary a) => String -> ArgDescr a-defaultArgDescr descr = ArgDescr descr Nothing readM show 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--instance Argument Integer where-   makeArgDescr = defaultArgDescr--instance (Integral a, Arbitrary a) => Argument (Ratio a) where-   makeArgDescr = ratioArgDescr---- | Parameterization with one argument using a default label-supply1 :: Argument x => -             (a -> Maybe x) -> (x -> Transformation a) -> Transformation a-supply1 = supplyLabeled1 "argument 1"---- | Parameterization with two arguments using default labels-supply2 :: (Argument x, Argument y) => -             (a -> Maybe (x, y)) -> (x -> y -> Transformation a) -> Transformation a-supply2 = supplyLabeled2 ("argument 1", "argument 2")---- | Parameterization with three arguments using default labels-supply3 :: (Argument x, Argument y, Argument z) => -             (a -> Maybe (x, y, z)) -> (x -> y -> z -> Transformation a) -> Transformation a-supply3 = supplyLabeled3 ("argument 1", "argument 2", "argument 3")---- | Parameterization with one argument using the provided label-supplyLabeled1 :: Argument x -                  => String -> (a -> Maybe x)-                  -> (x -> Transformation a) -> Transformation a-supplyLabeled1 s f t = -   let args = cons (makeArgDescr s) nil-       nest a = (a, ())-   in Abstraction args (fmap nest . f) (\(a, ()) -> t a)--supplyWith1 :: ArgDescr x -> (a -> Maybe x)-                  -> (x -> Transformation a) -> Transformation a-supplyWith1 descr f t = -   let args = cons descr nil-       nest a = (a, ())-   in Abstraction args (fmap nest . f) (\(a, ()) -> t a)-   --- | Parameterization with two arguments using the provided labels-supplyLabeled2 :: (Argument x, Argument y) -                   => (String, String) -> (a -> Maybe (x, y)) -                   -> (x -> y -> Transformation a) -> Transformation a-supplyLabeled2 (s1, s2) f t = -   let args = cons (makeArgDescr s1) (cons (makeArgDescr s2) nil)-       nest (a, b) = (a, (b, ()))-   in Abstraction args (fmap nest . f) (\(a, (b, ())) -> t a b)---- | Parameterization with three arguments using the provided labels-supplyLabeled3 :: (Argument x, Argument y, Argument z) -                  => (String, String, String) -> (a -> Maybe (x, y, z)) -                  -> (x -> y -> z -> Transformation a) -> Transformation a-supplyLabeled3 (s1, s2, s3) f t =-   let args = cons (makeArgDescr s1) (cons (makeArgDescr s2) (cons (makeArgDescr s3) nil))-       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-         s :*: t        -> rec s ++ rec t-         _ -> []---- | Returns a list of pretty-printed expected arguments. Nothing indicates that there are no such arguments-expectedArguments :: Rule a -> a -> Maybe [String]-expectedArguments r =-   case transformations r of-      [t] -> rec t-      _   -> const Nothing- where-    rec :: Transformation a -> a -> Maybe [String]-    rec trans a =  -       case trans of-          Abstraction args f _ -> -             fmap (showArguments args) (f a)-          LiftView v t -> do -             (b, _) <- safeHead (match v a)-             rec t b-          s :*: t -> -             rec s a `mplus` rec t a-          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)-         s :*: t              -> fmap (:*: t) (make s) `mplus`-                                 fmap (s :*:) (make t)-         _                    -> Nothing-   ---------------------------------------------------------------- Internal machinery for arguments-               -data ArgumentList a-   = Nil a-   | forall b c . Cons ((b, c) -> a, a -> (b, c)) (ArgDescr b) (ArgumentList c)---- smart constructor-nil :: ArgumentList ()-nil = Nil ()---- smart constructor (provides the isomorphism proofs)-cons :: ArgDescr a -> ArgumentList b -> ArgumentList (a, b)-cons = Cons (id, id)--showArguments :: ArgumentList a -> a -> [String]-showArguments (Nil _) _ = []-showArguments (Cons (_, f) arg list) a =-   let (b, c) = f a-   in showArgument arg b : showArguments list c-   -parseArguments :: ArgumentList a -> [String] -> Maybe a-parseArguments (Nil a) [] = Just a -parseArguments (Cons (f, _) arg list) (x:xs) = do-   b <- parseArgument  arg  x-   c <- parseArguments list xs-   return $ f (b, c)-parseArguments _ _ = Nothing-   -someArguments :: ArgumentList a -> [Some ArgDescr]-someArguments (Nil _) = []-someArguments (Cons _ arg list) = Some arg : someArguments list--ratioArgDescr :: (Integral a, Arbitrary a) => String -> ArgDescr (Ratio a)-ratioArgDescr descr = ArgDescr descr Nothing parseRatio showRatio arbitrary- where-   showRatio  r = show (numerator r) ++ if denominator r == 1 then "" else '/' : show (denominator r)-   parseRatio s = -      let readDivOp t = -             case dropWhile isSpace t of-                ('/':rest) -> return rest-                [] -> return "1"-                _  -> fail "no (/) operator" -      in safeHead [ fromInteger x / fromInteger y -                  | (x, s1) <- reads s-                  , s2 <- readDivOp s1-                  , (y, s3) <- reads s2-                  , y /= 0-                  , all isSpace s3 -                  ]-      ---------------------------------------------------------------- Rules---- | Abstract data type for representing rules-data Rule a = Rule -   { ruleId          :: Id  -- ^ Unique identifier of the rule-   , transformations :: [Transformation 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)-   , ruleGroups      :: [Id]-   , ruleSiblings    :: [Id]-   }--instance Show (Rule a) where-   show = showId--instance Eq (Rule a) where-   r1 == r2 = ruleId r1 == ruleId r2--instance Apply Rule where-   applyAll r a = do -      t <- transformations r-      applyAll t a--instance HasId (Rule a) where-   getId        = ruleId-   changeId f r = r { ruleId = f (ruleId r) } ---- | 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 }--addRuleToGroup :: HasId b => b -> Rule a -> Rule a-addRuleToGroup g r = r { ruleGroups = getId g : ruleGroups r }--ruleList :: (IsId n, RuleBuilder f a, Rewrite a) => n -> [f] -> Rule a-ruleList n = makeRuleList a . map (makeRewriteTrans . rewriteRule a)- where a = newId n- -rule :: (IsId n, RuleBuilder f a, Rewrite 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 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}---- | Perform the function before the rule has been fired-doBefore :: (a -> a) -> Rule a -> Rule a-doBefore f = doBeforeTrans (makeTrans (return . f))---- | Perform the function before the rule has been fired-doBeforeTrans :: Transformation a -> Rule a -> Rule a-doBeforeTrans t r = r {transformations = map (t :*:) (transformations r)}---- | Perform the function after the rule has been fired-doAfter :: (a -> a) -> Rule a -> Rule a-doAfter f r = r {transformations = map make (transformations r)}- where make t = t :*: makeTransList (return . f)--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-         s :*: t          -> f s ++ f t-         _                -> []--ruleRecognizer :: (a -> a -> Bool) -> Rule a -> a -> a -> Bool-ruleRecognizer eq r a b = or -   [ transRecognizer eq t a b | t <- transformations r ]--transRecognizer :: (a -> a -> Bool) -> Transformation a -> a -> a -> Bool-transRecognizer eq trans a b =-   case trans of-      Recognizer f t -> f a b || transRecognizer eq t a b-      LiftView v t   -> -         any (`eq` b) (applyAll trans a) || or  -- ?? Quick Fix-         [ transRecognizer (\x y -> eq (f x) (f y)) t av bv-         | (av, c) <- match v a -         , (bv, _) <- match v b-         , let f z = build v (z, c)-         ]-      _ -> any (`eq` b) (applyAll trans a)--useRecognizer :: (a -> a -> Bool) -> Transformation a -> Transformation a-useRecognizer = Recognizer----------------------------------------------------------------- Lifting--liftTrans :: View a b -> Transformation b -> Transformation a-liftTrans v = liftTransIn (v &&& identity) --liftTransIn :: (Crush m, Monad m) => ViewM m a (b, c) -> Transformation b -> Transformation a-liftTransIn = LiftView . viewList--liftRule :: View a b -> Rule b -> Rule a-liftRule v = liftRuleIn (v &&& identity) --liftRuleIn :: (Crush m, Monad m) => ViewM m a (b, c) -> Rule b -> Rule a-liftRuleIn v r = r-   { transformations = map (liftTransIn v) (transformations r) }----------------------------------------------------------------- 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 : concatMap (smartGenTrans a) (transformations r))--smartGenTrans :: a -> Transformation a -> [Gen a]-smartGenTrans a trans =-   case trans of-      RewriteRule r _ -> return (smartGenerator r)-      LiftView v t -> do-         (b, c) <- match v a-         gen    <- smartGenTrans b t-         return $ liftM (\n -> build v (n, c)) gen-      s :*: t -> -         smartGenTrans a s ++ smartGenTrans a t-      _ -> []--smartApplyRule :: Rule a -> a -> Gen (Maybe a)-smartApplyRule r a = do-   xss <- mapM (`smartApplyTrans` a) (transformations r)-   case concat xss of-      [] -> return Nothing-      xs -> oneof $ map (return . 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 (Nil a) = return a-smartArgs (Cons (f, _) descr xs) = liftM2 (curry f) (genArgument descr) (smartArgs xs)+{-# 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/Uniplate.hs 
@@ -1,119 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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----------------------------------------------------------------------------------module Common.Uniplate-   ( -- * Uniplate type class and utility functions-     Uniplate(..), universe, children, holes-   , transform, transformM, descend, descendM, rewrite, rewriteM-     -- * Additional functions-   , leafs-   ) where--import Data.Generics.Uniplate--leafs :: Uniplate a => a -> [a]-leafs a = case children a of-             [] -> [a]-             xs -> concatMap leafs xs--{-------------------------------------------------------------- Uniplate class for generic traversals--import Common.Utils (safeHead)-import Control.Monad--- | The Uniplate type class offers some light-weight functions for generic traversals. Only--- a minimal set of operations are supported-class Uniplate a where-   uniplate :: a -> ([a], [a] -> a)    -- ^ Function for generic traversals---- | Returns all subterms-universe :: Uniplate a => a -> [a]-universe a = a : [ c | b <- children a, c <- universe b ]---- | Returns all the immediate children of a term-children :: Uniplate a => a -> [a]-children = fst . uniplate---- | A bottom-up transformation-transform :: Uniplate a => (a -> a) -> a -> a-transform g a = g $ f $ map (transform g) cs- where-   (cs, f) = uniplate a---- | Monadic variant of transform-transformM :: (Monad m, Uniplate a) => (a -> m a) -> a -> m a-transformM g a = mapM (transformM g) cs >>= (g . f)- where-   (cs, f) = uniplate a---- | Applies a function to its immediate children-descend :: Uniplate a => (a -> a) -> a -> a-descend g a = -   let (cs, f) = uniplate a-   in f (map g cs)---- | Applies the function at a position until this is no longer possible-rewrite :: Uniplate a => (a -> Maybe a) -> a -> a-rewrite f = transform g-    where g x = maybe x (rewrite f) (f x)---- | Monadic variant of rewrite-rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a-rewriteM f = transformM g-    where g x = f x >>= maybe (return x) (rewriteM f)-------------------------------------------------------------- Additional functions---- | Like universe, but also returns the location of the subterm-subtermsAt :: Uniplate a => a -> [([Int], a)]-subtermsAt a = ([], a) : [ (i:is, b) | (i, c) <- zip [0..] (children a), (is, b) <- subtermsAt c ]-         --- | Selects a child based on a path. Nothing indicates that the path is invalid-getTermAt :: Uniplate a => [Int] -> a -> Maybe a-getTermAt is a = foldM (flip child) a is- where-   child n = safeHead . drop n . children ---- | Apply a function to one immediate child.-applyTo :: Uniplate a => Int -> (a -> a) -> a -> a-applyTo n f a = -   let (as, build) = uniplate a -       g i = if i==n then f else id-   in build (zipWith g [0..] as)---- | Monadic variant of applyTo-applyToM :: (Monad m, Uniplate a) => Int -> (a -> m a) -> a -> m a-applyToM n f a = -   let (as, build) = uniplate a -       g (i, b) = if i==n then f b else return b-   in liftM build $ mapM g (zip [0..] as)---- | Apply a function at a given position (based on a path).-applyAt :: Uniplate a => [Int] -> (a -> a) -> a -> a-applyAt is f = foldr applyTo f is---- | Monadic variant of applyAt-applyAtM :: (Monad m, Uniplate a) => [Int] -> (a -> m a) -> a -> m a-applyAtM is f = foldr applyToM f is--somewhere :: Uniplate a => (a -> a) -> a -> [a]-somewhere f = somewhereM (return . f)--somewhereM :: (MonadPlus m, Uniplate a) => (a -> m a) -> a -> m a-somewhereM f a = msum $ f a : map g [0..n-1]- where -   n   = length (children a)-   g i = applyToM i (somewhereM f) a--}
src/Common/Utils.hs view
@@ -1,133 +1,104 @@-{-# LANGUAGE ExistentialQuantification #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 where--import Control.Monad-import Data.Char-import Data.List-import Data.Ratio-import System.Random-import Test.QuickCheck--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)--stringToHex :: String -> Maybe Int-stringToHex = foldl op (Just 0)- where-   op (Just i) c = fmap (i*16+) (charToHex c)-   op Nothing  _ = Nothing--charToHex :: Char -> Maybe Int-charToHex c-   | isDigit c = return (ord c - 48)-   | toUpper c `elem` ['A' .. 'F'] = return (ord (toUpper c) - 55)-   | otherwise = Nothing--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-      -fixpointM :: (Monad m, Eq a) => (a -> m a) -> a -> m a-fixpointM f a = do-   b <- f a-   if a==b then return a else fixpointM f b-   -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]--splitAtSequence :: Eq a => [a] -> [a] -> Maybe ([a], [a])-splitAtSequence cs = f []- where-   f _   [] = Nothing-   f acc list@(x:xs)-      | cs `isPrefixOf` list = Just (reverse acc, drop (length cs) list)-      | otherwise            = f (x:acc) xs---- | 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 = concat . intersperse ", "---- | 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))+{-# 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 view
@@ -0,0 +1,102 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,133 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,293 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,217 +1,282 @@-{-# LANGUAGE GADTs #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 -   ( -- * Generalized monadic views-     ViewM, match, build, newView, makeView, biArr, identity, (>>>)-   , canonical, canonicalWith-   , Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..)-     -- * Simple views-   , View, ViewList, Match, belongsTo-   , simplify, simplifyWith, viewEquivalent, viewEquivalentWith-   , isCanonical, isCanonicalWith, matchM, canonicalM, viewList-     -- * Some combinators-   , swapView, listView, switchView, associativeView-     -- * Properties on views-   , propIdempotence, propSoundness, propNormalForm-   ) where--import Common.Id-import Common.Classes-import Control.Arrow-import Control.Monad-import Data.Maybe-import Test.QuickCheck-import qualified Control.Category as C--------------------------------------------------------------------------------------- Generalized monadic view--data ViewM m a b where-   Prim    :: Id -> (a -> m b) -> (b -> a) -> ViewM m a b-   (:>>>:) :: ViewM m a b -> ViewM m b c -> ViewM m a c -   First   :: ViewM m a b -> ViewM m (a, c) (b, c)-   Second  :: ViewM m b c -> ViewM m (a, b) (a, c)-   (:***:) :: ViewM m a c -> ViewM m b d -> ViewM m (a, b) (c, d)-   (:&&&:) :: ViewM m a b -> ViewM m a c -> ViewM m a (b, c)-   VLeft   :: ViewM m a b -> ViewM m (Either a c) (Either b c)-   VRight  :: ViewM m b c -> ViewM m (Either a b) (Either a c)-   (:+++:) :: ViewM m a c -> ViewM m b d -> ViewM m (Either a b) (Either c d)-   (:|||:) :: ViewM m a c -> ViewM m b c -> ViewM m (Either a b) c--instance Monad m => C.Category (ViewM m) where-   id    = identity-   v . w = w :>>>: v--instance Monad m => Arrow (ViewM m) where-   arr f  = Prim (newId "views.arr") (return . f) (error "Control.View.arr: function is not invertible")-   first  = First-   second = Second-   (***)  = (:***:)-   (&&&)  = (:&&&:)--instance Monad m => ArrowChoice (ViewM m) where-   left  = VLeft-   right = VRight-   (+++) = (:+++:)-   (|||) = (:|||:)--------------------------------------------------------------------------------------- Operations on a view---- The preferred way of constructing a view-newView :: (IsId n, Monad m) => n -> (a -> m b) -> (b -> a) -> ViewM m a b-newView = Prim . newId--makeView :: Monad m => (a -> m b) -> (b -> a) -> ViewM m a b-makeView = newView "views.makeView"--biArr :: Monad m => (a -> b) -> (b -> a) -> ViewM m a b-biArr f = makeView (return . f)--match :: Monad m => ViewM m a b -> a -> m b-match view =-   case view of-      Prim _ f _ -> f-      v :>>>: w  -> \a      -> match v a >>= match w-      First v    -> \(a, c) -> match v a >>= \b -> return (b, c)-      Second v   -> \(a, b) -> match v b >>= \c -> return (a, c)-      v :***: w  -> \(a, c) -> liftM2 (,) (match v a) (match w c)-      v :&&&: w  -> \a      -> liftM2 (,) (match v a) (match w a)-      VLeft v    -> either (liftM Left . match v) (return . Right)-      VRight v   -> either (return . Left) (liftM Right . match v)-      v :+++: w  -> either (liftM Left . match v) (liftM Right . match w)-      v :|||: w  -> either (match v) (match w)--build :: ViewM m a b -> b -> a-build view = -   case view of-      Prim _ _ f -> f-      v :>>>: w  -> build v . build w-      First v    -> first (build v)-      Second v   -> second (build v)-      v :***: w  -> build v *** build w-      v :&&&: _  -> build v . fst -- left-biased-      VLeft v    -> either (Left . build v) Right-      VRight v   -> either Left (Right . build v)-      v :+++: w  -> either (Left . build v) (Right . build w)-      v :|||: _  -> Left . build v -- left-biased--canonical :: Monad m => ViewM m a b -> a -> m a-canonical = canonicalWith id--canonicalWith :: Monad m => (b -> b) -> ViewM m a b -> a -> m a-canonicalWith f view = liftM (build view . f) . match view-------------------------------------------------------------------- Simple views (based on a particular monad)--type View      = ViewM Maybe-type ViewList  = ViewM []-type Match a b = a -> Maybe b--simplify :: View a b -> a -> a-simplify = simplifyWith id--simplifyWith :: (b -> b) -> View a b -> a -> a-simplifyWith f view a = fromMaybe a (canonicalWith f view a)--belongsTo :: a -> View a b -> Bool-belongsTo a view = isJust (match view a)--viewEquivalent :: Eq b => View a b -> a -> a -> Bool-viewEquivalent = viewEquivalentWith (==)--viewEquivalentWith :: (b -> b -> Bool) -> View 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-      -isCanonical :: Eq a => View a b -> a -> Bool-isCanonical = isCanonicalWith (==)-      -isCanonicalWith :: (a -> a -> Bool) -> View a b -> a -> Bool-isCanonicalWith eq v a = maybe False (eq a) (canonical v a)---- generalized match on a ViewM Maybe-matchM :: Monad m => View a b -> a -> m b-matchM v = maybe (Prelude.fail "no match") return . match v---- generalized canonical element on a ViewM Maybe-canonicalM :: Monad m => View a b -> a -> m a-canonicalM v = maybe (Prelude.fail "no match") return . canonicalWith id v--viewList :: (Crush m, Monad m) => ViewM m a b -> ViewList a b-viewList v = makeView (crush . match v) (build v)-------------------------------------------------------------------- Some combinators--identity :: Monad m => ViewM m a a -identity = newView "views.identity" return id--swapView :: View (a, b) (b, a)-swapView = -   let swap (a, b) = (b, a)-   in newView "views.swap" (return . swap) swap--listView :: Monad m => ViewM m a b -> ViewM m [a] [b]-listView v = makeView (mapM (match v)) (map (build v))--switchView :: (Monad m, Switch f) => ViewM m a b -> ViewM m (f a) (f b)-switchView v = makeView (switch . fmap (match v)) (fmap (build v))- -associativeView :: View a (a, a) -> ViewList a (a, a)-associativeView v = makeView (reverse . f) (build v)- where f a = -         case matchM v a of-           Just (x, y) -> [(x, y)] ++ [(x1, build v (x2, y)) | (x1, x2) <- f x]-                                   ++ [(build v (x, y1), y2) | (y1, y2) <- f y]-           Nothing -> []-------------------------------------------------------------------- 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+{-# 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--{- proving a parameterized view equivalent to one with a "context"--abstr1 :: (a -> View b c) -> View (a, b) (a, c)-abstr1 fun = makeView f g- where-   f (a, b) = do-      c <- match (fun a) b-      return (a, c)-   g (a, c) = (a, build (fun a) c)-   -abstr2 :: View (a, b) (a, c) -> (a -> View b c)-abstr2 v a = makeView f g- where-   f b = do -      (_, c) <- match v (a, b)-      return c-   g c = snd (build v (a, c)) -}
src/Documentation/DefaultPage.hs view
@@ -1,100 +1,102 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Exercise-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-      builder-      footer version--header :: Int -> HTMLBuilder-header level = do -   divClass "menu" $ do-      make exerciseOverviewPageFile  "Exercises"-      make "services.html"           "Services"-      make "tests.html"              "Tests"-      make "coverage/hpc_index.html" "Coverage"-      make "api/index.html"          "API"-   hr- where-   make target s = f $ link (up level ++ target) $ text s-   f m = spaces 3 >> text "[" >> space >> m >> space >> text "]" >> spaces 3-   -footer :: String -> HTMLBuilder-footer version = do -   hr -   italic $ 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 :: String--exerciseOverviewPageFile    = "exercises.html"-exerciseOverviewAllPageFile = "exercises-all.html"-serviceOverviewPageFile     = "services.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"--diagnosisExampleFile :: Id -> String-diagnosisExampleFile a = "examples/" ++ showId a ++ ".txt"----------------------------------------------------------------- Utility functions--showBool :: Bool -> String +-----------------------------------------------------------------------------
+-- 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/DerivationUnitTests.hs 
@@ -1,39 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more 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.DerivationUnitTests (main) where
-
-import Control.Monad
-import Common.Exercise
-import Text.XML
-import Domain.Math.Power.Exercises
-
-base = "test/dwo-derivations"
-
-main = make powerOfAExercise
-
-make :: Exercise a -> IO ()
-make ex = zipWithM_ (makeTest ex) [1 ..] (examples ex)
-
-makeTest :: Exercise a -> Int -> a -> IO ()
-makeTest ex n a = do
-   let file = base ++ "/" ++ show (exerciseCode ex) ++ show n ++ ".xml"
-   putStrLn $ "Writing " ++ file
-   writeFile file $ showXML $ makeRequest a ex
-
-makeRequest :: a -> Exercise a -> XML
-makeRequest a ex = makeXML "request" $ do
-   "service"    .=. "derivation"
-   "exerciseid" .=. show (exerciseCode ex)
-   "encoding"   .=. "string"
-   element "state" $ 
-      element "expr" $
-         text $ prettyPrinter ex a
+ src/Documentation/ExampleFile.hs view
@@ -0,0 +1,80 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,208 +1,220 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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) where--import Common.Context-import Common.Exercise-import Common.Derivation-import Common.Strategy hiding (not, replicate)-import Common.Transformation-import Common.Utils (Some(..), splitAtSequence)-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe-import Documentation.DefaultPage-import Documentation.RulePresenter-import Service.BasicServices-import Service.Diagnose-import Service.DomainReasoner-import Service.ExercisePackage-import Service.State-import Service.StrategyInfo-import System.Directory-import System.Random-import Text.HTML--makeExercisePage :: String -> ExercisePackage a -> DomainReasoner ()-makeExercisePage dir pkg = do-   let ex       = exercise pkg-       make     = makeId pkg-       makeId a = generatePageAt (length (qualifiers a)) dir . ($ (getId a))-       exFile   = dir ++ "/" ++ diagnosisExampleFile (getId ex)--   exampleFileExists <- liftIO (doesFileExist exFile)--   make exercisePageFile     (exercisePage exampleFileExists pkg)-   make exerciseStrategyFile (strategyPage ex)-   unless (null (examples (exercise pkg))) $-       make exerciseDerivationsFile (derivationsPage ex)-   when (exampleFileExists) $ do-      xs <- liftIO (readFile exFile)-      make exerciseDiagnosisFile (diagnosisPage xs pkg)-    `catchError` \_ -> return ()--exercisePage :: Bool -> ExercisePackage a -> HTMLBuilder-exercisePage exampleFileExists pkg = do-   idboxHTML "strategy" (getId pkg)-   -   h2 "1. General information"--   let bolds (x:xs) = bold x:xs-       bolds []     = []--   table $ map bolds-      [ [ text "Code",   ttText (showId ex)]-      , [ text "Status", text (show $ status ex)]-      , [ text "Strategy"-        , link (up level ++ exerciseStrategyFile exid) $-             text (showId $ strategy ex)-        ]-      , [ text "OpenMath support"-        , text $ showBool $ withOpenMath pkg-        ]-      , [ text "Textual feedback"-        , text $ showBool $ isJust $ getExerciseText pkg-        ]-      , [ 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)-       ups = up (length (qualifiers pkg)) -       f r = [ link (ups ++ ruleFile r) $ ttText (showId r)-             , text $ showBool $ isBuggyRule r-             , text $ showBool $ hasArguments r-             , text $ showBool $ r `elem` rs-             , text $ concat $ intersperse "," $ map showId $ ruleGroups r-             , when (isRewriteRule r) $-                  ruleToHTML (Some ex) r-             ]-   table ( [bold $ text "Rule name", bold $ text "Buggy"-           , bold $ text "Args" -           , bold $ text "Used", bold $ text "Groups"-           , bold $ text "Rewrite rule"-           ]-         : map f (ruleset ex)-         )-   when exampleFileExists $ do-      para $ link (up level ++ exerciseDiagnosisFile exid) $ do-         br-         text "See diagnosis examples"--   h2 "3. Example"-   let state = generateWith (mkStdGen 0) pkg 5-   derivationHTML ex (stateTerm state)-   para $ unless (null (examples ex)) $ -      link (up level ++ exerciseDerivationsFile exid) (text "More examples")- where-   ex    = exercise pkg-   exid  = getId ex-   level = length (qualifiers pkg)--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 ( [bold $ text "Location", bold $ 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 -   pre $ derivationM (forStep ups) (forTerm ex) der-   unless (ok der) $-      divClass "error" $ text "<<not ready>>"- where-   ups = length (qualifiers ex)-   der = derivationDiffEnv (defaultDerivation ex a)-   ok  = maybe False (isReady ex) . fromContext . last . terms--idboxHTML :: String -> Id -> HTMLBuilder-idboxHTML kind i = divClass "idbox" $ do-   font "id" $ ttText (showId i)-   spaces 3-   text $ "(" ++ kind ++ ")"-   unless (null $ description i) $ do-      br-      italic (text (description i))--diagnosisPage :: String -> ExercisePackage a -> HTMLBuilder-diagnosisPage xs pkg = do-   h1 ("Diagnosis examples for " ++ showId pkg)-   forM_ (zip [1::Int ..] (mapMaybe f (lines xs))) $ \(i, (t0, t1, expl)) -> do -      h2 (show i ++ ".")-      preText (t0 ++ "\n  =>\n" ++ t1)-      para $ do-         unless (null expl) $ do -            bold $ text "Description:"-            space-            text expl-            br-            bold $ text "Diagnosis:"-            space-            text (getDiagnosis t0 t1)- where-   ex  = exercise pkg-   f a = do -      (x, b) <- splitAtSequence "==>" a-      let (y, z) = fromMaybe (b, "") (splitAtSequence ":::" b)-          trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace-      return (trim x, trim y, trim z)-      -   getDiagnosis t0 t1 = -      case (parser ex t0, parser ex t1) of-         (Left msg, _) -> "parse error (before): " ++ msg-         (_, Left msg) -> "parse error (afterr): " ++ msg-         (Right a, Right b) -> show (diagnose (emptyState pkg a) b)-       -forStep :: HasId a => Int -> (a, Environment) -> HTMLBuilder  -forStep n (i, env) = do -      spaces 3-      text "=>"-      space-      let target = up n ++ ruleFile i-          make | null (description i) = link target-               | otherwise = linkTitle target (description i)-      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)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,17 +11,18 @@ -----------------------------------------------------------------------------
 module Documentation.Make (DocItem(..), makeDocumentation) where
 
-import Common.TestSuite
 import Common.Utils (Some(..))
+import Common.Utils.TestSuite
 import Control.Monad
 import Data.Maybe
-import Service.DomainReasoner
-import Documentation.SelfCheck
 import Documentation.ExercisePage
+import Documentation.OverviewPages
 import Documentation.RulePage
-import Documentation.TestsPage
+import Documentation.SelfCheck
 import Documentation.ServicePage
-import Documentation.OverviewPages
+import Documentation.TestsPage
+import Documentation.ViewPage
+import Service.DomainReasoner
 
 data DocItem = Pages | SelfCheck | BlackBox (Maybe String)
    deriving Eq
@@ -29,20 +30,27 @@ makeDocumentation :: String -> String -> DocItem -> DomainReasoner ()
 makeDocumentation docDir testDir item =
    case item of
-      Pages -> do 
+      Pages -> do
          report "Generating overview pages"
          makeOverviewExercises docDir
          makeOverviewServices  docDir
          report "Generating exercise pages"
-         pkgs <- getPackages
-         forM_ pkgs $ \(Some pkg) -> 
-            makeExercisePage docDir pkg
+         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)
@@ -52,7 +60,7 @@          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 '-'
+ src/Documentation/OpenMathDerivations.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,87 +1,86 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Documentation.DefaultPage-import Data.Char-import Data.List-import Data.Maybe-import Control.Monad-import Common.Utils (Some(..), safeHead)-import Common.Exercise-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-   -   unless showAll $ para $ do-      text "Show"-      space-      link exerciseOverviewAllPageFile $ -         text "all exercises"-      text ", including the ones under development"-      -   forM_ (zip [1::Int ..] (grouping list)) $ \(i, (dom, xs)) -> do-      h2 (show i ++ ". " ++ dom)-      table (map makeRow xs) - 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"+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,119 +1,110 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Context-import Common.Exercise-import Common.Transformation-import Common.Utils (commaList, Some(..))-import Control.Monad-import Data.List-import Documentation.DefaultPage-import Documentation.RulePresenter-import Service.DomainReasoner-import Service.ExercisePackage-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 (ExercisePackage a) (ExampleMap a)--makeRulePages :: String -> DomainReasoner ()-makeRulePages dir = do-   pkgs <- getPackages -   let exMap = M.fromList -          [ (getId pkg, Some (EI pkg (collectExamples (exercise pkg))))-          | Some pkg <- pkgs-          ]-       ruleMap = M.fromListWith (++)-          [ (getId r, [Some pkg]) -          | Some pkg <- pkgs-          , r <- ruleset (exercise pkg) -          ]-   forM_ (M.toList ruleMap) $ \(ruleId, list@(Some pkg:_)) -> do-      let noExamples = Some (EI pkg M.empty) -          level      = length (qualifiers ruleId) + 1-          usedIn     = sortBy compareId [ getId pkg1 | Some pkg1 <- list ]-      case M.findWithDefault noExamples (getId pkg) exMap of-         Some (EI pkg1 e) -> do-            let ex = exercise pkg1-            forM_ (getRule ex ruleId) $ \r ->-               generatePageAt level dir (ruleFile ruleId) $-                  rulePage ex e usedIn r--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 -      [ [bold $ text "Buggy", text $ showBool (isBuggyRule r)]-      , [bold $ text "Rewrite rule", text $ showBool (isRewriteRule r)]-      , [bold $ text "Groups", idList $ ruleGroups r]-      , [bold $ text "Siblings", idList $ ruleSiblings r] -      ]-   when (isRewriteRule r) $ para $-      ruleToHTML (Some ex) r--   h3 "Used in exercises"-   let f a = link (up ups ++ exercisePageFile a) (tt $ text $ show a)-       ups = 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 ups (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))--idboxHTML :: String -> Id -> HTMLBuilder-idboxHTML kind i = divClass "idbox" $ do-   para $ do -      font "id" $ ttText (showId i)-      spaces 3-      text $ "(" ++ kind ++ ")"-   unless (null $ description i) $-      para $ italic $ text (description i)--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 = linkTitle target (description i)-      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)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -12,22 +12,20 @@ module Documentation.RulePresenter (ruleToHTML) where
 
 import Common.Library
-import Control.Monad
 import Common.Utils (Some(..), safeHead)
-import Common.Rewriting.Term
+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) -> 
+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
-   -- showRuleName (unqualified r)
-   -- spaces 3
    showTerm ex lhs
    spaces 3
    showLeadsTo sound
@@ -35,11 +33,6 @@    showTerm ex rhs
    br
 
-{-     
-showRuleName :: String -> HTMLBuilder
-showRuleName s = text ("[" ++ s ++ "]")
--}
-
 showLeadsTo :: Bool -> HTMLBuilder
 showLeadsTo sound = text (if sound then "\x21D2" else "\x21CF")
 
@@ -48,29 +41,28 @@  where
    rec term =
       case term of
-         Var s   -> s
-         Num i   -> show i
-         Float a -> show a
-         Meta n  -> showMeta ex n
-         _ -> concatMap (either id recp) $  
+         TVar s   -> s
+         TNum i   -> show i
+         TFloat a -> show a
+         TMeta n  -> showMeta ex n
+         _ -> concatMap (either id recp) $
             case getSpine term of
-               (Con s, xs) -> 
-                  case specialSymbol s xs of
-                     Just ys -> ys
-                     Nothing -> spaced (Left (show s) : map Right xs)
+               (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 (isApply term) (rec term)
+
+   recp term = parIf (isApp term) (rec term)
    spaced    = intersperse (Left " ")
-      
-   isApply (Apply _ _) = True
-   isApply _           = False
-      
-   parIf b s = if b then "(" ++ s ++ ")" else s           
-         
+
+   isApp (TApp _ _) = True
+   isApp _          = False
+
+   parIf b s = if b then "(" ++ s ++ ")" else s
+
 specialSymbol :: Symbol -> [Term] -> Maybe [Either String Term]
 -- constants
-specialSymbol s [] 
+specialSymbol s []
    | sameSymbol s "logic1.true"     = con "T"
    | sameSymbol s "logic1.false"    = con "F"
    | sameSymbol s "relalg.universe" = con "V" -- universe
@@ -104,13 +96,13 @@    | sameSymbol s "relalg.add"        = bin " \x2020 " -- relative addition/dagger
  where
    bin x = return [Right a, Left x, Right b]
-specialSymbol s1 [Apply (Apply (Con s2) x) a] 
-   | sameSymbol s1 "calculus1.diff" && sameSymbol s2 "fns1.lambda" = 
-        return [Left "D(", Right x, Left ") ", Right a] 
+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 
+sameSymbol = (==) . show
 
 showMeta :: Exercise a -> Int -> String
 showMeta ex n
src/Documentation/SelfCheck.hs view
@@ -1,120 +1,133 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 System.Directory-import Common.TestSuite-import Common.Utils (useFixedStdGen, Some(..), snd3)-import Common.Exercise-import Service.ExercisePackage-import Control.Monad-import Service.Request-import Service.DomainReasoner-import Service.ModeJSON-import Service.ModeXML-import qualified Text.OpenMath.Tests as OpenMath-import qualified Text.UTF8 as UTF8-import qualified Text.JSON as JSON-import Data.List--selfCheck :: String -> DomainReasoner TestSuite-selfCheck dir = do-   pkgs        <- getPackages-   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-         -      suite "Domain checks" domainSuite-      -      suite "Exercise checks" $-         forM_ pkgs $ \(Some pkg) ->-            exerciseTestSuite (exercise pkg)-      -      suite "Black box tests" $ do -         liftIO (blackBoxTests run dir) >>= id---- 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-         liftIO useFixedStdGen -- fix the random number generator-         txt  <- liftIO $ readFile path-         expt <- liftIO $ readFile expPath-         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-   -   filterVersion = -      let p s = not (null s || "version" `isInfixOf` s)-      in unlines . filter p . lines--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 ]+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,119 +1,115 @@-{-# OPTIONS -XRankNTypes #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Documentation.DefaultPage-import Service.ExercisePackage-import Service.TypedExample-import Service.Types-import Service.DomainReasoner-import Service.State-import Text.HTML-import qualified Text.XML as XML-import Text.XML (XML)-import Control.Monad-import Common.Exercise-import Common.Utils (Some(..))--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 $ -               XML.element "font" $ do-                  "color" XML..=. "red"-                  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 pkg = newState pkg "~(p /\\ ~q)"-   logic2 pkg = newState pkg "~~p /\\ T"-   -   lineq1, lineq2 :: Args-   lineq1 pkg = newState pkg "5*(x+1) == 11"-   lineq2 pkg = newState pkg "5*(x+1) == (x-1)/2"-   -   (f +++ g) pkg = f pkg ++ g pkg-   -   noCfg _    = [Nothing ::: maybeTp StrategyCfg]-   noArgs _   = []-   exArgs pkg = [pkg ::: ExercisePkg]--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 => ExercisePackage a -> String -> m (TypedValue a)-newState pkg s = do-   let ex = exercise pkg-   case parser ex s of-      Left msg -> fail ("newState: " ++ msg)-      Right a  -> return (emptyState pkg a ::: stateTp)-      -type Args = forall a . ExercisePackage a -> [TypedValue a]--makeExample :: String -> Args -> String -> DomainReasoner Example-makeExample pkgName f srvName = do-   let a = newId pkgName-   Some pkg <- findPackage a-   srv      <- findService srvName-   tr       <- typedExample pkg srv (f pkg)-   return (showId pkg, tr)+{-# 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 view
@@ -1,76 +1,50 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.TestSuite-import Documentation.DefaultPage-import Documentation.SelfCheck-import Service.DomainReasoner-import Text.HTML-import qualified Text.XML as XML--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"-   makeTestLogWith formatHTML result-   -formatHTML :: FormatLog HTMLBuilder-formatHTML = FormatLog-   { formatRoot = \_ -> id-   , formatSuite = \loc s _ _ a -> -        showHeader loc s >> a -   , formatSuccesses = \xs -> -        let f (_, n) = if n==1 then "." else "(passed " ++ show n ++ " tests)"-        in mapM_ (\s -> ttText s >> br) (breakLine (concatMap f xs))-   , formatFailure = \s msg -> colorRed $ do-        bold (ttText ("Error" ++ putLabel s))-        tt space-        ttText msg-        br-   , formatWarning = \s msg -> colorOrange $ do-        ttText ("Warning" ++ putLabel s)-        tt space-        ttText msg-        br-   }- where -   putLabel s = if null s then ":" else " (" ++ s ++ "):"--breakLine :: String -> [String]-breakLine xs-   | null xs   = []-   | otherwise = ys : breakLine zs- where-   (ys, zs) = splitAt 80 xs--showHeader :: [Int] -> String -> HTMLBuilder-showHeader [a]   s = h2 (show a ++ ". " ++ s)-showHeader [a,b] s = h3 (show a ++ "." ++ show b ++ ". " ++ s)+-----------------------------------------------------------------------------
+-- 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))--colorRed :: HTMLBuilder -> HTMLBuilder-colorRed body = XML.element "font" $ do-   "color" XML..=. "red"-   body-   -colorOrange :: HTMLBuilder -> HTMLBuilder-colorOrange body = XML.element "font" $ do-   "color" XML..=. "#FE9A2E"-   body
+ src/Documentation/ViewPage.hs view
@@ -0,0 +1,74 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,20 +9,12 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.LinearAlgebra
-   ( module Domain.LinearAlgebra.Matrix
-   , module Domain.LinearAlgebra.Parser
-   , module Domain.LinearAlgebra.MatrixRules
-   , module Domain.LinearAlgebra.EquationsRules
-   , module Domain.LinearAlgebra.Strategies
-   , module Domain.LinearAlgebra.LinearSystem
-   , module Domain.LinearAlgebra.Exercises
-   ) where
-   
-import Domain.LinearAlgebra.Matrix
-import Domain.LinearAlgebra.Parser
-import Domain.LinearAlgebra.MatrixRules
-import Domain.LinearAlgebra.EquationsRules hiding (changeCover, findIndexM)
-import Domain.LinearAlgebra.Strategies
-import Domain.LinearAlgebra.LinearSystem
-import Domain.LinearAlgebra.Exercises+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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -14,7 +14,8 @@ import Common.Classes
 import Common.Context
 import Common.Exercise
-import Common.TestSuite
+import Common.Utils.TestSuite
+import Data.Maybe
 import Domain.LinearAlgebra hiding (getSolution)
 import Domain.Math.Expr
 import Domain.Math.Simplification (simplify)
@@ -33,12 +34,12 @@ 
 propEchelon :: Matrix Rational -> Bool
 propEchelon =
-   withoutContext inRowEchelonForm . applyD forwardPass . gaussContext
+   fromMaybe False . fromContextWith inRowEchelonForm . applyD forwardPass . gaussContext
 
 propReducedEchelon :: Matrix Rational -> Bool
-propReducedEchelon = 
-   withoutContext inRowReducedEchelonForm . applyD gaussianElimStrategy . gaussContext
-   
+propReducedEchelon =
+   fromMaybe False . fromContextWith inRowReducedEchelonForm . applyD gaussianElimStrategy . gaussContext
+
 propSound :: Matrix Rational -> Bool
 propSound m =
    (fromContext . applyD gaussianElimStrategy . gaussContext) m
@@ -46,7 +47,7 @@ 
 propSolution :: Matrix Rational -> Property
 propSolution m1 =
-   forAll (arbSolution m1) $ \(solution, m2) -> 
+   forAll (arbSolution m1) $ \(solution, m2) ->
       let m3  = (fromContext . applyD gaussianElimStrategy . gaussContext) m2
           p r = simplify (sum (zipWith g (solution ++ [-1]) r)) == 0
           g   = (*) . fromRational
@@ -58,9 +59,6 @@    let finalCol  = map (return . sum . zipWith (*) solution) (rows m)
        newMatrix = makeMatrix $ zipWith (++) (rows m) finalCol
    return (solution, newMatrix)
-   
-withoutContext :: (a -> Bool) -> Context a -> Bool
-withoutContext f = maybe False f . fromContext
 
 gaussContext :: Matrix Rational -> Context (Matrix Expr)
 gaussContext = inContext gaussianElimExercise . fmap fromRational
src/Domain/LinearAlgebra/EquationsRules.hs view
@@ -1,219 +1,215 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Prelude hiding (repeat)-import Common.Context-import Common.Transformation-import Common.Utils-import Common.Navigator-import Common.Id-import Common.View hiding (simplify)-import Control.Monad-import Data.List hiding (repeat)-import Data.Maybe-import Domain.Math.Expr-import Domain.Math.Data.Relation-import Domain.Math.Simplification (simplify)-import Domain.LinearAlgebra.LinearView-import Domain.LinearAlgebra.LinearSystem-import Domain.LinearAlgebra.MatrixRules (covered) -- for context-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" $ -   supplyLabeled2 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" $ -   supplyLabeled3 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" $ -   supplyLabeled2 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" $ -   supplyLabeled3 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,16 +9,14 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.LinearAlgebra.Exercises 
+module Domain.LinearAlgebra.Exercises
    ( gramSchmidtExercise, linearSystemExercise
    , gaussianElimExercise, systemWithMatrixExercise
    ) where
 
-import Common.Classes
-import Common.Context
-import Common.Exercise
-import Common.Transformation
+import Common.Library hiding (simplify)
 import Control.Monad
+import Data.Function
 import Domain.LinearAlgebra.EquationsRules
 import Domain.LinearAlgebra.GramSchmidtRules
 import Domain.LinearAlgebra.LinearSystem
@@ -41,10 +39,11 @@                               Right a  -> Right (fmap simplified a)
                               Left msg -> Left msg
    , prettyPrinter  = unlines . map show . vectors
-   , equivalence    = \x y -> let f = length . filter (not . isZero) . vectors . gramSchmidt
+   , equivalence    = withoutContext $
+                      \x y -> let f = length . filter (not . isZero) . vectors . gramSchmidt
                               in f x == f y
    , extraRules     = rulesGramSchmidt
-   , isReady        = orthonormalList . filter (not . isZero) . vectors
+   , ready          = predicate (orthonormalList . filter (not . isZero) . vectors)
    , strategy       = gramSchmidtStrategy
    , randomExercise = let f = simplified . fromInteger . (`mod` 25)
                       in simpleGenerator (liftM (fmap f) arbitrary)
@@ -59,37 +58,39 @@                                Right a  -> Right (simplify a)
                                Left msg -> Left msg
    , prettyPrinter  = unlines . map show
-   , equivalence    = \x y -> let f = fromContext . applyD linearSystemStrategy 
+   , equivalence    = withoutContext $
+                      \x y -> let f = fromContext . applyD linearSystemStrategy
                                     . inContext linearSystemExercise . map toStandardForm
-                              in case (f x, f y) of  
+                              in case (f x, f y) of
                                     (Just a, Just b) -> getSolution a == getSolution b
-                                    _ -> False 
+                                    _ -> False
    , extraRules     = equationsRules
    , ruleOrdering   = ruleOrderingWithId [getId ruleScaleEquation]
-   , isReady        = inSolvedForm
+   , ready          = predicate inSolvedForm
    , strategy       = linearSystemStrategy
    , randomExercise = simpleGenerator (fmap matrixToSystem arbMatrix)
    }
-   
+
 gaussianElimExercise :: Exercise (Matrix Expr)
 gaussianElimExercise = makeExercise
-   { exerciseId     = describe "Gaussian Elimination" $ 
+   { 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    = \x y -> fmap simplified x === fmap simplified y
+   , equivalence    = withoutContext (eqMatrix `on` fmap simplified)
    , extraRules     = matrixRules
-   , isReady        = inRowReducedEchelonForm
+   , ready          = predicate inRowReducedEchelonForm
    , strategy       = gaussianElimStrategy
    , randomExercise = simpleGenerator arbMatrix
+   , testGenerator  = Just arbMatrix
    }
- 
+
 systemWithMatrixExercise :: Exercise Expr
 systemWithMatrixExercise = makeExercise
-   { exerciseId     = describe "Solve Linear System with Matrix" $ 
+   { exerciseId     = describe "Solve Linear System with Matrix" $
                          newId "linearalgebra.systemwithmatrix"
    , status         = Provisional
    , parser         = \s -> case (parser linearSystemExercise s, parser gaussianElimExercise s) of
@@ -100,40 +101,39 @@                                   (Just ls, _) -> (unlines . map show) (ls :: Equations Expr)
                                   (_, Just m)  -> ppMatrix (m :: Matrix Expr)
                                   _            -> show expr
-   , equivalence    = \x y -> let f expr = case (fromExpr expr, fromExpr expr) of
+   , 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) -> equivalence linearSystemExercise a b
+                                    (Just a, Just b) -> simpleEquivalence linearSystemExercise a b
                                     _ -> False
    , extraRules     = map useC equationsRules ++ map useC (matrixRules :: [Rule (Context (Matrix Expr))])
-   , isReady        = inSolvedForm . (fromExpr :: Expr -> Equations 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 = do
-   a <- oneof $ map return [-5 .. 5]
-   b <- oneof $ map return [-5 .. 5]
-   c <- oneof $ map return [-5 .. 5]
-   return $ makeMatrix [[1, a, b], [0, 1, c], [0, 0, 1]]
+arbUpperMatrix = threeNums $ \a b c ->
+   makeMatrix [[1, a, b], [0, 1, c], [0, 0, 1]]
 
 arbAugmentedMatrix :: (Enum a, Num a) => Gen (Matrix a)
-arbAugmentedMatrix = do
-   a <- oneof $ map return [-5 .. 5]
-   b <- oneof $ map return [-5 .. 5]
-   c <- oneof $ map return [-5 .. 5]
-   return $ makeMatrix [[1, 0, 0, 1], [a, 1, 0, 1], [b, c, 1, 1]]
-   
+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
src/Domain/LinearAlgebra/GramSchmidtRules.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -12,11 +12,11 @@ module Domain.LinearAlgebra.GramSchmidtRules where
 
 import Common.Context
-import Common.Transformation
 import Common.Navigator hiding (current)
+import Common.Transformation
 import Common.Utils
-import Domain.LinearAlgebra.Vector
 import Control.Monad
+import Domain.LinearAlgebra.Vector
 
 varI, varJ :: Var Int
 varI = newVar "considered" 0
@@ -36,7 +36,7 @@ -- 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" $ supplyLabeled2 descr args transOrthogonal
+ruleOrthogonal = makeRule "Make orthogonal" $ supply2 descr args transOrthogonal
  where
    descr = ("vector 1", "vector 2")
    args  = evalCM $ \_ -> do
@@ -45,7 +45,7 @@               guard (i>j)
               return (j, i)
 
--- Variable "j" is for administrating which vectors are already orthogonal 
+-- 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
@@ -54,7 +54,7 @@    writeVar varJ j
    return vs
 
--- Consider the next vector 
+-- 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
@@ -73,7 +73,7 @@ 
 setCurrent :: Vector a -> VectorSpace a -> ContextMonad (VectorSpace a)
 setCurrent v vs = do
-   i <- readVar varI 
+   i <- readVar varI
    case splitAt (i-1) (vectors vs) of
       (xs, _:ys) -> return $ makeVectorSpace (xs ++ v:ys)
       _          -> mzero
@@ -87,7 +87,7 @@       guard (isUnit u)
       case splitAt j (vectors xs) of
          (begin, v:end) -> Just $ makeVectorSpace $ begin ++ makeOrthogonal u v:end
-         _ -> Nothing 
+         _ -> Nothing
 
 -- Find proper abstraction, and move this function to transformation module
 contextTrans :: (a -> Maybe a) -> Transformation (Context a)
src/Domain/LinearAlgebra/LinearSystem.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,25 +11,25 @@ -----------------------------------------------------------------------------
 module Domain.LinearAlgebra.LinearSystem where
 
-import Domain.Math.Data.Relation
-import Domain.LinearAlgebra.Matrix (Matrix, makeMatrix, rows)
-import Domain.LinearAlgebra.LinearView
+import Common.Rewriting
+import Common.Utils
+import Common.Utils.Uniplate
+import Control.Monad
+import Data.Foldable (toList)
 import Data.List
 import Data.Maybe
-import Common.Classes
-import Control.Monad
-import Common.Utils
-import Common.Uniplate
-import Common.Rewriting
+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 crush
+getVarsSystem = S.toList . S.unions . map varSet . concatMap toList
 
 evalSystem :: (Uniplate a, IsLinear a) => (String -> a) -> LinearSystem a -> Bool
-evalSystem f = 
+evalSystem f =
    let evalEq (x :==: y) = x==y
    in all (evalEq . fmap (evalLinearExpr f))
 
@@ -50,7 +50,7 @@    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
@@ -60,7 +60,6 @@       let c = getConstant rhs - getConstant lhs
       in (lhs - rhs + c) :==: c
 
-
 inSolvedForm :: IsLinear a => LinearSystem a -> Bool
 inSolvedForm xs = invalidSystem xs || isJust (getSolution xs)
 
@@ -83,10 +82,10 @@  where
    varList = vs ++ (variables \\ vs)
    makeEquation [] = 0 :==: 0
-   makeEquation xs = 
-      let lhs = sum (zipWith (\v a -> a * variable v) varList (init xs))  
+   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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -14,11 +14,11 @@    , splitLinearExpr, evalLinearExpr, linearView
    ) where
 
-import Control.Monad
-import Data.List
 import Common.Rewriting
-import Common.Uniplate
+import Common.Utils.Uniplate
 import Common.View
+import Control.Monad
+import Data.List
 import Domain.Math.Expr
 import qualified Data.Map as M
 
@@ -29,9 +29,9 @@ 
 linearView :: View Expr (LinearMap Expr)
 linearView = makeView f g
- where 
+ where
    -- compositional (sumView would be a more restrictive alternative)
-   f expr = 
+   f expr =
       case expr of
          Nat _    -> return $ LM M.empty expr
          Var s    -> return $ LM (M.singleton s 1) 0
@@ -43,7 +43,7 @@          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    = []
@@ -58,7 +58,7 @@ 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) 
+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
@@ -101,7 +101,7 @@       Nothing -> descend (evalLinearExpr f) a
 
 renameVariables :: IsLinear a => (String -> String) -> a -> a
-renameVariables f a = 
+renameVariables f a =
    case getVariable a of
       Just s  -> variable (f s)
       Nothing -> descend (renameVariables f) a
src/Domain/LinearAlgebra/Matrix.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,29 +9,31 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.LinearAlgebra.Matrix 
+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, (===)
+   , reduce, forward, backward, inverse, invertible, rank, nullity, eqMatrix
    , switchRows, scaleRow, addRow
    , inRowEchelonForm, inRowReducedEchelonForm
    , nonZero, pivot, isPivotColumn
    , isSquare, identityMatrix, isLowerTriangular, isUpperTriangular
    ) where
 
-import Common.Classes
-import Common.Rewriting hiding (inverse)
+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 Domain.Math.Expr.Symbols (openMathSymbol)
 import Test.QuickCheck
-import qualified Text.OpenMath.Dictionary.Linalg2 as OM
 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]]
@@ -40,14 +42,17 @@ type Row    a = [a]
 type Column a = [a]
 
-instance Functor Matrix where 
+instance Functor Matrix where
    fmap f (M rs) = M (map (map f) rs)
 
-instance Switch Matrix where
-   switch (M xss) = liftM M (mapM sequence xss)
+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 = 
+   toTerm =
       let f = function matrixrowSymbol . map toTerm
       in function matrixSymbol . map f . rows
    fromTerm a = do
@@ -66,13 +71,13 @@    coarbitrary = coarbitrary . rows
 
 arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a)
-arbSizedMatrix (i, j) = 
+arbSizedMatrix (i, j) =
    do rs <- replicateM i (vector j)
       return (makeMatrix rs)
 
 matrixSymbol, matrixrowSymbol :: Symbol
-matrixSymbol    = openMathSymbol OM.matrixSymbol
-matrixrowSymbol = openMathSymbol OM.matrixrowSymbol
+matrixSymbol    = newSymbol OM.matrixSymbol
+matrixrowSymbol = newSymbol OM.matrixrowSymbol
 
 instance Simplify a => Simplify (Matrix a) where
    simplifyWith opt = fmap (simplifyWith opt)
@@ -145,7 +150,7 @@ scale a = fmap (*a)
 
 multiply :: Num a => Matrix a -> Matrix a -> Matrix a
-multiply a b 
+multiply a b
    | snd (dimensions a) == fst (dimensions b) =
         M $ map (\r -> map (sum . zipWith (*) r) (columns b)) (rows a)
    | otherwise =
@@ -158,7 +163,7 @@ reduce = backward . forward
 
 forward :: Fractional a => Matrix a -> Matrix a
-forward m 
+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)
@@ -184,21 +189,21 @@ rank = length . filter (isJust . pivot) . rows . reduce
 
 nullity :: Fractional a => Matrix a -> Int
-nullity m = snd (dimensions m) - rank m 
- 
+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 
+ where
    (h, w) = dimensions m
 
 invertible :: Fractional a => Matrix a -> Bool
 invertible = isJust . inverse
 
-(===) :: Fractional a => Matrix a -> Matrix a -> Bool
-m1 === m2 = reduce m1 == reduce m2
+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]]
 
@@ -216,7 +221,7 @@  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 
+identityMatrix n = M $ map (\y -> map (\x -> if x==y then 1 else 0) list) list
  where list = [0..n-1]
 
 -------------------------------------------------------
@@ -229,28 +234,28 @@ switchRows i j m@(M rs)
    | i == j = m
    | i >  j = switchRows j i m
-   | checkRow i m && checkRow j 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 = 
+   | otherwise =
         error "switchRows: invalid rows"
 
 scaleRow :: Num a => Int -> a -> Matrix a -> Matrix a
 scaleRow i a m@(M rs)
-   | checkRow i m = 
+   | checkRow i m =
         let f y = if y==i then map (*a) else id
         in M $ zipWith f [0..] rs
-   | otherwise = 
+   | 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 = 
+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 = 
+   | otherwise =
         error "addRow: invalid row"
 
 -------------------------------------------------------
@@ -265,7 +270,7 @@ 
 inRowEchelonForm :: Num a => Matrix a -> Bool
 inRowEchelonForm (M rs) =
-   null (filter nonZero (dropWhile nonZero rs)) &&
+   not (any nonZero (dropWhile nonZero rs)) &&
    increasing (map (length . takeWhile (==0)) (filter nonZero rs))
  where
    increasing (x:ys@(y:_)) = x < y && increasing ys
@@ -277,7 +282,7 @@ -- or row canonical form
 inRowReducedEchelonForm :: Num a => Matrix a -> Bool
 inRowReducedEchelonForm m@(M rs) =
-   inRowEchelonForm m && 
+   inRowEchelonForm m &&
    all (==1) (mapMaybe pivot rs) &&
    all (isPivotColumn . flip column m . length . takeWhile (==0)) (filter nonZero rs)
 
@@ -287,7 +292,7 @@              _    -> Nothing
 
 isPivotColumn :: Num a => Column a -> Bool
-isPivotColumn c = 
+isPivotColumn c =
    case filter (/=0) c of
       [1] -> True
       _   -> False
src/Domain/LinearAlgebra/MatrixRules.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,20 +11,20 @@ -----------------------------------------------------------------------------
 module Domain.LinearAlgebra.MatrixRules where
 
-import Domain.Math.Simplification
-import Domain.LinearAlgebra.Matrix
 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 = 
+matrixRules =
    let noArgs f = f (const Nothing)
    in [ noArgs ruleScaleRow
       , noArgs ruleExchangeRows
-      , noArgs ruleAddMultiple 
+      , noArgs ruleAddMultiple
       ]
 
 ruleFindColumnJ :: Num a => Rule (Context (Matrix a))
@@ -33,7 +33,7 @@    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
@@ -61,7 +61,7 @@    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
@@ -84,17 +84,17 @@ -- Parameterized rules
 
 ruleScaleRow :: (Argument a, Fractional a) => (Context (Matrix a) -> Maybe (Int, a)) -> Rule (Context (Matrix a))
-ruleScaleRow f = makeRule "linearalgebra.gaussianelim.scale" (supplyLabeled2 descr f rowScale)
+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" (supplyLabeled2 descr f rowExchange)
+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" (supplyLabeled3 descr f  rowAdd)
+ruleAddMultiple f = makeRule "linearalgebra.gaussianelim.add" (supply3 descr f  rowAdd)
  where descr  = ("row 1", "row2", "scale factor")
-      
+
 ---------------------------------------------------------------------------------
 -- Parameterized transformations
 
@@ -102,7 +102,7 @@ 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)
@@ -119,7 +119,7 @@    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
@@ -129,7 +129,7 @@ -- 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
 
@@ -138,9 +138,9 @@ columnJ = newVar "columnJ" 0
 
 subMatrix :: Matrix a -> ContextMonad (Matrix a)
-subMatrix m = do 
+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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,87 +9,74 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.LinearAlgebra.Parser 
-   ( parseMatrix, parseVectorSpace, ppMatrix, ppMatrixWith
-   , parseSystem
+module Domain.LinearAlgebra.Parser
+   ( parseMatrix, parseVectorSpace, parseSystem
+   , ppMatrix, ppMatrixWith
    ) where
 
-import Domain.Math.Data.Relation
-import Domain.LinearAlgebra.Matrix
+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
-import Text.Parsing
 
-{-
-testje = case parseSystem " \n\n x == 43 \n 3*y == sqrt 4 \n" of -- "\n\n 1*x + 3*y + 2 + 87 == 2  \n   " of
-            this -> this -}
-
 parseSystem :: String -> Either String (LinearSystem Expr)
-parseSystem = either Left f . parseWithM s pSystem
- where
-   s0 = specialSymbols "\n" scannerExpr
-   s  = s0 {keywordOperators = "==" : keywordOperators s0 }
-   f Nothing  = Left "System is not linear"
-   f (Just m) = Right m
+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
 
-pSystem :: TokenParser (Maybe (LinearSystem Expr))
-pSystem = convertSystem <$> pEquations pExpr
- where
-   convertSystem :: Equations Expr -> Maybe (LinearSystem Expr)
-   convertSystem eqs 
-      | all f eqs = return eqs
-      | otherwise = Nothing
-    where 
-       f (a :==: b) = isLinear a && isLinear b
- 
 -----------------------------------------------------------
 --- Parser
 
 parseMatrix :: String -> Either String (Matrix Expr)
-parseMatrix = either Left f . parseWithM s p
- where
-   s = specialSymbols "\n" scannerExpr
-   p = pMatrix pFractional
-   f Nothing  = Left "Matrix is not rectangular"
-   f (Just m) = Right m
-
-pMatrix :: TokenParser a -> TokenParser (Maybe (Matrix a))
-pMatrix p = make <$> pLines True (pList1 p)
- where 
-   make xs = if isRectangular xs then Just (makeMatrix xs) else Nothing 
+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 = parseWithM s p
- where
-   s = specialSymbols "\n" scannerExpr
-   p = makeVectorSpace <$> pVectors pExpr
-
-pVectors :: TokenParser a -> TokenParser [Vector a]
-pVectors p = pLines True (pVector p)
-
-pVector :: TokenParser a -> TokenParser (Vector a)
-pVector p = fromList <$> myParens (myListSep (pSpec ',') p)
+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
 
-myListSep :: TokenParser a -> TokenParser b -> TokenParser [b]
-myListSep sep p = optional ((:) <$> p <*> pList (sep *> p)) []
+nonEmptyLines :: String -> [String]
+nonEmptyLines = filter (not . all isSpace) . lines
 
-myParens :: TokenParser a -> TokenParser a
-myParens p = pSpec '(' *> p <* pSpec ')'
+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 
-        
+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 
+   format m = let ws = foldr (zipWith max . map length) (repeat 0) m
                   align i s = take i (s ++ repeat ' ')
-              in unlines $ map (unwords . zipWith align ws) m+                  par s = "(" ++ s ++ ")"
+              in unlines $ map (par . intercalate ", " . zipWith align ws) m
src/Domain/LinearAlgebra/Strategies.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,42 +9,42 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.LinearAlgebra.Strategies 
+module Domain.LinearAlgebra.Strategies
    ( gaussianElimStrategy, linearSystemStrategy
    , gramSchmidtStrategy, systemWithMatrixStrategy
    , forwardPass
    ) where
 
-import Prelude hiding (repeat)
-import Domain.Math.Expr
-import Domain.Math.Simplification
-import Domain.LinearAlgebra.Matrix
-import Domain.LinearAlgebra.MatrixRules
+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 Common.Strategy hiding (not)
-import Common.Transformation
-import Common.Context
-import Common.Id
+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" $ 
+gaussianElimStrategy = label "Gaussian elimination" $
    forwardPass <*> backwardPass
 
 forwardPass :: LabeledStrategy (Context (Matrix Expr))
-forwardPass = label "Forward pass" $ 
+forwardPass = label "Forward pass" $
    simplifyRule <*>
-   repeat   (   label "Find j-th column"      ruleFindColumnJ 
+   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" $ 
+backwardPass = label "Backward pass" $
    simplifyRule <*>
    repeat   (   label "Uncover row"  ruleUncoverRow
            <*>  label "Sweep"        (repeat ruleZerosBP)
@@ -61,9 +61,9 @@               )
 
 backSubstitution :: LabeledStrategy (Context (LinearSystem Expr))
-backSubstitution = label "Back substitution" $ 
+backSubstitution = label "Back substitution" $
    ruleIdentifyFreeVariables <*> backSubstitutionSimple
-   
+
 systemToEchelonWithEEO :: LabeledStrategy (Context (LinearSystem Expr))
 systemToEchelonWithEEO =
    label "System to Echelon Form (EEO)" $
@@ -88,17 +88,17 @@ 
 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)
+   <*> 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 "Consider next vector"   ruleNext
+   <*> label "Make vector orthogonal" (repeat (ruleNextOrthogonal <*> try ruleOrthogonal))
    <*> label "Normalize"              (try ruleNormalize)
 
 varVars :: Var [String]
@@ -114,9 +114,9 @@       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" $ 
+conv2 = describe "Convert matrix to linear system" $
    makeSimpleRule "linearalgebra.linsystem.frommatrix" $ withCM $ \expr -> do
       vs <- readVar varVars
       m  <- fromExpr expr
src/Domain/LinearAlgebra/Vector.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,7 +9,7 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.LinearAlgebra.Vector 
+module Domain.LinearAlgebra.Vector
    ( Vector, VectorSpace
    , makeVectorSpace, vectors, sameDimension, gramSchmidt
    , fromList, toList, liftV, liftV2, showVectorWith
@@ -17,12 +17,13 @@    , scale, norm, distance, vectorSum, innerProduct, dimension
    ) where
 
-import Control.Monad
-import Common.Classes
 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 Domain.Math.Expr.Symbols (openMathSymbol) 
 import Test.QuickCheck
 import qualified Text.OpenMath.Dictionary.Linalg2 as OM
 
@@ -31,7 +32,7 @@ 
 newtype Vector a = V [a]
    deriving (Eq, Ord)
-   
+
 newtype VectorSpace a = VS [Vector a]
    deriving (Eq, Ord)
 
@@ -41,9 +42,12 @@ instance Functor Vector where
    fmap f (V xs) = V (map f xs)
 
-instance Switch Vector where
-   switch (V xs) = liftM V (switch 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
 
@@ -70,7 +74,7 @@    coarbitrary = coarbitrary . toList
 
 vectorSymbol :: Symbol
-vectorSymbol = openMathSymbol OM.vectorSymbol
+vectorSymbol = newSymbol OM.vectorSymbol
 
 instance Simplify a => Simplify (Vector a) where
    simplifyWith opt = fmap (simplifyWith opt)
@@ -87,7 +91,7 @@       xs <- fromTerm a
       guard (sameDimension xs)
       return (makeVectorSpace xs)
-      
+
 instance Simplify a => Simplify (VectorSpace a) where
    simplifyWith opt = fmap (simplifyWith opt)
 
@@ -97,6 +101,7 @@       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
 
@@ -112,9 +117,9 @@ 
 -- | Checks that all vectors in vector space have same dimension
 makeVectorSpace :: [Vector a] -> VectorSpace a
-makeVectorSpace xs 
+makeVectorSpace xs
    | sameDimension xs = VS xs
-   | otherwise        = error "makeVectorSpace: different dimensions" 
+   | otherwise        = error "makeVectorSpace: different dimensions"
 
 vectors :: VectorSpace a -> [Vector a]
 vectors (VS xs) = xs
@@ -128,7 +133,7 @@ -- Vector operations
 
 showVectorWith :: (a -> String) -> Vector a -> String
-showVectorWith f (V xs) = "(" ++ concat (intersperse "," (map f xs)) ++ ")"
+showVectorWith f (V xs) = "(" ++ intercalate "," (map f xs) ++ ")"
 
 toList :: Vector a -> [a]
 toList (V xs) = xs
@@ -165,18 +170,18 @@ 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 ] 
+   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)
src/Domain/Logic.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,22 +9,13 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.Logic
-   ( module Domain.Logic.BuggyRules
-   , module Domain.Logic.Exercises
-   , module Domain.Logic.Formula
-   , module Domain.Logic.GeneralizedRules
-   , module Domain.Logic.Generator
-   , module Domain.Logic.Parser
-   , module Domain.Logic.Rules
-   , module Domain.Logic.Strategies
-   ) where
+module Domain.Logic (module Export) where
 
-import Domain.Logic.BuggyRules hiding (rule, ruleList)
-import Domain.Logic.Exercises
-import Domain.Logic.Formula
-import Domain.Logic.GeneralizedRules
-import Domain.Logic.Generator
-import Domain.Logic.Parser
-import Domain.Logic.Rules      hiding (rule, ruleList)
-import Domain.Logic.Strategies+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 view
@@ -1,230 +1,228 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 where--import Domain.Logic.Formula-import Domain.Logic.Generator()-import Domain.Logic.Rules (makeGroup, logic)-import Common.Id-import Common.Rewriting-import Common.Transformation (Rule, buggyRule)-import qualified Common.Transformation as Rule---- Collection of all known buggy rules-buggyRules :: [Rule SLogic]-buggyRules = snd $ makeGroup "Common misconceptions"-   [ 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, Rewrite a) => String -> f -> Rule a-rule = Rule.rule . logic . ( "buggy" # )--ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a-ruleList = Rule.ruleList . logic . ( "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)+-----------------------------------------------------------------------------
+-- 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)
    ]-  -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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,17 +11,12 @@ -- A set of example proofs
 --
 -----------------------------------------------------------------------------
-module Domain.Logic.Examples 
+module Domain.Logic.Examples
    ( exampleProofs
    ) where
 
-
-import Domain.Logic.Formula
 import Common.Utils (ShowString(..))
-
-
-
-
+import Domain.Logic.Formula
 
 exampleProofs :: [(SLogic, SLogic)]
 exampleProofs = [(Not(p :||: (Not p :&&: q)), Not(p :||: q)),
@@ -38,12 +33,9 @@                  ((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")
-
-
-
+   r = Var (ShowString "r")
src/Domain/Logic/Exercises.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -8,20 +8,15 @@ -- Stability   :  provisional
 -- Portability :  portable (depends on ghc)
 --
--- Exercise for the logic domain, used for the OUNL course 
+-- Exercise for the logic domain, used for the OUNL course
 -- "Discrete Wiskunde A (DWA)"
 --
 -----------------------------------------------------------------------------
-module Domain.Logic.Exercises 
+module Domain.Logic.Exercises
    ( dnfExercise, dnfUnicodeExercise
    ) where
 
-import Common.Context
-import Common.Derivation
-import Common.Exercise
-import Common.Navigator
-import Common.Rewriting (differenceMode)
-import Common.Strategy
+import Common.Library
 import Data.Maybe
 import Domain.Logic.BuggyRules
 import Domain.Logic.Formula
@@ -39,15 +34,14 @@    , status         = Stable
    , parser         = parseLogicPars
    , prettyPrinter  = ppLogicPars
-   , equivalence    = eqLogic
-   , similarity     = equalLogicA
-   , isReady        = isDNF
-   , isSuitable     = suitable
-   , extraRules     = map liftToContext (logicRules ++ buggyRules)
+   , equivalence    = withoutContext eqLogic
+   , similarity     = withoutContext equalLogicA
+   , ready          = predicate isDNF
+   , suitable       = predicate mySuitable
+   , extraRules     = map liftToContext (extraLogicRules ++ buggyRules)
    , strategy       = dnfStrategyDWA
    , navigation     = navigator
-   , difference     = differenceMode eqLogic
-   , testGenerator  = Just (restrictGenerator suitable arbitrary)
+   , testGenerator  = Just (restrictGenerator mySuitable arbitrary)
    , randomExercise = useGenerator (const True) logicExercise
    }
 
@@ -60,33 +54,30 @@    , prettyPrinter = ppLogicUnicodePars
    }
 
-logicExercise :: Int -> Gen SLogic
-logicExercise n = 
-   let (gen, (minStep, maxStep)) 
-          | n == 1    = generateLevel Easy
-          | n == 3    = generateLevel Difficult 
-          | otherwise = generateLevel Normal 
+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
 
-suitable :: SLogic -> Bool
-suitable = (<=2) . countEquivalences
+mySuitable :: SLogic -> Bool
+mySuitable = (<=2) . countEquivalences
 
 stepsRemaining :: Int -> SLogic -> Maybe Int
-stepsRemaining i = 
+stepsRemaining i =
    lengthMax i . derivationTree dnfStrategyDWA . inContext dnfExercise
 
--- QuickCheck property to monitor the number of steps needed 
+-- QuickCheck property to monitor the number of steps needed
 -- to normalize a random proposition (30-40% is ok)
 {-
 testGen :: Property
-testGen = forAll generateLogic $ \p -> 
+testGen = forAll generateLogic $ \p ->
    let n = steps p
    in countEquivalences p <= 2 ==> label (show (n >= 4 && n <= 12)) True
-   
+
 testme :: IO ()
-testme = quickCheck testGen 
+testme = quickCheck testGen
 
 start = ((r :<->: p) :||: (q :->: s)) :&&: (Not s :<->: (p :||: r))
  where
− src/Domain/Logic/FeedbackText.hs 
@@ -1,172 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)------ Feedback messages reported for the logic domain. Content to be provided --- by Josje Lodder.----------------------------------------------------------------------------------module Domain.Logic.FeedbackText where--import Data.List-import Data.Maybe-import Common.Id-import Common.Transformation-import Domain.Logic.Rules-import Domain.Logic.BuggyRules--feedbackSyntaxError :: String -> String -feedbackSyntaxError msg-   | "(" `isPrefixOf` msg            = "Syntax error at " ++ msg-   | "Syntax error" `isPrefixOf` msg = msg-   | otherwise                       = "Syntax error: " ++ msg--feedbackBuggy :: Bool -> [Rule a] -> String-feedbackBuggy ready [br] -   | br ~= buggyRuleCommImp = -        f "Did you think that implication is commutative? This is not the case. "-   | br ~= buggyRuleAssImp = -        f "Did you think that implication is associative? This is not the case. "-   | br ~= buggyRuleImplElim2 = -        f "Make sure that you use the rule for implication elimanation, you seemed to use equivalence elimination "-   | br ~= buggyRuleEquivElim3 = -        f "Make sure that you use the rule for equivalence elimanation, you seemed to use implication elimination "-   | br ~= buggyRuleIdemImp = -        f "Did you think that implication is idempotent? This is not the case. "-   | br ~= buggyRuleIdemEqui = -        f "Did you think that equivalence is idempotent? This is not the case. "-   | br ~= buggyRuleAndSame = -        f "Did you think that phi AND phi is equivalent to True? This is not the case. Idempotency of AND means that phi AND phi is equivalent to phi. "-   | br ~= buggyRuleOrSame = -        f "Did you think that phi OR phi is equivalent to True? This is not the case. Idempotency of OR means that phi OR phi is equivalent to phi. "-   | br ~= buggyRuleAndCompl = -        f "Be careful in the application of the the complement-rules "-   | br ~= buggyRuleOrCompl = -        f "Be careful in the application of the the complement-rules " -   | br ~= buggyRuleTrueProp = -        f "Be careful in the application of the the True-False rules "     -   | br ~= buggyRuleFalseProp = -        f "Be careful in the application of the the True-False rules " -   | br ~= buggyRuleEquivElim1 = -        f "Be careful with the elimination of an equivalence; take care of the negations. "-   | br ~= buggyRuleEquivElim2 = -        f "Be careful with the elimination of an equivalence; make sure that the disjunctions and the conjunctions are at the right place. "-   | br ~= buggyRuleImplElim = -        f "Be careful with the elimination of an implication; make sure the negation is at the right place. "-   | br ~= buggyRuleImplElim1 = -        f "Did you try to eliminate an implication? In that case you used an AND instead of an OR "-   | br ~= buggyRuleDeMorgan1 = -        f "Did you try to apply DeMorgan? Be careful with the negations. " -   | br ~= buggyRuleDeMorgan2 = -        f "Did you try to apply DeMorgan? Make sure that you remove the outer negation when applying this rule "-   | br ~= buggyRuleDeMorgan3 = -        f "Did you try to apply DeMorgan? Make sure that you replace AND by OR. "-   | br ~= buggyRuleDeMorgan4 = -        f "Did you try to apply DeMorgan? Make sure that you replace OR by AND. "-   | br ~= buggyRuleDeMorgan5 = -        f "Did you try to apply DeMorgan? Take care of the  scope of the negations. "        -   | br ~= buggyRuleNotOverImpl = -        f "Did you think that you can distribute a negation over an implication? This is not the case. "-   | br ~= buggyRuleParenth1 = -        f "Take care of the negations and the parentheses. " -   | br ~= buggyRuleParenth2 = -        f "Take care of the outer negation when you eliminate an equivalence. " -   | br ~= buggyRuleParenth3 = -        f "Did you try to apply double negation? At this place this is not allowed, because of the parenthesis between the negations. " -   | br ~= buggyRuleAssoc = -        f "Did you change the parentheses? This is not allowed in a subformula consisting of a disjunction and a conjunction. "-   | br ~= buggyRuleAbsor = -        f "Did you try to apply absorption? You cant't apply this rule at this place since the resulting sub formula is not a subformula of the bigger term. "        -   | br ~= buggyRuleDistr = -        f "Did you try to apply distribution? Take care of the place of the disjunctions and the conjunctions. "-   | br ~= buggyRuleDistrNot = -        f "Did you try to apply distribution? Don't forget the negations!. "- where f = incorrect ready-feedbackBuggy ready _ = incorrect ready ""--feedbackNotEquivalent :: Bool -> String-feedbackNotEquivalent ready = incorrect ready ""-    -feedbackSame :: String-feedbackSame = "You have submitted a similar term. " ++ -   "Maybe you inserted or removed parentheses (the tool supports associativity)?"--feedbackOk :: [Rule a] -> (String, Bool)-feedbackOk [one] = (okay (appliedRule one), True)-feedbackOk _     = ("You have combined multiple steps. Press the Back button and perform one step at the time.", False)---- TODO Bastiaan: welke regel wordt er dan verwacht door de strategie?-feedbackDetour :: Bool -> Maybe (Rule a) -> [Rule a] -> (String, Bool)-feedbackDetour True _ [one] = (appliedRule one ++ " " ++ feedbackFinished, True)-feedbackDetour True _ _     = (feedbackMultipleSteps ++ " " ++ feedbackFinished, True)-feedbackDetour _ _ [one] | one `inGroup` groupCommutativity =-   ("You have applied one of the commutativity rules correctly. This step is not mandatory, but sometimes helps to simplify the formula.", True)-feedbackDetour _ mexp [one] = -   let however = case mexp >>= ruleText of-                    Just s  -> "However, the standard strategy suggests to use " ++ s ++ "." -                    Nothing -> "However, the standard strategy suggests a different step."   -   in (appliedRule one ++ " This is correct. " ++ however, True)-feedbackDetour ready _ _ = (feedbackUnknown ready, False)--feedbackUnknown :: Bool -> String-feedbackUnknown ready = feedbackMultipleSteps ++ " " ++ backAndHint ready--feedbackMultipleSteps :: String-feedbackMultipleSteps = "You have combined multiple steps (or made a mistake)."--feedbackFinished :: String-feedbackFinished = "Are you aware that you already reached disjunctive normal form?"--appliedRule :: Rule a -> String-appliedRule r = "You have applied " ++ txt ++ " correctly."- where txt = fromMaybe "some rule" (ruleText r)--ruleText :: Rule a -> Maybe String-ruleText r-   | r ~= ruleFalseZeroOr || r ~= ruleTrueZeroOr || r ~= ruleFalseZeroAnd || r ~= ruleTrueZeroAnd || r ~= ruleNotTrue || r ~= ruleNotFalse = -        return "one of the False/True rules"-   | r ~= ruleComplOr || r ~= ruleComplAnd = return "a complement rule" -   | r ~= ruleNotNot  = return "double negation" -   | r ~= ruleDefImpl  = return "implication elimination" -   | r ~= ruleDefEquiv  = return "equivalence elimination" -   | r `inGroup` groupCommutativity = return "commutativity"-   | r `inGroup` groupAssociativity = return "associativity"-   | r `inGroup` groupDistributionOrOverAnd = return "distribution of or over and"-   | r `inGroup` groupDistributionAndOverOr = return "distribution of and over or"-   | r `inGroup` groupIdempotency = return "idempotency"-   | r `inGroup` groupAbsorption = return "absorption"-   | r `inGroup` groupDeMorgan = return "De Morgan"-   | r `inGroup` groupInverseDeMorgan = return "De Morgan"-   | r `inGroup` groupInverseDistr = return "distributivity"-    -- TODO Josje: aanvullen met alle regels (ook die ook in de DWA strategie voorkomen)-   | otherwise = Nothing----------------------------------------------------------------------------- General text-  -incorrect :: Bool -> String -> String-incorrect ready s = "This is incorrect. " ++ s ++ backAndHint ready--okay :: String -> String-okay s = "Well done! " ++ s--backAndHint :: Bool -> String-backAndHint ready = "Press the Back button and try again." ++-   if ready then "" else " You may ask for a hint."------------------------------------------------------------------------------ Helper functions--(~=) :: Rule a -> Rule b -> Bool-r1 ~= r2 = getId r1 == getId r2---- Quick and dirty fix!-inGroup :: Rule a -> (Id, b) -> Bool-inGroup r n = -   let rs = filter (~= r) (logicRules ++ buggyRules)-   in fst n `elem` concatMap ruleGroups rs
src/Domain/Logic/Formula.hs view
@@ -1,231 +1,208 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 where--import Common.Classes-import Common.Id-import Common.Rewriting-import Common.Uniplate (Uniplate(..), universe)-import Common.Utils (ShowString, subsets)-import Common.View-import Control.Monad-import Data.List-import Data.Maybe-import Domain.Math.Expr.Symbols (openMathSymbol)-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 f = foldLogic (Var . f, (:->:), (:<->:), (:&&:), (:||:), Not, T, F)--instance Crush Logic where-   crush p = [ x | Var x <- universe p ]--instance Switch Logic where-   switch = foldLogic -      ( liftM Var, liftM2 (:->:), liftM2 (:<->:), liftM2 (:&&:)-      , liftM2 (:||:), liftM Not, return T, return F-      )---- | 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, true, false) = 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         -> true -         F         -> false---- | 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-      Var _       -> True-      Not (Var _) -> True-      T           -> True-      F           -> True-      _           -> False---- | 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---- | Function disjunctions returns all Logic expressions separated by an or--- | operator at the top level.-disjunctions :: Logic a -> [Logic a]-disjunctions p = fromMaybe [p] $ match (magmaListView orMonoid) p---- | Function conjunctions returns all Logic expressions separated by an and--- | operator at the top level.-conjunctions :: Logic a -> [Logic a]-conjunctions p = fromMaybe [p] $ match (magmaListView andMonoid) p- --- | 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 p = nub [ s | Var s <- universe p ]   --instance Uniplate (Logic a) where-   uniplate this =-      case this of -         p :->: q  -> ([p, q], \[a, b] -> a :->:  b)-         p :<->: q -> ([p, q], \[a, b] -> a :<->: b)-         p :&&: q  -> ([p, q], \[a, b] -> a :&&:  b)-         p :||: q  -> ([p, q], \[a, b] -> a :||:  b)-         Not p     -> ([p], \[a] -> Not a)-         _         -> ([], \[] -> 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 (foldr1 (:&&:) xs)-         | s == orSymbol         = return (foldr1 (:||:) xs)-      f _ _ = fail "fromTerm"--trueSymbol, falseSymbol, notSymbol, impliesSymbol, equivalentSymbol,-   andSymbol, orSymbol :: Symbol--trueSymbol       = openMathSymbol OM.trueSymbol-falseSymbol      = openMathSymbol OM.falseSymbol-notSymbol        = openMathSymbol OM.notSymbol-impliesSymbol    = openMathSymbol OM.impliesSymbol-equivalentSymbol = openMathSymbol OM.equivalentSymbol-andSymbol        = openMathSymbol OM.andSymbol-orSymbol         = openMathSymbol OM.orSymbol--logicOperators :: [Magma (Logic a)]-logicOperators = map toMagma [andMonoid, orMonoid]--andMonoid :: Monoid (Logic a)-andMonoid = monoid andOperator (makeConstant (getId trueSymbol) T isT)- where-   isT T = True-   isT _ = False -   -orMonoid :: Monoid (Logic a)-orMonoid = monoid orOperator (makeConstant (getId falseSymbol) F isF)- where-   isF F = True-   isF _ = False--andOperator:: BinaryOp (Logic a)-andOperator = makeBinary (getId andSymbol) (:&&:) isAnd- where -   isAnd (p :&&: q) = Just (p, q)-   isAnd _          = Nothing--orOperator :: BinaryOp (Logic a)-orOperator = makeBinary (getId orSymbol) (:||:) isOr- where-   isOr (p :||: q) = Just (p, q)-   isOr _          = Nothing--implOperator :: BinaryOp (Logic a)   -implOperator = makeBinary (getId impliesSymbol) (:->:) isImpl- where-   isImpl (p :->: q) = Just (p, q)-   isImpl _           = Nothing-   -equivOperator :: BinaryOp (Logic a)   -equivOperator = makeBinary (getId equivalentSymbol) (:<->:) isEquiv- where-   isEquiv (p :<->: q) = Just (p, q)-   isEquiv _           = Nothing+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,156 +1,143 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 -   ( generalRules, inverseRules-   , 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 Domain.Logic.Formula-import Common.Transformation (Rule)-import qualified Common.Transformation as Rule-import Control.Monad--generalRules :: [Rule SLogic]-generalRules =-   [ generalRuleDeMorganOr, generalRuleDeMorganAnd-   , generalRuleAndOverOr, generalRuleOrOverAnd-   ]--inverseRules :: [Rule SLogic]-inverseRules = -   [ inverseDeMorganOr, inverseDeMorganAnd-   , inverseAndOverOr, inverseOrOverAnd-   ]--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 $ foldr1 (:||:) 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 $ foldr1 (:&&:) 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 :&&: foldr1 (:||:) ys)-    `mplus` do-      pairs <- mapM isAndLast xs-      let (ys, as) = unzip pairs-      guard (allSame as)-      return (foldr1 (:||:) 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 :||: foldr1 (:&&:) ys)-    `mplus` do-      pairs <- mapM isOrLast xs-      let (ys, as) = unzip pairs-      guard (allSame as)-      return (foldr1 (:&&:) 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 (foldr1 (:&&:) (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 (foldr1 (:||:) (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 (foldr1 (:||:) (map (:&&: y) xs))-         (_, ys) | length ys > 2 ->-            return (foldr1 (:||:) (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 (foldr1 (:&&:) (map (:||: y) xs))-         (_, ys) | length ys > 2 ->-            return (foldr1 (:&&:) (map (x :||:) ys))-         _ -> Nothing+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,7 +1,7 @@ {-# LANGUAGE TypeSynonymInstances #-}
 -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,55 +11,60 @@ --
 -----------------------------------------------------------------------------
 module Domain.Logic.Generator
-   ( generateLogic, generateLevel, equalLogicA, Level(..)
+   ( generateLogic, generateLevel, equalLogicA, equalLogicACI
    ) where
 
+import Common.Algebra.Boolean
+import Common.Exercise
 import Common.Utils (ShowString(..))
-import Domain.Logic.Formula
+import Common.Utils.Uniplate
 import Control.Monad
 import Data.Char
+import Data.List
+import Domain.Logic.Formula
 import Test.QuickCheck
-import Common.Rewriting
-import Common.Uniplate
-import Common.View
 
 -------------------------------------------------------------
--- Code that doesn't belong here, but the arbitrary instance
--- is needed for the Rewrite instance.
-
-instance Rewrite SLogic where
-   operators = logicOperators
+-- Code that doesn't belong here
 
 -- | Equality modulo associativity of operators
-equalLogicA:: SLogic -> SLogic -> Bool
+equalLogicA :: Eq a => Logic a -> Logic a -> Bool
 equalLogicA p q = rec p == rec q
  where
-   make  = simplifyWith (map rec) . magmaListView
    rec a = case a of
-              _ :&&: _ -> make andMonoid a
-              _ :||: _ -> make orMonoid  a
+              _ :&&: _ -> 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
 
-data Level = Easy | Normal | Difficult 
-   deriving Show
-
 generateLogic :: Gen SLogic
 generateLogic = normalGenerator
 
-generateLevel :: Level -> (Gen SLogic, (Int, Int))
-generateLevel level =
-   case level of
-      Easy      -> (easyGenerator,      (3, 6))
-      Normal    -> (normalGenerator,    (4, 12))
-      Difficult -> (difficultGenerator, (7, 18))
+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 :: Gen SLogic
 easyGenerator = do
-   n  <- oneof [return 2, return 4] -- , return 8]
+   n  <- elements [2, 4] -- , return 8]
    sizedGen True varGen n
 
 -- Use the propositions with 4-12 steps
@@ -73,7 +78,7 @@ difficultGenerator :: Gen SLogic
 difficultGenerator = do
    let vs = ShowString "s" : varList
-   p0 <- sizedGen False (oneof $ map return vs) 4
+   p0 <- sizedGen False (elements vs) 4
    p1 <- preventSameVar vs p0
    return (removePartsInDNF p1)
 
@@ -81,16 +86,16 @@ varList = map ShowString ["p", "q", "r"]
 
 varGen :: Gen ShowString
-varGen = oneof $ map return varList
+varGen = elements varList
 
 sizedGen :: Bool -> Gen a -> Int -> Gen (Logic a)
-sizedGen constants gen = go 
+sizedGen constants gen = go
  where
    go n
       | n > 0 =
            let rec   = go (n `div` 2)
                op2 f = liftM2 f rec rec
-           in frequency 
+           in frequency
                  [ (2, go 0)
                  , (2, op2 (:->:))
                  , (1, op2 (:<->:))
@@ -106,11 +111,11 @@ -- Simple tricks for creating for "nice" logic propositions
 
 preventSameVar :: Eq a => [a] -> Logic a -> Gen (Logic a)
-preventSameVar xs = rec 
+preventSameVar xs = rec
  where
    rec p = case holes p of
               [(Var a, _), (Var b, update)] | a==b -> do
-                 c <- oneof $ map return $ filter (/=a) xs
+                 c <- elements $ filter (/=a) xs
                  return $ update (Var c)
               _ -> descendM rec p
 
@@ -119,11 +124,11 @@  where
    buildOr [] = T
    buildOr xs = foldl1 (:||:) xs
-   
+
    simple = all f . conjunctions
     where
       f (Not p) = null (children p)
-      f p       = null (children p) 
+      f p       = null (children p)
 
 -----------------------------------------------------------
 --- QuickCheck generator
@@ -132,13 +137,10 @@    arbitrary = sized (\i -> sizedGen True varGen (i `min` 4))
 
 instance CoArbitrary SLogic where
-   coarbitrary logic = 
-      case logic of
-         Var x     -> variant (0 :: Int) . coarbitrary (map ord (fromShowString x))
-         p :->: q  -> variant (1 :: Int) . coarbitrary p . coarbitrary q
-         p :<->: q -> variant (2 :: Int) . coarbitrary p . coarbitrary q
-         p :&&: q  -> variant (3 :: Int) . coarbitrary p . coarbitrary q
-         p :||: q  -> variant (4 :: Int) . coarbitrary p . coarbitrary q
-         Not p     -> variant (5 :: Int) . coarbitrary p
-         T         -> variant (6 :: Int)  
-         F         -> variant (7 :: Int)+   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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -10,129 +10,100 @@ --
 -----------------------------------------------------------------------------
 module Domain.Logic.Parser
-   ( parseLogic, parseLogicPars, parseLogicUnicodePars, parseLogicProof
+   ( parseLogic, parseLogicPars, parseLogicUnicodePars -- , parseLogicProof
    , ppLogicPars, ppLogicUnicodePars
    ) where
 
+import Common.Algebra.Boolean
 import Common.Utils (ShowString(..))
-import Control.Monad.Error (liftM2)
-import Text.Parsing
-import Control.Arrow
 import Domain.Logic.Formula
-   
-logicScanner :: Scanner
-logicScanner = (specialSymbols "~" defaultScanner)
-   { keywords         = ["T", "F"]
-   , keywordOperators = "~" : concatMap (map fst . snd) operatorTable
-   }
-
-logicUnicodeScanner :: Scanner
-logicUnicodeScanner = (specialSymbols (concat unicodeSyms) defaultScanner)
-   { keywords         = ["T", "F"]
-   , keywordOperators = unicodeSyms
-   }
-   
-operatorTable :: OperatorTable SLogic
-operatorTable = 
-   [ (RightAssociative, [("<->", (:<->:))])
-   , (RightAssociative, [("||",  (:||:))])
-   , (RightAssociative, [("/\\", (:&&:))])
-   , (RightAssociative, [("->",  (:->:))])
-   ]
+import Text.Parsing
+import qualified Text.ParserCombinators.Parsec.Token as P
 
 -----------------------------------------------------------
 --- Parser
 
--- | Parser for logic formulas that respects all associativity and priority laws 
--- | of the constructors
 parseLogic :: String -> Either String SLogic
-parseLogic = analyseAndParse pLogic . scanWith logicScanner
- where
-   pLogic = pOperators operatorTable (basicWithPos pLogic)
-   
--- | Parser for logic formulas that insists on more parentheses: "and" and "or" are associative, 
--- | but implication and equivalence are not. Priorities of the operators are unknown, and thus 
--- | parentheses have to be written explicitly. No parentheses are needed for Not (Not p). Superfluous
--- | parentheses are permitted
+parseLogic = parseBalanced (parserSLogic False False)
+
+parseLogicUnicode :: String -> Either String SLogic
+parseLogicUnicode = parseBalanced (parserSLogic True False)
+
 parseLogicPars :: String -> Either String SLogic
-parseLogicPars s
-   = either Left suspiciousVariable 
-   $ left (ambiguousOperators parseLogic s)
-   $ analyseAndParse (pLogicGen asciiTuple)
-   $ scanWith logicScanner s
+parseLogicPars input =
+     either (Left . ambiguousOperators parseLogic input) suspiciousVariable
+   $ parseBalanced (parserSLogic False True) input
 
 parseLogicUnicodePars :: String -> Either String SLogic
-parseLogicUnicodePars s 
-   = either Left suspiciousVariable 
-   $ left (ambiguousOperators (parseLogic . concatMap f) s)
-   $ analyseAndParse (pLogicGen unicodeTuple)
-   $ scanWith logicUnicodeScanner s
- where
-   -- quick fix (since we only need to know whether the parser succeeds)
-   f c | [c] == andUSym   = andASym
-       | [c] == orUSym    = orASym
-       | [c] == notUSym   = notASym
-       | [c] == implUSym  = implASym
-       | [c] == equivUSym = equivASym
-       | otherwise        = [c]
+parseLogicUnicodePars input =
+   either (Left . ambiguousOperators parseLogicUnicode input) suspiciousVariable
+   $ parseBalanced (parserSLogic True True) input
 
-pLogicGen :: SymbolTuple -> TokenParser SLogic
-pLogicGen (impl, equiv, conj, disj, neg, tr, fl) = pLogic
+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 = flip ($) <$> basic <*> optional composed id
-   basic     =  basicWithPosGen (neg, tr, fl) pLogic
-   composed  =  flip (:<->:) <$ pKey equiv <*> basic
-            <|> flip (:->:)  <$ pKey impl  <*> basic
-            <|> (\xs p -> foldr1 (:&&:) (p:xs)) <$> pList1 (pKey conj *> basic)
-            <|> (\xs p -> foldr1 (:||:) (p:xs)) <$> pList1 (pKey disj  *> basic)
- 
-basicWithPos :: TokenParser SLogic -> TokenParser SLogic
-basicWithPos = basicWithPosGen ("~", "T", "F")
+   pLogic
+      | extraPars = atom <**> option id composed
+      | otherwise = buildExpressionParser table atom
 
-basicWithPosGen :: (String, String, String) -> TokenParser SLogic -> TokenParser SLogic 
-basicWithPosGen t@(nt, tr, fl) p = 
-       (Var . ShowString) <$> pVarid
-   <|> pParens p
-   <|> T  <$ pKey tr
-   <|> F  <$ pKey fl
-   <|> Not <$ pKey nt <*> basicWithPosGen t p
+   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)
+      ]
 
-parseLogicProof :: String -> Either String (SLogic, SLogic)
-parseLogicProof s
-   = either Left susp
-   $ left (ambiguousOperators parseLogic s)
-   $ analyseAndParse pProof
-   $ scanWith extScanner s
- where
-   pProof = (,) <$> pLogicGen asciiTuple <* pKey "==" <*> pLogicGen asciiTuple
-   susp (p, q) = liftM2 (,) (suspiciousVariable p) (suspiciousVariable q)
-   extScanner = logicScanner 
-      {keywordOperators = "==" : keywordOperators logicScanner}
+   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
 
--- analyze parentheses
-analyseAndParse :: TokenParser a -> [Token] -> Either String a
-analyseAndParse p ts =
-   case checkParentheses ts of
-      Just err -> Left (show err)
-      Nothing  -> either (Left . f) Right (parse p ts)
- where
-   f (Just t) = show (tokenPosition t) ++ ": Unexpected " ++ show t
-   f Nothing  = "Syntax error"
-
 ambiguousOperators :: (String -> Either a b) -> String -> String -> String
 ambiguousOperators p s err =
-   let msg = "Ambiguous use of operators (write parentheses)"
+   let msg = "Syntax error: ambiguous use of operators (write parentheses)"
    in either (const err) (const msg) (p s)
 
--- Report variables 
+-- 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?" 
+                 ++ ". Did you forget an operator?"
       _   -> Right r
  where
    p xs = length xs > 1 && all (`elem` "pqrst") xs
@@ -149,15 +120,15 @@ ppLogicUnicodePars = ppLogicParsGen unicodeTuple
 
 ppLogicParsGen :: SymbolTuple -> SLogic -> String
-ppLogicParsGen (impl, equiv, conj, disj, neg, tr, fl) = 
+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)) 
+   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
@@ -177,12 +148,9 @@ andASym   = "/\\"
 orASym    = "||"
 notASym   = "~"
-   
+
 -----------------------------------------------------------
 --- Unicode symbols
-
-unicodeSyms :: [String]
-unicodeSyms = [implUSym, equivUSym, andUSym, orUSym, notUSym]
 
 unicodeTuple :: SymbolTuple
 unicodeTuple = (implUSym, equivUSym, andUSym, orUSym, notUSym, "T", "F")
− src/Domain/Logic/Proofs.hs 
@@ -1,319 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more 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: to prove two propositions equivalent
---
------------------------------------------------------------------------------
-module Domain.Logic.Proofs (proofExercise) where
-
-import Prelude hiding (repeat)
-import Common.Context
-import Common.Rewriting
-import Common.Rewriting.AC
-import Common.Strategy hiding (fail, not)
-import Common.Exercise
-import Common.Utils
-import Common.View
-import Common.Transformation
-import Common.Navigator
-import Data.List hiding (repeat)
-import Control.Monad
-import Data.Maybe
-import Domain.Logic.Formula
-import Domain.Logic.Generator (equalLogicA)
-import Domain.Logic.Parser
-import Domain.Logic.Rules
-import Domain.Logic.GeneralizedRules
-import Domain.Logic.Strategies (somewhereOr)
-import Domain.Logic.Examples 
-import Domain.Math.Expr ()
-import Common.Uniplate
-
-see :: Int -> IO ()
-see n = printDerivation proofExercise (examples proofExercise !! n)
-
--- Currently, we use the DWA strategy
-proofExercise :: Exercise [(SLogic, SLogic)]
-proofExercise = makeExercise
-   { exerciseId     = describe "Prove two propositions equivalent" $
-                         newId "logic.proof"
-   , status         = Experimental
---   , parser         = parseLogicProof
-   , prettyPrinter  = let f (p, q) = ppLogicPars p ++ " == " ++ ppLogicPars q
-                      in commaList . map f
---   , equivalence    = \(p, _) (r, s) -> eqLogic p r && eqLogic r s
---   , similarity     = \(p, q) (r, s) -> equalLogicA p r && equalLogicA q s
-   , isSuitable     = all (uncurry eqLogic)
-   , isReady        = all (uncurry equalLogicA)
-   , strategy       = proofStrategy
-   , navigation     = termNavigator
-   , examples       = map return $ exampleProofs ++
-                      let p = Var (ShowString "p") 
-                          q = Var (ShowString "q")
-                      in [(q :&&: p, p :&&: (q :||: q))]
-   }
-
-instance (IsTerm a, IsTerm b) => IsTerm (a, b) where
-   toTerm (a, b) = binary tupleSymbol (toTerm a) (toTerm b)
-   fromTerm term = do
-      (a, b) <- isBinary tupleSymbol term
-      liftM2 (,) (fromTerm a) (fromTerm b)
-   
-tupleSymbol :: Symbol
-tupleSymbol = newSymbol "basic.tuple"
-
-proofStrategy :: LabeledStrategy (Context [(SLogic, SLogic)])
-proofStrategy = label "proof equivalent" $
-   repeat (
-         somewhere (useC commonExprAtom)
-      |> somewhere splitTop
-      |> somewhere rest
-      ) <*>
-   repeat (somewhere (use normLogicRule))
- where
-   splitTop =  use topIsNot  <|> use topIsAnd <|> use topIsOr
-           <|> use topIsImpl <|> use topIsEquiv
-   rest =  use notDNF <*> mapRulesS useC (repeat dnfStrategyDWA)
-       <|> simpler
-
-   simpler :: Strategy (Context [(SLogic, SLogic)])
-   simpler =
-      use tautologyOr <|> use idempotencyAnd <|> use contradictionAnd
-      <|> use absorptionSubset <|> use fakeAbsorption <|> use fakeAbsorptionNot
-      <|> alternatives (map use list)
-            
-   list = [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr
-          , ruleAbsorpOr, ruleComplOr
-          ]
-
-   notDNF :: Rule SLogic
-   notDNF = minorRule $ makeSimpleRule "not-dnf" $ \p ->
-      if isDNF p then Nothing else Just p
-
------------------------------------------------------------------------------
--- To DNF, with priorities (the "DWA" approach)
-
-dnfStrategyDWA :: Strategy (Context SLogic)
-dnfStrategyDWA =
-   toplevel <|> somewhereOr
-      (  label "Simplify"                            simplify
-      |> label "Eliminate implications/equivalences" eliminateImplEquiv
-      |> label "Eliminate nots"                      eliminateNots
-      |> label "Move ors to top"                     orToTop
-      )
- where
-    toplevel = useRules 
-       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr
-       , ruleAbsorpOr, ruleComplOr
-       ]
-    simplify = 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 ]
-
-useRules :: [Rule SLogic] -> Strategy (Context SLogic)
-useRules = alternatives . map liftToContext
-
-onceLeft :: IsStrategy f => f (Context a) -> Strategy (Context a)
-onceLeft s = ruleMoveDown <*> s <*> ruleMoveUp
- where
-   ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" (down 1)   
-   ruleMoveUp   = minorRule $ makeSimpleRule "MoveUp" safeUp
-   
-   safeUp a = Just (fromMaybe a (up a))
-   
-onceRight :: IsStrategy f => f (Context a) -> Strategy (Context a)
-onceRight s = ruleMoveDown <*> s <*> ruleMoveUp
- where
-   ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" (down 2)   
-   ruleMoveUp   = minorRule $ makeSimpleRule "MoveUp" safeUp
-   
-   safeUp a = Just (fromMaybe a (up a))
-
-testje :: Rule (Context SLogic)
-testje = makeSimpleRule "testje" $ \a -> error $ show a
-
-go n = printDerivation proofExercise [exampleProofs !! n] --(p :||: Not p, Not F)
- --where p = Var (ShowString "p") 
- 
-normLogicRule :: Rule (SLogic, SLogic)
-normLogicRule = makeSimpleRule "Normalize" $ \tuple@(p, q) -> do
-   guard (p /= q)
-   let xs  = sort (varsLogic p `union` varsLogic q)
-       new = (normLogicWith xs p, normLogicWith xs q)
-   guard (tuple /= new)
-   return new
-
--- Find a common subexpression that can be treated as a box
-commonExprAtom :: Rule (Context (SLogic, SLogic))
-commonExprAtom = makeSimpleRule "commonExprAtom" $ withCM $ \(p, q) -> do 
-   let f  = filter same . filter ok . nub . sort . universe 
-       xs = f p `intersect` f q -- todo: only largest common sub expr
-       ok (Var _) = False
-       ok T       = False
-       ok F       = False
-       ok (Not a) = ok a
-       ok _       = True
-       same cse = eqLogic (sub cse p) (sub cse q)
-       new = head (logicVars \\ (varsLogic p `union` varsLogic q))
-       sub a this
-          | a == this = Var new
-          | otherwise = descend (sub a) this
-   case xs of 
-      hd:_ -> do modifyVar substVar ((show new, show hd):)
-                 return (sub hd p, sub hd q)
-      _ -> fail "not applicable"
-   
-substVar :: Var [(String, String)]
-substVar = newVar "subst" []
-   
-logicVars :: [ShowString]
-logicVars = [ ShowString [c] | c <- ['a'..] ]
-
-normLogic :: Ord a => Logic a -> Logic a
-normLogic p = normLogicWith (sort (varsLogic p)) p 
-   
-normLogicWith :: Eq a => [a] -> Logic a -> Logic a
-normLogicWith xs p = make (filter keep (subsets xs))
- where
-   keep ys = evalLogic (`elem` ys) p
-   make = makeOrs . map atoms
-   atoms ys = makeAnds [ f (x `elem` ys) (Var x) | x <- xs ]
-   f b = if b then id else Not
-   
-makeOrs  xs = if null xs then F else foldr1 (:||:) xs
-makeAnds xs = if null xs then T else foldr1 (:&&:) xs
-
-
--- p \/ q \/ ~p     ~> T           (propageren)
-tautologyOr :: Rule SLogic 
-tautologyOr = makeSimpleRule "tautologyOr" $ \p -> do
-   let xs = disjunctions p
-   guard (any (\x -> Not x `elem` xs) xs)
-   return T
-
--- p /\ q /\ p      ~> p /\ q
-idempotencyAnd :: Rule SLogic
-idempotencyAnd = makeSimpleRule "idempotencyAnd" $ \p -> do
-   let xs = conjunctions p
-       ys = nub xs
-   guard (length ys < length xs)
-   return (makeAnds ys)
-
--- p /\ q /\ ~p     ~> F           (propageren)
-contradictionAnd :: Rule SLogic
-contradictionAnd = makeSimpleRule "contradictionAnd" $ \p -> do
-   let xs = conjunctions p
-   guard (any (\x -> Not x `elem` xs) xs)
-   return F
-
--- (p /\ q) \/ ... \/ (p /\ q /\ r)    ~> (p /\ q) \/ ...
---    (subset relatie tussen rijtjes: bijzonder geval is gelijke rijtjes)
-absorptionSubset :: Rule SLogic
-absorptionSubset = makeSimpleRule "absorptionSubset" $ \p -> do
-   let xss = map conjunctions (disjunctions p)
-       yss = nub $ filter (\xs -> all (ok xs) xss) xss
-       ok xs ys = not (ys `isSubsetOf` xs) || xs == ys
-   guard (length yss < length xss)
-   return $ makeOrs (map makeAnds yss)
-   
--- p \/ ... \/ (~p /\ q /\ r)  ~> p \/ ... \/ (q /\ r)
---    (p is hier een losse variabele)
-fakeAbsorption :: Rule SLogic
-fakeAbsorption = makeSimpleRuleList "fakeAbsorption" $ \p -> do
-   let xs = disjunctions p
-   v <- [ a | a@(Var _) <- xs ]
-   let ys  = map (makeAnds . filter (/= Not v) . conjunctions) xs
-       new = makeOrs ys
-   guard (p /= new)
-   return new
-
--- ~p \/ ... \/ (p /\ q /\ r)  ~> ~p \/ ... \/ (q /\ r)
---   (p is hier een losse variabele)
-fakeAbsorptionNot :: Rule SLogic
-fakeAbsorptionNot = makeSimpleRuleList "fakeAbsorptionNot" $ \p -> do
-   let xs = disjunctions p
-   v <- [ a | Not a@(Var _) <- xs ]
-   let ys  = map (makeAnds . filter (/= v) . conjunctions) xs
-       new = makeOrs ys
-   guard (p /= new)
-   return new
-
-topIsNot :: Rule (SLogic, SLogic)
-topIsNot = makeSimpleRule "top-is-not" f
- where
-   f (Not p, Not q) = Just (p, q)
-   f _ = Nothing
-
-acTopRuleFor :: IsId a => a -> BinaryOp SLogic -> Rule [(SLogic, SLogic)]
-acTopRuleFor s op = makeSimpleRuleList s f
- where
-   f [(lhs, rhs)] = do
-      let myView = magmaListView (semiGroup op)
-          make   = build myView
-      xs <- matchM myView lhs
-      ys <- matchM myView rhs
-      guard (length xs > 1 && length ys > 1)
-      list <- liftM (map (make *** make)) (pairingsAC False xs ys)
-      guard (all (uncurry eqLogic) list)
-      return list
-   f _ = []
-
-topIsAnd :: Rule [(SLogic, SLogic)]
-topIsAnd = acTopRuleFor "top-is-and" andOperator
-
-topIsOr :: Rule [(SLogic, SLogic)]
-topIsOr = acTopRuleFor "top-is-or" orOperator
-
-topIsEquiv :: Rule [(SLogic, SLogic)]
-topIsEquiv = acTopRuleFor "top-is-equiv" equivOperator
-
-topIsImpl :: Rule [(SLogic, SLogic)]
-topIsImpl = makeSimpleRule "top-is-impl" f
- where
-   f [(p :->: q, r :->: s)] = do
-      guard (eqLogic p r && eqLogic q s)
-      return [(p, r), (q, s)]
-   f _ = Nothing
-   
-{- Strategie voor sterke(?) normalisatie
-
-(prioritering)
- 
-1. p \/ q \/ ~p     ~> T           (propageren)
-   p /\ q /\ p      ~> p /\ q
-   p /\ q /\ ~p     ~> F           (propageren)
-
-2. (p /\ q) \/ ... \/ (p /\ q /\ r)    ~> (p /\ q) \/ ...
-         (subset relatie tussen rijtjes: bijzonder geval is gelijke rijtjes)
-   p \/ ... \/ (~p /\ q /\ r)  ~> p \/ ... \/ (q /\ r)
-         (p is hier een losse variabele)
-   ~p \/ ... \/ (p /\ q /\ r)  ~> ~p \/ ... \/ (q /\ r)
-         (p is hier een losse variabele)
-
-3. a) elimineren wat aan een kant helemaal niet voorkomt (zie regel hieronder)
-   b) rijtjes sorteren
-   c) rijtjes aanvullen
-   
-Twijfelachtige regel bij stap 3: samennemen in plaats van aanvullen:
-   (p /\ q /\ r) \/ ... \/ (~p /\ q /\ r)   ~> q /\ r
-          (p is hier een losse variable)
--}
src/Domain/Logic/Rules.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -8,92 +8,57 @@ -- Stability   :  provisional
 -- Portability :  portable (depends on ghc)
 --
--- Rewrite rules in the logic domain (including all the rules from the 
+-- Rewrite rules in the logic domain (including all the rules from the
 -- DWA course)
 --
 -----------------------------------------------------------------------------
-module Domain.Logic.Rules where
+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 Domain.Logic.Formula
 import Common.Id
-import Common.Transformation (Rule, addRuleToGroup, minorRule)
 import Common.Rewriting
-import Domain.Logic.Generator()
+import Common.Transformation (Rule, minorRule)
+import Domain.Logic.Formula
 import Domain.Logic.GeneralizedRules
+import Domain.Logic.Generator()
 import qualified Common.Transformation as Rule
- 
-logicRules :: [Rule SLogic]
-logicRules = concatMap snd
-   [ groupCommutativity, groupAssociativity, groupIdempotency
-   , groupAbsorption, groupTrueProperties, groupFalseProperties, groupDoubleNegation
-   , groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination, groupAdditional
-   , groupDistributionOrOverAnd, groupDistributionAndOverOr
-   , groupInverseDeMorgan,groupInverseDistr
+
+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" 
+logic = ( # ) "logic.propositional"
 
-rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a
+rule :: RuleBuilder f a => String -> f -> Rule a
 rule = Rule.rule . logic
 
-ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
+ruleList :: RuleBuilder f a => String -> [f] -> Rule a
 ruleList = Rule.ruleList . logic
 
 -----------------------------------------------------------------------------
--- Grouping DWA rules
-
-makeGroup :: String -> [Rule SLogic] -> (Id, [Rule SLogic])
-makeGroup s rs =  
-   let a = logic s
-   in (a, map (addRuleToGroup a) rs)
-
-groupCommutativity, groupAssociativity, groupDistributionOrOverAnd, 
-   groupDistributionAndOverOr,groupIdempotency, groupAbsorption, 
-   groupTrueProperties, groupFalseProperties, groupDoubleNegation,
-   groupDeMorgan, groupImplicationEliminatinon, groupEquivalenceElimination,
-   groupInverseDeMorgan, groupInverseDistr :: (Id, [Rule SLogic])
-
-groupCommutativity = makeGroup "Commutativity" 
-   [ruleCommOr, ruleCommAnd]
-groupAssociativity = makeGroup "Associativity"
-   [ruleAssocOr, ruleAssocAnd]
-groupIdempotency = makeGroup "Idempotency"
-   [ruleIdempOr, ruleIdempAnd]
-groupAbsorption = makeGroup "Absorption"
-   [ruleAbsorpOr, ruleAbsorpAnd]
-groupTrueProperties = makeGroup "True Properties"
-   [ruleTrueZeroOr, ruleTrueZeroAnd, ruleComplOr, ruleNotTrue]
-groupFalseProperties = makeGroup "False Properties"
-   [ruleFalseZeroOr, ruleFalseZeroAnd, ruleComplAnd, ruleNotFalse]
-groupDoubleNegation = makeGroup "Double Negation"
-   [ruleNotNot]
-groupDeMorgan = makeGroup "De Morgan" 
-   [ruleDeMorganOr, ruleDeMorganAnd, generalRuleDeMorganOr, generalRuleDeMorganAnd ]
-groupImplicationEliminatinon = makeGroup "Implication Elimination"
-   [ruleDefImpl]
-groupEquivalenceElimination = makeGroup "Equivalence Elimination"
-   [ruleDefEquiv]
-groupDistributionOrOverAnd = makeGroup "DistributionOrOverAnd"
-   [generalRuleOrOverAnd, ruleOrOverAnd ]
-groupDistributionAndOverOr = makeGroup "DistributionAndOverOr"
-   [generalRuleAndOverOr, ruleAndOverOr ]
-groupInverseDeMorgan = makeGroup "InverseDeMorgan" 
-   [inverseDeMorganOr, inverseDeMorganAnd]
-groupInverseDistr = makeGroup "InverseDistr"
-   [inverseAndOverOr, inverseOrOverAnd]
-   
------------------------------------------------------------------------------
 -- Commutativity
 
-ruleCommOr :: Rule SLogic  
+ruleCommOr :: Rule SLogic
 ruleCommOr = rule "CommOr" $
    \x y -> x :||: y  :~>  y :||: x
 
-ruleCommAnd :: Rule SLogic 
+ruleCommAnd :: Rule SLogic
 ruleCommAnd = rule "CommAnd" $
    \x y -> x :&&: y  :~>  y :&&: x
-   
+
 -----------------------------------------------------------------------------
 -- Associativity (implicit)
 
@@ -104,27 +69,27 @@ ruleAssocAnd :: Rule SLogic
 ruleAssocAnd = minorRule $ rule "AssocAnd" $
    \x y z -> (x :&&: y) :&&: z  :~>  x :&&: (y :&&: z)
-   
+
 -----------------------------------------------------------------------------
 -- Distributivity
 
-ruleAndOverOr :: Rule SLogic 
+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 :: 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, ruleIdempAnd :: Rule SLogic
 
 ruleIdempOr = rule "IdempOr" $
    \x -> x :||: x  :~>  x
@@ -135,26 +100,26 @@ -----------------------------------------------------------------------------
 -- Absorption
 
-ruleAbsorpOr, ruleAbsorpAnd :: Rule SLogic 
+ruleAbsorpOr, ruleAbsorpAnd :: Rule SLogic
 
-ruleAbsorpOr = ruleList "AbsorpOr" 
+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 
+   [ \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, ruleTrueZeroAnd, ruleComplOr, ruleNotTrue :: Rule SLogic
 
 ruleTrueZeroOr = ruleList "TrueZeroOr"
    [ \x -> T :||: x  :~>  T
@@ -164,8 +129,8 @@ ruleTrueZeroAnd = ruleList "TrueZeroAnd"
    [ \x -> T :&&: x  :~>  x
    , \x -> x :&&: T  :~>  x
-   ] 
- 
+   ]
+
 ruleComplOr = ruleList "ComplOr"
    [ \x -> x :||: Not x  :~>  T
    , \x -> Not x :||: x  :~>  T
@@ -173,22 +138,22 @@ 
 ruleNotTrue = rule "NotTrue" $
    Not T  :~>  F
-   
+
 -----------------------------------------------------------------------------
 -- False-properties
 
-ruleFalseZeroOr, ruleFalseZeroAnd, ruleComplAnd, ruleNotFalse :: Rule SLogic 
+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
@@ -200,80 +165,74 @@ -----------------------------------------------------------------------------
 -- Double negation
 
-ruleNotNot :: Rule SLogic 
+ruleNotNot :: Rule SLogic
 ruleNotNot = rule "NotNot" $
    \x -> Not (Not x)  :~>  x
-   
+
 -----------------------------------------------------------------------------
 -- De Morgan
 
-ruleDeMorganOr :: Rule SLogic 
+ruleDeMorganOr :: Rule SLogic
 ruleDeMorganOr = rule "DeMorganOr" $
    \x y -> Not (x :||: y)  :~>  Not x :&&: Not y
 
-ruleDeMorganAnd :: Rule SLogic 
+ruleDeMorganAnd :: Rule SLogic
 ruleDeMorganAnd = rule "DeMorganAnd" $
    \x y -> Not (x :&&: y)  :~>  Not x :||: Not y
-   
+
 -----------------------------------------------------------------------------
 -- Implication elimination
 
-ruleDefImpl :: Rule SLogic 
+ruleDefImpl :: Rule SLogic
 ruleDefImpl = rule "DefImpl" $
    \x y -> x :->: y  :~>  Not x :||: y
-   
+
 -----------------------------------------------------------------------------
 -- Equivalence elimination
 
-ruleDefEquiv :: Rule SLogic 
+ruleDefEquiv :: Rule SLogic
 ruleDefEquiv = rule "DefEquiv" $
    \x y -> x :<->: y  :~>  (x :&&: y) :||: (Not x :&&: Not y)
 
 -----------------------------------------------------------------------------
 -- Additional rules, not in the DWA course
 
-groupAdditional :: (Id, [Rule SLogic])
-groupAdditional = makeGroup "Additional rules"
-   [ ruleFalseInEquiv, ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl
-   , ruleCommEquiv, ruleDefEquivImpls, ruleEquivSame, ruleImplSame
-   ]
-
-ruleFalseInEquiv :: Rule SLogic 
+ruleFalseInEquiv :: Rule SLogic
 ruleFalseInEquiv = ruleList "FalseInEquiv"
    [ \x -> F :<->: x  :~>  Not x
    , \x -> x :<->: F  :~>  Not x
    ]
-   
-ruleTrueInEquiv :: Rule SLogic 
+
+ruleTrueInEquiv :: Rule SLogic
 ruleTrueInEquiv = ruleList "TrueInEquiv"
    [ \x -> T :<->: x  :~>  x
    , \x -> x :<->: T  :~>  x
    ]
 
-ruleFalseInImpl :: Rule SLogic 
+ruleFalseInImpl :: Rule SLogic
 ruleFalseInImpl = ruleList "FalseInImpl"
    [ \x -> F :->: x  :~>  T
    , \x -> x :->: F  :~> Not x
    ]
-   
-ruleTrueInImpl :: Rule SLogic 
+
+ruleTrueInImpl :: Rule SLogic
 ruleTrueInImpl = ruleList "TrueInImpl"
    [ \x -> T :->: x  :~>  x
    , \x -> x :->: T  :~>  T
    ]
-        
-ruleCommEquiv :: Rule SLogic 
+
+ruleCommEquiv :: Rule SLogic
 ruleCommEquiv = rule "CommEquiv" $
    \x y -> x :<->: y  :~>  y :<->: x
 
-ruleDefEquivImpls :: Rule SLogic 
+ruleDefEquivImpls :: Rule SLogic
 ruleDefEquivImpls = rule "DefEquivImpls" $
    \x y -> x :<->: y  :~>  (x :->: y) :&&: (y :->: x)
 
-ruleEquivSame :: Rule SLogic 
+ruleEquivSame :: Rule SLogic
 ruleEquivSame = rule "EquivSame" $
    \x -> x :<->: x  :~>  T
 
-ruleImplSame :: Rule SLogic 
+ruleImplSame :: Rule SLogic
 ruleImplSame = rule "ImplSame" $
    \x -> x :->: (x::SLogic)  :~>  T
src/Domain/Logic/Strategies.hs view
@@ -1,103 +1,98 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Prelude hiding (repeat)-import Domain.Logic.Rules-import Domain.Logic.GeneralizedRules-import Domain.Logic.Formula-import Common.Context (Context, liftToContext)-import Common.Transformation-import Common.Strategy-import Common.Navigator---------------------------------------------------------------------------------- To DNF, with priorities (the "DWA" approach)--dnfStrategyDWA :: LabeledStrategy (Context SLogic)-dnfStrategyDWA =  label "Bring to dnf (DWA)" $ -   repeat $ toplevel <|> somewhereOr-      (  label "Simplify"                            simplify-      |> label "Eliminate implications/equivalences" eliminateImplEquiv-      |> label "Eliminate nots"                      eliminateNots-      |> label "Move ors to top"                     orToTop-      )- where-    toplevel = useRules -       [ ruleFalseZeroOr, ruleTrueZeroOr, ruleIdempOr-       , ruleAbsorpOr, ruleComplOr-       ]-    simplify = 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 = repeat $ topDown $ useRules-      [ ruleFalseZeroOr, ruleTrueZeroOr, ruleTrueZeroAnd-      , ruleFalseZeroAnd, ruleNotTrue, ruleNotFalse, ruleFalseInEquiv-      , ruleTrueInEquiv, ruleFalseInImpl, ruleTrueInImpl-      ]-   eliminateImplEquiv = repeat $ bottomUp $ useRules-      [ ruleDefImpl, ruleDefEquiv -      ] -   eliminateNots = repeat $ topDown $ -      useRules-         [ generalRuleDeMorganAnd, generalRuleDeMorganOr ]-      |> useRules-         [ ruleDeMorganAnd, ruleDeMorganOr-         , ruleNotNot-         ]-   orToTop = repeat $ somewhere $  -      liftToContext generalRuleAndOverOr |> -      liftToContext ruleAndOverOr-      --- local helper function-useRules :: [Rule SLogic] -> Strategy (Context SLogic)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,96 +1,100 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 where--import Common.View-import Domain.Logic.Formula----------------------------------------------------------------- Smart constructors--infixr 2 .<->.-infixr 3 .->. -infixr 4 .||. -infixr 5 .&&.--(.<->.) :: 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 = newView "logic.orView" (($ []) . 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 = newView "logic.andView" (($ []) . f) (foldr ((.&&.). Var) T)- where-   f (p :&&: q) = (>>= f p) .  f q-   f (Var a)    = return . (a:)-   f T          = return+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,84 +1,84 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------
+-- 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/Clipboard.hs 
@@ -1,114 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Clipboard -   ( addToClipboard, addListToClipboard-   , lookupClipboard, lookupListClipboard, removeClipboard-     -- generalized interface-   , addToClipboardG, addListToClipboardG-   , lookupClipboardG, lookupListClipboardG-   , maybeOnClipboardG-   ) where--import Common.Context-import Control.Monad-import Common.Rewriting-import Data.Maybe-import Domain.Math.Data.Relation-import Domain.Math.Expr-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 = either (fail . show) (return . toTerm) . parseExpr--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/Data/DecimalFraction.hs view
@@ -0,0 +1,81 @@+{-# 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 view
@@ -1,364 +1,309 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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). @Intervals@--- is a normalized (and sorted) list of intervals that supports testing for--- equality.----------------------------------------------------------------------------------module Domain.Math.Data.Interval-   ( -- Data types-     Intervals, Interval-     -- Interval constructors-   , empty, singleton, unbounded, open, closed-   , leftOpen, rightOpen, greaterThan, greaterThanOrEqualTo-   , lessThan, lessThanOrEqualTo-     -- Inspecing an interval-   , isEmpty, leftPoint, rightPoint, Endpoint(..)-     -- Making intervals-   , except, toList, fromList-   , union, intersect, complement-   , isIn, isInInterval-     -- QuickChecks-   , testMe-   ) where--import Common.TestSuite-import Common.Utils (commaList)-import Control.Monad-import Data.Maybe-import Test.QuickCheck------------------------------------------------------------------------- Data declarations--newtype Intervals a = IS [Interval a]-   deriving Eq--data Interval a = Empty | I (Endpoint a) (Endpoint a)-   deriving Eq--data Endpoint a = Excluding a | Including a | Unbounded-   deriving Eq--instance Show a => Show (Intervals a) where-   show xs = "{ " ++ commaList (map show (toList xs)) ++ " }"--instance Show a => Show (Interval a) where-   show interval =-      case interval of-         Empty -> "{}"-         I 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--instance Functor Interval where-   fmap _ Empty   = Empty-   fmap f (I a b) = I (fmap f a) (fmap f b) -- function should not change order--instance Functor Intervals where-   fmap f (IS xs) = IS (map (fmap f) xs)--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 = Empty--singleton :: Ord a => a -> Interval a-singleton a = closed a 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 =-   case liftM2 compare (getPoint pl) (getPoint pr) of-      Just LT -> I pl pr-      Just EQ-         | isIncluding pl && isIncluding pr -> I pl pr-         | otherwise                        -> Empty-      Just GT -> Empty-      Nothing -> I pl pr--isIncluding :: Endpoint a -> Bool-isIncluding (Including _) = True-isIncluding _             = False--isExcluding :: Endpoint a -> Bool-isExcluding (Excluding _) = True-isExcluding _             = False------------------------------------------------------------------------- Inspecting an interval--isEmpty :: Interval a -> Bool-isEmpty Empty = True-isEmpty _     = False--leftPoint, rightPoint :: Interval a -> Endpoint a-leftPoint  (I a _) = a-leftPoint Empty    = error "leftPoint Empty"-rightPoint (I _ a) = a-rightPoint Empty   = error "rightPoint Empty"------------------------------------------------------------------------- Combining multiple intervals--except :: Ord a => a -> Intervals a-except a = fromList [lessThan a, greaterThan a]--toList :: Intervals a -> [Interval a]-toList (IS xs) = xs--fromList :: Ord a => [Interval a] -> Intervals a-fromList = foldr insert (IS [])--insert :: Ord a => Interval a -> Intervals a -> Intervals a-insert Empty xs  = xs-insert iv@(I l _) (IS xs) = rec xs- where-   rec []        = IS [iv]-   rec (hd:rest) =-      case (hd, merge iv hd) of-         (Empty, _)       -> rec rest-         (_, Just new)    -> insert new (IS rest)-         (I a _, Nothing)-            | minPointLeft a l == a -> let IS tl = rec rest in IS (hd:tl)-            | otherwise             -> IS (iv:hd:rest)--union :: Ord a => Intervals a -> Intervals a -> Intervals a-union xs = foldr insert xs . toList--intersect :: Ord a => Intervals a -> Intervals a -> Intervals a-intersect (IS xs) (IS ys) = fromList (f xs ys)- where-   f (a@(I _ ar):as) (b@(I _ br):bs) = inBoth a b : rest-    where-      rest | maxPointRight ar br == ar = f (a:as) bs-           | otherwise                 = f as (b:bs)-   f _ _ = []--complement :: Ord a => Intervals a -> Intervals a-complement (IS xs) = fromList (left ++ zipWith f xs (drop 1 xs) ++ right)- where-   f (I _ a) (I b _) = fromMaybe Empty (liftM2 I (g a) (g b))-   f _ _             = Empty-   -   g (Including a) = Just (Excluding a)-   g (Excluding a) = Just (Including a)-   g Unbounded     = Nothing-   -   left = case xs of -             I al _:_ -> maybe [] (return . I Unbounded) (g al)-             _        -> [unbounded]-   right = case reverse xs of -              I _ ar:_ -> maybe [] (return . flip I Unbounded) (g ar)-              _        -> [unbounded]--isIn :: Ord a => a -> Intervals a -> Bool-isIn a (IS xs) = any (isInInterval a) xs--isInInterval :: Ord a => a -> Interval a -> Bool-isInInterval _ Empty   = False-isInInterval a (I x y) = f GT x && f LT y- where-   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 => Interval a -> Interval a -> Maybe (Interval a)-merge a Empty = Just a-merge Empty b = Just b-merge ia@(I al ar) ib@(I bl br)-   | minPointLeft al bl /= al = merge ib ia-   | otherwise = -        case liftM2 compare (getPoint ar) (getPoint bl) of-           Just LT -> Nothing-           Just EQ-              | isIncluding ar || isIncluding bl -> ok-              | otherwise     -> Nothing-           Just GT -> ok-           Nothing -> ok- where-   ok = Just (I al (maxPointRight ar br))--inBoth :: Ord a => Interval a -> Interval a -> Interval a-inBoth _ Empty = Empty-inBoth Empty _ = Empty-inBoth (I al ar) (I bl br) = makeInterval (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 = frequency -      [ (1, return Empty)-      , (5, liftM2 makeInterval arbitrary arbitrary)-      ]-instance (CoArbitrary a, Ord a) => CoArbitrary (Interval a) where-   coarbitrary Empty   = variant (0 :: Int)-   coarbitrary (I a b) = variant (1 :: Int) . coarbitrary a . coarbitrary b-   -instance (Arbitrary a, Ord a) => Arbitrary (Intervals a) where-   arbitrary = do-      n  <- choose (0, 100)-      xs <- replicateM n arbitrary-      return (fromList xs)-instance (CoArbitrary a, Ord a) => CoArbitrary (Intervals a) where-   coarbitrary (IS 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 "singleton"                $ op1 singleton (==)-   -     addProperty "open"       $ op2 open      (<)  (<)-     addProperty "closed"     $ op2 closed    (<=) (<=)-     addProperty "left open"  $ op2 leftOpen  (<)  (<=)-     addProperty "right open" $ op2 rightOpen (<=) (<)-   -   suite "From/to lists" $ do-      addProperty "" fromTo1-      addProperty "" fromTo2-   -   suite "Combinators" $ do-      addProperty "except"     defExcept-      addProperty "union"      defUnion-      addProperty "intersect"  defIntersect-      addProperty "complement" defComplement-   -   suite "Combinator properties" $ do-      addProperty "inverse complement"    $ selfInverse complement-      addProperty "transitive union"      $ transitive  union-      addProperty "commutative union"     $ commutative union-      addProperty "absorption union"      $ absorption  union-      addProperty "transitive intersect"  $ transitive  intersect-      addProperty "commutative intersect" $ commutative intersect-      addProperty "absorption intersect"  $ absorption  intersect--fromTo1, fromTo2 :: Intervals Int -> Bool-fromTo1 a = fromList (toList a) == a-fromTo2 a = fromList (reverse (toList a)) == a--defExcept :: Int -> Int -> Bool-defExcept a b = isIn a (except b) == (a/=b)--defUnion, defIntersect :: Int -> Intervals Int -> Intervals 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 -> Intervals Int -> Bool-defComplement a b = isIn a (complement b) == not (isIn a b)--op0 :: Interval Int -> (Int -> Bool) -> Int -> Bool-op0 g p a = isInInterval a g == p a--op1 :: (Int -> Interval Int) -> (Int -> Int -> Bool) -> Int -> Int -> Bool-op1 g op a b = isInInterval 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 = isInInterval a (g b c) == (b `opl` a && a `opr` c)--transitive :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Intervals Int -> Intervals Int -> Bool-transitive op a b c = op a (op b c) == op (op a b) c--commutative :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Intervals Int -> Bool-commutative op a b = op a b == op b a--absorption :: (Intervals Int -> Intervals Int -> Intervals Int) -> Intervals Int -> Bool-absorption op a = op a a == a--selfInverse :: (Intervals Int -> Intervals Int) -> Intervals Int -> Bool-selfInverse op a = op (op a) == a+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,52 @@+{-# 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 view
@@ -1,138 +1,146 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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-   , orList, (\/), true, false-   , isTrue, isFalse-   , disjunctions, normalize, idempotent, fromBool-   , oneDisjunct, orListView-   ) where--import Common.View-import Control.Monad-import Common.Classes-import Common.Rewriting-import qualified Domain.Logic.Formula as Logic-import Domain.Logic.Formula (Logic((:||:)))-import Test.QuickCheck-import Data.List (intersperse, nub, sort)----------------------------------------------------------------- Data type--data OrList a = T | OrList [a] -   deriving (Ord, Eq)----------------------------------------------------------------- Functions--orList :: [a] -> OrList a-orList = OrList--true, false :: OrList a-true  = T-false = OrList []--isTrue :: OrList a -> Bool-isTrue T = Prelude.True-isTrue _ = False--isFalse :: OrList a -> Bool-isFalse (OrList []) = True-isFalse _           = False--disjunctions :: OrList a -> Maybe [a]-disjunctions T           = Nothing-disjunctions (OrList xs) = Just xs--(\/) :: OrList a -> OrList a -> OrList a-p \/ q = maybe T orList (liftM2 (++) (disjunctions p) (disjunctions q))---- | Sort the propositions and remove duplicates-normalize :: Ord a => OrList a -> OrList a-normalize T           = T-normalize (OrList xs) = OrList (nub $ sort xs)---- | Remove duplicates-idempotent :: Eq a => OrList a -> OrList a-idempotent T           = T-idempotent (OrList xs) = OrList (nub xs)--oneDisjunct :: Monad m => (a -> m (OrList a)) -> OrList a -> m (OrList a)-oneDisjunct f xs = -   case disjunctions xs of -      Just [a] -> f a-      _ -> fail "oneDisjunct"--fromBool :: Bool -> OrList a-fromBool b = if b then true else false----------------------------------------------------------------- Instances---- local helper-joinOr :: OrList (OrList a) -> OrList a-joinOr = maybe T (foldr (\/) false) . disjunctions--instance Rewrite a => Rewrite (OrList a)--instance Functor OrList where-   fmap _ T           = T-   fmap f (OrList xs) = OrList (map f xs)--instance Monad OrList where-   return  = OrList . return-   m >>= f = joinOr (fmap f m)--instance Switch OrList where-   switch T           = return T-   switch (OrList xs) = liftM orList (sequence xs)--instance Crush OrList where-   crush T           = []-   crush (OrList xs) = xs--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 (OrList xs)-instance CoArbitrary a => CoArbitrary (OrList a) where-   coarbitrary T           = variant (0 :: Int)-   coarbitrary (OrList xs) = variant (1 :: Int) . coarbitrary xs--instance Show a => Show (OrList a) where-   show T = "true"-   show (OrList xs) -      | null xs   = "false"-      | otherwise = unwords (intersperse "or" (map show xs))----------------------------------------------------------------- View to the logic data type- -orListView :: View (Logic a) (OrList a)-orListView = makeView f g - where-   f p  = case p of-             Logic.Var a -> return (return a)-             Logic.T     -> return true-             Logic.F     -> return false-             a :||: b    -> liftM2 (\/) (f a) (f b)-             _           -> Nothing-   g xs = case disjunctions xs of-             Nothing -> Logic.T-             Just [] -> Logic.F-             Just ys -> foldr1 (:||:) (map Logic.Var ys)+{-# 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 view
@@ -1,216 +1,253 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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, power, scale-   , degree, lowestDegree, coefficient, terms-   , isMonic, toMonic, isRoot, positiveRoots, negativeRoots-   , derivative, eval, division, longDivision, polynomialGCD-   , factorize-   ) where--import qualified Data.IntMap as IM-import qualified Data.IntSet as IS-import Data.Char-import Control.Monad-import Common.Classes-import Data.List  (nub)-import Data.Ratio (approxRational)-import Domain.Math.Approximation (newton, within)---- Invariants: all keys are non-negative, all values are non-zero-newtype Polynomial a = P (IM.IntMap a) deriving Eq--instance Num a => Show (Polynomial a) where-   show (P m) = -      let 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-      in "f(x) = " ++ -         if IM.null m then "0" else -             fix (concatMap f (reverse (IM.toList m)))---- the Functor instance does not maintain the invariant-instance Functor Polynomial where-   fmap f (P m) = P (IM.map f m)--instance Switch Polynomial where-   switch (P m) = liftM P (switch m)--instance Num a => Num (Polynomial a) where-   P m1 + P m2   = P (IM.filter (/= 0) (IM.unionWith (+) m1 m2))-   p    * P m2   = IM.foldWithKey op 0 m2-    where op n a m = raise n (scale a p) + m-   negate         = fmap negate-   fromInteger n-      | n == 0    = P IM.empty-      | otherwise = P (IM.singleton 0 (fromInteger n))-   -- not defined for polynomials-   abs    = error "abs not defined for polynomials"-   signum = error "signum not defined for polynomials"---- a single variable (such as "x") -var :: Num a => Polynomial a-var = P (IM.singleton 1 1)--con :: a -> Polynomial a-con = P . IM.singleton 0---- | Raise all powers by a constant (discarding negative exponents)-raise :: Int -> Polynomial a -> Polynomial a-raise i p@(P m)-   | i > 0     = P $ IM.fromAscList [ (n+i, a) | (n, a) <- IM.toList m ]-   | i == 0    = p-   | otherwise = P $ IM.fromAscList [ (n+i, a) | (n, a) <- IM.toList m, n+i>=0 ]- -power :: Num a => Polynomial a -> Int -> Polynomial a-power _ 0 = 1-power p n = p * power p (n-1)--scale :: Num a => a -> Polynomial a -> Polynomial a-scale a p = if a==0 then 0 else fmap (*a) p----------------------------------------------------degree :: Polynomial a -> Int-degree (P m)-   | IS.null is = 0-   | otherwise  = IS.findMax is- where is = IM.keysSet m--lowestDegree :: Polynomial a -> Int-lowestDegree (P m)-   | IS.null is = 0-   | otherwise  = IS.findMin is- where is = IM.keysSet m---coefficient :: Num a => Int -> Polynomial a -> a-coefficient n (P m) = IM.findWithDefault 0 n m--terms :: Polynomial a -> [(a, Int)]-terms (P m) = [ (a, n) | (n, a) <- IM.toList m ]--isMonic :: Num a => Polynomial a -> Bool-isMonic p = coefficient (degree p) p == 1--toMonic :: Fractional a => Polynomial a -> Polynomial a-toMonic p = scale (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 (P m) = signChanges (IM.elems m)---- Returns the maximal number of negative roots (Descartes theorem)--- Multiple roots are counted separately-negativeRoots :: Num a => Polynomial a -> Int-negativeRoots (P m) = signChanges (flipOdd (IM.elems m))- 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 m) = P $ IM.fromAscList -   [ (n-1, fromIntegral n*a) | (n, a) <- IM.toList m, n > 0 ]--eval :: Num a => Polynomial a -> a -> a-eval (P m) x = sum [ a * x^n | (n, a) <- IM.toList m ] ---- polynomial division, no remainder-division :: Fractional a => Polynomial a -> Polynomial a -> Maybe (Polynomial a)-division p1 p2-   | degree p1 < degree p2 = Nothing-   | b==0      = return a-   | otherwise = Nothing - where -   (a, b) = longDivision p1 p2---- polynomial long division-longDivision :: Fractional a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a)-longDivision p1 p2 = monicLongDivision (scale (recip a) p1) (scale (recip a) p2)- where 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 = P . IM.filter (/= 0) . 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         = power 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 <- [division 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]+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,176 +1,173 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 qualified Data.IntMap as IM-import Common.Utils-import Control.Monad-import Data.Maybe------------------------------------------------------------------ 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)-   a - b             = a + negate 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)--greatestPower :: Integer -> Maybe (Integer, Integer)-greatestPower n = do-  guard $ n > 1-  let (as, xs) = unzip $ factors $ fromInteger n-  x <- safeHead xs-  guard $ allsame xs && x > 1-  return (fromIntegral (product as), fromIntegral x)---- 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 "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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,9 +11,9 @@ -- Mathematical relations
 --
 -----------------------------------------------------------------------------
-module Domain.Math.Data.Relation 
+module Domain.Math.Data.Relation
    ( -- * Type class
-     Relational(..), mapLeft, mapRight, updateLeft, updateRight
+     Relational(..)
      -- * Relation data type
    , Relation, relationType, RelationType(..), relationSymbols
    , notRelation, eval
@@ -25,14 +25,16 @@    , Inequality(..), inequalityView
    ) where
 
-import Common.View
 import Common.Rewriting
-import Common.Classes
-import Domain.Math.Expr.Symbols (openMathSymbol)
-import Text.OpenMath.Dictionary.Relation1
+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 Control.Monad
+import Text.OpenMath.Dictionary.Relation1
 
 -----------------------------------------------------------------------------
 -- Type class for relations
@@ -40,20 +42,12 @@ class Functor f => Relational f where
    leftHandSide  :: f a -> a
    rightHandSide :: f a -> a
-   flipSides     :: f a -> f a -- possibly also flips operator 
+   flipSides     :: f a -> f a -- possibly also flips operator
    constructor   :: f a -> b -> b -> f b
    isSymmetric   :: f a -> Bool
    -- default definitions
    isSymmetric _ = False
 
-mapLeft, mapRight :: Relational f => (a -> a) -> f a -> f a
-mapLeft  f p = updateLeft  (f (leftHandSide p))  p
-mapRight f p = updateRight (f (rightHandSide p)) p
-
-updateLeft, updateRight :: Relational f => a -> f a -> f a
-updateLeft  a p = constructor p a (rightHandSide p)
-updateRight a p = constructor p (leftHandSide p) a
-
 -----------------------------------------------------------------------------
 -- Relation data type
 
@@ -61,7 +55,7 @@    deriving (Eq, Ord)
 
 -- Corresponds exactly to the symbols in the relation1 OpenMath dictionary
-data RelationType = EqualTo | NotEqualTo | LessThan | GreaterThan 
+data RelationType = EqualTo | NotEqualTo | LessThan | GreaterThan
                   | LessThanOrEqualTo | GreaterThanOrEqualTo | Approximately
    deriving (Show, Eq, Ord, Enum)
 
@@ -71,6 +65,12 @@ 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
@@ -79,11 +79,11 @@    isSymmetric = (`elem` [EqualTo, NotEqualTo, Approximately]) . relationType
 
 instance IsTerm a => IsTerm (Relation a) where
-   toTerm p = 
+   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 = 
+   fromTerm term =
       case getFunction term of
          Just (s, [a, b]) ->
             case [ rt | (rt, (_, t)) <- relationSymbols, s==t ] of
@@ -91,17 +91,15 @@                _    -> fail "fromTerm: relation"
          _ -> fail "fromTerm: relation"
 
-instance Rewrite a => Rewrite (Relation a)
-
 relationSymbols :: [(RelationType, (String, Symbol))]
 relationSymbols =
-   [ (EqualTo,              ("==", openMathSymbol eqSymbol))
-   , (NotEqualTo,           ("/=", openMathSymbol neqSymbol))
-   , (LessThan,             ("<",  openMathSymbol ltSymbol))
-   , (GreaterThan,          (">",  openMathSymbol gtSymbol))
-   , (LessThanOrEqualTo,    ("<=", openMathSymbol leqSymbol))
-   , (GreaterThanOrEqualTo, (">=", openMathSymbol geqSymbol))
-   , (Approximately,        ("~=", openMathSymbol approxSymbol))
+   [ (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
@@ -111,10 +109,10 @@    swap (x, y) = (y, x)
    xs = [ (EqualTo, NotEqualTo)
         , (LessThan, GreaterThanOrEqualTo)
-        , (LessThanOrEqualTo, GreaterThan) 
+        , (LessThanOrEqualTo, GreaterThan)
         ]
 
-eval :: Ord a => RelationType -> a -> a -> Bool
+eval :: (Ord a, Num a) => RelationType -> a -> a -> Bool
 eval relType =
    case relType of
       EqualTo              -> (==)
@@ -123,9 +121,9 @@       GreaterThan          -> (>)
       LessThanOrEqualTo    -> (<=)
       GreaterThanOrEqualTo -> (>=)
-      Approximately        -> (==)
+      Approximately        -> \a b -> 1000 * abs (a-b) < 1
 
--- helpers   
+-- helpers
 showRelType :: RelationType -> String
 showRelType = fst . (? relationSymbols)
 
@@ -138,29 +136,24 @@ (?) :: Eq a => a -> [(a, b)] -> b
 a ? xs = fromMaybe (error "Relation: Error in lookup") (lookup a xs)
 
------------------------------------------------------------------------------
--- Traversable instance declarations
-
-instance Switch Relation where switch = switchRelation
-instance Crush  Relation where crush  = crushRelation
+foldMapRelation :: (Relational f, Monoid m) => (a -> m) -> f a -> m
+foldMapRelation f p = f (leftHandSide p) `mappend` f (rightHandSide p)
 
-switchRelation :: (Relational f, Monad m) => f (m a) -> m (f a)
-switchRelation p =
-   liftM2 (constructor p) (leftHandSide p) (rightHandSide p)
-            
-crushRelation :: Relational f => f a -> [a]
-crushRelation p = [leftHandSide p, 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 (crush p)
-   
+   coarbitrary p = coarbitrary (relationType p) . coarbitrary (toList p)
+
 instance Arbitrary RelationType where
-   arbitrary = oneof $ map return [EqualTo .. Approximately]
+   arbitrary = elements [EqualTo .. Approximately]
+
 instance CoArbitrary RelationType where
    coarbitrary op = variant (fromEnum op)
 
@@ -172,8 +165,8 @@ (.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.) :: a -> a -> Relation a
 (.==.) = makeType EqualTo
 (./=.) = makeType NotEqualTo
-(.<.)  = makeType LessThan 
-(.>.)  = makeType GreaterThan 
+(.<.)  = makeType LessThan
+(.>.)  = makeType GreaterThan
 (.<=.) = makeType LessThanOrEqualTo
 (.>=.) = makeType GreaterThanOrEqualTo
 (.~=.) = makeType Approximately
@@ -197,21 +190,22 @@ instance Functor Equation where
    fmap f (x :==: y) = f x :==: f y
 
-instance Zip Equation where
-   fzipWith f (a :==: b) (c :==: d) = f a c :==: f b d
+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
+   flipSides (x :==: y) = y :==: x
    constructor   = const (:==:)
    isSymmetric   = const True
 
-instance Switch Equation where switch = switchRelation
-instance Crush  Equation where crush  = crushRelation
-
 instance Arbitrary a => Arbitrary (Equation a) where
    arbitrary   = liftM2 (:==:) arbitrary arbitrary
+
 instance CoArbitrary a => CoArbitrary (Equation a) where
    coarbitrary = coarbitrary . build equationView
 
@@ -219,8 +213,6 @@    toTerm = toTerm . build equationView
    fromTerm a = fromTerm a >>= matchM equationView
 
-instance Rewrite a => Rewrite (Equation a)
-
 equationView :: View (Relation a) (Equation a)
 equationView = makeView f g
  where
@@ -233,34 +225,38 @@ -- 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 = 
+   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 = fromMaybe (error "inequality: flipSides") . matchM inequalityView
              . flipSides . build inequalityView
-   constructor ineq = 
+   constructor ineq =
       let relType = relationType (build inequalityView ineq)
       in fst (relType ? inequalityTable)
 
-instance Switch Inequality where switch = switchRelation
-instance Crush  Inequality where crush  = crushRelation
-
 instance Arbitrary a => Arbitrary (Inequality a) where
-   arbitrary = do 
-      op <- oneof $ map (return . fst . snd) inequalityTable
+   arbitrary = do
+      op <- elements $ map (fst . snd) inequalityTable
       liftM2 op arbitrary arbitrary
+
 instance CoArbitrary a => CoArbitrary (Inequality a) where
    coarbitrary = coarbitrary . build inequalityView
 
@@ -268,21 +264,19 @@    toTerm = toTerm . build inequalityView
    fromTerm a = fromTerm a >>= matchM inequalityView
 
-instance Rewrite a => Rewrite (Inequality a)
-
 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 
+      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 = 
+inequalityTable =
    [ (LessThan, ((:<:), (.<.))), (LessThanOrEqualTo, ((:<=:), (.<=.)))
    , (GreaterThan, ((:>:), (.>.))), (GreaterThanOrEqualTo, ((:>=:), (.>=.)))
    ]
src/Domain/Math/Data/SquareRoot.hs view
@@ -1,177 +1,190 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Prelude hiding (sqrt)-import Data.Ratio-import qualified Domain.Math.Data.PrimeFactors as P-import qualified Data.Map as M-import qualified Prelude-import Control.Monad------------------------------------------------------------------ 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 "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 => Fractional (SquareRoot a) where-   recip (S b m) = S b (recipSqMap m)-   fromRational  = con . fromRational------------------------------------------------------------------ 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,66 @@+{-# 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 view
@@ -0,0 +1,168 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,24 +9,25 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.Math.Derivative.Exercises 
+module Domain.Math.Derivative.Exercises
    ( derivativeExercise, derivativePolyExercise
    , derivativeProductExercise, derivativeQuotientExercise
    , derivativePowerExercise
    ) where
 
 import Common.Library
-import Common.Uniplate
+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.Examples.DWO5
 import Domain.Math.Expr
 import Domain.Math.Numeric.Views
-import Domain.Math.Polynomial.CleanUp
 import Domain.Math.Polynomial.Generators
 import Domain.Math.Polynomial.RationalExercises
 import Domain.Math.Polynomial.Views
@@ -41,69 +42,70 @@    { exerciseId    = diffId # "polynomial"
    , status        = Provisional
    , parser        = parseExpr
-   , isReady       = (`belongsTo` polyNormalForm rationalView)
-   , isSuitable    = isPolyDiff
-   , equivalence   = eqPolyDiff
-   , similarity    = simPolyDiff
+   , ready         = predicateView (polyNormalForm rationalView)
+   , suitable      = predicate isPolyDiff
+   , equivalence   = withoutContext eqPolyDiff
+   , similarity    = withoutContext (viewEquivalent cleanUpACView)
    , strategy      = derivativePolyStrategy
    , navigation    = navigator
-   , examples      = concat (diffSet1 ++ diffSet2 ++ diffSet3)
-   , testGenerator = Just $ liftM (diff . lambda (Var "x")) $ 
+   , 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." $ 
+   \the parentheses in your answer." $
    derivativePolyExercise
    { exerciseId    = diffId # "product"
-   , isReady       = noDiff
+   , ready         = predicate noDiff
    , strategy      = derivativeProductStrategy
-   , examples      = concat diffSet3
+   , 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." $ 
+   \remove parentheses in the numerator." $
    derivativePolyExercise
    { exerciseId    = diffId # "quotient"
-   , isReady       = readyQuotientDiff
-   , isSuitable    = isQuotientDiff
-   , equivalence   = eqQuotientDiff
+   , ready         = predicate readyQuotientDiff
+   , suitable      = predicate isQuotientDiff
+   , equivalence   = withoutContext eqQuotientDiff
    , strategy      = derivativeQuotientStrategy
    , ruleOrdering  = ruleOrderingWithId [ruleDerivQuotient]
-   , examples      = concat diffSet4
+   , 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." $ 
+   \rational exponents." $
    derivativePolyExercise
    { exerciseId    = diffId # "power"
    , status        = Experimental
-   , isReady       = \a -> noDiff a && onlyNatPower a
-   , isSuitable    = const True
+   , ready         = predicate noDiff <&&> predicate onlyNatPower
+   -- , isSuitable    = const True
    , equivalence   = \_ _ -> True -- \x y -> eqApprox (evalDiff x) (evalDiff y)
    , strategy      = derivativePowerStrategy
-   , examples      = concat (diffSet5 ++ diffSet6)
+   , examples      = level Medium $ concat (diffSet5 ++ diffSet6)
    , testGenerator = Nothing
    }
 
 derivativeExercise :: Exercise Expr
 derivativeExercise = makeExercise
    { exerciseId   = describe "Derivative" diffId
-   , status       = Experimental
+   , status       = Provisional
    , parser       = parseExpr
-   , isReady      = noDiff
+   , ready        = predicate noDiff
    , strategy     = derivativeStrategy
    , ruleOrdering = derivativeOrdering
+   , equivalence   = withoutContext eqQuotientDiff
    , navigation   = navigator
-   , examples     = concat (diffSet3++diffSet4++
-                            diffSet5++diffSet6++diffSet7++diffSet8)
+   , examples     = level Medium $ concat $ diffSet3++diffSet4++diffSet5
+                            {- diffSet6 -- ++diffSet7++diffSet8 -}
    }
 
 derivativeOrdering :: Rule a -> Rule a -> Ordering
@@ -126,20 +128,10 @@    return (all isp ys)
 
 eqPolyDiff :: Expr -> Expr -> Bool
-eqPolyDiff x y = 
-   let f a = fromMaybe (descend f a) (apply ruleDerivPolynomial a)
-   in viewEquivalent (polyViewWith rationalView) (f x) (f y)
+eqPolyDiff = viewEquivalent (polyViewWith rationalView) `on` evalDiff
 
 eqQuotientDiff :: Expr -> Expr -> Bool
-eqQuotientDiff a b = eqSimplifyRational (make a) (make b)
- where
-   make = inContext derivativeQuotientExercise . f
-   rs   = [ ruleDerivPolynomial, ruleDerivQuotient, ruleDerivProduct
-          , ruleDerivNegate, ruleDerivPlus, ruleDerivMin
-          ]
-   f x  = case mapMaybe (`apply` x) rs of
-             hd:_ -> f hd
-             []   -> descend f x
+eqQuotientDiff = eqSimplifyRational `on` (cleanUpExpr . evalDiff)
 
 readyQuotientDiff :: Expr -> Bool
 readyQuotientDiff expr = fromMaybe False $ do
@@ -150,70 +142,39 @@        nfp = (`belongsTo` polyNormalForm rationalView)
    return (all nfp ys && all isp zs)
 
-simPolyDiff :: Expr -> Expr -> Bool
-simPolyDiff x y =
-   let f = acExpr . cleanUpExpr
-   in f x == f y
-
 noDiff :: Expr -> Bool
-noDiff e = null [ () | Sym s _ <- universe e, isDiffSymbol s ]   
+noDiff e = all (not . isDiffSymbol) [ s | Sym s _ <- universe e]
 
 onlyNatPower :: Expr -> Bool
-onlyNatPower e = and [ isNat a | Sym s [_, a] <- universe e, isPowerSymbol s ]
+onlyNatPower e = all isNat [ a | Sym s [_, a] <- universe e, isPowerSymbol s ]
  where
    isNat (Nat _) = True
    isNat _       = False
 
-{-
 evalDiff :: Expr -> Expr
-evalDiff expr
-   | isDiff expr = 
-        case concatMap (`applyAll` expr) list of
-           hd:_ -> evalDiff hd 
-           _    -> expr
-   | otherwise = descend evalDiff expr
- where
-   list = [ ruleDerivPolynomial, ruleDerivPowerFactor
-          , ruleDerivPlus, ruleDerivMin, ruleDerivNegate
-          , ruleDerivProduct, ruleDerivQuotient
-          , ruleDerivPowerChain, ruleDerivSqrtChain, ruleDerivRoot
-          ]
-
-go = checkExercise derivativePowerExercise
-
-raar i = printDerivation derivativePowerExercise expr
- where 
-   expr = examples derivativePowerExercise !! i
-
-eqApprox :: Expr -> Expr -> Bool
-eqApprox a b = rec 5 doubleList
+evalDiff da =
+   case da of
+      Sym d [Sym l [Var x, expr]] | isDiffSymbol d && isLambdaSymbol l ->
+         cleanUpExpr (rec x expr)
+      _ -> descend evalDiff da
  where
-   vs = nub (collectVars a ++ collectVars b)
- 
-   rec 0 = const True
-   rec n = rec2 n 10
-    
-   rec2 _ 0 ds = undefined -- a==b
-   rec2 n m ds = case eqApproxWith f a b of  
-                    Just b  -> b && rec (n-1) ys 
-                    Nothing -> rec2 n (m-1) ys
+   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
-      (xs, ys) = splitAt (length vs) ds
-      f = (xs !!) . fromMaybe 0 . (`elemIndex` vs)
-
-eqApproxWith :: (String -> Double) -> Expr -> Expr -> Maybe Bool
-eqApproxWith f a b = do
-   d1 <- match doubleView (subst a)
-   d2 <- match doubleView (subst b)
-   return $ abs (d1 - d2) < 1e-9 -- 11 is still ok for example set
- where 
-    subst (Var s) = Number (f s)
-    subst expr    = descend subst expr
-    
-doubleList :: [Double] -- between -20 and 20
-doubleList = iterate next (pi*exp 1)
-  where   
-    next :: Double -> Double
-    next a = if b > 20 then b-20 else b 
-     where
-       b = a + exp 3 * log 2 -}
+      diffExpr = diff (lambda x expr)
src/Domain/Math/Derivative/Rules.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,25 +11,20 @@ -----------------------------------------------------------------------------
 module Domain.Math.Derivative.Rules where
 
-import Prelude hiding ((^))
-import Common.Transformation
-import Common.View
+import Common.Library hiding (root)
 import Control.Monad
-import Domain.Math.Expr
-import Common.Id
-import Common.Rewriting
 import Data.Maybe
-import Domain.Math.Polynomial.Views
-import Domain.Math.Numeric.Views
 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 Domain.Math.Power.Utils ( (<&>) )
-
+import Prelude hiding ((^))
 
 derivativeRules :: [Rule Expr]
 derivativeRules =
    [ ruleDerivCon, ruleDerivPlus, ruleDerivMin, ruleDerivNegate
-   , ruleDerivMultiple, ruleDerivPower, ruleDerivVar 
+   , ruleDerivMultiple, ruleDerivPower, ruleDerivVar
    , ruleDerivProduct, ruleDerivQuotient, ruleDerivPowerChain
    , ruleSine, ruleLog, ruleDerivSqrt, ruleDerivSqrtChain
    ]
@@ -40,8 +35,8 @@ ln :: Expr -> Expr
 ln = unary lnSymbol
 
-lambda :: Expr -> Expr -> Expr
-lambda = binary lambdaSymbol
+lambda :: String -> Expr -> Expr
+lambda = binary lambdaSymbol . Var
 
 diffId :: Id
 diffId = newId "calculus.differentiation"
@@ -54,13 +49,13 @@ -- Rules for Diffs
 
 ruleSine :: Rule Expr
-ruleSine = rule (diffId, "sine") $ 
-   \x -> diff (lambda x (sin x))  :~>  cos x
+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 x))  :~>  1/x
-       
+   \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)
@@ -75,7 +70,7 @@ 
 ruleDerivVar :: Rule Expr
 ruleDerivVar = rule (diffId, "var") $
-   \x -> diff (lambda x x)  :~>  1
+   \x -> diff (lambda x (Var x))  :~>  1
 
 ruleDerivProduct :: Rule Expr
 ruleDerivProduct = rule (diffId, "product") $
@@ -85,7 +80,7 @@ -- 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") 
+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)
    ]
@@ -93,7 +88,7 @@ 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." $ 
+   \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
@@ -102,60 +97,60 @@       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 v, e]]) 
-      | isDiffSymbol d && isLambdaSymbol l && withoutVar v e = return 0
+ 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 [x@(Var v), n :*: e]]) 
-       | isDiffSymbol d && isLambdaSymbol l && withoutVar v n = 
+ 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 [x@(Var v), e :*: n]]) 
-       | isDiffSymbol d && isLambdaSymbol l && withoutVar v n = 
+    f (Sym d [Sym l [Var x, e :*: n]])
+       | isDiffSymbol d && isLambdaSymbol l && withoutVar x n =
        return $ n * diff (lambda x e)
-    f _ = Nothing 
+    f _ = Nothing
 
 ruleDerivPower :: Rule Expr
 ruleDerivPower = makeSimpleRule (diffId, "power") f
- where 
-   f (Sym d [Sym l [x@(Var v), Sym p [x1, n]]]) 
-      | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && x==x1 && withoutVar v n =
-      return $ n * (x ^ (n-1)) 
+ 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 [x@(Var v), Sym p [a, n]]]) 
-      | isDiffSymbol d && isLambdaSymbol l && isPowerSymbol p && withoutVar v n =
+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 [x@(Var _), Sqrt x1]]) 
-      | isDiffSymbol d && isLambdaSymbol l && x==x1 =
-      return $ 1 / (2 * sqrt x) 
-   f _ = Nothing 
-   
+   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 [x@(Var _), Sqrt a]]) 
+   f (Sym d [Sym l [Var x, Sqrt a]])
       | isDiffSymbol d && isLambdaSymbol l =
       return $ (1 / (2 * sqrt a)) * diff (lambda x a)
-   f _ = Nothing 
-   
+   f _ = Nothing
+
 ruleDefRoot :: Rule Expr
 ruleDefRoot = rule (diffId, "def-root") $
    \a b -> root a b :~> a ^ (1/b)
@@ -163,20 +158,20 @@ 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
-   (up, c) <- match divView expr
-   (a, b)  <- match plusView up
+   (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
@@ -192,19 +187,16 @@                Nothing -> do
                   (x, r) <- match powView expr
                   return (1, x, r)
-   g (a, x, r) = a .*. (Var x .^. fromRational r) 
-  
-   powView = (powerView <&> noPowerView) >>> myVarView *** rationalView
-   myVarView   = makeView isVar Var
+   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)
-   
-   isVar (Var x) = Just x
-   isVar _       = Nothing
-   
+
 isDiff :: Expr -> Bool
 isDiff = isJust . getDiffExpr
 
 getDiffExpr :: Expr -> Maybe Expr
-getDiffExpr (Sym d [Sym l [Var _, expr]]) | 
+getDiffExpr (Sym d [Sym l [Var _, expr]]) |
    isDiffSymbol d && isLambdaSymbol l = Just expr
 getDiffExpr _ = Nothing
src/Domain/Math/Derivative/Strategies.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,7 +9,7 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.Math.Derivative.Strategies 
+module Domain.Math.Derivative.Strategies
    ( derivativeStrategy, derivativePolyStrategy
    , derivativeProductStrategy, derivativeQuotientStrategy
    , derivativePowerStrategy, getDiffExpr
@@ -17,20 +17,20 @@ 
 import Common.Library
 import Data.Maybe
-import Domain.Math.Derivative.Rules 
+import Domain.Math.CleanUp
+import Domain.Math.Derivative.Rules
 import Domain.Math.Expr
-import Domain.Math.Polynomial.CleanUp
-import Domain.Math.Polynomial.Views
-import Domain.Math.Polynomial.Rules
 import Domain.Math.Numeric.Views
-import Domain.Math.Power.Strategies
+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 = cleanUpStrategy (applyTop cleanUpExpr) $
-   label "Derivative" $ repeatS $ somewhere $ 
+derivativeStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
+   label "Derivative" $ repeatS $ somewhere $
       alternatives (map liftToContext derivativeRules)
       <|> derivativePolyStepStrategy
       <|> check isDiffC <*> once (once (liftToContext ruleDefRoot))
@@ -38,44 +38,46 @@    isDiffC = maybe False isDiff . current
 
 derivativePolyStrategy :: LabeledStrategy (Context Expr)
-derivativePolyStrategy = cleanUpStrategy (applyTop cleanUpExpr) $
+derivativePolyStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
    label "derivative-polynomial" $
-      repeatS (somewhere (alternatives (map liftToContext rulesPolyNF)))
+      repeatS (somewhere (alternatives rulesPolyNF))
       <*> derivativePolyStepStrategy
 
-rulesPolyNF :: [Rule Expr]
+rulesPolyNF :: [Rule (Context Expr)]
 rulesPolyNF =
+   distributeDivisionMulti :
+   map liftToContext
    [ distributionSquare, distributeTimes, merge
-   , distributeDivision, noDivisionConstant
+   , noDivisionConstant
    ]
 
 derivativeProductStrategy :: LabeledStrategy (Context Expr)
-derivativeProductStrategy = cleanUpStrategy (applyTop cleanUpExpr) $
+derivativeProductStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
    label "derivative-product" $
       repeatS (somewhere (derivativePolyStepStrategy |> alternatives list))
  where
-   list = map liftToContext
-      [ distributeDivision, noDivisionConstant
+   list = distributeDivisionMulti : map liftToContext
+      [ noDivisionConstant
       , ruleDerivProduct, defPowerNat
       , ruleDerivNegate, ruleDerivPlus, ruleDerivMin
       ]
 
 derivativeQuotientStrategy :: LabeledStrategy (Context Expr)
-derivativeQuotientStrategy = cleanUpStrategy (applyTop cleanUpExpr) $
+derivativeQuotientStrategy = cleanUpStrategyAfter (applyTop cleanUpExpr) $
    label "derivative-quotient" $
    repeatS (somewhere (derivativePolyStepStrategy |> alternatives list))
-   <*> repeatS (exceptLowerDiv (alternatives (map liftToContext rulesPolyNF)))
+   <*> repeatS (exceptLowerDiv (alternatives rulesPolyNF))
  where
    list = map liftToContext
       [ ruleDerivQuotient, ruleDerivPlus, ruleDerivMin, ruleDerivNegate ]
-      
+
 derivativePowerStrategy :: LabeledStrategy (Context Expr)
-derivativePowerStrategy = label "derivative-power" $ 
-   cleanUpStrategy (applyTop cleanUpExpr) (label "split-rational" 
+derivativePowerStrategy = label "derivative-power" $
+   cleanUpStrategyAfter (applyTop cleanUpExpr) (label "split-rational"
       (repeatS (somewhere (liftToContext ruleSplitRational)))) <*>
-   configure mycfg powerOfStrategy <*> 
-   repeatS (distr <*> configure mycfg powerOfStrategy) <*>
-   cleanUpStrategy (applyTop cleanUpExpr) (label "use-derivative-rules" 
+   configure mycfg simplifyPowerStrategy <*>
+   repeatS (distr <*> configure mycfg simplifyPowerStrategy) <*>
+   cleanUpStrategyAfter (applyTop cleanUpExpr) (label "use-derivative-rules"
       (repeatS (somewhere (alternatives list)))) <*>
    configure mycfg nonNegBrokenExpStrategy
  where
@@ -83,9 +85,9 @@       [ ruleDerivPlus, ruleDerivMin, ruleDerivNegate, ruleDerivPowerFactor
       , ruleDerivCon ]
    mycfg = [(byName myFractionTimes, Remove)]
-   distr = cleanUpStrategy (applyTop cleanUpExpr) $ 
-      label "distr" (somewhere (alternatives (map liftToContext rulesPolyNF)))
-      
+   distr = cleanUpStrategyAfter (applyTop cleanUpExpr) $
+      label "distr" (somewhere (alternatives rulesPolyNF))
+
 derivativePolyStepStrategy :: LabeledStrategy (Context Expr)
 derivativePolyStepStrategy = label "derivative-poly-step" $
    check polyDiff <*> liftToContext ruleDerivPolynomial
@@ -94,9 +96,9 @@    nfPoly   = (`belongsTo` polyNormalForm rationalView)
 
 exceptLowerDiv :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr)
-exceptLowerDiv = somewhereWith "except-lower-div" $ \a -> 
+exceptLowerDiv = somewhereWith "except-lower-div" $ \a ->
    if isDivC a then [0] else [0 .. arity a-1]
- where 
+ where
    isDivC = maybe False isDiv . current
    isDiv (_ :/: _) = True
    isDiv _         = False
src/Domain/Math/Equation/BalanceRules.hs view
@@ -1,37 +1,37 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Numeric.Views-import Domain.Math.Expr--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)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,88 +1,59 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Context-import Common.Exercise-import Common.Strategy hiding (replicate)-import Control.Monad-import Domain.Math.Data.Relation-import Domain.Math.Data.OrList-import Domain.Math.Equation.CoverUpRules-import Domain.Math.Equation.Views-import Domain.Math.Examples.DWO1-import Domain.Math.Expr-import Prelude hiding (repeat)----------------------------------------------------------------- Exercise--coverUpExercise :: Exercise (OrList (Equation Expr))-coverUpExercise = makeExercise -   { exerciseId   = describe "solve an equation by covering up" $-                       newId "algebra.equations.coverup"-   , status       = Provisional-   , parser       = parseExprWith (pOrList (pEquation pExpr))-   -- , equivalence  = \_ _ -> True-   , isReady      = solvedEquations-   , extraRules   = coverUpRulesOr-   , strategy     = coverUpStrategy-   , navigation   = termNavigator-   , examples     = map (orList . return) (concat (fillInResult ++ coverUpEquations))-   }----------------------------------------------------------------- Strategy and rules-   -coverUpStrategy :: LabeledStrategy (Context (OrList (Equation Expr)))-coverUpStrategy = label "Cover-up" $ -   repeat $ somewhere $ alternatives coverUpRulesOr--{--cleanUp :: Rule (OrList (Equation Expr)) -> Rule (OrList (Equation Expr))-cleanUp = doAfter $ fmap $ fmap cleanUpExpr--cleanUpExpr :: Expr -> Expr-cleanUpExpr = transform (simplify (makeView f fromRational))- where-   f (Negate a) = liftM negate (f a)-   f (Sqrt a)   = match rationalView a >>= rootedRational 2-   f (Sym s [Nat n, a]) | isRootSymbol s =-      match rationalView a >>= rootedRational n-   f e = match rationalView e--rootedInt :: Integer -> Integer -> Maybe Integer -rootedInt a b = do-   guard (a > 0)-   let d = fromInteger b ** Prelude.recip (fromInteger a) :: Double-       n = round d :: Integer-   guard (n Prelude.^ a == b)-   return n-   -rootedRational :: Integer -> Rational -> Maybe Rational -rootedRational a r = do-   x <- rootedInt a (numerator r)-   y <- rootedInt a (denominator r)-   return (fromInteger x / fromInteger y)--}---------------------------------------------------------------- Testing--{-   -main = map test (concat (fillInResult ++ coverUpEquations))--test e = case apply coverUpStrategy (inContext (OrList [e])) of-            Just a | solvedList (fromContext a)  -> True-                   | otherwise -> error (show (e, a))-            _ -> error (show e) -}+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,205 +1,203 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Classes-import Common.Context-import Common.Id-import Common.Rewriting-import Common.Transformation-import Common.View-import Control.Monad.Identity-import Data.Maybe-import Domain.Math.Data.OrList-import Domain.Math.Data.Relation-import Domain.Math.Expr-------------------------------------------------------------------------- Constructors for cover-up rules--coverUpFunction :: (Switch 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-      _   <- switch $ fmap (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 = [Identity (fb a b)]-   in makeSimpleRuleList name $ map runIdentity . 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 $ orList $ new1 : [ new2 | new1 /= new2, even n ]-      -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 = join . fmap (f . coverUp)- where-   f :: Equation Expr -> OrList (Equation Expr)-   f eq = case apply coverUpPower (return eq) of-             Just xs -> coverUpOrs xs-             Nothing -> return 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,59 +1,62 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 -   ( solvedRelations, solvedRelation-   , equationSolvedForm, solvedEquation, solvedEquations -   , solvedRelationWith-   ) where--import Domain.Math.Expr-import Domain.Math.Data.OrList-import Domain.Math.Data.Relation-import Common.View-import Common.Classes---- generalized to relation-solvedRelations :: (Crush f, Relational g) => f (g Expr) -> Bool-solvedRelations = all solvedRelation . crush---- The variable may appear on one of the sides of the relation (right-hand side--- is thus allowed), but must be isolated-solvedRelation :: Relational f => f Expr -> Bool-solvedRelation r =-   case (getVariable (leftHandSide r), getVariable (rightHandSide r)) of-      (Just _, Just _)  -> False-      (Just x, Nothing) -> withoutVar x (rightHandSide r)-      (Nothing, Just x) -> withoutVar x (leftHandSide r)-      _ -> hasNoVar (leftHandSide r) && hasNoVar (rightHandSide r)---- The variable must appear on the left-solvedRelationWith :: Relational f => (Expr -> Bool) -> f Expr -> Bool-solvedRelationWith p r =-   isVariable (leftHandSide r) && p (rightHandSide r)------------------------------------------------------------------ Views on equations--solvedEquations :: OrList (Equation Expr) -> Bool-solvedEquations = all solvedEquation . crush--solvedEquation :: Equation Expr -> Bool-solvedEquation eq@(lhs :==: rhs) = -   (eq `belongsTo` equationSolvedForm) || (hasNoVar lhs && hasNoVar rhs)--equationSolvedForm :: View (Equation Expr) (String, Expr)-equationSolvedForm = makeView f g- where-   f (Var x :==: e) | withoutVar x e =-      return (x, e)-   f _ = Nothing-   g (s, e) = Var s :==: e+-----------------------------------------------------------------------------
+-- 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/Examples/DWO1.hs 
@@ -1,517 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Examples.DWO1-   ( calculateResults, fillInResult-   , coverUpEquations, linearEquations-   , quadraticEquations, findFactors-   , modulusEquations, sqrtEquations, sqrtSubstEquations, brokenEquations-   , simplerSqrt, simplerSqrt2, simplerSqrt3-   ) where--import Prelude hiding ((^))-import Common.Rewriting-import Domain.Math.Data.Relation-import Domain.Math.Expr--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-      ]--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-      ]  --linearEquations :: [[Equation Expr]]-linearEquations = [level1, level2, level3, level4, level5]- where-   level1 :: [Equation Expr]-   level1 = -      let x = variable "x" in-      [ 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-      ]--   level2 :: [Equation Expr]-   level2 = -      let x = variable "x" in-      [ 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-      ]--   level3 :: [Equation Expr]-   level3 = -      let x = variable "x" in-      [ 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)-      ]--   level4 :: [Equation Expr]-   level4 = -      let x = variable "x" in-      [ (1/2)*x - 4            :==: 2*x + 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 + 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)-      , (-1+(2/5))*x + 3+(1/2) :==: (3/5)*x + (9/10)-      ]--   level5 :: [Equation Expr]-   level5 = -      let x = variable "x" in-      [ (1/4)*(x-3)         :==: (1/2)*x - 4-      , (x+3)/2             :==: 5*((1/2)*x + 1 + (1/2))-      , (1/2)*(7-(2/3)*x)   :==: 2 + (1/9)*x-      , (3/4)*x - (x-1)     :==: 3 + (2+(1/2))*(x-1)-      , -(5/4)*(x-7)        :==: (3/4)*(x+2) - (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)-      ]--quadraticEquations :: [[Equation Expr]]-quadraticEquations = [level1, level2, level3, level4, level5, level6]- where-   level1 = -      let x = variable "x" in-      [ 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-      ] -   -   level2 = -      let x = variable "x" in-      [ (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-      ]-   -   level3 = -      let x = variable "x" in-      [ 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-      ]-      -   level4 = -      let x = variable "x" in-      [ 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-      ]-      -   level5 = -      let x = variable "x" in-      [ (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)-      ]-   -   level6 = -      let x = variable "x" in-      [ 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-      ]---- Ontbinden in factoren (VWO B, hoofdstuk 1)-findFactors :: [[Expr]]-findFactors =-   let x = variable "x" in-   [ -- (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-     ]-   ]--modulusEquations :: [[Equation Expr]]-modulusEquations = -   let x = variable "x" in-   [ [ abs (2*x + 3)  :==: 2 -     , abs (5 - 2*x)  :==: 1-     , abs (4*x + 7)  :==: 3-     , abs (11 - 3*x) :==: 15-     ]-   , [ abs (x^2 + 3) :==: 9-     , abs (x^2 - 7) :==: 2-     , abs (3-x^2)   :==: 6-     , abs (9-x^2)   :==: 7-     ]-   , [ abs (2*x^2+3)     :==: 19-     , abs (3*x^2-2)     :==: 1-     , abs (6-2*x^2)     :==: 2-     , abs (3-(1/2)*x^2) :==: 15-     ]-   , [ abs (4*x^3-72)       :==: 36-     , abs (0.2*x^4 - 112)  :==: 13-     , abs (2*x^4-4.25)     :==: 3.75-     , abs (1.75 - 0.5*x^3) :==: 2.25-     ]-   ]--sqrtEquations :: [[Equation Expr]]-sqrtEquations = -   let x = variable "x" in-   [ [ 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 -     ]-   ]-   -sqrtSubstEquations :: [[Equation Expr]]-sqrtSubstEquations = -   let x = variable "x" in-   [ [ 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-     ]-   ]-   -brokenEquations :: [[Equation Expr]]-brokenEquations = -   let x = variable "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)-     ]-   ]-   -infix 9 *|---- short-hand notation for a product with a square-root-(*|) :: Expr -> Expr -> Expr-a *| b = a * sqrt b--simplerSqrt :: [[Expr]]-simplerSqrt = -   let a = Var "a" in-   [ [ 9*|5 * 7*|3, 3*|2 * 2*|5, 5*|2 * 6*|7, 4*|6 * 2*|7, (6*a)*|3 * 9*|2-     , 5*|5 * (2*a)*|7, a*|6 * 7*|5, 8*|7 * a*|3-     ]-   , [ sqrt 15 / 6*|3, 5*|30/sqrt 5, 4*|10 / 5*|2, 5*|21 / 2*|7, (6*a)*|35 / 3*|5-     , (5*a)*|14 / 9*|2, a*|6 / 7*|3, (a*3)*|42 / 7*|7-     ]-   , [ 5/2*|2, 2/5*|3, 3/2*|5, 8/7*|6, (2*a)/3*|7, (6*a)/7*|10, (5*a)/3*|11-     , (6*a)/5*|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)*|2)^2, ((1/2)*|3)^2, ((2/7)*|5)^2, ((2/3)*|7)^2-     ]-   ]-   -simplerSqrt2 :: [[Expr]]-simplerSqrt2 = -   let a = Var "a" in-   [ [ (((1/7)*a)*|2)^2, (((3/5)*a)*|3)^2, (((1/3)*a)*|5)^2, (((4/7)*a)*|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-     ] -   ]-   -simplerSqrt3 :: [[Expr]]-simplerSqrt3 = -   let a = Var "a" in-   [ [ (2*|7 + 7*|3)^2, (sqrt 2 + 6*|3)^2, (4*|3 + 3*|2)^2, (2*|5 + sqrt 7)^2-     , (3*|6 - 4*|5)^2, (5*|3 - sqrt 2)^2, (4*|6 - 2*|7)^2, (sqrt 5 - 2*|3)^2-     ]-   , [ (2*|3 - 2)^2, (5*|2 - 1)^2, (3+4*|3)^2, (2+3*|6)^2, (4*|2+3)*(4*|2 - 3)-     , (sqrt 7 + sqrt 3)*(sqrt 7 - sqrt 3), (2*|2 - sqrt 5)*(2*|2 + sqrt 5)-     , (6-3*|3)*(6+3*|3)-     ]-   , [ (a-sqrt 3)^2,  (2*|6 + a)^2, (2*a + a*|5)^2, (a*|3 - (2*a)*|2)^2-     , (a-sqrt 7)*(a+sqrt 7), (3*a + 2*|3)*(3*a - 2*|3)-     , (2*a + a*|2)*(2*a - a*|2), ((3*a)*|5 - a)*((3*a)*|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*|3 + sqrt 6), 5/(3*|2 - sqrt 3)-     , 2/(sqrt 11-sqrt 2)-     ]-   , [ 2*|3 / (sqrt 5 + sqrt 2), 6*|5 / (sqrt 7 + sqrt 3)-     , 4*|3 / (sqrt 5 - sqrt 3), 8*|7 / (sqrt 6 - sqrt 5)-     ]-   ]
− src/Domain/Math/Examples/DWO2.hs 
@@ -1,235 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Examples.DWO2 where--import Prelude hiding ((^))-import Domain.Math.Expr-import Domain.Math.Data.Relation------------------------------------------------------------------------- Algemene applet--higherDegreeEquations :: [Equation Expr]-higherDegreeEquations = -   let x = variable "x" in-   [ 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-   let x = Var "x" 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 =-   let x = Var "x" in-   [ [ 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 = -   let x = Var "x" in-   [ 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-   ]---- Havo B hoofdstuk 3, Hogeregraadsvgl.-higherEq1 :: [[Equation Expr]]-higherEq1 = -   let x = Var "x" in-   [ [ (1/3)*x^3 :==: 9-     , x^5 - 12 :==: 20-     , 1 - 8*x^3 :==: -124-     , 16 - 32*x^5 :==: - 227-     ]-   , [ 3*x^4 :==: 48-     , (1/9)*x^6 + 12 :==: 93-     , 39 - 8*x^2 :==: 21-     , (1/2)*x^4 - 13 :==: 27.5-     ]-   , [ 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-     ]-   , [ 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-     ]-   ]------------------------------------------------------------------------- VWO A/C applets---- hoofdstuk 2-ineqQuad2 :: [Inequality Expr]-ineqQuad2 =-   let x = Var "x" in-   [ 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-   ]-   ------------------------------------------------------------------------ VWO B applets---- hoofdstuk 1-higherEq2 :: [[Equation Expr]]-higherEq2 =-   let x = Var "x" in-   [ [ 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-     ]-   , [ 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-     ] -   , [ 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-     ] -   , [ 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-     ] -   , [ (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-     ]-     -- (Ontbinden applet)-    , [ 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-      ]-    , [ 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)-    , [ 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-      ]-    , [ 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-      ]-    ]------------------------------------------------------------------------- Extra test cases--extraIneqQuad :: [Inequality Expr]-extraIneqQuad = -   let x = Var "x" in-   [ 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/Examples/DWO3.hs 
@@ -1,482 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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.Examples.DWO3 where--import Prelude hiding ((^))-import Common.Rewriting-import Domain.Math.Expr--------------------------------------------------------------- HAVO B 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---- 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/Examples/DWO4.hs 
@@ -1,502 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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.Examples.DWO4 -   ( brokenEquations, normBroken, normBroken2, normBrokenCon, deelUit-   , powerEquations, expEquations, logEquations, higherPowerEquations-   , rootEquations, rootEquations2, rootSubstEquations, expEquations2-   ) where--import Prelude hiding ((^))-import Common.Rewriting-import Domain.Math.Data.Relation-import Domain.Math.Expr--------------------------------------------------------------- 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 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)-     ]-   ]---- 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/Examples/DWO5.hs 
@@ -1,167 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Examples.DWO5 -   ( diffSet1, diffSet2, diffSet3, diffSet4-   , diffSet5, diffSet6, diffSet7, diffSet8-   ) where--import Domain.Math.Expr-import Prelude hiding ((^))-import Data.Maybe--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+(1+1/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/ExerciseList.hs view
@@ -0,0 +1,98 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,24 +1,18 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Common.Rewriting.Term-   , module Domain.Math.Expr.Data-   , module Domain.Math.Expr.Parser-   , module Domain.Math.Expr.Symbols-   , module Domain.Math.Expr.Views-   ) where--import Domain.Math.Expr.Data-import Domain.Math.Expr.Parser-import Domain.Math.Expr.Symbols-import Domain.Math.Expr.Views-import Common.Rewriting.Term hiding (Term(..))+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,115 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,278 +1,274 @@-{-# LANGUAGE DeriveDataTypeable #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 where--import Common.Rewriting-import Common.Uniplate-import Common.Utils (commaList)-import Common.View-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.Rewriting.Term as Term---------------------------------------------------------------------------- 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) -> (as, function s)-         _            -> ([], const expr)---------------------------------------------------------------------------- Arbitrary instance--instance Arbitrary Expr where-   arbitrary = natGenerator -      -- 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) -}-instance CoArbitrary Expr where      -   coarbitrary expr =-      case expr of -         a :+: b  -> variant (0 :: Int) . coarbitrary a . coarbitrary b-         a :*: b  -> variant (1 :: Int) . coarbitrary a . coarbitrary b-         a :-: b  -> variant (2 :: Int) . coarbitrary a . coarbitrary b-         Negate a -> variant (3 :: Int) . coarbitrary a-         Nat n    -> variant (4 :: Int) . coarbitrary n-         a :/: b  -> variant (5 :: Int) . coarbitrary a . coarbitrary b-         Number d -> variant (6 :: Int) . coarbitrary d-         Sqrt a   -> variant (7 :: Int) . coarbitrary a-         Var s    -> variant (8 :: Int) . coarbitrary s-         Sym f xs -> variant (9 :: Int) . coarbitrary (show f) . coarbitrary xs-  -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--varGenerator :: [String] -> Gen Expr-varGenerator xs-   | null xs   = error "varGenerator: empty list"-   | otherwise = oneof [ return (Var x) | x <- xs ]---------------------------------------------------------------------------- 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-         -- 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"-      | 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 Rewrite Expr--instance Different Expr where-   different = (Nat 0, Nat 1)--instance IsTerm Expr where -   toTerm (Nat n)    = Term.Num n-   toTerm (Number d) = Term.Float d-   toTerm (Var v)    = Term.Var v-   toTerm expr = -      case getFunction expr of-         Just (s, xs) -> function s (map toTerm xs)-         Nothing      -> error "IsTerm Expr"--   fromTerm (Term.Num n)   = return (fromInteger n)-   fromTerm (Term.Float d) = return (Number d)-   fromTerm (Term.Var 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+{-# 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--exprView :: IsTerm a => View Expr a-exprView = makeView fromExpr toExpr
src/Domain/Math/Expr/Parser.hs view
@@ -1,133 +1,203 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 -   ( scannerExpr, parseExpr, parseExprWith, pExpr-   , pEquations, pEquation, pOrList, pFractional-   , pRelation, pLogic, pLogicRelation-   ) where--import Prelude hiding ((^))-import Text.Parsing-import Control.Monad.Error-import Common.Rewriting-import Common.Transformation-import qualified Domain.Logic.Formula as Logic-import Domain.Logic.Formula (Logic)-import Domain.Math.Data.Relation-import Domain.Math.Expr.Data-import Domain.Math.Expr.Symbols-import Domain.Math.Data.OrList-import Test.QuickCheck (arbitrary)--scannerExpr :: Scanner-scannerExpr = defaultScanner -   { keywords             = ["sqrt", "root", "log", "and", "or", "true", "false", "D"]-   , keywordOperators     = ["==", "<=", ">=", "<", ">", "~=", "+", "-", "*", "^", "/"]-   , operatorCharacters   = "+-*/^.=<>~"-   , qualifiedIdentifiers = True-   }--parseExprWith :: TokenParser a -> String -> Either String a-parseExprWith = parseWithM scannerExpr--parseExpr :: String -> Either String Expr-parseExpr = parseExprWith pExpr--pExpr :: TokenParser Expr-pExpr = expr6---- This expression could have a fraction at top-level: both the numerator--- and denominator are atoms, optionally preceded by a (unary) minus-pFractional :: TokenParser Expr-pFractional = expr6u --expr6, expr6u, expr7, expr8, term, atom :: TokenParser Expr-expr6  =  pChainl ((+) <$ pKey "+" <|> (-) <$ pKey "-") expr6u-expr6u =  optional (Negate <$ pKey "-") id <*> expr7-expr7  =  pChainl ((*) <$ pKey "*" <|> (/) <$ pKey "/") expr8-expr8  =  pChainr ((^) <$ pKey "^") term-term   =  symb <*> pList atom-      <|> atom-atom   =  fromInteger <$> pInteger-      <|> Number <$> pReal -      <|> Var <$> pVarid-      <|> pParens pExpr--symb :: TokenParser ([Expr] -> Expr)-symb = qualifiedSymb-    -- To fix: sqrt expects exactly one argument-    <|> (\xs -> function rootSymbol (xs ++ [2])) <$ pKey "sqrt" -    <|> function rootSymbol <$ pKey "root"-    <|> function logSymbol  <$ pKey "log"-    <|> makeDiff <$ pKey "D"- where-   makeDiff [x,a] = unary diffSymbol (binary lambdaSymbol x a)-   makeDiff _     = symbol bottomSymbol--qualifiedSymb :: TokenParser ([Expr] -> Expr)-qualifiedSymb = f <$> (pQVarid <|> pQConid)- where f (a, b) = function $ newSymbol (a, b)--pEquations :: TokenParser a -> TokenParser (Equations a)-pEquations = pLines True . pEquation--pEquation :: TokenParser a -> TokenParser (Equation a)-pEquation p = (:==:) <$> p <* pKey "==" <*> p--pRelation :: TokenParser a -> TokenParser (Relation a)-pRelation p = (\x f -> f x) <$> p <*> pRelationType <*> p--pRelationChain :: TokenParser a -> TokenParser [Relation a]-pRelationChain p = f <$> p <*> pList1 ((,) <$> pRelationType <*> p)- where-   f _ [] = []-   f a ((op, b):xs) = op a b:f b xs--pRelationType :: TokenParser (a -> a -> Relation a)-pRelationType = pChoice (map make table)- where -   make (s, f) = f <$ pKey s-   table = -      [ ("==", (.==.)), ("<=", (.<=.)), (">=", (.>=.))-      , ("<", (.<.)), (">", (.>.)), ("~=", (.~=.))-      ]-   -pOrList :: TokenParser a -> TokenParser (OrList a)-pOrList p = (join . orList) <$> pSepList pTerm (pKey "or")- where -   pTerm =  return <$> p -        <|> true   <$  pKey "true" -        <|> false  <$  pKey "false"--pLogic :: TokenParser a -> TokenParser (Logic a)-pLogic p = levelOr- where -   levelOr    =  pChainr ((Logic.:||:) <$ pKey "or")  levelAnd-   levelAnd   =  pChainr ((Logic.:&&:) <$ pKey "and") levelAtom-   levelAtom  =  Logic.Var <$> p-             <|> Logic.F   <$  pKey "false"-             <|> Logic.T   <$  pKey "true" -             <|> pParens levelOr--pLogicRelation :: TokenParser a -> TokenParser (Logic (Relation a))-pLogicRelation p = (Logic.catLogic . fmap f) <$> pLogic (pRelationChain p)- where-   f xs = if null xs then Logic.T else foldr1 (Logic.:&&:) (map Logic.Var xs)---------------------------------------------------------------------------- Argument descriptor (for parameterized rules)--instance Argument Expr where-   makeArgDescr = exprArgDescr--exprArgDescr :: String -> ArgDescr Expr-exprArgDescr descr = ArgDescr descr Nothing (either (const Nothing) Just . parseExpr) show arbitrary+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,138 +1,144 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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-   ( openMathSymbol-     -- 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-     -- Matching-   , isPlus, isTimes, isMinus, isDivide, isPower, isNegate, isRoot-   , isPowerSymbol, isRootSymbol, isLogSymbol, isDivideSymbol-   , (^), root-   ) where--import Common.Id-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-import qualified Text.OpenMath.Symbol               as OM---- | Conversion function-openMathSymbol :: OM.Symbol -> Symbol-openMathSymbol s = newSymbol (OM.dictionary s # OM.symbolName s)------------------------------------------------------------------ Arith1 dictionary--plusSymbol, timesSymbol, minusSymbol, divideSymbol, rootSymbol,-   powerSymbol, negateSymbol, absSymbol :: Symbol-   -plusSymbol   = openMathSymbol OM.plusSymbol-timesSymbol  = openMathSymbol OM.timesSymbol-minusSymbol  = openMathSymbol OM.minusSymbol-divideSymbol = openMathSymbol OM.divideSymbol-rootSymbol   = openMathSymbol OM.rootSymbol-powerSymbol  = openMathSymbol OM.powerSymbol-negateSymbol = openMathSymbol OM.unaryMinusSymbol-absSymbol    = openMathSymbol OM.absSymbol------------------------------------------------------------------ Transc1 dictionary--logSymbol, sinSymbol, cosSymbol, lnSymbol, expSymbol, tanSymbol,-   sinhSymbol, tanhSymbol, coshSymbol :: Symbol--logSymbol  = openMathSymbol OM.logSymbol-sinSymbol  = openMathSymbol OM.sinSymbol-cosSymbol  = openMathSymbol OM.cosSymbol-lnSymbol   = openMathSymbol OM.lnSymbol-expSymbol  = openMathSymbol OM.expSymbol -tanSymbol  = openMathSymbol OM.tanSymbol-sinhSymbol = openMathSymbol OM.sinhSymbol-tanhSymbol = openMathSymbol OM.tanhSymbol-coshSymbol = openMathSymbol OM.coshSymbol------------------------------------------------------------------ Other dictionaries--diffSymbol, lambdaSymbol, listSymbol, piSymbol :: Symbol--diffSymbol   = openMathSymbol OM.diffSymbol-lambdaSymbol = openMathSymbol OM.lambdaSymbol-listSymbol   = openMathSymbol OM.listSymbol-piSymbol     = openMathSymbol OM.piSymbol------------------------------------------------------------------ Extra math symbols--signumSymbol, asinSymbol, atanSymbol, acosSymbol, asinhSymbol, atanhSymbol,-   acoshSymbol, bottomSymbol, fcompSymbol :: 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"------------------------------------------------------------------ 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 :: Symbol -> Bool--isPowerSymbol  = (== powerSymbol)-isRootSymbol   = (== rootSymbol)-isLogSymbol    = (== logSymbol)-isDivideSymbol = (== divideSymbol)--infixr 8 ^--(^) :: WithFunctions a => a -> a -> a-(^) = binary powerSymbol--root :: WithFunctions a => a -> a -> a-root = binary rootSymbol---- 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)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,171 +1,152 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 where--import Prelude hiding (recip, (^))-import Common.Rewriting-import Common.View-import Domain.Math.Expr.Data-import Domain.Math.Expr.Symbols-import qualified Data.Set as S----------------------------------------------------------------- Smart constructors--infixr 8 .^.-infixl 7 .*., ./.-infixl 6 .-., .+.--(.+.) :: Expr -> Expr -> Expr-Nat 0 .+. b         = b-a     .+. Nat 0     = a-a     .+. Negate b  = a .-. b-a     .+. (b :+: c) = (a .+. b) .+. c-a     .+. (b :-: c) = (a .+. b) .-. c-a     .+. b         = a :+: b--(.-.) :: Expr -> Expr -> Expr-Nat 0 .-. b         = neg b-a     .-. Nat 0     = a-a     .-. Negate b  = a .+. b-a     .-. (b :+: c) = (a .-. b) .-. c-a     .-. (b :-: c) = (a .-. b) .+. c-a     .-. b         = a :-: b--neg :: Expr -> Expr-neg (Nat 0)    = 0-neg (Negate a) = a-neg (a :+: b)  = neg a .-. b-neg (a :-: b)  = neg a .+. b-neg a          = Negate a--(.*.) :: Expr -> Expr -> Expr-Nat 0    .*. _             = Nat 0-_        .*. Nat 0         = Nat 0-Nat 1    .*. b             = b-a        .*. Nat 1         = a-Negate a .*. b             = neg (a .*. b)-a        .*. Negate b      = neg (a .*. b)-a        .*. (Nat 1 :/: b) = a ./. b-a        .*. (b :*: c)     = (a .*. b) .*. c-a        .*. b             = a :*: b--(./.) :: Expr -> Expr -> Expr-a ./. Nat 1           = a-Negate a ./. b        = neg (a ./. b)-a        ./. Negate b = neg (a ./. b)-(a :/: b) ./. c       = a ./. (b .*. c)-a ./. b               = a :/: b--recip :: Expr -> Expr-recip (Nat 1 :/: a) = a-recip a             = Nat 1 :/: a--(.^.) :: 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 :: Match Expr (Expr, Expr)-   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 :: Match Expr (Expr, Expr)-   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 :: Match Expr (Expr, Expr)-   matchDiv (a :/: b)  = Just (a, b)-   matchDiv (Negate a) = do (x, y) <- matchDiv a-                            Just (neg x, y)-   matchDiv _          = Nothing----------------------------------------------------------------- Some constant views--conView :: View Expr Integer-conView = makeView f fromInteger- where-   f (Nat n)    = return n-   f (Negate e) = fmap negate (f e)-   f _          = Nothing--fractionView :: View Expr (Integer, Integer) -- second component is positive-fractionView = divView >>> signs >>> (conView *** conView)- where-   signs = makeView (Just . f) id-   f (a, Negate b) = f (neg a, b)-   f (a, b)        = (a, b)- ----------------------------------------------------------------- Sums and products--sumView :: View Expr [Expr]-sumView = makeView (return . ($ []) . f False) (foldl (.+.) 0)- where-   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 n e          = if n then (neg e:) else (e:)--simpleProductView :: View Expr (Bool, [Expr])-simpleProductView = makeView (Just . second ($ []) . f) g- where-   f (a :*: b)  = f a .&&. f b-   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 neg else id) (foldl (.*.) 1 xs)--productView :: View Expr (Bool, [Expr])-productView = makeView (Just . second ($ []) . f False) g- where-   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)-   --- 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,69 +1,79 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Exercise-import Common.Strategy-import Common.View-import Domain.Math.Expr-import Domain.Math.Numeric.Strategies-import Domain.Math.Numeric.Views-import Domain.Math.Numeric.Generators-import Domain.Math.Examples.DWO1 (calculateResults)-import Common.Context-   ---------------------------------------------------------------- Exercises--numericExercise :: LabeledStrategy (Context Expr) -> Exercise Expr-numericExercise s = makeExercise -   { status        = Alpha-   , parser        = parseExpr-   , equivalence   = viewEquivalent rationalView-   , strategy      = s-   , navigation   = termNavigator-   }--naturalExercise :: Exercise Expr-naturalExercise = (numericExercise naturalStrategy)-   { exerciseId   = describe "simplify expression (natural numbers)" $ -                       newId "numbers.natural"-   , isReady      = (`belongsTo` integerNormalForm)-   , examples     = concat calculateResults-   }--integerExercise :: Exercise Expr-integerExercise = (numericExercise integerStrategy)-   { exerciseId   = describe "simplify expression (integers)" $ -                       newId "numbers.integers"-   , isReady      = (`belongsTo` integerNormalForm)-   , examples     = concat calculateResults-   }-   -rationalExercise :: Exercise Expr-rationalExercise = (numericExercise rationalStrategy)-   { exerciseId     = describe "simplify expression (rational numbers)" $ -                         newId "numbers.rational"-   , isReady        = (`belongsTo` rationalNormalForm)-   , randomExercise = simpleGenerator (rationalGenerator 5)-   }--fractionExercise :: Exercise Expr-fractionExercise = (numericExercise fractionStrategy)-   { exerciseId     = describe "simplify expression (fractions)" $ -                         newId "arithmetic.fractions"-   , isReady        = (`belongsTo` rationalNormalForm)-   , randomExercise = simpleGenerator (rationalGenerator 5)-   }+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,82 +1,109 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Control.Monad-import Common.View-import Common.Utils (ratioGen)-import Domain.Math.Numeric.Views-import Test.QuickCheck-import Domain.Math.Expr------------------------------------------------------------------------ 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 -> oneof $ map return-                 [ 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)-                oneof $ map return -                   [ (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))+-----------------------------------------------------------------------------
+-- 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/Laws.hs 
@@ -1,103 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more information, --- see the file "LICENSE.txt", which is included in the distribution.--------------------------------------------------------------------------------- |--- Maintainer  :  bastiaan.heeren@ou.nl--- Stability   :  provisional--- Portability :  portable (depends on ghc)------ Algebraic laws, for testing purposes----------------------------------------------------------------------------------module Domain.Math.Numeric.Laws -   ( numLaws, testNumLaws, testNumLawsWith-   , fracLaws, testFracLaws, testFracLawsWith-   ) where--import Common.TestSuite-import Test.QuickCheck--testNumLaws :: Num a => String -> Gen a -> TestSuite-testNumLaws = testNumLawsWith (==)--testNumLawsWith :: Num a => (a -> a -> Bool) -> String -> Gen a -> TestSuite-testNumLawsWith eq s g = suite ("Num instance for " ++ s) $-   mapM_ ($ g) (numLaws eq)--testFracLaws :: Fractional a => String -> Gen a -> TestSuite-testFracLaws = testFracLawsWith (==)--testFracLawsWith :: Fractional a => (a -> a -> Bool) -> String -> Gen a -> TestSuite-testFracLawsWith eq s g = suite ("Fractional instance for " ++ s) $ -   mapM_ ($ g) (fracLaws eq)--numLaws :: Num a => (a -> a -> Bool) -> [Gen a -> TestSuite]-numLaws eq =-   [ law1 "plus zero left"     $ \a      ->      0+a === a-   , law1 "plus zero right"    $ \a      ->      a+0 === a-   , law2 "plus comm"          $ \a b    ->      a+b === b+a-   , law3 "plus trans"         $ \a b c  ->  a+(b+c) === (a+b)+c-   , law1 "negate zero"        $ \a      ->       -0 === 0        `asTypeOf` a-   , law1 "negate double"      $ \a      ->    -(-a) === a-   , law1 "minus zero left"    $ \a      ->      0-a === -a-   , law1 "minus zero right"   $ \a      ->      a-0 === a-   , law2 "negate plus"        $ \a b    ->   -(a+b) === -a-b-   , law2 "negate minus"       $ \a b    ->   -(a-b) === -a+b-   , law2 "plus negate"        $ \a b    ->   a+(-b) === a-b-   , law1 "times zero left"    $ \a      ->      0*a === 0-   , law1 "times zero right"   $ \a      ->      a*0 === 0-   , law1 "times one left"     $ \a      ->      1*a === a-   , law1 "times one right"    $ \a      ->      a*1 === a-   , law2 "times comm"         $ \a b    ->      a*b === b*a-   , law3 "times trans"        $ \a b c  ->  a*(b*c) === (a*b)*c-   , law2 "times negate left"  $ \a b    ->   (-a)*b === -(a*b)-   , law2 "times negate right" $ \a b    ->   a*(-b) === -(a*b)-   , law3 "times plus left"    $ \a b c  ->  (a+b)*c === a*c + b*c-   , law3 "times plus right"   $ \a b c  ->  a*(b+c) === a*b + a*c-   , law3 "times minus left"   $ \a b c  ->  (a-b)*c === a*c - b*c-   , law3 "times minus right"  $ \a b c  ->  a*(b-c) === a*b - a*c-   ]- where-   infix 4 ===-   a === b = property (a `eq` b)--fracLaws :: Fractional a => (a -> a -> Bool) -> [Gen a -> TestSuite]-fracLaws eq =-   [ law3 "division numerator"   $ \a b c  ->      (a/b)/c === a/(b*c)          <| b/=0 && c/=0-   , law3 "division denominator" $ \a b c  ->      a/(b/c) === a*(c/b)          <| b/=0 && c/=0-   , law1 "zero numerator"       $ \a      ->          0/a === 0 <| a/=0-   , law1 "one numerator"        $ \a      ->          1/a === recip a          <| a/=0-   , law1 "one denominator"      $ \a      ->          a/1 === a-   , law1 "division is one"      $ \a      ->          a/a === 1                <| a/=0-   , law1 "recip double"         $ \a      ->            a === recip (recip a)  <| a/=0-   , law3 "times division left"  $ \a b c  ->      (a/b)*c === (a*c)/b          <| b/=0-   , law3 "times division right" $ \a b c  ->      a*(b/c) === (a*b)/c          <| c/=0-   , law3 "plus division left"   $ \a b c  ->      (a/b)+c === (a+c*b)/b        <| b/=0-   , law3 "plus division right"  $ \a b c  ->      a+(b/c) === (a*c+b)/c        <| c/=0-   , law3 "minus division left"  $ \a b c  ->      (a/b)-c === (a-c*b)/b        <| b/=0-   , law3 "minus division right" $ \a b c  ->      a-(b/c) === (a*c-b)/c        <| c/=0-   , law2 "negate numerator"     $ \a b    ->      a/(-b)  === -(a/b)           <| b/=0-   , law2 "negate denominator"   $ \a b    ->       (-a)/b === -(a/b)           <| b/=0-   , law2 "recip times"          $ \a b    ->  recip (a*b) === recip a*recip b  <| a/=0 && b/=0-   , law2 "recip division"       $ \a b    ->  recip (a/b) === b/a              <| a/=0 && b/=0-   ]- where-   infix 4 ===-   a === b = property (a `eq` b)-   infix 1 <|-   p <| b = b ==> p---- local helper-functions-law1 :: Show a => String -> (a -> Property) -> Gen a -> TestSuite-law1 s p g = addProperty s (make g id p)--law2 :: Show a => String -> (a -> a -> Property) -> Gen a -> TestSuite-law2 s p g = addProperty s (make g (make g id) p)--law3 :: Show a => String -> (a -> a -> a -> Property) -> Gen a -> TestSuite-law3 s p g = addProperty s (make g (make g (make g id)) p)--make :: Show a => Gen a -> (b -> Property) -> (a -> b) -> Property-make g c p = forAll g (c . p)
src/Domain/Math/Numeric/Rules.hs view
@@ -1,164 +1,164 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Control.Monad-import Domain.Math.Expr-import Domain.Math.Numeric.Views-import Common.View----------------------------------------------------------------- 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 integerNormalForm e1))-   (c, d)   <- (matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm 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 integerNormalForm e1))-      (c, d)   <- (matchM fractionForm e2 `mplus` liftM (\n -> (n, 1)) (matchM integerNormalForm e2))-      return (build fractionForm (a*c, b*d)) +-----------------------------------------------------------------------------
+-- 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 view
@@ -1,80 +1,77 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Context-import Common.Strategy-import Common.View-import Domain.Math.Expr-import Domain.Math.Numeric.Rules-import Domain.Math.Numeric.Views-import Prelude hiding (repeat)----------------------------------------------------------------- Strategies--naturalStrategy :: LabeledStrategy (Context Expr)-naturalStrategy = label "simplify" $ -   repeat $ 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" $ -   repeat $ somewhere $ alternatives $ map use-      [ calcPlusWith     "integer" integerNormalForm-      , calcMinusWith    "integer" integerNormalForm-      , calcTimesWith    "integer" integerNormalForm-      , calcDivisionWith "integer" integerNormalForm-      , doubleNegate, negateZero-      ]--rationalStrategy :: LabeledStrategy (Context Expr)-rationalStrategy = label "simplify" $ -   repeat $ somewhere $ alternatives $ map use-      [ calcPlusWith     "rational" rationalRelaxedForm-      , calcMinusWith    "rational" rationalRelaxedForm-      , calcTimesWith    "rational" rationalRelaxedForm-      , calcDivisionWith "integer"      integerNormalForm-      , doubleNegate, negateZero, divisionDenominator-      , divisionNumerator, simplerFraction-      ]--fractionStrategy :: LabeledStrategy (Context Expr)-fractionStrategy = label "simplify" $ -   repeat $ -      somewhere -         (  use (calcPlusWith     "integer" integerNormalForm)-        <|> use (calcMinusWith    "integer" integerNormalForm)-        <|> use (calcTimesWith    "integer" integerNormalForm) -- not needed?-        -- <|> use (calcDivisionWith "integer" integerNormalForm)  -- not needed?-         ) |> -      somewhere-         (  use doubleNegate <|> use negateZero <|> use divisionDenominator  -        <|> use fractionPlus <|> use fractionTimes <|> use divisionNumerator-         ) |>-      somewhere (use fractionPlusScale) |>+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,89 +1,89 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.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"   integerNormalForm-      f "rational normal form"  rationalNormalForm-      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" integerNormalForm-    -- f rationalNormalForm -- 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 rationalNormalForm-      f "ratio expr nonzero" ratioExprGenNonZero rationalNormalForm--   suite "View relations" $ do-      let va .>. vb = forM_ numGenerators $ \g -> -             addProperty "" $ forAll g $ \a -> -                not (a `belongsTo` va) || a `belongsTo` vb-      integerNormalForm .>. integerView-      rationalNormalForm .>. rationalRelaxedForm-      rationalRelaxedForm .>. rationalView-      integerNormalForm .>. rationalNormalForm-      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  integerNormalForm-      f "integer"  integerStrategy  integerView  integerNormalForm-      f "rational" rationalStrategy rationalView rationalNormalForm-      f "fraction" fractionStrategy rationalView rationalNormalForm--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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,187 +1,238 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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-   ( integralView, integerView-   , rationalView, doubleView, mixedFractionView-   , integerNormalForm, rationalNormalForm, mixedFractionNormalForm-   , rationalRelaxedForm, fractionForm-   , intDiv, fracDiv, exprToNum-   ) where--import Common.Rewriting-import Common.View-import Control.Monad-import Data.Ratio-import Domain.Math.Expr------------------------------------------------------------------------ Numeric views--integralView :: Integral a => View Expr a-integralView = newView "num.integer" (exprToNum f) fromIntegral- where-   f s [x, y] -      | isDivideSymbol s = -           intDiv x y-      | isPowerSymbol s = do-           guard (y >= 0)-           return (x Prelude.^ y)-   f _ _ = Nothing-   -integerView :: View Expr Integer-integerView = integralView--rationalView :: View Expr Rational-rationalView = newView "num.rational" (exprToNum f) fromRational- where-   f s [x, y] -      | isDivideSymbol s = -           fracDiv x y-      | isPowerSymbol s = do-           let ry = toRational y-           guard (denominator ry == 1)-           let a = x Prelude.^ abs (numerator ry)-           return (if numerator ry < 0 then 1/a else a)-   f _ _ = Nothing-   -mixedFractionView :: View Expr Rational-mixedFractionView = newView "num.mixed-fraction" (match rationalView) mix - where-   mix r = -      let (d, m) = abs (numerator r) `divMod` denominator r-          rest   = fromInteger m ./. fromInteger (denominator r)-          sign   = if numerator r < 0 then negate else id-      in sign (fromInteger d .+. rest)--doubleView :: View Expr Double-doubleView = newView "num.double" rec Number- where-   rec expr =-      case expr of-         Sym s xs -> mapM rec xs >>= doubleSym s-         Number d -> return d-         _        -> exprToNumStep rec expr- ----------------------------------------------------------------------- Numeric views in normal form ---- N or -N (where n is a natural number)-integerNormalForm :: View Expr Integer-integerNormalForm = newView "num.integer-nf" (optionNegate f) fromInteger- where-   f (Nat n) = Just n-   f _       = Nothing---- 5, -(2/5), (-2)/5, but not 2/(-5), 6/8, or -((-2)/5)-rationalNormalForm :: View Expr Rational-rationalNormalForm = newView "num.rational-nf" f fromRational- where   -   f (Nat a :/: Nat b) = simple a b-   f (Negate (Nat a :/: Nat b)) = fmap negate (simple a b)-   f (Negate (Nat a) :/: Nat b) = fmap negate (simple a b)-   f a = fmap fromInteger (match integerNormalForm a)-   -   simple a b-      | a > 0 && b > 1 && gcd a b == 1 = -           Just (fromInteger a / fromInteger b)-      | otherwise = Nothing--mixedFractionNormalForm :: View Expr Rational-mixedFractionNormalForm = newView "num.mixed-fraction-nf" f fromRational- where-   f (Negate (Nat a) :-: (Nat b :/: Nat c)) | a > 0 = fmap (negate . (fromInteger a+)) (simple b c)-   f (Negate (Nat a :+: (Nat b :/: Nat c))) | a > 0 = fmap (negate . (fromInteger a+)) (simple b c)-   f (Nat a :+: (Nat b :/: Nat c)) | a > 0 = fmap (fromInteger a+) (simple b c)-   f (Nat a :/: Nat b) = simple a b-   f (Negate (Nat a :/: Nat b)) = fmap negate (simple a b)-   f (Negate (Nat a) :/: Nat b) = fmap negate (simple a b)-   f a = fmap fromInteger (match integerNormalForm a)-   -   simple a b-      | a > 0 && b > 1 && gcd a b == 1 && a < b = -           Just (fromInteger a / fromInteger b)-      | otherwise = Nothing--fractionForm :: View Expr (Integer, Integer)-fractionForm = newView "num.fraction-form" f (\(a, b) -> (fromInteger a :/: fromInteger b))- where-   f (Negate a) = liftM (first negate) (g a)-   f a = g a-   g (e1 :/: e2) = do-      a <- match integerNormalForm e1-      b <- match integerNormalForm e2-      guard (b /= 0)-      return (a, b)-   g _       = Nothing--rationalRelaxedForm :: View Expr Rational-rationalRelaxedForm = newView "num.rational-relaxed" (optionNegate f) fromRational- where-   f (e1 :/: e2) = do-      a <- match integerNormalForm e1-      b <- match integerNormalForm e2-      fracDiv (fromInteger a) (fromInteger b)-   f (Nat n) = Just (fromInteger n)-   f _       = Nothing---- helper-function-optionNegate :: (MonadPlus m, Num a) => (Expr -> m a) -> Expr -> m a-optionNegate f (Negate a) = do b <- f a; guard (b /= 0); return (negate b)-optionNegate f a          = f a------------------------------------------------------------------------ Helper functions--doubleSym :: Symbol -> [Double] -> Maybe Double-doubleSym s [x, y] -   | isDivideSymbol s = fracDiv x y-   | isPowerSymbol  s = floatingPower x y   -   | isRootSymbol   s && x >= 0 && y >= 1 = Just (x ** (1/y))-doubleSym _ _ = Nothing---- General numeric interpretation function: constructors Sqrt and--- (:/:) are interpreted with function-exprToNum :: (Monad m, Num a) => (Symbol -> [a] -> m a) -> Expr -> m a-exprToNum f = rec - where-   rec expr =-      case expr of-         Sym s xs -> mapM rec xs >>= f s-         _        -> exprToNumStep rec expr--exprToNumStep :: (Monad m, Num a) => (Expr -> m a) -> Expr -> m a-exprToNumStep rec expr = -   case expr of -      a :+: b  -> liftM2 (+)    (rec a) (rec b)-      a :*: b  -> liftM2 (*)    (rec a) (rec b)-      a :-: b  -> liftM2 (-)    (rec a) (rec b)-      Negate a -> liftM  negate (rec a)-      Nat n    -> return (fromInteger n)-      a :/: b  -> rec (Sym divideSymbol [a, b])-      Sqrt a   -> rec (Sym rootSymbol [a, 2])-      _        -> fail "exprToNumStep"--intDiv :: Integral a => a -> a -> Maybe a-intDiv x y -   | y /= 0 && m == 0 = Just d-   | otherwise        = Nothing- where (d, m) = x `divMod` y- -fracDiv :: Fractional a => a -> a -> Maybe a-fracDiv x y -   | y /= 0    = Just (x / y)-   | otherwise = Nothing-   -floatingPower :: (Ord a, Floating a) => a -> a -> Maybe a-floatingPower x y -   | x==0 && y<0 = Nothing-   | otherwise   = Just (x**y)+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,263 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,245 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,474 @@+{-# 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 view
@@ -1,468 +1,463 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Prelude hiding ((^))-import Common.Id-import Domain.Math.Expr-import Domain.Math.Data.Relation-import Domain.Math.Data.OrList-import Domain.Math.Polynomial.Views-import Domain.Math.Polynomial.Rules-import Domain.Math.Polynomial.CleanUp-import Domain.Math.Numeric.Views-import Domain.Math.Data.Polynomial-import Domain.Math.Equation.CoverUpRules-import Common.Classes-import Common.Context-import Common.Rewriting-import Common.View-import Common.Transformation (Rule, buggyRule, siblingOf, Transformation, useRecognizer, supply1, makeTransList)-import Control.Monad-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, Rewrite 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" $ -   useRecognizer recognizeEq $ supply1 (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 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 :: Rational -> Transformation (Equation Expr)-multiplyOneSide r = makeTransList $ \(lhs :==: rhs) -> do-      xs <- matchM sumView lhs-      ys <- matchM sumView rhs-      let f = map (*fromRational 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" $ -   useRecognizer recognizeEq $ supply1 (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 r) eq1)-      in maybe False p (recognizeMultiplication a1 b1) -      || maybe False p (recognizeMultiplication a2 b2)--multiplyForgetOne :: Rational -> 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 (*fromRational 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 $ orList [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 $ orList [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) -      [ orList [ f (+) True,  f (-) True  ],-        orList [ f (+) False, f (-) True  ],-        orList [ 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) -      [ orList [ f (+) True,  f (-) True  ],-        orList [ f (+) False, f (-) True  ],-        orList [ 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)-      [ orList [ f (+) True,  f (-) True  ],-        orList [ f (+) False, f (-) True  ],-        orList [ f (+) True,  f (-) False ]]-         -oneSolution :: Rule (OrList (Equation Expr))-oneSolution = buggyRule $ makeRule "abc.one-solution" $ -   abcMisconception $ \x a b c -> do-      let discr = sqrt (fromRational (b*b - 4 * a * c))-          f (?) = Var x :==: (-fromRational b ? discr) / (2 * fromRational a)-      [ return $ f (+), return $ f (-) ]+-----------------------------------------------------------------------------
+-- 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/CleanUp.hs 
@@ -1,210 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.CleanUp -   ( cleanUpRelations, cleanUpRelation, cleanUpExpr-   , cleanUpSimple, collectLikeTerms-   , acExpr, smart-   ) where--import Common.Utils (fixpoint)-import Common.Uniplate-import Common.View-import Control.Monad-import Data.List-import Data.Maybe-import Data.Ord-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-import Domain.Math.Power.OldViews-import Domain.Math.Simplification hiding (simplify, simplifyWith)-import Domain.Math.SquareRoot.Views-import Prelude hiding ((^), recip)-import qualified Prelude-import Data.Ratio--------------------------------------------------------------------------- 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))--------------------------------------------------------------------------- Expr normalization--collectLikeTerms :: Expr -> Expr-collectLikeTerms = simplifyWith f sumView- where-   f = mergeAlikeSum . map (simplifyWith (second mergeAlikeProduct) productView)----------------------------------------------------------------- Cleaning up--cleanUpSimple :: Expr -> Expr-cleanUpSimple = fixpoint (transform (f2 . f1))- where-   use v = simplifyWith (assocPlus v) sumView-   f1 = use rationalView-   f2 = smartConstructors--cleanUpRelations :: OrList (Relation Expr) -> OrList (Relation Expr)-cleanUpRelations = idempotent . join . fmap 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)-              _                -> return 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))---- normalize expr with associativity and commutative rules for + and *-acExpr :: Expr -> Expr-acExpr expr = -   case (match sumView expr, match productView expr) of-      (Just xs, _) | length xs > 1 -> -         build sumView $ sort $ map acExpr xs-      (_, Just (b, xs)) | length xs > 1 -> -         build productView (b, sort $ map acExpr xs)-      _ -> -         descend acExpr expr-   ---------------------------------------------------------------- Technique 1: fixed points of views-{--cleanUpFix :: Expr -> Expr-cleanUpFix = fixpoint (f4 . f3 . f2 . f1)- where-   use v = transform (simplifyWith (assoPlus v) sumView)- -   f1 = use rationalView-   f2 = use (squareRootViewWith rationalView)-   f3 = use (powerFactorViewWith rationalView)-   f4 = smartConstructors--}-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` do-      a <- canonical specialSqrtOrder e-      -- Just simplify order of terms with square roots for now-      return (transform smart a)-    `mplus` do-      xs <- match sumView e-      guard (length xs > 1)-      return $ build sumView $-         assocPlus myView xs-    `mplus`-      canonical myView e-    `mplus` do-      (b, xs) <- match productView e-      guard (length xs > 1)-      return $ build productView -         (b, assocTimes myView xs)- where-   myView = powerFactorViewWith rationalView--specialSqrtOrder :: View Expr [Expr]-specialSqrtOrder = 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 (Sqrt a)  = maybe (Sqrt a) (`simplerRoot` 2) (match rationalView a)-smart e = e------------------------------------------------------------------ Testing--{---- List with hard cases-hardCases = map cleanUpExpr $ let x=Var "x" in-  [ -1/2*x*(x/1)-  , (x/(-3))-  , (x/(-3))^2-  , (0-x)*(-x)/(-5/2)-  , (x/(-1))^2-  , (x/(-1))^2-(-7/2)*x/(-1)-  , (x^2+0)*3-  , -(49/9*x^2+0^2)*(3/16)-  , (0*x-(-x^2))*(-3)-  , x^2 - x^2-  , x^2-x^2-(x+x)*1-  , x^2/(16/3)-x^2*(-1/3)-(x+(-26/3)-x^2)*1-  , (-7+7*x)^2-(x*0)^2/(-3)-  , 1*(x+93)+4-  , (1*(x+(-93/5))-(-4+x/19))/8-(x^2-x+(19/2-x)-34/3*(x*(-41/2)))/9-  ] -}
src/Domain/Math/Polynomial/Equivalence.hs view
@@ -1,322 +1,277 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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-   ) where--import Common.Classes-import Common.Context-import Common.Rewriting-import Common.Uniplate-import Common.View-import Control.Monad-import Data.List (sort, nub)-import Data.Maybe-import Data.Ord-import Domain.Logic.Formula hiding (Var, disjunctions)-import Domain.Math.Clipboard-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.CleanUp-import Domain.Math.Polynomial.Views-import Domain.Math.SquareRoot.Views-import Prelude hiding ((^), sqrt)-import qualified Domain.Logic.Formula as Logic--relationIntervals :: Ord a => RelationType -> a -> Intervals a-relationIntervals relType a = -   case relType of-      EqualTo              -> only singleton a-      NotEqualTo           -> except a-      LessThan             -> only lessThan a-      GreaterThan          -> only greaterThan a-      LessThanOrEqualTo    -> only lessThanOrEqualTo a-      GreaterThanOrEqualTo -> only greaterThanOrEqualTo a-      Approximately        -> only singleton a -- i.e., equalTo- where    -   only f = fromList . return . f--logicIntervals :: Ord a => Logic (Intervals a) -> Intervals a-logicIntervals = foldLogic -   ( id-   , \p q -> complement p `union` q -- p->q  =  ~p||q-   , \p q -> (p `intersect` q) `union` (complement p `intersect` complement q)  -- p<->q  =  (p&&q)||(~p&&~q)-   , intersect-   , union-   , complement-   , fromList [unbounded]-   , fromList [empty]-   )--------------------------------------------------------------             -linEq :: Relation Expr -> Relation Expr -> Bool-linEq a b = fromMaybe False $ liftM2 (==) (linRel a) (linRel b)--linRel :: Relation Expr -> Maybe (String, Intervals Rational)-linRel = linRelWith rationalView--linRelWith :: (Ord a, Fractional a)-           => View Expr a -> Relation Expr -> Maybe (String, Intervals a)-linRelWith v rel =-   case match (linearViewWith v) (lhs - rhs) of-      Nothing -> -         case match (polyViewWith v) (lhs - rhs) of-            Just (s, p) | degree p == 0 -> -               case compare (coefficient 0 p) 0 of-                  LT | relationType rel `elem` [LessThan, LessThanOrEqualTo] -> -                          return (s, fromList [unbounded])-                     | otherwise ->-                          return (s, fromList [empty])-                  EQ | relationType rel `elem` [EqualTo, LessThanOrEqualTo, GreaterThanOrEqualTo] -> -                          return (s, fromList [unbounded])-                     | otherwise -> -                          return (s, fromList [empty])-                  GT | relationType rel `elem` [GreaterThan, GreaterThanOrEqualTo] -> -                          return (s, fromList [unbounded])-                     | otherwise ->-                          return (s, fromList [empty])-            _ -> Nothing-      Just (s, a, b) -         | a==0 -> -              return (s, fromList [ unbounded | b==0 ])-         | otherwise -> do-              let zero = -b/a-                  tp = relationType $ (if a<0 then flipSides else id) rel-              return (s, relationIntervals 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, Intervals Q)) -> Logic (Relation Expr) -> Logic (Relation Expr) -> Bool-polyEq f p q = fromMaybe False $ do-   xs <- switch (fmap f p)-   ys <- switch (fmap f q)-   let vs = map fst (crush xs ++ crush ys)-   guard (null vs || all (==head vs) vs)-   let ix = logicIntervals (fmap snd xs)-       iy = logicIntervals (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, Intervals Q)-highRel2 p = do-   xs <- switch (fmap highRel p)-   let vs = map fst (crush xs)-   guard (null vs || all (==head vs) vs)-   return (head vs, logicIntervals (fmap snd xs))--highRel :: Relation Expr -> Maybe (String, Intervals Q)-highRel rel = msum -   [ cuTimes rel >>= highRel-   , cuPower rel >>= highRel2-   , cuPlus rel >>= highRel-   , quadrRel rel -   ]--quadrRel :: Relation Expr -> Maybe (String, Intervals 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 | tp `elem` [NotEqualTo, GreaterThan, GreaterThanOrEqualTo] ->-                    fromList [unbounded]-               | tp `elem` [EqualTo, Approximately, LessThan, LessThanOrEqualTo] ->-                    fromList [empty]-            EQ | tp `elem` [EqualTo, Approximately, LessThanOrEqualTo] -> -                    fromList [singleton pa]-               | tp == NotEqualTo ->-                    except pa-               | tp == LessThan ->-                    fromList [empty]-               | tp == GreaterThan ->-                    except pa-               | tp == GreaterThanOrEqualTo ->-                    fromList [unbounded]-            GT | tp `elem` [EqualTo, Approximately] -> -                    fromList [singleton pa, singleton pb]-               | tp == NotEqualTo -> -                    except pa `intersect` except pb-               | tp == LessThan -> -                    fromList [open pa pb]-               | tp == LessThanOrEqualTo ->-                    fromList [closed pa pb]-               | tp == GreaterThan -> -                    fromList [lessThan pa, greaterThan pb]-               | tp == GreaterThanOrEqualTo ->-                    fromList [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 = rec (fmap f p0) (fmap f q0)- where-   rec a b   -      | isOr a =-           let collect = nub . sort . trueOr . collectOr-           in recList (collect a) (collect b)-      | isAnd a =-           let collect = nub . sort . falseAnd . collectAnd-           in recList (collect a) (collect b)-      | otherwise = -           shallowEq a b && recList (children a) (children b)- -   recList xs ys = -      length xs == length ys && and (zipWith rec xs ys) - -   collectOr (p :||: q) = collectOr p ++ collectOr q-   collectOr F = []-   collectOr a = [a]-   -   trueOr xs = if T `elem` xs then [] else xs-   -   collectAnd (p :&&: q) = collectAnd p ++ collectAnd q-   collectAnd T = []-   collectAnd a = [a]-   -   falseAnd xs = if F `elem` xs then [] else xs-   -   shallowEq a b = -      let g = descend (const T) -      in g a == g b -      -   isOr (_ :||: _) = True-   isOr _          = False-   -   isAnd (_ :||: _) = True-   isAnd _          = False-   -   -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)+{-# 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 view
@@ -0,0 +1,394 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,237 +1,220 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 where--import Domain.Math.Approximation-import Common.Context-import Common.Exercise-import Common.Rewriting-import Common.Strategy-import Common.Classes-import Common.Uniplate-import Common.View-import Data.Maybe-import Domain.Math.Data.OrList-import Domain.Math.Data.Relation-import Domain.Math.Equation.Views-import Domain.Math.Examples.DWO1-import Domain.Math.Examples.DWO2-import Domain.Math.Expr-import Domain.Math.Polynomial.BuggyRules-import Domain.Math.Polynomial.CleanUp-import Domain.Math.Polynomial.Rules-import Domain.Math.Polynomial.Strategies-import Domain.Math.Polynomial.Views-import Domain.Math.Polynomial.Equivalence-import Domain.Math.Numeric.Views-import Domain.Math.Equation.CoverUpRules-import Control.Monad----------------------------------------------------------------- Exercises--linearExercise :: Exercise (Equation Expr)-linearExercise = makeExercise -   { exerciseId   = describe "solve a linear equation" $ -                       newId "algebra.equations.linear"-   , status       = Provisional-   , parser       = parseExprWith (pEquation pExpr)-   , similarity   = eqRelation (acExpr . cleanUpExpr)-   , equivalence  = viewEquivalent linearEquationView-   , isSuitable   = (`belongsTo` linearEquationView)-   , isReady      = solvedRelationWith $ \a -> -                       a `belongsTo` mixedFractionNormalForm || -                       a `belongsTo` rationalNormalForm-   , extraRules   = map use buggyRulesEquation ++-                    map use buggyRulesExpr -   , ruleOrdering = ruleOrderingWithId-                       [ getId coverUpTimes, getId flipEquation-                       , getId removeDivision-                       ]-   , strategy     = linearStrategy-   , navigation   = termNavigator-   , examples     = concat (linearEquations ++ [specialCases])-   }- where-   specialCases = -      let x = Var "x" -      in [5 :==: x, 5 :==: x + 1, x - 1/5 :==: 2]-      -linearMixedExercise :: Exercise (Equation Expr)-linearMixedExercise = linearExercise -   { exerciseId   = describe "solve a linear equation with mixed fractions" $ -                       newId "algebra.equations.linear.mixed"-   , isReady      = solvedRelationWith (`belongsTo` mixedFractionNormalForm)-   , strategy     = linearMixedStrategy-   } --quadraticExercise :: Exercise (OrList (Relation Expr))-quadraticExercise = makeExercise -   { exerciseId   = describe "solve a quadratic equation" $ -                       newId "algebra.equations.quadratic"-   , status       = Provisional-   , parser       = \input -> case parseExprWith (pOrList (pEquation pExpr)) input of-                                 Left err -> Left err-                                 Right xs -> Right (build (switchView equationView) xs)-   , similarity   = eqOrList cleanUpExpr-   , equivalence  = equivalentRelation (viewEquivalent quadraticEquationsView)-   , isSuitable   = (`belongsTo` (switchView equationView >>> quadraticEquationsView))-   , isReady      = solvedRelations-   , extraRules   = map use abcBuggyRules ++ buggyQuadratic ++-                    map use buggyRulesEquation ++ map use buggyRulesExpr -   , ruleOrdering = ruleOrderingWithId $ -                       quadraticRuleOrder ++ [getId buggySquareMultiplication]-   , strategy     = quadraticStrategy-   , navigation   = termNavigator-   , examples     = map (orList . return . build equationView) (concat quadraticEquations)-   }-   -higherDegreeExercise :: Exercise (OrList (Relation Expr))-higherDegreeExercise = makeExercise -   { exerciseId    = describe "solve an equation (higher degree)" $-                        newId "algebra.equations.polynomial"-   , status        = Provisional-   , parser        = parser quadraticExercise-   , similarity    = eqOrList cleanUpExpr-   , eqWithContext = Just $ eqAfterSubstitution $ -                        equivalentRelation (viewEquivalent higherDegreeEquationsView)-   , isSuitable    = (`belongsTo` (switchView equationView >>> higherDegreeEquationsView))-   , isReady       = solvedRelations-   , extraRules    = map use abcBuggyRules ++ buggyQuadratic ++-                     map use buggyRulesEquation ++ map use buggyRulesExpr -   , ruleOrdering = ruleOrderingWithId quadraticRuleOrder-   , strategy      = higherDegreeStrategy-   , navigation   = termNavigator-   , examples      = map (orList . return . build equationView) -                        (concat $ higherEq1 ++ higherEq2 ++ [higherDegreeEquations])-   }-   -quadraticNoABCExercise :: Exercise (OrList (Relation Expr))-quadraticNoABCExercise = quadraticExercise-   { exerciseId   = describe "solve a quadratic equation without abc-formula" $ -                       newId "algebra.equations.quadratic.no-abc"-   , status       = Alpha-   , 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       = Alpha-   , parser       = parseExprWith (pOrList (pRelation pExpr))-   , strategy     = configure cfg quadraticStrategy-   , equivalence  = 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       = parseExprWith pExpr-   , similarity   = \a b -> cleanUpExpr a == cleanUpExpr b-   , equivalence  = viewEquivalent (polyViewWith rationalView)-   , isReady      = (`belongsTo` linearFactorsView)-   , strategy     = findFactorsStrategy-   , navigation   = termNavigator-   , extraRules   = map liftToContext buggyRulesExpr-   , examples     = concat findFactors-   }--linearFactorsView :: View Expr (Bool, [(String, Expr, Expr)])-linearFactorsView = 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 ( normOrList cleanUpExpr -                         . fmap toApprox -                         . simplify quadraticEquationsView-                         ) . switch . fmap toEq-        in fromMaybe False $ liftM2 (==) (norm a) (norm b)-   | otherwise =-        equivalentRelation (viewEquivalent quadraticEquationsView) a b - where-   hasApprox = maybe False (any isApproximately) . disjunctions-   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 (Number . 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 <- switch (fmap (match equationView) ra)-   b <- switch (fmap (match equationView) rb)+-----------------------------------------------------------------------------
+-- 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)--eqOrList :: (Relational f, Ord (f Expr)) => -               (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr) -> Bool-eqOrList f x y = normOrList f x == normOrList f y--eqRelation :: (Relational f, Eq (f Expr)) => (Expr -> Expr) -> f Expr -> f Expr -> Bool-eqRelation f x y = fmap f x == fmap f y---- Normalize the order of disjunctions. Simplify the expression with the function--- passed as argument, but do not change (flip) the sides of the relation.-normOrList :: (Relational f, Ord (f Expr)) => -                 (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr)-normOrList f = normalize . fmap (fmap (normExpr f))--normExpr :: (Expr -> Expr) -> Expr -> Expr-normExpr f = rec . f- where-   plusOperator  = makeCommutative $ monoid -                      (makeBinary (getId plusSymbol) (+) isPlus)-                      (simpleConstant "zero" 0)-   timesOperator = makeCommutative $ monoid -                      (makeBinary (getId timesSymbol) (*) isTimes)-                      (simpleConstant "one" 1)-   make          = simplifyWith (map rec) . magmaListView-   -   rec expr = -      case expr of-         _ :+: _ -> make plusOperator  expr-         _ :*: _ -> make timesOperator expr-         _       -> descend rec expr
src/Domain/Math/Polynomial/Generators.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,16 +9,16 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.Math.Polynomial.Generators 
+module Domain.Math.Polynomial.Generators
    ( polynomialGen, polynomialDegreeGen
-   , cubicGen, quadraticGen, linearGen 
+   , cubicGen, quadraticGen, linearGen
    ) where
 
-import Prelude hiding ((^))
+import Control.Monad
 import Domain.Math.Expr
 import Domain.Math.Numeric.Generators
+import Prelude hiding ((^))
 import Test.QuickCheck
-import Control.Monad
 
 polynomialGen :: Int -> Gen Expr
 polynomialGen n = do
@@ -30,8 +30,8 @@ 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) 
+   | n==0 && d==1 = return (Var "x")
+   | n==0         = return (Var "x" ^ fromIntegral d)
    | otherwise    = oneof $
         [ timesGen, plusGen
         , liftM2 (:/:) (rec d) ratGenNZ
@@ -42,17 +42,17 @@       d1 <- choose (0, d)
       a <- rec d1
       b <- rec d
-      oneof $ map return [a :+: b, b :+: a, a :-: b, b :-: a, Negate b]
+      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 <- oneof [ return i | i <- [2..d], d `mod` i == 0 ]
+      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
src/Domain/Math/Polynomial/IneqExercises.hs view
@@ -1,336 +1,306 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Context-import Common.Exercise-import Common.Rewriting-import Common.Strategy hiding (not)-import Common.Transformation-import Common.Uniplate (descend)-import Common.View-import Control.Monad-import Data.List (nub, sort)-import Data.Maybe (fromMaybe)-import Domain.Math.Data.Interval-import Domain.Logic.Formula (Logic((:||:), (:&&:)), catLogic)-import Domain.Math.Clipboard-import Domain.Math.Data.OrList-import Domain.Math.Data.Relation-import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus)-import Domain.Math.Polynomial.Exercises (eqRelation, normExpr)-import Domain.Math.Equation.Views-import Domain.Math.Examples.DWO2-import Domain.Math.Expr-import Domain.Math.Numeric.Views-import Domain.Math.Polynomial.CleanUp-import Domain.Math.Polynomial.Rules -import Domain.Math.Polynomial.Strategies-import Domain.Math.Polynomial.Equivalence-import Domain.Math.SquareRoot.Views-import Prelude hiding (repeat)-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       = parseExprWith (pRelation pExpr)-   , isReady      = solvedRelation-   , equivalence  = linEq-   , similarity   = eqRelation cleanUpExpr-   , strategy     = ineqLinear-   , navigation   = termNavigator-   , examples     = let x = Var "x"-                        extra = (x-12) / (-2) :>: (x+3)/3-                    in 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        = parseExprWith (pLogicRelation pExpr)-   , prettyPrinter = showLogicRelation-   , isReady       = solvedRelations-   , eqWithContext = Just quadrEqContext-   , similarity    = simLogic (fmap (normExpr cleanUpExpr) . flipGT)-   , strategy      = ineqQuadratic-   , navigation    = termNavigator-   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder-   , examples      = 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        = parseExprWith (pLogicRelation pExpr)-   , prettyPrinter = showLogicRelation-   , isReady       = solvedRelations-   , eqWithContext = Just highEqContext-   , similarity    = simLogic (fmap (normExpr cleanUpExpr) . flipGT)-   , strategy      = ineqHigherDegree-   , navigation    = termNavigator-   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder-   , examples      = map (Logic.Var . build inequalityView) ineqHigh-   }--ineq :: String-ineq = "algebra.inequalities"--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 = cleanUpStrategy (applyTop (fmap cleanUpSimple)) ineqLinearG--ineqLinearG :: IsTerm a => LabeledStrategy (Context a)-ineqLinearG = label "Linear inequation" $-   label "Phase 1" (repeat -       (  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 = cleanUpStrategy (applyTop cleanUpLogicRelation) $ -   label "Quadratic inequality" $ -      use trivialRelation-       |> try (useC turnIntoEquation) -      <*> quadraticStrategyG-      <*> useC solutionInequation--ineqHigherDegree :: LabeledStrategy (Context (Logic (Relation Expr)))-ineqHigherDegree = cleanUpStrategy (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 idempotent 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-   removeClipboard "ineq"-   orv  <- maybeCM (matchM orListView r)-   case disjunctions orv of -      Nothing -> -- both sides are the same-         if relationType inEquation `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]-         then return Logic.T-         else return Logic.F-      Just [] -> do -- no solutions found for equations-         let vs = vars (toExpr inEquation)-         guard (not (null vs))-         if evalIneq inEquation (head vs) 0-            then return Logic.T -            else return Logic.F-      Just 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 = relationType inEquation `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]-         return $ fromIntervals v fromDExpr $ -            fromList [ 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, singleton 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 (evalType (relationType r)) (useSide leftHandSide) (useSide rightHandSide)-    where-      useSide f = match doubleView (sub (f r))-      -      evalType tp =-         case tp of -            EqualTo              -> (==)-            NotEqualTo           -> (/=)-            LessThan             -> (<)-            GreaterThan          -> (>)-            LessThanOrEqualTo    -> (<=)-            GreaterThanOrEqualTo -> (>=)-            Approximately        -> \a b -> abs (a-b) < 0.001-      -      sub (Var x) | x==v = Number 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+-----------------------------------------------------------------------------
+-- 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-  -fromIntervals :: Eq a => String -> (a -> Expr) -> Intervals a -> Logic (Relation Expr)-fromIntervals v f = ors . map (fromInterval v f) . toList- where-   ors [] = Logic.F-   ors xs = foldr1 (:||:) xs-   -fromInterval :: Eq a => String -> (a -> Expr) -> Interval a -> Logic (Relation Expr)-fromInterval v f i -   | isEmpty i = Logic.F-   | otherwise = -        case (leftPoint i, rightPoint i) of-           (Unbounded, Unbounded) -> Logic.T-           (Unbounded, Including b) -> Logic.Var (Var v .<=. f b)-           (Unbounded, Excluding b) -> Logic.Var (Var v .<. f b)-           (Including a, Unbounded) -> Logic.Var (Var v .>=. f a)-           (Excluding a, Unbounded) -> Logic.Var (Var v .>. f a)-           (Including a, Including b) -              | a == b    -> Logic.Var (Var v .==. f a)-              | otherwise -> Logic.Var (Var v .>=. f a) :&&: Logic.Var (Var v .<=. f b) -           (Including a, Excluding b) -> Logic.Var (Var v .>=. f a) :&&: Logic.Var (Var v .<. f b) -           (Excluding a, Including b) -> Logic.Var (Var v .>. f a) :&&: Logic.Var (Var v .<=. f b) -           (Excluding a, Excluding b) -> Logic.Var (Var v .>. f a) :&&: Logic.Var (Var v .<. f b)
src/Domain/Math/Polynomial/LeastCommonMultiple.hs view
@@ -1,138 +1,138 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Prelude hiding ((^))-import Common.TestSuite-import Common.View-import Control.Monad-import Data.List-import Data.Ratio-import Data.Maybe-import Domain.Math.Expr-import Domain.Math.Numeric.Views-import Domain.Math.Power.Views-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 <- oneof $ map (return . 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 +-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,166 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,313 +1,273 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Classes-import Common.Context-import Common.Exercise-import Common.Navigator-import Common.Rewriting-import Common.Strategy hiding (not)-import Common.Uniplate-import Common.Utils (fst3)-import Common.View-import Control.Monad-import Data.List hiding (repeat, replicate)-import Data.Maybe-import Domain.Logic.Formula hiding (disjunctions, Var)-import qualified Domain.Logic as Logic-import qualified Domain.Logic.Views as Logic-import Domain.Logic.Views hiding (simplify)-import Domain.Math.Clipboard-import Domain.Math.Data.OrList-import Domain.Math.Data.Relation-import Domain.Math.Equation.CoverUpRules-import Domain.Math.Equation.Views-import Domain.Math.Examples.DWO4-import Domain.Math.Expr-import Domain.Math.Numeric.Views-import Domain.Math.Polynomial.CleanUp-import Domain.Math.Polynomial.Exercises (eqOrList)-import Domain.Math.Polynomial.LeastCommonMultiple-import Domain.Math.Polynomial.RationalRules-import Domain.Math.Polynomial.Rules-import Domain.Math.Polynomial.Strategies-import Domain.Math.Polynomial.Views-import Domain.Math.SquareRoot.Views-import Domain.Math.Power.OldViews-import Prelude hiding (repeat, replicate, until, (^))-import qualified Data.Set as S--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        = parseExprWith (pOrList (pEquation pExpr))-   , isSuitable    = isJust . rationalEquations-   , isReady       = solvedRelations-   , eqWithContext = Just eqRationalEquation-   , similarity    = eqOrList cleanUpExpr-   , strategy      = rationalEquationStrategy-   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder-   , navigation    = termNavigator-   , examples      = map return (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 -- Provisional-   , parser        = parseExpr--- isSuitable-   , isReady       = simplifiedRational-   -- , eqWithContext = Just eqSimplifyRational-   , similarity    = \x y -> cleanUpExpr x == cleanUpExpr y-   , strategy      = simplifyRationalStrategy-   , ruleOrdering  = ruleOrderingWithId quadraticRuleOrder-   , navigation    = termNavigator-   , examples      = 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     = 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" $ until 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 crush . crush) .  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" $-      until isDivC $ -         use fractionPlus <|> use fractionScale <|> use turnIntoFraction-   phaseSimplerDiv = label "Simplify division" $-      repeat $-         (onlyLowerDiv findFactorsStrategyG <|> somewhere (useC cancelTermsDiv)-            <|> commit (onlyUpperDiv (repeat 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).-commit :: IsStrategy f => f (Context Expr) -> Strategy (Context Expr)-commit 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 = maybe (return true) f . disjunctions- where -   f xs = do -      yss <- mapM rationalEquation xs-      return (join (orList yss))- -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 $ orList $ map (:==: 0) as-   return (restrictOrList condition new1)--restrictOrList :: Logic (Relation Expr) -> OrList Expr -> OrList Expr-restrictOrList p0 = maybe true (orList . filter p) . disjunctions- where-   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 T-         (False, EqualTo)    -> return F -         (True,  NotEqualTo) -> return F-         (False, NotEqualTo) -> return T-         _ -> 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-      ys <- disjunctions (restrictOrList (f ctx) xs)-      return (sort (nub ys))-   -eqSimplifyRational :: Context Expr -> Context Expr -> Bool-eqSimplifyRational ca cb = fromMaybe False $ do-   a <- fromContext ca-   b <- fromContext cb-   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 (manyVars || 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)---------------------- test code--{--raar = brokenExpr $ x^2/(5*x+6) + 1- where x = Var "x"---go0 = checkExercise rationalEquationExercise--go = checkExercise simplifyRationalExercise--see n = printDerivation ex (examples ex !! (n-1))- where ex = --rationalEquationExercise  -            simplifyRationalExercise-      -go4 = printDerivation findFactorsExercise $ -a + 4- where x = Var "x"-       a = Var "a"-       -test = e4- where -   a  = Var "a"-   b  = Var "b"-   -   e1 = 6*a*b*a-   e2 = -4*b^2*a*2-   e3 = lcmExpr e1 e2-   e4 = divisionExpr e3 e1-   e5 = divisionExpr e3 e2-   -go = putStrLn $ unlines $ map show $ zip [1..] $ map (brokenEq []) (concat brokenEquations)--}+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,186 +1,182 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Context-import Common.Id-import Common.Transformation-import Common.View-import Control.Monad-import Data.Maybe-import Domain.Logic.Formula hiding (disjunctions, Var)-import Domain.Logic.Views-import Domain.Math.Clipboard-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.CleanUp-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 $ orList [a1 :==: 0, 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 >>> (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) . nott-   eq = expr :==: 0-   xs = fmap (build equationView . fmap cleanUpExpr) $ -        case match higherDegreeEquationsView (return eq) of-           Just ys -> build orListView (coverUpOrs (build higherDegreeEquationsView ys))+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,592 +1,610 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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, distributeDivision-   , distributeTimes, distributionSquare, exposeSameFactor, factorLeftAsSquare-   , factorVariablePower, flipEquation, higherSubst, merge, moveToLeft, mulZero-   , niceFactors, niceFactorsNew, noDivisionConstant, noLinFormula, oneVar-   , parentNotNegCheck, prepareSplitSquare, quadraticRuleOrder, removeDivision-   , ruleApproximate, ruleNormalizeMixedFraction, ruleNormalizeRational-   , sameFactor, simplerLinearFactor, simplerPolynomial, simplerSquareRoot-   , squareBothSides, substBackVar, varToLeft-   ) where--import Common.Library hiding (terms, simplify)-import Common.Uniplate (universe, descend)-import Common.Utils-import Control.Monad-import Data.List-import Data.Maybe-import Data.Ord-import Data.Ratio-import Domain.Math.Approximation (precision)-import Domain.Math.Clipboard-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.CleanUp-import Domain.Math.Polynomial.Views-import Domain.Math.Power.OldViews-import Domain.Math.Simplification hiding (simplifyWith)-import Domain.Math.SquareRoot.Views -import Prelude hiding ( (^) )--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 (b /= 0 && c == 0)-      -- also search for constant factor-      let d | a<0 && b<0 = -gcdFrac a b-            | otherwise  = 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 thisView $ -   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)- where-   thisView = polyNormalForm rationalView >>> swapView >>> first quadraticPolyView- --- Simplified variant of simplerPoly: just bring a to 1.--- Needed for quadratic strategy without square formula-bringAToOne :: Rule (Equation Expr)-bringAToOne = rhsIsZero $ liftRuleIn thisView $ -   describe "Bring 'a' to one" $ -   makeSimpleRule (quadreq, "scale") $ \(a, b, c) -> do-   guard (a `notElem` [0, 1])-   return (1, b/a, c/a)- where-   thisView = polyNormalForm rationalView >>> swapView >>> first quadraticPolyView----------------------------------------------------------------- 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 $ orList $ 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---- Do not simplify (5+sqrt 53)/2-simplerSquareRoot :: Rule Expr-simplerSquareRoot = describe "simpler square root" $ -   makeSimpleRule (quadreq, "simpler-sqrt") $ \e -> do-      xs <- f e-      guard (not (null xs))-      new <- canonical (squareRootViewWith rationalView) e-      ys <- f new-      guard (xs /= ys)-      return new- where-   -- 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)---- Two out of three "merkwaardige producten"-distributionSquare :: Rule Expr-distributionSquare = describe "distribution square" $-   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^2 == b^2-squareBothSides :: Rule (OrList (Equation Expr))-squareBothSides = describe "square both sides" $ -   rule (quadreq, "square-both") $ \a b -> -   orList [a^2 :==: b^2] :~> orList [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 = doBeforeTrans condition $-   describe "flip equation" $-   rule (lineq, "flip") $ \a b ->-      (a :==: b) :~> (b :==: a)- where-   condition = makeTrans $ \eq@(lhs :==: rhs) -> do-      guard (hasSomeVar rhs && hasNoVar lhs)-      return eq---- 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---------------------------------------------------------------------- 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 $ orList [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)-   return $ Var s .^. fromIntegral n * build myView (s, raise (-n) p)---- 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 $ orList [ 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 (sumView >>> listView 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 $ return $ -         Var x :==: (-fromRational b) / (2 * fromRational a)-      GT -> return $ orList-         [ 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 productView) $ -   makeSimpleRuleList (polyeq, "expose-factor") $ \((bx, xs) :==: (by, ys)) -> do -      (nx, ny) <- [ (xs, new) | x <- xs, suitable x, new <- exposeList x ys ] ++-                  [ (new, ys) | y <- ys, suitable y, new <- exposeList y xs ]-      return ((bx, nx) :==: (by, ny))- where-   suitable 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 division 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 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 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)-      case mapMaybe f (concat zs) of-         [] -> Nothing-         ps -> let (bs, ns) = unzip ps-               in if or bs then return (fromInteger (foldr1 lcm ns))-                           else Nothing--distributeTimes :: Rule Expr-distributeTimes = describe "distribution multiplication" $ -   makeSimpleRuleList (lineq, "distr-times") $-      liftM collectLikeTerms . applyAll distributionT--distributeDivision :: Rule Expr-distributeDivision = describe "distribution division" $-   makeSimpleRule (quadreq, "distr-div") $ \expr -> do-      (xs, r) <- match (divView >>> (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 new = collectLikeTerms old-          f = maybe 0 length . match sumView-      guard (f old > 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 /= 1 && d /= -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 = makeSimpleRuleList s $ \a -> do-   b <- canonicalM 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-   -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))+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,183 +1,194 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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-   ) where--import Prelude hiding (repeat, replicate, fail)-import Common.Strategy-import Common.Navigator-import Common.Id-import Common.Uniplate (transform)-import Common.View-import Common.Context-import Domain.Math.Equation.CoverUpRules hiding (coverUpPlus)-import Domain.Math.Polynomial.Rules-import Domain.Math.Numeric.Views-import Domain.Math.Data.OrList-import Domain.Math.Data.Relation-import Domain.Math.Expr-import Domain.Math.Polynomial.CleanUp-import Data.Maybe-import Common.Rewriting----------------------------------------------------------------- Linear equations--linearStrategy :: LabeledStrategy (Context (Equation Expr))-linearStrategy = cleanUpStrategy (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 cleanUpStrategy f (configureNow (configure cfg linearStrategyG))--linearStrategyG :: IsTerm a => LabeledStrategy (Context a)-linearStrategyG =-   label "Linear Equation" $-       label "Phase 1" (repeat (-               use removeDivision-          <|>  multi (showId distributeTimes) (somewhere (useC parentNotNegCheck <*> use distributeTimes))-          <|>  multi (showId merge) (once (use merge))))-   <*> label "Phase 2" (repeat (-              (use flipEquation |> use varToLeft)-          <|> use (coverUpPlusWith oneVar) -          <|> use (coverUpMinusLeftWith oneVar)-          <|> use (coverUpMinusRightWith oneVar)-          <|> use coverUpTimes -          <|> use coverUpNegate-           ))-   <*> repeat (once -          (  use ruleNormalizeRational-         <|> remove (use ruleNormalizeMixedFraction)-          ))-   ---------------------------------------------------------------- Quadratic equations--quadraticStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))-quadraticStrategy = -   cleanUpStrategy (applyTop cleanUpRelations) quadraticStrategyG--quadraticStrategyG :: IsTerm a => LabeledStrategy (Context a)-quadraticStrategyG = -   label "Quadratic Equation Strategy" $ repeat $-   -- 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" (-         multi (showId simplerSquareRoot) (somewhere (use simplerSquareRoot)))-      <|> -      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))-        <|> multi (showId distributeDivision) (somewhere -               (once (use distributeDivision)))-        <|> somewhere (use flipEquation)-         )-      |> somewhere (use moveToLeft <|> remove (use prepareSplitSquare))---------------------------------------------------------------- Higher degree equations--higherDegreeStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))-higherDegreeStrategy = -   cleanUpStrategy (applyTop cleanUpRelations) higherDegreeStrategyG--higherDegreeStrategyG :: IsTerm a => LabeledStrategy (Context a)-higherDegreeStrategyG = label "higher degree" $ -   higherForm -   <*> label "quadratic"  quadraticStrategyG-   <*> afterSubst- where-   higherForm = label "higher degree form" $ repeat $-      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  <*> repeat (somewhere (use coverUpPower)) ---------------------------------------------------------------- Finding factors in an expression--findFactorsStrategy :: LabeledStrategy (Context Expr)-findFactorsStrategy = cleanUpStrategy (applyTop cleanUpSimple) $-   label "find factors" $ replicate 10 $ try 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,104 +1,23 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.TestSuite-import Common.View-import Domain.Math.Polynomial.Generators-import Domain.Math.Polynomial.Views-import Domain.Math.Numeric.Views-import Domain.Math.Numeric.Laws-import Test.QuickCheck----------------------------------------------------------------- Testing instances--tests :: TestSuite-tests = do -   let v = viewEquivalent (polyViewWith rationalView)-   testNumLawsWith v "polynomial" (sized polynomialGen)---- see the derivations for the DWO exercise set-{--seeLE  n = printDerivation linearExercise $ concat linearEquations !! (n-1)-seeQE  n = printDerivation quadraticExercise $ orList $ return $ build equationView $ concat quadraticEquations !! (n-1)-seeHDE n = printDerivation higherDegreeExercise $ orList $ return $ build equationView $ higherDegreeEquations !! (n-1)---- test strategies with DWO exercise set-{--testLE  = concat $ zipWith (f linearExercise)       [1..] $ concat linearEquations-testQE  = concat $ zipWith (f quadraticExercise)    [1..] $ map (orList . return . build equationView) $ concat quadraticEquations-testHDE = concat $ zipWith (f higherDegreeExercise) [1..] $ map (orList . return . build equationView) higherDegreeEquations--}-f :: (Show b, Show a) => Exercise a -> b -> a -> [b]-f s n e = map p (g (applyAll (strategy s) (inContext s e))) where-  g xs | null xs   = error $ show n ++ ": " ++ show e-       | otherwise = xs-  p a  | maybe False (isReady s) (fromContext a) = n-       | otherwise = error $ show n ++ ": " ++ show e ++ "  =>  " ++ maybe "??" show (fromContext a)-       -randomLE = quickCheck $ forAll (liftM2 (:==:) (sized linearGen) (sized linearGen)) $ \eq -> -   (>0) (sum (take 10 $ f linearExercise 1 eq))-randomQE = quickCheck $ forAll (liftM2 (:==:) (sized quadraticGen) (sized quadraticGen)) $ \eq -> -   (>0) (sum (take 10 $ f quadraticExercise 1 (orList [build equationView eq])))--{--eqLE = concat $ zipWith (g linearExercise) [1..] $ concat linearEquations  -eqQE = concat $ zipWith (g quadraticExercise) [1..] $ map (orList . return) $ concat quadraticEquations-eqHDE = concat $ zipWith (g higherDegreeExercise) [1..] $ map (orList . return) higherDegreeEquations--g s n e = map p (h (derivations (derivationTree (strategy s) (inContext e)))) where-  h xs | null xs   = error $ show n ++ ": " ++ show e-       | otherwise = xs-  p (a, xs) = case [ (x, y) | x <- ys, y <- ys, Prelude.not (equivalence s x y) ] of-                 [] -> let l = length xs in l*l-                 (x, y):_ -> error $ show n ++ ": " ++ show x ++ "   is not   " ++ show y-   where ys = map fromContext (a : map snd xs)--}-   --- e1 = match higherDegreeEquationsView $ OrList [(x :==: 2)] where x = Var "x"--- e2 = simplify rationalView (Sqrt ())---- goLE = eqTest ineqLinearExercise-goQE = eqTest ineqQuadraticExercise----eqTest :: Exercise a -> IO ()-eqTest ex =-   forM_ (examples ex) $ \eq -> do-      let tree  = derivationTree (strategy ex) (inContext ex eq)-      forM_ (derivations tree) $ \d -> do-         let xs = terms d-             pp = maybe "??" (prettyPrinter ex) . fromContext-         forM [ (a, b) | a <- xs, b <- xs ] $ \(a, b) ->-            if equalityIneq a b -- equivalence ex (fromContext a) (fromContext b)-             then putChar '.' -             else error $ unlines ["", pp a, pp b]--equalityIneq :: Context (Logic (Relation Expr)) -> Context (Logic (Relation Expr)) -> Bool-equalityIneq ca cb = fromMaybe False $-   liftM2 (equivalence ineqQuadraticExercise) (f ca) (f cb)- where-   f = fmap g . fromContext-   g | any clipboardHasIneq [ca,cb] = turnIntoEqualTo-     | otherwise                    = id--clipboardHasIneq :: Context a -> Bool-clipboardHasIneq = isJust . evalCM (\_ -> lookupClipboard "ineq")--turnIntoEqualTo :: Logic (Relation a) -> Logic (Relation a)-turnIntoEqualTo = g . fmap (\rel -> -   leftHandSide rel .==. rightHandSide rel)- where-   -- temporary fix-   g (p :&&: q) = g p :&&: g q-   g (p :||: q) = g p :||: g q-   g p          = p -}+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,323 +1,334 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 -- polyViewFor, polyViewForWith-   , quadraticView, quadraticViewWith --, quadraticViewFor quadraticViewForWith-   , linearView, linearViewWith -- linearViewFor linearViewForWith-   , constantPolyView, linearPolyView, quadraticPolyView, cubicPolyView-   , monomialPolyView, binomialPolyView, trinomialPolyView-   , polyNormalForm-   , linearEquationView, quadraticEquationView, quadraticEquationsView-   , higherDegreeEquationsView-   ) where--import Prelude hiding ((^))-import Control.Monad-import Common.View-import Common.Classes-import Common.Rewriting-import Common.Uniplate (transform, descend, children)-import Common.Utils (distinct)-import Domain.Math.Data.Polynomial-import Domain.Math.Data.Relation-import Domain.Math.Data.OrList-import Domain.Math.Expr-import Domain.Math.Numeric.Views-import Domain.Math.Polynomial.CleanUp-import Domain.Math.Equation.CoverUpRules-import Data.Maybe-import qualified Domain.Math.Data.SquareRoot as SQ-import Domain.Math.SquareRoot.Views-import Domain.Math.Power.OldViews (powerFactorViewForWith)------------------------------------------------------------------------ Polynomial view--polyView :: View Expr (String, Polynomial Expr)-polyView = polyViewWith identity--polyViewWith :: Fractional a => View Expr a -> View Expr (String, Polynomial a)-polyViewWith v = makeView matchPoly (uncurry buildPoly)- where-   matchPoly expr = do -      pv <- selectVar expr-      p  <- matchPolyFor pv expr-      return (pv, 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-            c <- match v b-            guard (c /= 0)-            guard (withoutVar pv b)-            p <- f a-            return (fmap (/c) p)-         Sym s [a, n] | isPowerSymbol s ->-           liftM2 power (f a) (matchNat n)-         _ -> do -            guard (withoutVar pv expr)-            liftM con (match v expr)-    where-      f = matchPolyFor pv-   -   buildPoly pv = -      let f (a, n) = build v a .*. (Var pv .^. fromIntegral n)-      in build sumView . map f . reverse . terms-   -   -   matchNat expr = do-      n <- match integralView expr-      guard (n >= 0)-      return n------------------------------------------------------------------------ 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 >>> makeView f g- where-   f (s, (a, b, c)) = return (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 >>> makeView f g- where-   f (s, (a, b)) = return (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 = foldl1 (+) (map f as)- where-   f (a, n) = con a * power var 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 = sumView >>> listView (powerFactorViewForWith pv v)--polyNormalForm :: Num a => View Expr a -> View Expr (String, Polynomial a)-polyNormalForm v = makeView f (uncurry g)- where-   f e = do-      pv <- selectVar e-      xs <- match (listOfPowerFactors pv v) e-      guard (distinct (map snd xs))-      return (pv, buildPairs xs)-   g pv = build (listOfPowerFactors pv v) . reverse . terms-   ----------------------------------------------------------------------- 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 eq = do -      ors <- switch (fmap (match quadraticEquationView) eq)-      return (normalize (join ors))--   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 $ orList [-b/twoA]-                  GT   -> return $ orList [(-b+sdiscr)/twoA, (-b-sdiscr)/twoA]-            [a, b]     -> return $ orList [-b/a]-            [a] | a==0 -> return true-            _          -> return false-   -   g ors = -      case disjunctions ors of-         Nothing -> 0 :==: 0-         Just xs -> -            let make (x, a) = Var x .-. build (squareRootViewWith rationalView) a-            in build productView (False, map make xs) :==: 0--higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr)-higherDegreeEquationsView = makeView f (fmap (:==: 0))- where-   f    = Just . normalize . join . fmap make . coverUpOrs-   make = orList . 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) -> scale y (power var 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,356 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,101 +1,114 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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-   ) where--import Prelude hiding ( (^) )--import Common.Context-import Common.Exercise-import Common.View-import Domain.Math.Data.OrList-import Domain.Math.Data.Relation-import Domain.Math.Equation.Views-import Domain.Math.Examples.DWO4-import Domain.Math.Expr hiding (isPower)-import Domain.Math.Numeric.Views-import Domain.Math.Power.Rules-import Domain.Math.Power.Equation.Strategies-import Domain.Math.Power.Equation.NormViews------------------------------------------------------------------ Exercises--powerEqExercise :: Exercise (Relation Expr)-powerEqExercise = let precision = 2 in makeExercise-  { status         = Provisional-  , parser         = parseExprWith (pRelation pExpr)-  , strategy       = powerEqApproxStrategy-  , navigation     = termNavigator-  , exerciseId     = describe "solve power equation algebraically with x > 0" $ -                       newId "algebra.manipulation.exponents.equation"-  , examples       = concatMap (map $ build equationView) $ -                       powerEquations ++ [last higherPowerEquations]-  , isReady        = solvedRelation-  , isSuitable   = (`belongsTo` (normPowerEqApproxView precision))-  , equivalence    = viewEquivalent (normPowerEqApproxView precision)-  }-  -expEqExercise :: Exercise (Equation Expr)-expEqExercise = makeExercise-  { status         = Provisional-  , parser         = parseExprWith (pEquation pExpr)-  , strategy       = expEqStrategy-  , navigation     = termNavigator-  , exerciseId     = describe "solve exponential equation algebraically" $ -                       newId "algebra.manipulation.exponential.equation"-  , examples       = concat expEquations-  , isReady        = \ rel -> isVariable (leftHandSide rel) -                           && rightHandSide rel `belongsTo` rationalView-  , isSuitable     = (`belongsTo` normExpEqView)-  , equivalence    = viewEquivalent normExpEqView-  , ruleOrdering   = ruleOrderingWithId [ getId root2power ]  -  }--logEqExercise :: Exercise (OrList (Relation Expr))-logEqExercise = makeExercise-  { status         = Provisional-  , parser         = parseExprWith (pOrList (pRelation pExpr))-  , strategy       = logEqStrategy-  , navigation     = termNavigator-  , exerciseId     = describe "solve logarithmic equation algebraically" $ -                       newId "algebra.manipulation.logarithmic.equation"-  , examples       = map (orList . return . build equationView) (concat logEquations)-  , isReady        = solvedRelations-  , isSuitable     = (`belongsTo` (switchView equationView >>> normLogEqView))-  , equivalence    = viewEquivalent (switchView equationView >>> normLogEqView)-  , ruleOrdering   = ruleOrderingWithId [ getId calcPower-                                        , getId calcRoot ]-  }--higherPowerEqExercise :: Exercise (OrList (Equation Expr))-higherPowerEqExercise = makeExercise-  { status         = Provisional-  , parser         = parseExprWith (pOrList (pEquation pExpr))-  , strategy       = higherPowerEqStrategy-  , navigation     = termNavigator-  , exerciseId     = describe "solve higher power equation algebraically" $ -                       newId "algebra.manipulation.exponents.equation"-  , examples       = map (orList . return) $ concat $ init higherPowerEquations-  , isReady        = solvedRelations-  , isSuitable     = maybe False and . disjunctions . fmap (`belongsTo` normPowerEqView)-  , equivalence    = let f = normalize . fmap (simplify normPowerEqView')-                     in \ x y -> f x == f y-  , ruleOrdering   = ruleOrderingWithId [ getId calcPower-                                        , getId calcRoot ]+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,215 +1,204 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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-   , normPowerEqView-   , normExpEqView-   , normLogEqView---   , normLogView-   ) -} where--import Common.Classes-import Common.View-import Common.Rewriting hiding (rewrite)-import Control.Arrow ( (>>^) )-import Control.Monad-import Data.List-import Data.Maybe-import Data.Ratio-import Domain.Math.Approximation-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.CleanUp-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 Common.Uniplate---- Change to configurable strategy!-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 expr >>= constRight-      -- match power-      (c, ax)        <- match (timesView <&> (identity >>^ (,) 1)) $-                          simplify normPowerView lhs-      (a, x)         <- match myPowerView ax-      -- simplify, scale and take root-      let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x)-      return (a, simplify rationalView y)--    myPowerView =  powerView -               <&> (rootView >>> second (makeView (\a->Just (1 ./. a)) (1 ./.)))-               <&> (identity >>^ \a->(a,1))--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 expr >>= constRight-      -- match power-      (c, (a, x))    <- match unitPowerView lhs-      -- simplify, scale and take root-      let y = cleanUpExpr $ (rhs ./. c) .^. (1 ./. x)-      return (a, simplify myRationalView y)--constRight :: Equation Expr -> Maybe (Equation Expr)-constRight (lhs :==: rhs) = do-  (vs, cs) <- fmap (partition hasSomeVar) (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 :: Equation Expr -> Maybe (Equation Expr)-varLeft (lhs :==: rhs) = do-  (vs, cs) <- fmap (partition hasSomeVar) (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 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 . switch . fmap f) id  -- AG: needs to be replaced by higherOrderEqView-  where-    f expr@(lhs :==: rhs) = return $-      case match logView lhs of-        Just (b, x) -> x :==: simplify myRationalView (b .^. rhs)-        Nothing     -> expr-    g = fmap (fmap (simplify myRationalView) . simplify normPowerEqView) -      . simplify quadraticEquationsView ---- liftToOrListView :: View a b -> View (OrList a) (OrList b)--- liftToOrListView v = makeView (switch . fmap (match v)) ()--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     -> Nat 0-        Nat n     -          | n == b    -> Nat 1-          | otherwise -> maybe (logBase (fromInteger b) (fromInteger n)) Nat -                       $ 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--myRationalView :: View Expr Rational-myRationalView = makeView (return . rewrite simplerPower) id >>> rationalView--simplerPower :: Expr -> Maybe Expr-simplerPower expr = -  case expr of      -    Sqrt x -> simplerPower $ x .^. (1/2)-    Sym s [x, y]-      | isRootSymbol s  -> simplerPower $ x .^. (1/y)-      | isPowerSymbol s -> f-      | otherwise -> Nothing-        where f | y == 0 || x == 1 = Just 1-                | y == 1 = Just x-                | x == 0 = Just 0-                | otherwise =-                  -- geheel getal-                  liftM fromRational (match rationalView expr) -                  `mplus`-                  -- wortel-                  do -                    ry <- match rationalView y-                    rx <- match rationalView x-                    guard $ numerator ry == 1 && denominator rx == 1-                    liftM fromInteger $ takeRoot (numerator rx) (denominator ry)-                  `mplus`-                  -- (a/b)^y -> a^x/b^y-                  do-                    (a, b) <- match divView x-                    return $ build divView (a .^. y, b .^. y)-    _ -> Nothing---- myRationalView = makeView (exprToNum f) id >>> rationalView---   where---     f s [x, y] ---       | isDivideSymbol s = ---           fracDiv x y---       | isPowerSymbol s = do---           ry <- match rationalView y---           rx <- match rationalView x---           if      ry == 0 then return 1                      -- 0---           else if ry == 1 then return rx                     -- 1---           else if denominator ry == 1 then            -- geheel getal---             let a = x Prelude.^ abs (numerator ry)---             in return $ if numerator ry < 0 then 1 / a else a---           else if numerator ry == 1 then              -- breuk / root---             if denominator ry > 1 then ---               if denominator rx == 1 then---                 takeRoot (numerator rx) (denominator ry)   -- breuk/root---               else---                 f powerSymbol [numerator rx, ] / f powerSymbol []---             else---               take---           else                                       -- no calculation---       | isRootSymbol s = do---           n <- match integerView y---           b <- match integerView x---           liftM fromInteger $ lookup b $ map swap (allPowers n)---     f _ _ = Nothing-+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,123 +1,136 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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-  ) where--import Common.Transformation-import Common.Rewriting-import Common.View hiding (simplify)-import Control.Monad-import Domain.Math.Approximation (precision)-import qualified Domain.Math.Data.PrimeFactors as PF-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 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)))---- -- root a x = b  =>  a = b^x--- nthPower :: Rule (Equation Expr)--- nthPower = makeSimpleRule (powereq, "nth-power") $ \(lhs :==: rhs) -> do---   guard $ hasSomeVar lhs---   (a, x) <- match rootView lhs---   return $ a :==: rhs .^. 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 .~=.) . Number . precision n-    f (d :==: Var x) = -      match doubleView d >>= Just . (.~=. Var x) . Number . precision n-    f _              = Nothing---- -- a*x + c = b*y + d  =>  a*x - b*y = d - c   (move vars to the left, cons to the right)--- varLeftConRight :: Rule (Equation Expr)--- varLeftConRight = makeSimpleRule (powereq, "var-left-con-right") $ ---   \(lhs :==: rhs) -> do---     (xs, cs) <- fmap (partition hasSomeVar) (match sumView lhs)---     (ys, ds) <- fmap (partition hasSomeVar) (match sumView rhs)---     guard $ length cs > 0 || length ys > 0---     return $ fmap collectLikeTerms $ +-----------------------------------------------------------------------------
+-- 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)---- 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--- this reciprocal rule is more strict, it demands a same base on the lhs--- of the equation. Perhaps do this via the enviroment?-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-
src/Domain/Math/Power/Equation/Strategies.hs view
@@ -1,115 +1,135 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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 Prelude hiding (repeat, not)--import Common.Classes-import Common.Context-import Common.Id-import Common.Navigator-import Common.Rewriting-import Common.Strategy-import Common.View (belongsTo)-import Control.Arrow-import Data.Maybe-import Domain.Math.Data.Relation-import Domain.Math.Data.OrList-import Domain.Math.Expr-import Domain.Math.Equation.CoverUpExercise-import Domain.Math.Equation.CoverUpRules-import Domain.Math.Polynomial.CleanUp-import Domain.Math.Polynomial.Strategies (quadraticStrategy, linearStrategy)-import Domain.Math.Polynomial.Rules (flipEquation)-import Domain.Math.Power.Rules-import Domain.Math.Power.Utils-import Domain.Math.Power.Equation.Rules-import Domain.Math.Numeric.Rules---- | Strategies -----------------------------------------------------------------powerEqStrategy :: IsTerm a => LabeledStrategy (Context a)-powerEqStrategy = cleanUpStrategy clean strat-  where-    strat =  label "Power equation" $ repeat-          $  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-         <*> repeat (somewhereNotInExp (use factorAsPower))-         <*> repeat (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"-              $  use logarithm-             <*> try (use flipEquation)-             <*> repeat (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------ | Help functions -------------------------------------------------------------myCoverUpStrategy :: IsTerm a => Strategy (Context a)-myCoverUpStrategy = repeat $ alternatives $ map use coverUpRules--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+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,482 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,132 +1,159 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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.Classes -import Common.Context-import Common.Exercise-import Common.Navigator-import Common.Rewriting-import Common.Strategy hiding (not, replicate)-import Common.Utils (distinct)-import Common.View-import Data.Maybe-import Domain.Math.Examples.DWO3-import Domain.Math.Expr hiding (isPower)-import Domain.Math.Numeric.Views-import Domain.Math.Power.Rules-import Domain.Math.Power.Strategies-import Domain.Math.Power.NormViews-import Domain.Math.Power.Views----- | Exercises ------------------------------------------------------------------powerExercise :: LabeledStrategy (Context Expr) -> Exercise Expr-powerExercise s = makeExercise -   { status        = Provisional-   , parser        = parseExpr-   , navigation    = navigator                     -   , strategy      = s-   }--simplifyPowerExercise :: Exercise Expr-simplifyPowerExercise = (powerExercise simplifyPowerStrategy)-   { exerciseId   = describe "simplify expression (powers)" $ -                       newId "algebra.manipulation.exponents.simplify"-   , isReady      = isPowerAdd-   , isSuitable   = (`belongsTo` normPowerMapView)-   , equivalence  = viewEquivalent normPowerMapView-   , examples     = concat $  simplerPowers -                           ++ powers1 ++ powers2 -                           ++ negExp1 ++ negExp2-                           ++ normPower1 ++ normPower2 ++ normPower3-   , ruleOrdering = ruleOrderingWithId $ map getId-                      [ root2power, subExponents, reciprocalVar, addExponents-                      , mulExponents, distributePower ]-   }--powerOfExercise :: Exercise Expr-powerOfExercise = (powerExercise powerOfStrategy)-   { exerciseId   = describe "write as a power of a" $ -                       newId "algebra.manipulation.exponents.powerof"-   , isReady      = isSimplePower-   , isSuitable   = (`belongsTo` normPowerView)-   , equivalence  = viewEquivalent normPowerNonNegRatio-   , examples     = concat $  powersOfA ++ powersOfX -                           ++ brokenExp1' ++ brokenExp2 ++ brokenExp3 -                           ++ normPower5' ++ normPower6-   , ruleOrdering = ruleOrderingWithId $ map getId-                      [ root2power, addExponents, subExponents, mulExponents-                      ,  distributePower, reciprocalVar ]-   }--nonNegBrokenExpExercise :: Exercise Expr-nonNegBrokenExpExercise = (powerExercise nonNegBrokenExpStrategy)-   { exerciseId   = describe "write with a non-negative exponent" $ -                       newId "algebra.manipulation.exponents.nonnegative"-   , isReady      = isPower plainNatView-   , isSuitable   = (`belongsTo` normPowerNonNegDouble)-   , equivalence  = viewEquivalent normPowerNonNegDouble-   , examples     = concat $  nonNegExp ++ nonNegExp2 ++ negExp4 ++ negExp5 -                           ++ brokenExp1 -                           ++ normPower4' ++ normPower5-   , ruleOrdering = ruleOrderingWithId [ getId mulExponents-                                       , getId reciprocalFrac-                                       , getId reciprocalInv-                                       , getId power2root-                                       , getId distributePower ]-   }--calcPowerExercise :: Exercise Expr-calcPowerExercise = (powerExercise calcPowerStrategy)-   { exerciseId   = describe "simplify expression (powers)" $ -                       newId "arithmetic.exponents"-   , isReady      = isPowerAdd-   , isSuitable   = (`belongsTo` normPowerMapView)-   , equivalence  = viewEquivalent normPowerMapView-   , examples     = 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 Just (_, xs) = match productView expr -      f (Nat 1 :/: a) = g a-      f a = g a-      g (Sym s [Var _, a]) | isPowerSymbol s = isJust (match v a)-      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 Just xs = match sumView expr+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,147 +1,146 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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 Prelude hiding ((^), recip)-import qualified Prelude-import Control.Monad-import Common.View-import Data.List-import qualified Data.Map as M-import Domain.Math.Expr-import Domain.Math.Numeric.Views-import Domain.Math.Power.Utils--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 (\x y -> fst x == fst y) . 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-             +-----------------------------------------------------------------------------
+-- 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 view
@@ -1,55 +1,57 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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 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)-   +-----------------------------------------------------------------------------
+-- 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 view
@@ -1,320 +1,310 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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, calcRoot, simplifyPower-  , onePower, powerOne, zeroPower, powerZero, divBase, reciprocalVar-  , reciprocalPower, factorAsPower, calcPlainRoot, simpleAddExponents-    -- * Root rules-  , power2root, root2power-    -- * Log rules-  , logarithm-    -- * Common rules-  , myFractionTimes, pushNegOut-  ) where--import Prelude hiding ( (^) )-import qualified Prelude--import Common.Classes-import Control.Arrow ( (>>^) )-import Common.Id-import Common.Transformation-import Common.View-import Control.Monad-import Data.List-import Data.Maybe-import qualified Domain.Math.Data.PrimeFactors as PF-import Domain.Math.Data.OrList-import Domain.Math.Data.Relation-import Domain.Math.Expr-import Domain.Math.Numeric.Views-import Domain.Math.Power.Utils-import Domain.Math.Power.Views----- | 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."--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) <- match (rootView >>> (integerView *** integerView)) expr-  y      <- takeRoot n x-  return $ fromInteger y---- | [root n x, ... ]-calcRoot :: Rule (OrList Expr)-calcRoot = makeSimpleRuleList (power, "root") $ \ ors ->-  fromMaybe [] (disjunctions ors) >>= maybeToList . f-    where -      f 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 $ orList 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` varView || 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 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 else 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-  (a, b)   <- match (divView <&> (identity >>^ \e -> (e,1))) e1-  (c, d)   <- match (divView <&> (identity >>^ \e -> (e,1))) 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 :: View 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 $ +-----------------------------------------------------------------------------
+-- 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 view
@@ -1,85 +1,71 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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-   , powerOfStrategy-   , calcPowerStrategy-   , nonNegBrokenExpStrategy-   ) where--import Prelude hiding (repeat, not)--import Common.Classes-import Common.Context-import Common.Id-import Common.Navigator-import Common.Strategy-import Common.Transformation-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 -----------------------------------------------------------------simplifyPowerStrategy :: LabeledStrategy (Context Expr)-simplifyPowerStrategy = cleanUpStrategyRules "Simplify" powerRules --powerOfStrategy :: LabeledStrategy (Context Expr)-powerOfStrategy = cleanUpStrategyRules "Write as power of" powerRules --nonNegBrokenExpStrategy :: LabeledStrategy (Context Expr)-nonNegBrokenExpStrategy = cleanUpStrategy (change cleanup . applyTop cleanup) strategy-  where-    rs = [ addExponents, subExponents, mulExponents, reciprocalInv-         , distributePower, distributePowerDiv, power2root, zeroPower-         , calcPowerPlus, calcPowerMinus-         ]-    strategy = label "Write with non-negative exponent" $ exhaustiveStrategy rs-    cleanup = applyD divisionNumerator-            . applyD myFractionTimes-            . mergeConstants -            . simplifyWith simplifyConfig {withMergeAlike = False}--calcPowerStrategy :: LabeledStrategy (Context Expr)-calcPowerStrategy = cleanUpStrategy cleanup strategy-  where-    strategy = label "Calculate power" $ exhaustiveStrategy rules-    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 +-----------------------------------------------------------------------------
+-- 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 view
@@ -1,185 +1,227 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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 Prelude hiding (repeat, replicate)--import Common.Context-import Common.Rewriting-import Common.Strategy hiding (not)-import Common.Transformation-import Common.View-import Control.Monad-import Data.List hiding (repeat, replicate)-import Data.Ratio-import qualified Domain.Math.Data.PrimeFactors as PF-import Domain.Math.Data.Relation-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 = repeat . 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 -------------------------------------------------------------(<&>) :: (MonadPlus m) => ViewM m a b -> ViewM m a b -> ViewM m a b-v <&> w = makeView (\x -> match v x `mplus` match w x) (build v)--infixl 1 <&>--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 (:==:))----- | 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" integerNormalForm-   , doubleNegate, negateZero, divisionDenominator, divisionNumerator-   , simplerFraction-   ]-   -fractionRules :: [Rule Expr]-fractionRules =-   [ fractionPlus, fractionPlusScale, fractionTimes-   , calcPlusWith "integer" integerNormalForm-   , calcMinusWith "integer" integerNormalForm-   , calcTimesWith "integer" integerNormalForm -- not needed?-   , calcDivisionWith "integer" integerNormalForm-   , doubleNegate, negateZero, smartRule divisionDenominator-   , smartRule divisionNumerator, simplerFraction-   ]----- | Common functions -----------------------------------------------------------takeRoot :: Integer -> Integer -> Maybe Integer-takeRoot n x = do-  y <- if (abs n == 1) -         then Just 1-         else lookup x $ map swap $ PF.allPowers (abs n)-  guard $ n > 0 || (n < 0 && odd x)-  return $ if n > 0 then y else negate y--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)+{-# 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 view
@@ -1,160 +1,132 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- 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-     powerView, powerViewWith, powerViewForWith, powerViewFor, powerFactorView-   , consPowerView, consPowerViewForWith, consPowerViewFor,consPowerViewForVar-   , unitPowerViewForVar, unitPowerViewVar, unitPowerView, strictPowerView-   , rootView, strictRootView-     -- * Log view-   , logView-     -- * Other views-   , plainNatView, plainRationalView, varView-   ) where--import Control.Arrow ( (>>^) )-import Control.Monad-import Common.Rewriting-import Common.View-import Domain.Math.Expr-import Domain.Math.Power.Utils----- | Power views with constant factor -------------------------------------------consPowerView :: View Expr (Expr, (Expr, Expr))-consPowerView = addNegativeView $ addUnitTimesView powerView--consPowerViewForWith :: Num a => View Expr a -> View Expr b -> a -> View Expr (Expr, b)-consPowerViewForWith va vb a = -  addNegativeView $ addUnitTimesView (powerViewForWith va vb a)--consPowerViewFor :: Expr -> View Expr (Expr, Expr)-consPowerViewFor = consPowerViewForWith identity identity--consPowerViewForVar :: String -> View Expr (Expr, Expr)-consPowerViewForVar = consPowerViewFor . Var--unitPowerViewForVar :: String -> View Expr (Expr, Expr)-unitPowerViewForVar s = makeView f g-  where-    f expr = do-      (c, (s', x)) <- match unitPowerViewVar expr-      guard $ s == s'-      return (c, x)-    g (c, x) = build unitPowerViewVar (c , (s, x))--unitPowerViewWith :: View Expr a -> View Expr (Expr, (a, Expr))-unitPowerViewWith v = addNegativeView $ addUnitTimesView $ -  powerViewWith v identity <&> (unitTimes v >>^ swap)--unitPowerViewVar :: View Expr (Expr, (String, Expr))-unitPowerViewVar = unitPowerViewWith varView---- | 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 == 1 || x == -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 = makeView f g -  where-    f = match ((strictRootView >>^ h) <&> strictPowerView)-    h (a, b) = (a, 1 ./. b)-    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 >>> first va >>> second 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) -> View Expr (Bool, [Expr])-powerFactorView p = productView >>> second (makeView f id)-  where-    f = Just . 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)+-----------------------------------------------------------------------------
+-- 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----- | Help (non-power) views -----------------------------------------------------unitTimes :: Num t => View a b -> View a (t, b)-unitTimes = (>>^ (,) 1)--addTimesView :: View Expr a -> View Expr (Expr, a)-addTimesView v = timesView >>> second v--addUnitTimesView :: View Expr a -> View Expr (Expr, a)-addUnitTimesView v = addTimesView v <&> unitTimes v--negateView :: (Num a, WithFunctions a) => View a a-negateView = makeView isNegate negate--addNegativeView :: View Expr a -> View Expr a-addNegativeView v = v <&> (negateView >>> v)--varView :: View Expr String-varView = makeView f Var-  where-    f (Var s) = Just s-    f _       = Nothing
+ src/Domain/Math/Safe.hs view
@@ -0,0 +1,78 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,230 +1,209 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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(..), smartConstructors-   , simplifyConfig-   , Simplified, simplified, liftS, liftS2-   , simplifyRule-   , mergeAlike, distribution, constantFolding-   , mergeAlikeSum, mergeAlikeProduct-   ) where--import Common.Context-import Common.Navigator-import Common.Transformation-import Common.Uniplate-import Common.View hiding (simplify, simplifyWith)-import Control.Monad-import Data.List-import Data.Maybe-import Domain.Math.Data.Relation-import Domain.Math.Expr hiding (recip)-import Domain.Math.Numeric.Views-import Domain.Math.SquareRoot.Views-import Test.QuickCheck-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)  smartConstructors-     . 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 (Simplified a) where-   simplifyWith _ = id--instance (Simplify a, IsTerm a) => IsTerm (Simplified a) where-   toTerm (S x) = toTerm x-   fromTerm     = liftM simplified . fromTerm--instance (Arbitrary a, Simplify a) => Arbitrary (Simplified a) where-   arbitrary = liftM simplified arbitrary-instance (CoArbitrary a, Simplify a) => CoArbitrary (Simplified a) where-   coarbitrary (S x) = coarbitrary x--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----------------------------------------------------------------- Simplification with the smart constructors--smartConstructors :: Expr -> Expr-smartConstructors = transform $ \expr ->-   case expr of-      a :+: b  -> a .+. b-      a :-: b  -> a .-. b-      Negate a -> neg a-      a :*: b  -> a .*. b-      a :/: b  -> a ./. b-      Sym s [a, b] | isPowerSymbol s -> -         a .^. b-      _        -> expr------------------------------------------------------------------ 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-   -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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,33 +1,29 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Control.Monad-import Test.QuickCheck-import Domain.Math.Data.SquareRoot-import Domain.Math.Numeric.Laws-import Common.TestSuite------------------------------------------------------------------------ Testing- -tests :: TestSuite-tests = -   testNumLaws  "square roots" squareRootGen-   -- 	testFracLaws "square roots" squareRootGen--squareRootGen :: Gen (SquareRoot Rational)-squareRootGen = do-   n <- choose (0, 10)-   let f r1 r2 = fromRational r1 * sqrtRational (abs r2)-   ps <- replicateM n $ liftM2 f arbitrary arbitrary-   return (sum ps)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,45 +1,50 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Control.Monad-import Common.View-import Domain.Math.Numeric.Views-import Domain.Math.Expr hiding ((^))-import Domain.Math.Data.SquareRoot--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 fracDiv (f a) (f b)-         Sqrt a   -> fmap sqrtRational (match rationalView a)-         Sym s [a, b] | isPowerSymbol s ->-            liftM2 (^) (f a) (match integerView b)-         _ -> fmap con (match v expr)-   -   g = build sumView . map h . toList-   h (a, n)  -      | n == 0    = 0-      | n == 1    = build v a+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,30 +9,23 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Domain.RelationAlgebra 
-   ( module Domain.RelationAlgebra.Formula
-   , module Domain.RelationAlgebra.Rules
-   , module Domain.RelationAlgebra.Exercises
-   , module Domain.RelationAlgebra.Strategies
-   , module Domain.RelationAlgebra.Generator
-   , module Domain.RelationAlgebra.Parser
-   ) where
-   
-import Domain.RelationAlgebra.Formula
-import Domain.RelationAlgebra.Rules
-import Domain.RelationAlgebra.Exercises
-import Domain.RelationAlgebra.Strategies
-import Domain.RelationAlgebra.Generator
-import Domain.RelationAlgebra.Parser
+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 Test.QuickCheck 
-import System.Random
-import Data.List
 import Common.Classes
-import Common.Context 
+import Common.Context
 import Control.Monad
+import Data.List
+import System.Random
+import Test.QuickCheck
 
 nrpairs = 2000 -- 20000
 
@@ -41,9 +34,9 @@ 
 pairs :: [(RelAlg, RelAlg)]
 pairs = take nrpairs $ generate 100 (mkStdGen 280578) (repeatM arbitrary)
- 
+
 precision :: IO ()
-precision = do 
+precision = do
    let f (x, y) = probablyEqualWithG (mkStdGen 28) x y
        ms   = map f pairs
        freq = map g $ group $ sort ms
@@ -51,14 +44,14 @@        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 ] 
+       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)) $ 
+       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)"
src/Domain/RelationAlgebra/Exercises.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,43 +11,36 @@ -----------------------------------------------------------------------------
 module Domain.RelationAlgebra.Exercises (cnfExercise) where
 
-import Prelude hiding (repeat)
+import Common.Library
+import Data.Maybe
 import Domain.RelationAlgebra.Formula
 import Domain.RelationAlgebra.Generator
-import Domain.RelationAlgebra.Strategies
-import Domain.RelationAlgebra.Rules
 import Domain.RelationAlgebra.Parser
-import Common.Classes
-import Common.Exercise
-import Common.Context
-import Data.Maybe
-import Common.Derivation
-import Common.Rewriting (differenceMode)
-import Common.Strategy hiding (not)
-import Common.Transformation
-import Common.Navigator
+import Domain.RelationAlgebra.Rules
+import Domain.RelationAlgebra.Strategies
+import Prelude hiding (repeat)
+import Test.QuickCheck
 
 cnfExercise :: Exercise RelAlg
-cnfExercise = testableExercise
+cnfExercise = makeExercise
    { exerciseId     = describe "To conjunctive normal form" $
                          newId "relationalgebra.cnf"
    , status         = Alpha
    , parser         = parseRelAlg
    , prettyPrinter  = ppRelAlg
-   , equivalence    = probablyEqual -- isEquivalent
+   , equivalence    = withoutContext probablyEqual -- isEquivalent
    , extraRules     = map liftToContext (relAlgRules ++ buggyRelAlgRules)
    , strategy       = toCNF
    , navigation     = navigator
-   , difference     = differenceMode probablyEqual
-   , ordering       = compare
-   , isReady        = ready cnfExercise
+   , 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 = 
+stepsRemaining i =
    lengthMax i . derivationTree toCNF . inContext cnfExercise
 
 {- cnfExerciseSimple :: Exercise RelAlg
@@ -56,7 +49,7 @@    , description = description cnfExercise ++ " (simple)"
    , strategy    = label "Apply rules exhaustively" $ repeat $ somewhere $ alternatives $ ruleset cnfExercise
    } -}
-   
-ready :: Exercise a -> a -> Bool
-ready ex = null . applyAll (alternatives $ filter (not . isBuggyRule) (ruleset ex)) 
+
+myReady :: Exercise a -> a -> Bool
+myReady ex = null . applyAll (alternatives $ filter (not . isBuggyRule) (ruleset ex))
          . inContext ex
src/Domain/RelationAlgebra/Formula.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,19 +11,19 @@ -----------------------------------------------------------------------------
 module Domain.RelationAlgebra.Formula where
 
-import Common.Uniplate (Uniplate(..))
 import Common.Rewriting
 import Common.Utils
+import Common.Utils.Uniplate
 import Control.Monad
 import Data.List
-import qualified Data.Set as S
 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 3 :+:
+infixr 4 :||:
 infixr 5 :&&:
 
 -- | The data type RelAlg is the abstract syntax for the domain
@@ -47,7 +47,7 @@ -------------------------------------
 
 isAtom :: RelAlg -> Bool
-isAtom  r = 
+isAtom  r =
     case r of
       Var _             -> True
       Not I             -> True
@@ -58,20 +58,20 @@       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)
@@ -89,20 +89,20 @@          p :||: q  -> rec p `disj` rec q
          Not p     -> neg (rec p)
          Inv p     -> inv (rec p)
-         V         -> univ 
+         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) 
+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 ] 
+              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 ] 
+              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 ]
@@ -125,7 +125,7 @@    makeRngs n g
       | n == 0    = []
       | otherwise = let (g1, g2) = split g in g1 : makeRngs (n-1) g2
-   eval g = 
+   eval g =
       let MkGen f   = arbRelations as
           (size, a) = randomR (0, 100) g
       in evalRelAlg (f a size) as
@@ -136,20 +136,20 @@ -- Suitable for small domains (e.g., with just 2 elements)
 arbRelation :: Eq a => [a] -> Gen (Relation a)
 arbRelation as = do
-   let f _ = oneof $ map return [True, False]
+   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 
+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 
+   return $ S.fromAscList $ concat xs
 
 -- Test on a limited domain whether two relation algebra terms are equivalent
 (===) :: RelAlg -> RelAlg -> Property
@@ -157,31 +157,31 @@ 
 -- | Function varsRelAlg returns the variables that appear in a RelAlg expression.
 varsRelAlg :: RelAlg -> [String]
-varsRelAlg = foldRelAlg (return, union, union, union, union, id, id, [], [])      
+varsRelAlg = foldRelAlg (return, union, union, union, union, id, id, [], [])
 
 instance Uniplate RelAlg where
    uniplate term =
-      case term of 
-         s :.:  t  -> ([s, t], \[a, b] -> a :.:  b)
-         s :+:  t  -> ([s, t], \[a, b] -> a :+:  b)
-         s :&&: t  -> ([s, t], \[a, b] -> a :&&: b)
-         s :||: t  -> ([s, t], \[a, b] -> a :||: b)
-         Not s     -> ([s], \[a] -> Not a)
-         Inv s     -> ([s], \[a] -> Inv a)
-         _         -> ([], \[] -> 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)
-   --(var, comp, add, conj, disj, not, inverse, universe, ident)
+
 instance IsTerm RelAlg where
-   toTerm = foldRelAlg 
+   toTerm = foldRelAlg
       ( variable, binary compSymbol, binary addSymbol
       , binary conjSymbol
       , binary disjSymbol, unary notSymbol, unary invSymbol
       , symbol universeSymbol, symbol identSymbol
       )
 
-   fromTerm a = 
+   fromTerm a =
       fromTermWith f a `mplus` liftM Var (getVariable a)
     where
       f s []
@@ -196,7 +196,7 @@          | 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"
src/Domain/RelationAlgebra/Generator.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,45 +11,30 @@ -----------------------------------------------------------------------------
 module Domain.RelationAlgebra.Generator (templateGenerator) where
 
-import Domain.RelationAlgebra.Formula
-import Common.Rewriting
 import Control.Monad
+import Domain.RelationAlgebra.Formula
 import Test.QuickCheck
 
-instance Rewrite RelAlg
-
 instance Arbitrary RelAlg where
    arbitrary = sized (arbRelAlg . min 8)
-instance CoArbitrary RelAlg where
-   coarbitrary term =
-      case term of
-         Var x    -> variant (0 :: Int) . coarbitrary x
-         p :.:  q -> variant (1 :: Int) . coarbitrary p . coarbitrary q
-         p :+:  q -> variant (2 :: Int) . coarbitrary p . coarbitrary q       
-         p :&&: q -> variant (3 :: Int) . coarbitrary p . coarbitrary q       
-         p :||: q -> variant (4 :: Int) . coarbitrary p . coarbitrary q       
-         Not p    -> variant (5 :: Int) . coarbitrary p
-         Inv p    -> variant (6 :: Int) . coarbitrary p  
-         V        -> variant (7 :: Int)        
-         I        -> variant (8 :: Int)
-   
+
 arbRelAlg :: Int -> Gen RelAlg
-arbRelAlg 0 = frequency [(8, liftM Var (oneof $ map return relAlgVars)), (1, return V), (1, return empty), (1, return I)]
+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 
+                    , unop Not, unop Inv
                     ]
  where
    binop op = liftM2 op rec rec
    unop op  = liftM op rec
-   rec      = arbRelAlg (n `div` 2)  
+   rec      = arbRelAlg (n `div` 2)
 
 relAlgVars :: [String]
 relAlgVars = ["q", "r", "s"]
-  
+
 -------------------------------------------------------------------
 -- Templates
 
-template1, template2, template3, template4, template7, template8 :: 
+template1, template2, template3, template4, template7, template8 ::
    RelAlg -> RelAlg -> RelAlg -> RelAlg
 
 template5 :: RelAlg -> RelAlg -> RelAlg -> RelAlg -> RelAlg
@@ -59,11 +44,11 @@ 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))) 
+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) 
+       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))
 
 -------------------------------------------------------------------
@@ -85,7 +70,7 @@ 
 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)
 
@@ -96,7 +81,7 @@ hulpgen2 n = liftM3 template7 (arbInvNotMol 1) (arbRelAlg n) (arbRelAlg n)
 
 arbInvNotMol :: Int -> Gen RelAlg
-arbInvNotMol 0 = frequency [(10, liftM Var (oneof $ map return relAlgVars)), (1, return V), (1, return empty), (1, return I)]
+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
@@ -107,4 +92,4 @@ arbMaybeInvNotMol n = frequency [(3, liftM Just (arbInvNotMol n)), (1, return Nothing)]
 
 arbVar :: Gen RelAlg
-arbVar = liftM Var (oneof $ map return relAlgVars)+arbVar = liftM Var (elements relAlgVars)
src/Domain/RelationAlgebra/Parser.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -13,79 +13,70 @@ 
 import Domain.RelationAlgebra.Formula
 import Text.Parsing
-
-myScanner :: Scanner
-myScanner = defaultScanner
-   { keywords         = ["V", "E", "I"]
-   , keywordOperators = invSym : notSym : concatMap (map fst . snd) operatorTable
-   , specialCharacters = "-~" ++ specialCharacters defaultScanner
-   }
-
-operatorTable :: OperatorTable RelAlg
-operatorTable = 
-   [ (RightAssociative, [(orSym, (:||:))])
-   , (RightAssociative, [(andSym, (:&&:))])
-   , (NoMix,            [(compSym, (:.:)), (addSym, (:+:))])
-   ]
+import qualified Text.ParserCombinators.Parsec.Token as P
 
-andSym, orSym, addSym, compSym, notSym, invSym :: String
-andSym  = "/\\"
-orSym   = "\\/" 
-addSym  = "!"
-compSym = ";"
-notSym  = "-"
-invSym  = "~"
-   
 -----------------------------------------------------------
 --- Parser
 
 parseRelAlg  :: String -> Either String RelAlg
-parseRelAlg = analyseAndParse pRelAlg . scanWith myScanner
+parseRelAlg = parseSimple relalg
+ where
+   relalg = buildExpressionParser table term
 
-pRelAlg :: Parser Token RelAlg
-pRelAlg = pOperators operatorTable pTerm
+   term = foldl (flip ($)) <$> atom <*> many pUn
 
--- Two postfix operators
-pTerm :: Parser Token RelAlg
-pTerm = foldl (flip ($)) <$> pAtom <*> pList pUnOp
- where
-   pUnOp  =  Inv <$ pKey invSym 
-         <|> Not <$ pKey notSym
+   pUn = choice
+      [ Inv <$ reservedOp "~"
+      , Not <$ reservedOp "-"
+      ]
 
-pAtom :: Parser Token RelAlg
-pAtom  =  Var <$> pVarid
-      <|> pParens pRelAlg
-      <|> const V     <$> pKey "V"
-      <|> const empty <$> pKey "E"
-      <|> const I     <$> pKey "I"
+   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 ]
+      ]
+
 -----------------------------------------------------------
---- Helper-function for parentheses analyses
+--- Lexer
 
-analyseAndParse :: Parser Token a -> [Token] -> Either String a
-analyseAndParse p ts =
-   case checkParentheses ts of
-      Just err -> Left (show err)
-      Nothing  -> either (Left . f) Right (parse p ts)
- where
-   f (Just t) = show (tokenPosition t) ++ ": Unexpected " ++ show t
-   f Nothing  = "Syntax error"
-                               
+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 :: (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) = 
+         )
+   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, "") . ("-"++) 
+   nott p _  = p (6, "") . ("-"++)
    inv  p _  = p (6, "") . ("~"++)
    parIf b f = if b then ("("++) . f . (")"++) else f
src/Domain/RelationAlgebra/Rules.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,11 +11,11 @@ -----------------------------------------------------------------------------
 module Domain.RelationAlgebra.Rules where
 
-import Domain.RelationAlgebra.Formula
-import Domain.RelationAlgebra.Generator()
 import Common.Id
-import Common.Transformation (Rule, addRuleToGroup, buggyRule)
 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]
@@ -24,16 +24,16 @@            ]
 compAddRules :: [Rule RelAlg]
 compAddRules = [ ruleCompOverUnion {- , ruleCompOverIntersec  -}
-               , {- ruleAddOverUnion,-} ruleAddOverIntersec 
+               , {- ruleAddOverUnion,-} ruleAddOverIntersec
                ]
 relAlgRules :: [Rule RelAlg]
-relAlgRules = invRules ++ compAddRules ++ 
+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
@@ -42,161 +42,132 @@                    ]
 
 relalg :: IsId a => a -> Id
-relalg = (#) "relationalgebra"
+relalg = ( # ) "relationalgebra"
 
-rule :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a
+rule :: RuleBuilder f a => String -> f -> Rule a
 rule = Rule.rule . relalg
 
-ruleList :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
+ruleList :: RuleBuilder f a => String -> [f] -> Rule a
 ruleList = Rule.ruleList . relalg
-                   
--- | 1. Alle ~ operatoren naar binnen verplaatsen
 
-conversionGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a
-conversionGroup s = 
-   addRuleToGroup (relalg "Conversion") . rule s
+-- | 1. Alle ~ operatoren naar binnen verplaatsen
 
 ruleInvOverUnion :: Rule RelAlg
-ruleInvOverUnion = conversionGroup "InvOverUnion" $ 
+ruleInvOverUnion = rule "InvOverUnion" $
    \r s -> Inv (r :||: s) :~> Inv r :||: Inv s
 
 ruleInvOverIntersec :: Rule RelAlg
-ruleInvOverIntersec = conversionGroup "InvOverIntersect" $  
+ruleInvOverIntersec = rule "InvOverIntersect" $
    \r s -> Inv (r :&&: s) :~> Inv r :&&: Inv s --- !!!!!!! ALLEEN VOOR FUNCTIES
 
 ruleInvOverComp :: Rule RelAlg
-ruleInvOverComp = conversionGroup "InvOverComp" $ 
+ruleInvOverComp = rule "InvOverComp" $
    \r s -> Inv (r :.: s) :~> Inv s :.: Inv r
 
 ruleInvOverAdd :: Rule RelAlg
-ruleInvOverAdd = conversionGroup "InvOverAdd" $ 
+ruleInvOverAdd = rule "InvOverAdd" $
    \r s -> Inv (r :+: s) :~> Inv s :+: Inv r
 
 ruleInvOverNot :: Rule RelAlg
-ruleInvOverNot = conversionGroup "InvOverNot" $ 
+ruleInvOverNot = rule "InvOverNot" $
    \r -> Inv (Not r) :~> Not (Inv r)
-   
+
 ruleDoubleInv :: Rule RelAlg
-ruleDoubleInv = conversionGroup "DoubleInv" $ 
+ruleDoubleInv = rule "DoubleInv" $
    \r -> Inv (Inv r) :~> r
-      
 
-
-
--- | 2. Alle ; en + operatoren zoveel mogelijk naar binnen verplaatsen 
-distributionGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
-distributionGroup s = 
-   addRuleToGroup (relalg "Distribution") . ruleList s
+-- | 2. Alle ; en + operatoren zoveel mogelijk naar binnen verplaatsen
 
 ruleCompOverUnion :: Rule RelAlg
-ruleCompOverUnion = distributionGroup "CompOverUnion" 
-   [ \q r s -> q :.: (r :||: s) :~>  (q :.: r) :||: (q :.: s) 
-   , \q r s -> (q :||: r) :.: s :~>  (q :.: s) :||: (r :.: s) 
+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 = distributionGroup "CompOverIntersec" 
+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 = distributionGroup "AddOverUnion"  
+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 = distributionGroup "AddOverIntersec"  
-   [ \q r s -> q :+: (r :&&: s) :~>  (q :+: r) :&&: (q :+: s)  
-   , \q r s -> (q :&&: r) :+: s :~>  (q :+: s) :&&: (r :+: s)  
+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 = distributionGroup "UnionOverIntersec" 
-   [ \q r s -> q :||: (r :&&: s) :~> (q :||: r) :&&: (q :||: s) 
-   , \q r s -> (q :&&: r) :||: s :~> (q :||: s) :&&: (r :||: s) 
+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
 
-deMorganGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a
-deMorganGroup s = 
-   addRuleToGroup (relalg "DeMorgan") . rule s
-
 ruleDeMorganOr :: Rule RelAlg
-ruleDeMorganOr = deMorganGroup "DeMorganOr" $
+ruleDeMorganOr = rule "DeMorganOr" $
    \r s -> Not (r :||: s) :~> Not r :&&: Not s
-   
+
 ruleDeMorganAnd :: Rule RelAlg
-ruleDeMorganAnd = deMorganGroup "DeMorganAnd" $
+ruleDeMorganAnd = rule "DeMorganAnd" $
    \r s -> Not (r :&&: s) :~> Not r :||: Not s
 
 -- | 5. Idempotency
 
-idempotencyGroup :: (RuleBuilder f a, Rewrite a) => String -> f -> Rule a
-idempotencyGroup s = 
-   addRuleToGroup (relalg "Idempotency") . rule s
-
 ruleIdempOr :: Rule RelAlg
-ruleIdempOr = idempotencyGroup "IdempotencyOr" $
+ruleIdempOr = rule "IdempotencyOr" $
    \r -> r :||: r :~>  r
-   
+
 ruleIdempAnd :: Rule RelAlg
-ruleIdempAnd = idempotencyGroup "IdempotencyAnd" $
+ruleIdempAnd = rule "IdempotencyAnd" $
    \r -> r :&&: r :~>  r
 
 -- | 6. Complement
 
-complementGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
-complementGroup s = 
-   addRuleToGroup (relalg "Complement") . ruleList s
-
 ruleDoubleNegation :: Rule RelAlg
-ruleDoubleNegation = complementGroup "DoubleNegation"
-   [ \r -> Not (Not r) :~> r
-   ]
+ruleDoubleNegation = rule "DoubleNegation" $
+   \r -> Not (Not r) :~> r
 
 ruleRemCompl :: Rule RelAlg
-ruleRemCompl = complementGroup "RemCompl" 
+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 = complementGroup "NotOverComp"
-   [ \r s -> Not (r :.: s) :~> Not r :+: Not s
-   ]
-   
+ruleNotOverComp = rule "NotOverComp" $
+   \r s -> Not (r :.: s) :~> Not r :+: Not s
+
 ruleNotOverAdd :: Rule RelAlg
-ruleNotOverAdd = complementGroup "NotOverAdd"
-   [ \r s -> Not (r :+: s) :~> Not r :.: Not s
-   ]
-  
--- | 7. Absorption complement
+ruleNotOverAdd = rule "NotOverAdd" $
+   \r s -> Not (r :+: s) :~> Not r :.: Not s
 
-absorptionGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
-absorptionGroup s = 
-   addRuleToGroup (relalg "Absorption") . ruleList s
+-- | 7. Absorption complement
 
 ruleAbsorpCompl :: Rule RelAlg
-ruleAbsorpCompl = absorptionGroup "AbsorpCompl" 
+ruleAbsorpCompl = ruleList "AbsorpCompl"
    [ \r s -> r :&&: (Not r :||: s) :~> r :&&: s
-   , \r s -> r :&&: (s :||: Not r) :~> 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 :||: (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 = absorptionGroup "Absorp"  
+ruleAbsorp = ruleList "Absorp"
    [ \r s -> r :&&: (r :||: s)  :~> r
    , \r s -> r :&&: (s :||: r)  :~> r
    , \r s -> (r :||: s) :&&: r  :~> r
@@ -209,28 +180,24 @@ 
 -- | 8. Remove redundant expressions
 
-simplificationGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
-simplificationGroup s = 
-   addRuleToGroup (relalg "Simplification") . ruleList s
-
 ruleRemRedunExprs :: Rule RelAlg
-ruleRemRedunExprs = simplificationGroup "RemRedunExprs"  
+ruleRemRedunExprs = ruleList "RemRedunExprs"
    [ \r -> r :||: V :~> V
-   , \r -> V :||: r :~> V 
+   , \r -> V :||: r :~> V
    , \r -> r :&&: V :~> r
-   , \r -> V :&&: r :~> 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 
+--   , (E :+: r)  :~> r
    , \_ -> Inv V :~> V
    -- rules involving the empty relation
    , \_ -> Inv empty    :~> empty
    , \r -> r :||: empty :~> r
-   , \r -> empty :||: r :~> r 
+   , \r -> empty :||: r :~> r
    , \r -> r :&&: empty :~> empty
    , \r -> empty :&&: r :~> empty
    , \r -> r :.: empty  :~> empty
@@ -241,78 +208,78 @@    , \r -> I :.: r :~> r
    , \r -> r :.: I :~> r
    ]
-      
+
 -- Buggy rules:
 
-buggyGroup :: (RuleBuilder f a, Rewrite a) => String -> [f] -> Rule a
-buggyGroup s = addRuleToGroup (relalg "Buggy") . buggyRule 
-             . Rule.ruleList ("relationalgebra.buggy." ++ s)
-    
+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 
+buggyRuleIdemComp = buggyGroup "IdemComp"
+   [ \q -> q :.: q :~> q
    ]
-    
+
 buggyRuleIdemAdd :: Rule RelAlg
 buggyRuleIdemAdd = buggyGroup "IdemAdd"
    [ \q -> q :+: q :~>  q
    ]
 
 buggyRuleDeMorgan :: Rule RelAlg
-buggyRuleDeMorgan = buggyGroup "DeMorgan" 
+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!  
+    , \q r -> Not (q :||: r) :~> Not (Not q :&&: Not r) --note the firstNot in both formulas!
     ]
-    
+
 buggyRuleNotOverAdd :: Rule RelAlg
-buggyRuleNotOverAdd = buggyGroup "NotOverAdd" 
+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! 
+     , \q r -> Not (q :+: r) :~> Not (Not q :.: Not r) --note the firstNot in both formulas!
      ]
-     
+
 buggyRuleNotOverComp :: Rule RelAlg
-buggyRuleNotOverComp = buggyGroup "NotOverComp" 
+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! 
+     , \q r -> Not (q :.: r) :~> Not (Not q :.: Not r) --note the firstNot in both formulas!
      ]
-     
+
 buggyRuleParenth :: Rule RelAlg
-buggyRuleParenth = buggyGroup "Parenth" 
+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 -> 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
     , \q r -> Inv (Inv q :+: r)  :~> q :+: r
     ]
-    
+
 buggyRuleAssoc :: Rule RelAlg
-buggyRuleAssoc = buggyGroup "Assoc"  
+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
+    , \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)
     ]
 
@@ -325,20 +292,20 @@ buggyRuleInvOverAdd = buggyGroup "InvOverAdd"
    [ \r s -> Inv (r :+: s) :~> Inv r :+: Inv s
    ]
-   
+
 buggyRuleCompOverIntersec :: Rule RelAlg
-buggyRuleCompOverIntersec = buggyGroup "CompOverIntersec" 
+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" 
+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" 
+buggyRuleRemCompl = buggyGroup "RemCompl"
    [ \r -> r :&&: Not r :~> V
    , \r -> Not r :&&: r :~> V
    , \r -> r :||: Not r :~> empty
src/Domain/RelationAlgebra/Strategies.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -11,15 +11,15 @@ -----------------------------------------------------------------------------
 module Domain.RelationAlgebra.Strategies (toCNF) where
 
-import Domain.RelationAlgebra.Rules
-import Domain.RelationAlgebra.Formula
 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" $ 
+toCNF = label "To CNF" $
    repeat $  label "step1" step1
           |> label "step2" step2
           |> label "step3" step3
@@ -28,18 +28,13 @@       [ ruleRemCompl, ruleRemRedunExprs, ruleDoubleNegation
       , ruleIdempOr, ruleIdempAnd, ruleAbsorp, ruleAbsorpCompl
       ] ++ invRules
-   step2 = topDown $ useRules 
+   step2 = topDown $ useRules
       [ ruleCompOverUnion, ruleAddOverIntersec, ruleDeMorganOr, ruleDeMorganAnd
       , ruleNotOverComp, ruleNotOverAdd
       ]
-   step3 = somewhere $ liftToContext 
+   step3 = somewhere $ liftToContext
       ruleUnionOverIntersec
 
 -- local helper-function
 useRules :: [Rule RelAlg] -> Strategy (Context RelAlg)
-useRules = alternatives . map liftToContext
-   
-
-
-   
-   
+useRules = alternatives . map liftToContext
src/Main.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -15,7 +15,6 @@ 
 import Common.Utils (useFixedStdGen)
 import Control.Monad
-import Control.Monad.Trans
 import Data.IORef
 import Data.Time
 import Documentation.Make
@@ -23,8 +22,9 @@ import Main.LoggingDatabase
 import Main.Options
 import Network.CGI
+import Service.FeedbackScript.Analysis
 import Service.ModeJSON (processJSON)
-import Service.ModeXML  (processXML)
+import Service.ModeXML (processXML)
 import Service.Request
 
 main :: IO ()
@@ -32,44 +32,50 @@    startTime <- getCurrentTime
    flags     <- serviceOptions
    logRef    <- newIORef (return ())
-   
-   case withInputFile flags of      
+
+   case withInputFile flags of
       -- from file
-      Just file -> do  
-         when (FixRNG `elem` flags) 
+      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) $ 
+         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 $ 
+      _ | 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          
+         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) <- lift $ process input
-         lift $ writeIORef logRef $ -- save logging action for later
+         (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 $ 
+process input = useIDEAS $
    case discoverDataFormat input of
       Just XML  -> processXML input
       Just JSON -> processJSON input
src/Main/IDEAS.hs view
@@ -1,130 +1,106 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Rewriting-import Common.Utils (Some(..), fromShowString)-import Main.Options-import Service.DomainReasoner-import Service.ExercisePackage-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.Logic.FeedbackText as Logic-import qualified Domain.Math.Expr as Math-import qualified Domain.Math.Data.Interval as MathInterval-import qualified Domain.Math.Derivative.Exercises as Math-import qualified Domain.Math.Equation.CoverUpExercise as Math-import qualified Domain.Math.Numeric.Exercises as Math-import qualified Domain.Math.Numeric.Tests as MathNum-import qualified Domain.Math.Polynomial.Exercises as Math-import qualified Domain.Math.Polynomial.IneqExercises as Math-import qualified Domain.Math.Polynomial.RationalExercises as Math-import qualified Domain.Math.Polynomial.Tests as MathPoly-import qualified Domain.Math.Power.Exercises as Math-import qualified Domain.Math.Power.Equation.Exercises as Math-import qualified Domain.Math.SquareRoot.Tests as MathSqrt-import qualified Domain.Math.Polynomial.LeastCommonMultiple as MathLCM--- import qualified Domain.RegularExpr.Exercises as RE-import qualified Domain.RelationAlgebra as RA--useIDEAS :: DomainReasoner a -> IO a-useIDEAS action = runDomainReasoner $ do-   -- version information-   setVersion     shortVersion-   setFullVersion fullVersion-   -- exercise packages-   addPackages    packages-   -- services-   addServices    serviceList-   addPkgService  exerciselistS-   -- domain checks-   addTestSuite $ do-      MathNum.main-      MathPoly.tests-      MathSqrt.tests-      MathInterval.testMe-      MathLCM.testLCM-      LA.checks-   -- do the rest-   action--packages :: [Some ExercisePackage]-packages =-   [ -- logic and relation-algebra-     Some (package Logic.dnfExercise)-        { withOpenMath    = True-        , toOpenMath      = termToOMOBJ . toTerm . fmap (Math.Var . fromShowString)-        , fromOpenMath    = (>>= fromTerm) . omobjToTerm-        , getExerciseText = Just logicText-        }-   , Some (package Logic.dnfUnicodeExercise)-        { withOpenMath    = True-        , toOpenMath      = termToOMOBJ . toTerm . fmap (Math.Var . fromShowString)-        , fromOpenMath    = (>>= fromTerm) . omobjToTerm-        , getExerciseText = Just logicText-        }-   -- , somePackage Logic.proofExercise-   , somePackage RA.cnfExercise-     -- basic math-   -- , someTermPackage Math.naturalExercise-   -- , someTermPackage Math.integerExercise-   -- , someTermPackage Math.rationalExercise-   , someTermPackage Math.fractionExercise-   , someTermPackage Math.coverUpExercise-   , someTermPackage Math.linearExercise-   , someTermPackage Math.linearMixedExercise-   , someTermPackage Math.quadraticExercise-   , someTermPackage Math.higherDegreeExercise-   , someTermPackage Math.findFactorsExercise-   , someTermPackage Math.ineqLinearExercise-   , someTermPackage Math.ineqQuadraticExercise-   , someTermPackage Math.ineqHigherDegreeExercise-   , someTermPackage Math.rationalEquationExercise-   , someTermPackage Math.simplifyRationalExercise-   -- , someTermPackage Math.divisionBrokenExercise-   , someTermPackage Math.quadraticNoABCExercise-   , someTermPackage Math.quadraticWithApproximation-   , someTermPackage Math.derivativeExercise-   , someTermPackage Math.derivativePolyExercise-   , someTermPackage Math.derivativeProductExercise-   , someTermPackage Math.derivativeQuotientExercise-   -- , someTermPackage Math.derivativePowerExercise-   , someTermPackage Math.simplifyPowerExercise-   , someTermPackage Math.powerOfExercise     -   , someTermPackage Math.nonNegBrokenExpExercise-   , someTermPackage Math.calcPowerExercise-   , someTermPackage Math.powerEqExercise-   , someTermPackage Math.expEqExercise-   , someTermPackage Math.logEqExercise-     -- linear algebra-   , someTermPackage LA.gramSchmidtExercise-   , someTermPackage LA.linearSystemExercise-   , someTermPackage LA.gaussianElimExercise-   , someTermPackage LA.systemWithMatrixExercise-     -- regular expressions-   -- , somePackage RE.regexpExercise-   ]-   -logicText :: ExerciseText Logic.SLogic-logicText = ExerciseText-   { ruleText              = Logic.ruleText-   , appliedRule           = Logic.appliedRule-   , feedbackSyntaxError   = Logic.feedbackSyntaxError-   , feedbackSame          = Logic.feedbackSame-   , feedbackBuggy         = Logic.feedbackBuggy-   , feedbackNotEquivalent = Logic.feedbackNotEquivalent-   , feedbackOk            = Logic.feedbackOk-   , feedbackDetour        = Logic.feedbackDetour-   , feedbackUnknown       = Logic.feedbackUnknown-   }+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-}
 -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -36,10 +36,10 @@ 
      -- calculate duration
      end <- getCurrentTime
-     let diff = diffUTCTime end begin 
+     let diff = diffUTCTime end begin
 
      -- insert data into database
-     run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" 
+     run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)"
              [ toSql $ service req
              , toSql $ maybe "unknown" show (exerciseId req)
              , toSql $ fromMaybe "unknown" (source req)
@@ -76,5 +76,4 @@ 
 logEnabled :: Bool
 logEnabled = False
-#endif
-
+#endif
src/Main/Options.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -20,25 +20,27 @@ import System.Environment
 import System.Exit
 
-data Flag = Version | Help | Logging Bool | InputFile String 
-          | FixRNG | DocItem DocItem | DocDir String | TestDir String
+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 = 
+header =
    "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++
-   "Copyright 2010, Open Universiteit Nederland\n" ++
+   "Copyright 2011, Open Universiteit Nederland\n" ++
    versionText ++
    "\n\nUsage: ideas [OPTION]     (by default, CGI protocol)\n" ++
    "\nOptions:"
 
 versionText :: String
-versionText = 
+versionText =
   "version " ++ version ++ ", revision " ++ show revision ++
   ", logging " ++ (if logEnabled then "enabled" else "disabled")
 
 fullVersion :: String
-fullVersion = "version " ++ version ++ " (revision " 
+fullVersion = "version " ++ version ++ " (revision "
            ++ show revision ++ ", " ++ lastChanged ++ ")"
 
 shortVersion :: String
@@ -46,17 +48,20 @@ 
 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 []  ["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
@@ -67,14 +72,14 @@    args <- getArgs
    case getOpt Permute options args of
       (flags, [], [])
-         | flags == [Version] -> do 
+         | flags == [Version] -> do
               putStrLn ("IDEAS, " ++ versionText)
               exitSuccess
          | all (`notElem` flags) [Version, Help] ->
               return flags
       (_, _, errs) -> do
          putStrLn (concat errs ++ usageInfo header options)
-         exitFailure 
+         exitFailure
 
 docItems :: [Flag] -> [DocItem]
 docItems flags = [ x | DocItem x <- flags ]
@@ -86,17 +91,27 @@ 
 testDir :: [Flag] -> String
 testDir flags = case [ d | TestDir d <- flags ] of
-                  d:_ -> d
-                  _   -> "test"
+                   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 = 
+withInputFile flags =
    case [ file | InputFile file <- flags ] of
       [hd] -> Just hd
       _    -> Nothing
src/Main/Revision.hs view
@@ -1,8 +1,8 @@ -- Automatically generated by Makefile.  Do not change. module Main.Revision where version :: String-version = "0.7"+version = "1.0" revision :: Int-revision = 3724+revision = 4677 lastChanged :: String -lastChanged = "do, 23 dec 2010"+lastChanged = "Thu, 01 Sep 2011"
src/Service/BasicServices.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,145 +9,150 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Service.BasicServices 
+module Service.BasicServices
    ( -- * Basic Services
      stepsremaining, findbuggyrules, ready, allfirsts, derivation
-   , onefirst, applicable, allapplications, apply, generate, generateWith
+   , onefirst, applicable, allapplications, apply, generate
    ) where
 
-import Common.Library hiding (derivation, applicable, apply)
-import Common.Utils (safeHead)
+import Common.Library hiding (derivation, applicable, apply, ready)
+import Common.Utils (fst3, safeHead)
 import Data.List
 import Data.Maybe
-import System.Random (StdGen, newStdGen)
-import Control.Monad
-import Service.ExercisePackage
 import Service.State
+import System.Random (StdGen)
 import qualified Common.Classes as Apply
-      
--- result must be in the IO monad to access a standard random number generator
-generate :: ExercisePackage a -> Int -> IO (State a)
-generate pkg level = do 
-   stdgen <- newStdGen
-   return (generateWith stdgen pkg level)
 
-generateWith :: StdGen -> ExercisePackage a -> Int -> State a
-generateWith rng pkg level = 
-   emptyState pkg (randomTermWith rng level (exercise pkg))
+generate :: StdGen -> Exercise a -> Difficulty -> State a
+generate rng ex dif =
+   emptyState ex (randomTermWith rng dif ex)
 
-derivation :: Monad m => Maybe StrategyConfiguration -> State a -> m [(Rule (Context a), Context a)]
+-- TODO: add a location to each step
+derivation :: Maybe StrategyConfiguration -> State a -> Either String (Derivation (Rule (Context a), ArgValues) (Context a))
 derivation mcfg state =
-   case (statePrefix state, mcfg) of 
-      (Nothing, _) -> fail "Prefix is required"
-      -- configuration is only allowed beforehand: hence, the prefix 
+   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) -> 
+      (Just p, Just cfg) | null (prefixToSteps p) ->
          let newStrategy = configure cfg (strategy ex)
              newExercise = ex {strategy = newStrategy}
-             newPackage  = pkg {exercise = newExercise}
-         in rec timeout [] (empyStateContext newPackage (stateContext state))
-      _ -> rec timeout [] state
+         in rec timeout d0 (empyStateContext newExercise (stateContext state))
+      _ -> rec timeout d0 state
  where
-   pkg = exercisePkg state
-   ex  = exercise pkg
+   d0 = emptyDerivation state
+   ex = exercise state
    timeout = 50 :: Int
- 
-   rec i acc st = 
+
+   rec i acc st =
       case onefirst st of
-         Nothing           -> return (reverse acc)
-         Just (r, _, next)
-            |  i <= 0      -> fail msg
-            | otherwise    -> rec (i-1) ((r, stateContext next) : acc) next
+         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. " ++ 
-            concatMap f (reverse acc)
-      f (r, c) = let s = maybe "???" (prettyPrinter ex) (fromContext c)
-                 in "[" ++ show r ++ "]  " ++ s ++ "; "
+      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 :: Monad m => State a -> m [(Rule (Context a), Location, State a)]
-allfirsts state = 
+allfirsts :: State a -> Either String [(Rule (Context a), Location, ArgValues, State a)]
+allfirsts state =
    case statePrefix state of
-      Nothing -> 
-         fail "Prefix is required"
+      Nothing ->
+         Left "Prefix is required"
       Just p0 ->
          let tree = cutOnStep (stop . lastStepInPrefix) (prefixTree p0 (stateContext state))
-             f (r1, _, _) (r2, _, _) = 
-                ruleOrdering (exercise (exercisePkg state)) r1 r2
-         in return (sortBy f (mapMaybe make (derivations tree)))
+             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 <- safeHead (reverse (steps d))
-      termEnd   <- safeHead (reverse (terms d))
+      prefixEnd <- lastStep d
+      let ca = lastTerm (withoutLast d)
       case lastStepInPrefix prefixEnd of
          Just (RuleStep r) | isMajorRule r -> return
             ( r
-            , location termEnd
-            , makeState (exercisePkg state) (Just prefixEnd) termEnd
+            , location (lastTerm d)
+            , fromMaybe [] (expectedArguments r ca)
+            , makeState (exercise state) (Just prefixEnd) (lastTerm d)
             )
          _ -> Nothing
 
-onefirst :: Monad m => State a -> m (Rule (Context a), Location, State a)
-onefirst state = do
-   xs <- allfirsts state
-   case xs of
-      hd:_ -> return hd
-      []   -> fail "No step possible"
+   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 (exercisePkg state)))
+   in filter p (ruleset (exercise state))
 
 allapplications :: State a -> [(Rule (Context a), Location, State a)]
-allapplications state = xs ++ ys
+allapplications state = sortBy cmp (xs ++ ys)
  where
-   pkg = exercisePkg state
-   ex  = exercise pkg
-   xs  = concat (allfirsts state)
-   ps  = [ (r, loc) | (r, loc, _) <- xs ]
-   ys  = maybe [] f (top (stateContext state))
-           
+   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 pkg Nothing new)
+   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 :: 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 
+-- 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 :: Monad m => Rule (Context a) -> Location -> State a -> m (State a)
+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 return $ safeHead
-      [ s1 | (r1, loc1, s1) <- fromMaybe [] $ allfirsts state, showId r == showId r1, loc==loc1 ]
-      
+      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 -> return (makeState (exercisePkg state) Nothing new)
-         Nothing  -> fail ("Cannot apply " ++ show r)
-       
+         Just new -> Right (makeState (exercise state) Nothing new)
+         Nothing  -> Left ("Cannot apply " ++ show r)
+
 ready :: State a -> Bool
-ready state = isReady (exercise (exercisePkg state)) (stateTerm state)
+ready state = isReady (exercise state) (stateTerm state)
 
-stepsremaining :: Monad m => State a -> m Int
-stepsremaining = liftM length . derivation Nothing
+stepsremaining :: State a -> Either String Int
+stepsremaining = mapSecond derivationLength . derivation Nothing
 
-findbuggyrules :: State a -> a -> [Rule (Context a)]
+findbuggyrules :: State a -> a -> [(Rule (Context a), Location, ArgValues)]
 findbuggyrules state a =
-   let ex      = exercise (exercisePkg state)
-       buggies = filter isBuggyRule (ruleset ex)
-       p r     = ruleIsRecognized ex r (stateContext state) (inContext ex a)
-   in filter p buggies+   [ (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 view
@@ -1,143 +1,196 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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-   , diagnosisType, diagnosisTypeSynonym-   ) where --import Common.Library-import Common.Utils (safeHead)-import Data.List (sortBy)-import Data.Maybe-import Service.ExercisePackage-import Service.State-import Service.BasicServices-import Service.Types--------------------------------------------------------------------- Result types for diagnose service--data Diagnosis a-   = Buggy          (Rule (Context a))-   | NotEquivalent  -   | Similar        Bool (State a)-   | Expected       Bool (State a) (Rule (Context a))-   | Detour         Bool (State a) (Rule (Context a))-   | Correct        Bool (State a)--instance Show (Diagnosis a) where-   show diagnosis = -      case diagnosis of-         Buggy r        -> "Buggy rule " ++ show (show r)-         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"--------------------------------------------------------------------- The diagnose service--diagnose :: State a -> a -> Diagnosis a-diagnose state new-   -- Is the submitted term equivalent?-   | not (equivalenceContext ex (stateContext state) newc) =-        -- Is the rule used discoverable by trying all known buggy rules?-        case discovered True of-           Just r -> -- report the buggy rule-              Buggy r-           Nothing -> -- unknown mistake-              NotEquivalent-              -   -- Is the submitted term (very) similar to the previous one? -   | similarity ex (stateTerm state) 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--   -- Is the rule used discoverable by trying all known rules?-   | otherwise =-        let ns = restartIfNeeded (makeState pkg Nothing newc)-        in case discovered False of-              Just r ->  -- If yes, report the found rule as a detour-                 Detour (ready ns) ns r-              Nothing -> -- If not, we give up-                 Correct (ready ns) ns- where-   pkg  = exercisePkg state-   ex   = exercise pkg-   newc = inContext ex new-   -   expected = do-      xs <- allfirsts (restartIfNeeded state)-      let p (_, _, ns) = similarity ex new (stateTerm ns)-      safeHead (filter p xs)--   discovered searchForBuggy = safeHead-      [ r-      | r <- sortBy (ruleOrdering ex) (ruleset ex)-      , isBuggyRule r == searchForBuggy-      , ruleIsRecognized ex r sub1 sub2-      ]-    where -      (sub1, sub2) = -         case difference ex (not searchForBuggy) (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 (exercise pkg) = -        emptyState pkg (stateTerm state)-   | otherwise = state- where-   pkg = exercisePkg state-   -diagnosisType :: Type a (Diagnosis a)-diagnosisType = useSynonym diagnosisTypeSynonym--diagnosisTypeSynonym :: TypeSynonym a (Diagnosis a)-diagnosisTypeSynonym = typeSynonym "Diagnosis" to from tp- where-   to (Left r) = Buggy r-   to (Right (Left ())) = NotEquivalent-   to (Right (Right (Left (b, s)))) = Similar b s-   to (Right (Right (Right (Left (b, s, r))))) = Expected b s r-   to (Right (Right (Right (Right (Left (b, s, r)))))) = Detour b s r-   to (Right (Right (Right (Right (Right (b, s)))))) = Correct b s-   -   from (Buggy r)        = Left r-   from (NotEquivalent)  = Right (Left ())-   from (Similar b s)    = Right (Right (Left (b, s)))-   from (Expected b s r) = Right (Right (Right (Left (b, s, r))))-   from (Detour b s r)   = Right (Right (Right (Right (Left (b, s, r)))))-   from (Correct b s)    = Right (Right (Right (Right (Right (b, s)))))-   -   tp  =  Rule-      :|: Unit-      :|: Pair   Bool stateTp-      :|: tuple3 Bool stateTp Rule-      :|: tuple3 Bool stateTp Rule-      :|: Pair   Bool stateTp+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,192 +1,189 @@-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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-   , addPackages, addPackage, addPkgService-   , addServices, addService, addTestSuite-   , setVersion, setFullVersion-     -- * Accessor functions-   , getPackages, getExercises, getServices-   , getVersion, getFullVersion, getTestSuite-   , findPackage, findService-   ) where--import Common.Library-import Common.TestSuite-import Common.Utils (Some(..))-import Control.Monad.Error-import Control.Monad.State-import Data.Maybe-import Service.Types-import Service.ExercisePackage---------------------------------------------------------------------------- Domain Reasoner data type--newtype DomainReasoner a = DR { unDR :: ErrorT String (StateT Content IO) a }--data Content = Content-   { packages    :: [Some ExercisePackage]-   , services    :: [Some ExercisePackage] -> [Service]-   , testSuite   :: TestSuite-   , version     :: String-   , fullVersion :: Maybe String-   }-   -noContent :: Content-noContent = Content [] (const []) (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 fail return---------------------------------------------------------------------------- Instance declarations--instance Monad DomainReasoner where-   return a   = DR (return a)-   DR m >>= f = DR (m >>= unDR . f)-   fail s     = DR (fail s)--instance MonadError String DomainReasoner where-   throwError     = fail-   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--addPackages :: [Some ExercisePackage] -> DomainReasoner ()-addPackages xs = modify $ \c -> c { packages = xs ++ packages c }--addPackage :: Some ExercisePackage -> DomainReasoner ()-addPackage pkg = addPackages [pkg]--addPkgService :: ([Some ExercisePackage] -> Service) -> DomainReasoner ()-addPkgService f = modify $ \c -> -   c { services = \xs -> f xs : services c xs }--addServices :: [Service] -> DomainReasoner ()-addServices = mapM_ (addPkgService . const)--addService :: Service -> DomainReasoner ()-addService s = addServices [s]--addTestSuite :: TestSuite -> DomainReasoner ()-addTestSuite m = modify $ \c -> c { testSuite = testSuite c >> m }--setVersion :: String -> DomainReasoner ()-setVersion s = modify $ \c -> c { version = s }--setFullVersion :: String -> DomainReasoner ()-setFullVersion s = modify $ \c -> c  { fullVersion = Just s }---------------------------------------------------------------------------- Accessor functions--getPackages :: DomainReasoner [Some ExercisePackage]-getPackages = gets packages--getExercises :: DomainReasoner [Some Exercise]-getExercises = gets (map (\(Some pkg) -> Some (exercise pkg)) . packages)--getServices :: DomainReasoner [Service]-getServices = gets (\c -> services c (packages c))--getVersion :: DomainReasoner String-getVersion = gets version--getFullVersion :: DomainReasoner String-getFullVersion = gets fullVersion >>= maybe getVersion return--getTestSuite :: DomainReasoner TestSuite-getTestSuite = gets testSuite--findPackage :: Id -> DomainReasoner (Some ExercisePackage)-findPackage i = do-   pkgs <- getPackages -   case [ a | a@(Some pkg) <- pkgs, getId pkg == resolveId i ] of-      [this] -> return this-      _      -> fail $ "Package " ++ show i ++ " not found"-      -findService :: String -> DomainReasoner Service-findService txt = do-   srvs <- getServices-   case filter ((==txt) . showId) srvs of-      [hd] -> return hd-      []   -> fail $ "No service " ++ txt-      _    -> fail $ "Ambiguous service " ++ txt---------------------------------------------------------------------------- Identifier aliases (temporary)--resolveId :: Id -> Id-resolveId i = fromMaybe i (lookup i table)- where-   table = 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")-      ]+{-# 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 view
@@ -1,100 +1,106 @@-{-# LANGUAGE GADTs, Rank2Types #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Data.List-import Service.ExercisePackage-import Service.Types-import Service.DomainReasoner--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-   , 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-   , decoderPackage :: ExercisePackage a-   } --decoderExercise :: Decoder s a -> Exercise a-decoderExercise = exercise . decoderPackage--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 f _ t  -> liftM (first f) (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-      ExercisePkg ->-         return (decoderPackage dec, 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 _ f t  -> encodeType enc t (f tv)-      Pair t1 t2 -> do-         let (a, b) = tv-         x <- encodeType enc t1 a-         y <- encodeType enc t2 b-         return (encodeTuple enc [x, y])-      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-      IO t1         -> do let pp s | "user error (" `isPrefixOf` s = init (drop 12 s)-                                   | otherwise = s-                          result <- liftIO $ -                             liftM Right tv `catch` (return . Left . pp . show)-                          case result of -                             Left msg -> fail msg-                             Right a  -> encodeType enc t1 a-      Rule          -> encodeType enc String (showId tv)-      Term          -> encodeTerm enc tv-      Context       -> fromContext tv >>= encodeType enc Term-      Location      -> encodeType enc String (show tv)-      ExercisePkg   -> return (encodeTuple enc [])-      _             -> fail ("No support for result type: " ++ show tp)+{-# 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/ExercisePackage.hs 
@@ -1,129 +0,0 @@-{-# LANGUAGE Rank2Types #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.ExercisePackage-   ( -- Type, and selectors -     ExercisePackage, exercise, withOpenMath-   , toOpenMath, fromOpenMath, getExerciseText-     -- Constructors-   , package, termPackage, somePackage, someTermPackage-     -- Conversion functions to/from OpenMath-   , termToOMOBJ, omobjToTerm-     -- ExerciseText datatype-   , ExerciseText(..)-   ) where--import Common.Library-import Common.Utils (Some(..))-import Common.Rewriting.Term-import Control.Monad-import Data.Char-import Data.List-import Text.OpenMath.Object-import qualified Text.OpenMath.Symbol as OM-import Text.OpenMath.Dictionary.Fns1---------------------------------------------------------------------------------- Package data type (and constructor functions)--data ExercisePackage a = P-   { exercise        :: Exercise a-   , withOpenMath    :: Bool-   , toOpenMath      :: a -> OMOBJ -   , fromOpenMath    :: MonadPlus m => OMOBJ -> m a-   , getExerciseText :: Maybe (ExerciseText a)-   }--instance HasId (ExercisePackage a) where-   getId = getId . exercise-   changeId f pkg = pkg { exercise = changeId f (exercise pkg) }--package :: Exercise a -> ExercisePackage a-package ex = P -   { exercise        = ex-   , withOpenMath    = False-   , toOpenMath      = error "no OpenMath support"-   , fromOpenMath    = fail "no OpenMath support"-   , getExerciseText = Nothing-   }--termPackage :: IsTerm a => Exercise a -> ExercisePackage a-termPackage ex = (package ex)-   { withOpenMath = True-   , toOpenMath   = termToOMOBJ . toTerm-   , fromOpenMath = (>>= fromTerm) . omobjToTerm-   }--somePackage :: Exercise a -> Some ExercisePackage-somePackage = Some . package--someTermPackage :: IsTerm a => Exercise a -> Some ExercisePackage-someTermPackage = Some . termPackage-   --------------------------------------------------------------------------------- Utility functions for conversion to/from OpenMath--termToOMOBJ :: Term -> OMOBJ-termToOMOBJ term =-   case term of-      Var s     -> OMV s-      Con s     -> OMS (idToSymbol (getId s))-      Meta i    -> OMV ('$' : show i)-      Num n     -> OMI n-      Float d   -> OMF d-      Apply _ _ -> let (f, xs) = getSpine term-                   in make (map termToOMOBJ (f:xs))- where-   make [OMS s, OMV x, body] | s == lambdaSymbol = -      OMBIND (OMS s) [x] body-   make xs = OMA xs--omobjToTerm :: MonadPlus m => OMOBJ -> m Term-omobjToTerm omobj =-   case omobj of -      OMV x -> case isMeta x of-                  Just n  -> return (Meta n)-                  Nothing -> return (Var x)-      OMS s -> return (symbol (newSymbol (OM.dictionary s # OM.symbolName s)))-      OMI n -> return (Num n)-      OMF a -> return (Float a)-      OMA (x:xs) -> liftM2 makeTerm (omobjToTerm x) (mapM omobjToTerm xs)-      OMBIND binder xs body ->-         omobjToTerm (OMA (binder:map OMV xs++[body]))-      _ -> fail "Invalid OpenMath object"- where-   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)----------------------------------------------------------------- Exercise Text data type---    Note: ideally, this should be defined elsewhere---- Exercise extension for textual feedback-data ExerciseText a = ExerciseText-   { ruleText              :: Rule (Context a) -> Maybe String-   , appliedRule           :: Rule (Context a) -> String-   , feedbackSyntaxError   :: String -> String-   , feedbackSame          :: String-   , feedbackBuggy         :: Bool -> [Rule (Context a)] -> String-   , feedbackNotEquivalent :: Bool -> String-   , feedbackOk            :: [Rule (Context a)] -> (String, Bool)-   , feedbackDetour        :: Bool -> Maybe (Rule (Context a)) -> [Rule (Context a)] -> (String, Bool)-   , feedbackUnknown       :: Bool -> String-   }
+ src/Service/FeedbackScript/Analysis.hs view
@@ -0,0 +1,101 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,139 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,161 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -0,0 +1,134 @@+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,111 +1,76 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 -   ( ExerciseText(..)-   , onefirsttext, submittext, derivationtext, submitHelper-   ) where--import Common.Library hiding (derivation)-import Data.Maybe-import Common.Utils-import Service.Diagnose (restartIfNeeded)-import Service.ExercisePackage-import Service.State-import Service.Submit-import Service.BasicServices- ---------------------------------------------------------------- Services--derivationtext :: Monad m => State a -> Maybe String -> m [(String, Context a)]-derivationtext state _event = do-   exText <- exerciseText state-   xs     <- derivation Nothing state-   return (map (first (showRule exText)) xs)--onefirsttext :: Monad m => State a -> Maybe String -> m (Bool, String, State a)-onefirsttext state event =-   case onefirst state of-      Just (r, _, s) -> do-         exText <- exerciseText state-         let mtxt = fromContext (stateContext s) >>= useToRewrite exText r state-             msg  = case mtxt of-                       Just txt | event /= Just "hint button" -> txt-                       _ -> "Use " ++ showRule exText r-         return (True, msg, s)-      _ -> return (False, "Sorry, no hint available", state)-      -submittext :: Monad m => State a -> String -> Maybe String -> m (Bool, String, State a)-submittext state input _event = do-   exText <- exerciseText state-   return $-      case parser (exercise (exercisePkg state)) input of-         Left err -> -            (False, feedbackSyntaxError exText err, state)-         Right a  -> -            let result = submit state a-                (txt, b) = submitHelper exText state a result-            in case getResultState result of-                  Just new | b -> (True, txt, restartIfNeeded new)-                  _ -> (False, txt, state)---- 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)-submitHelper :: ExerciseText a -> State a -> a -> Result a -> (String, Bool)-submitHelper exText old a result =-   case result of-      Buggy rs        -> ( fromMaybe ""  (youRewroteInto old a) ++ -                           feedbackBuggy exText (ready old) rs-                         , False)-      NotEquivalent   -> ( fromMaybe ""  (youRewroteInto old a) ++-                           feedbackNotEquivalent exText (ready old)-                         , False)-      Ok rs _-         | null rs    -> (feedbackSame exText, False)-         | otherwise  -> feedbackOk exText rs-      Detour rs _     -> feedbackDetour exText (ready old) (expected old) rs-      Unknown _       -> ( fromMaybe ""  (youRewroteInto old a) ++ -                           feedbackUnknown exText (ready old)-                         , False)- where-   expected s = do-      xs <- allfirsts s-      fmap fst3 (safeHead xs)----------------------------------------------------------------- Helper functions--showRule :: ExerciseText a -> Rule (Context a) -> String-showRule exText r = -   fromMaybe ("rule " ++ showId r) (ruleText exText r)--useToRewrite :: ExerciseText a -> Rule (Context a) -> State a -> a -> Maybe String-useToRewrite exText r old = rewriteIntoText True txt old- where-   txt = "Use " ++ showRule exText r ++ " to rewrite "--youRewroteInto :: State a -> a -> Maybe String-youRewroteInto = rewriteIntoText False "You rewrote "--rewriteIntoText :: Bool -> String -> State a -> a -> Maybe String-rewriteIntoText mode txt old a = do-   let ex = exercise (exercisePkg old)-   p <- fromContext (stateContext old)-   (p1, a1) <- difference ex mode p a -   return $ txt ++ prettyPrinter ex p1 -         ++ " into " ++ prettyPrinter ex a1 ++ ". "--exerciseText :: Monad m => State a -> m (ExerciseText a)-exerciseText = -   let msg = "No support for textual feedback"-   in maybe (fail msg) return . getExerciseText . exercisePkg+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-}
 -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -16,18 +16,17 @@ 
 import Common.Library hiding (exerciseId)
 import Common.Utils (Some(..), distinct, readM)
-import Text.JSON
+import Control.Monad.Error
+import Data.Char
+import Data.Maybe
+import Service.DomainReasoner
+import Service.Evaluator
 import Service.Request
 import Service.State
-import qualified Service.Types as Tp
-import Service.Types hiding (String)
 import Service.Submit
-import Service.Evaluator
-import Service.ExercisePackage 
-import Service.DomainReasoner
-import Control.Monad
-import Data.Maybe
-import Data.Char
+import Service.Types hiding (String)
+import Text.JSON
+import qualified Service.Types as Tp
 
 -- TODO: Clean-up code
 extractExerciseId :: Monad m => JSON -> m Id
@@ -38,12 +37,12 @@       Array (String s:tl) | any p s -> extractExerciseId (Array tl)
       Array (hd:_) -> extractExerciseId hd
       _ -> fail "no code"
- where 
+ where
    p c = not (isAlphaNum c || isSpace c || c `elem` ".-")
 
 processJSON :: String -> DomainReasoner (Request, String, String)
 processJSON input = do
-   json <- parseJSON input
+   json <- either throwError return (parseJSON input)
    req  <- jsonRequest json
    vers <- getVersion
    resp <- jsonRPC json myHandler
@@ -51,7 +50,7 @@    return (req, out, "application/json")
 
 addVersion :: String -> JSON -> JSON
-addVersion version json = 
+addVersion version json =
    case json of
       Object xs -> Object (xs ++ [info])
       _         -> json
@@ -63,7 +62,7 @@    srv  <- case lookupM "method" json of
               Just (String s) -> return s
               _               -> fail "Invalid method"
-   let a = (lookupM "params" json >>= extractExerciseId)
+   let a = lookupM "params" json >>= extractExerciseId
    enc  <- case lookupM "encoding" json of
               Nothing         -> return Nothing
               Just (String s) -> liftM Just (readEncoding s)
@@ -72,7 +71,7 @@               Nothing         -> return Nothing
               Just (String s) -> return (Just s)
               _               -> fail "Invalid source"
-   return Request 
+   return Request
       { service    = srv
       , exerciseId = a
       , source     = src
@@ -82,86 +81,94 @@ 
 myHandler :: JSON_RPC_Handler DomainReasoner
 myHandler fun arg = do
-   pkg  <- if fun == "exerciselist" 
-           then return (Some (package emptyExercise))
-           else extractExerciseId arg >>= findPackage
+   ex   <- if fun == "exerciselist"
+           then return (Some emptyExercise)
+           else extractExerciseId arg >>= findExercise
    srv  <- findService fun
-   case jsonConverter pkg of
+   case jsonConverter ex of
       Some conv ->
          evalService conv srv arg
 
-jsonConverter :: Some ExercisePackage -> Some (Evaluator JSON JSON)
-jsonConverter (Some pkg) =
-   Some (Evaluator (jsonEncoder (exercise pkg)) (jsonDecoder pkg))
+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)
-   , encodeTerm  = return . String . prettyPrinter ex
-   , encodeTuple = jsonTuple
+   { 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 = 
+      | otherwise =
            case serviceType of
-              Tp.Tag s t | s == "Result" -> do
-                 result <- isSynonym submitTypeSynonym (a ::: serviceType) 
-                 encodeResult enc result
-                         | s == "elem" -> 
-                 encode enc t a
-                         | s == "State" -> do
-                 st <- isSynonym stateTypeSynonym (a ::: serviceType)
-                 encodeState (encodeTerm enc) st
-                 
-              Tp.List t    -> liftM Array (mapM (encode enc t) 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
+              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 _ f t)   = tupleList (f a ::: t)
-   tupleList (p ::: Tp.Pair t1 t2) = 
+   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 :: ExercisePackage a -> Decoder JSON a
-jsonDecoder pkg = Decoder
-   { decodeType     = decode (jsonDecoder pkg)
-   , decodeTerm     = reader (exercise pkg)
-   , decoderPackage = pkg
+jsonDecoder :: Exercise a -> Decoder JSON a
+jsonDecoder ex = Decoder
+   { decodeType      = decode (jsonDecoder ex)
+   , decodeTerm      = reader (parser ex)
+   , decoderExercise = ex
    }
  where
-   reader :: Monad m => Exercise a -> JSON -> m a
-   reader ex (String s) = either (fail . show) return (parser ex s)
-   reader _  _          = fail "Expecting a string when reading a term"
- 
-   decode :: Decoder JSON a -> Type a t -> JSON -> DomainReasoner (t, JSON) 
+   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.ExercisePkg -> \json -> case json of
-                                       Array (String _:rest) -> return (decoderPackage dec, Array rest)
-                                       _ -> return (decoderPackage dec, json)
-         Tp.Int      -> useFirst $ \json -> case json of 
+         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 
+         Tp.String   -> useFirst $ \json -> case json of
                                                String s -> return s
                                                _        -> fail "not a string"
-         Tp.Tag s _ | s == "State" -> do 
-            f <- equalM stateTp serviceType
-            useFirst (liftM f . decodeState (decoderPackage dec) (decodeTerm dec))
+         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
@@ -178,10 +185,10 @@ --------------------------
 
 encodeState :: Monad m => (a -> m JSON) -> State a -> m JSON
-encodeState f st = do 
+encodeState f st = do
    theTerm <- f (stateTerm st)
    return $ Array
-      [ String (showId (exercisePkg st))
+      [ String (showId (exercise st))
       , String (maybe "NoPrefix" show (statePrefix st))
       , theTerm
       , encodeContext (getEnvironment (stateContext st))
@@ -192,43 +199,42 @@  where
    f k = (k, String $ fromMaybe "" $ lookupEnv k env)
 
-decodeState :: Monad m => ExercisePackage a -> (JSON -> m a) -> JSON -> m (State a)
-decodeState pkg f (Array [a]) = decodeState pkg f a
-decodeState pkg f (Array [String _code, String p, ce, jsonContext]) = do
-   let ex  = exercise pkg
-       mpr = readM p >>= (`makePrefix` strategy ex)
-   a    <- f ce 
+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 pkg mpr (makeContext ex env a)
+   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)       
+ 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")]   
+      NotEquivalent -> return $ Object [("result", String "NotEquivalent")]
       Ok rs st      -> do
-         json <- encodeType enc stateTp st
+         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 stateTp st
+         json <- encodeType enc stateType st
          return $ Object [("result", String "Detour"), ("rules", Array $ map (String . showId) rs), ("state", json)]
       Unknown st    -> do
-         json <- encodeType enc stateTp st
+         json <- encodeType enc stateType st
          return $ Object [("result", String "Unknown"), ("state", json)]
 
 jsonTuple :: [JSON] -> JSON
-jsonTuple xs = 
-   case mapM f xs of 
+jsonTuple xs =
+   case mapM f xs of
       Just ys | distinct (map fst ys) -> Object ys
       _ -> Array xs
  where
src/Service/ModeXML.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-}
 -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -12,30 +12,31 @@ -- Services using XML notation
 --
 -----------------------------------------------------------------------------
-module Service.ModeXML 
+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.ExercisePackage
-import Service.ProblemDecomposition
+import Service.DomainReasoner
+import Service.Evaluator
+import Service.FeedbackScript.Syntax
+import Service.OpenMathSupport
 import Service.Request
 import Service.RulesInfo (rulesInfoXML)
-import Service.StrategyInfo
 import Service.State
-import Service.Diagnose
+import Service.StrategyInfo
 import Service.Types
-import qualified Service.Types as Tp
-import Service.Evaluator
 import Text.OpenMath.Object
+import Text.OpenMath.Symbol
 import Text.XML
-import Service.DomainReasoner
+import qualified Service.Types as Tp
 
 processXML :: String -> DomainReasoner (Request, String, String)
 processXML input = do
@@ -48,20 +49,20 @@    return (req, out, "application/xml")
 
 addVersion :: String -> XML -> XML
-addVersion s xml = 
+addVersion s xml =
    let info = [ "version" := s ]
    in xml { attributes = attributes xml ++ info }
 
 xmlRequest :: XML -> Either String Request
-xmlRequest xml = do   
+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 
+              Nothing -> return Nothing
+   return Request
       { service    = srv
       , exerciseId = a
       , source     = findAttribute "source" xml
@@ -72,18 +73,18 @@ xmlReply :: Request -> XML -> DomainReasoner XML
 xmlReply request xml = do
    srv <- findService (service request)
-   pkg <- 
+   ex  <-
       case exerciseId request of
-         Just code -> findPackage code
-         Nothing   
+         Just code -> findExercise code
+         Nothing
             | service request == "exerciselist" ->
-                 return (Some (package emptyExercise))
-            | otherwise -> 
+                 return (Some emptyExercise)
+            | otherwise ->
                  fail "unknown exercise code"
    Some conv <-
       case encoding request of
-         Just StringEncoding -> return (stringFormatConverter pkg)
-         _                   -> return (openMathConverter pkg)
+         Just StringEncoding -> return (stringFormatConverter ex)
+         _                   -> return (openMathConverter ex)
    res <- evalService conv srv xml
    return (resultOk res)
 
@@ -91,244 +92,244 @@ extractExerciseId = liftM newId . findAttribute "exerciseid"
 
 resultOk :: XMLBuilder -> XML
-resultOk body = makeXML "reply" $ do 
+resultOk body = makeXML "reply" $ do
    "result" .=. "ok"
    body
 
 resultError :: String -> XML
-resultError txt = makeXML "reply" $ do 
+resultError txt = makeXML "reply" $ do
    "result" .=. "error"
    element "message" (text txt)
 
 ------------------------------------------------------------
 -- Mixing abstract syntax (OpenMath format) and concrete syntax (string)
 
-stringFormatConverter :: Some ExercisePackage -> Some (Evaluator XML XMLBuilder)
-stringFormatConverter (Some pkg) = Some (stringFormatConverterTp pkg)
+stringFormatConverter :: Some Exercise -> Some (Evaluator XML XMLBuilder)
+stringFormatConverter (Some ex) = Some (stringFormatConverterTp ex)
 
-stringFormatConverterTp :: ExercisePackage a -> Evaluator XML XMLBuilder a
-stringFormatConverterTp pkg = 
-   Evaluator (xmlEncoder False f pkg) (xmlDecoder False g pkg)
+stringFormatConverterTp :: Exercise a -> Evaluator XML XMLBuilder a
+stringFormatConverterTp ex =
+   Evaluator (xmlEncoder False f ex) (xmlDecoder False g ex)
  where
-   ex = exercise pkg
-   f  = return . element "expr" . text . prettyPrinter ex
+   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 ExercisePackage -> Some (Evaluator XML XMLBuilder)
-openMathConverter (Some pkg) = Some (openMathConverterTp pkg)
-        
-openMathConverterTp :: ExercisePackage a -> Evaluator XML XMLBuilder a
-openMathConverterTp pkg =
-   Evaluator (xmlEncoder True f pkg) (xmlDecoder True g pkg)
+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 = return . builder . toXML . toOpenMath pkg
+   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 pkg omobj of
+      case fromOpenMath ex (if useFocus then transform noFocus omobj else omobj) of
          Just a  -> return a
-         Nothing -> fail "Unknown OpenMath object"
+         Nothing -> fail "Invalid OpenMath object for this exercise"
 
-xmlEncoder :: Bool -> (a -> DomainReasoner XMLBuilder) -> ExercisePackage a -> Encoder XMLBuilder a
-xmlEncoder b f pkg = Encoder
-   { encodeType  = xmlEncodeType b (xmlEncoder b f pkg) pkg
-   , encodeTerm  = f
-   , encodeTuple = sequence_
+   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 -> ExercisePackage a -> Type a t -> t -> DomainReasoner XMLBuilder
-xmlEncodeType b enc pkg serviceType =
+xmlEncodeType :: Bool -> Encoder XMLBuilder a -> Exercise a -> Type a t -> t -> DomainReasoner XMLBuilder
+xmlEncodeType b enc ex serviceType =
    case serviceType of
-      Tp.Tag s _ 
-         | s == "Diagnosis" -> \a -> do
-              d <- isSynonym diagnosisTypeSynonym (a ::: serviceType)
-              encodeDiagnosis b (encodeTerm enc) d
-         | s == "DecompositionReply" -> \a -> do
-              reply <- isSynonym replyTypeSynonym (a ::: serviceType)
-              encodeReply (encodeState b (encodeTerm enc)) reply
+      Tp.Tag s t1
          | s == "RulesInfo" -> \_ ->
-              rulesInfoXML (exercise pkg) (encodeTerm enc)
-         | s == "State" -> \a -> do
-              st <- isSynonym stateTypeSynonym (a ::: serviceType)
-              encodeState b (encodeTerm enc) st
-      Tp.List t1  -> \xs -> 
-         case allAreTagged t1 of
-            Just f -> do
-               let make = element "elem" . mapM_ (uncurry (.=.)) . f
-               let elems = mapM_ make xs
-               return (element "list" elems)
-            _ -> do
-               bs <- mapM (xmlEncodeType b enc pkg t1) xs
-               let elems = mapM_ (element "elem") bs
-               return (element "list" elems)
-      Tp.Tag s t1  -> liftM (element s) . xmlEncodeType b enc pkg t1  -- quick fix
-      Tp.Strategy  -> return . builder . strategyToXML
-      Tp.Rule      -> return . ("ruleid" .=.) . showId
-      Tp.Term      -> encodeTerm enc
-      Tp.Context   -> encodeContext b (encodeTerm enc)
-      Tp.Location  -> return . {-element "location" .-} text . show
-      Tp.Id        -> return . text . show
-      Tp.Bool      -> return . text . map toLower . show
-      Tp.String    -> return . text
-      Tp.Int       -> return . text . show
-      _            -> encodeDefault enc serviceType
+              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) -> ExercisePackage a -> Decoder XML a
-xmlDecoder b f pkg = Decoder
-   { decodeType     = xmlDecodeType b (xmlDecoder b f pkg)
-   , decodeTerm     = f
-   , decoderPackage = pkg
+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 = 
+xmlDecodeType b dec serviceType =
    case serviceType of
-      Tp.Context     -> keep $ decodeContext b (decoderPackage dec) (decodeTerm dec)
+      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 -> decodeConfiguration
+      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" -> \xml -> do 
-              g  <- equalM stateTp serviceType
-              st <- decodeState b (decoderPackage dec) (decodeTerm dec) xml
-              return (g st, xml)
-         | s == "answer" -> \xml ->
-              findChild "answer" xml >>= xmlDecodeType b dec 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         
+ where
    keep :: Monad m => (XML -> m a) -> XML -> m (a, XML)
    keep f xml = liftM (\a -> (a, xml)) (f xml)
-         
-allAreTagged :: Type a t -> Maybe (t -> [(String, String)])
-allAreTagged (Iso _ f t) = fmap (. f) (allAreTagged t)
-allAreTagged (Pair t1 t2) = do 
-   f1 <- allAreTagged t1
-   f2 <- allAreTagged t2
-   return $ \(a,b) -> f1 a ++ f2 b
-allAreTagged (Tag s Bool)   = Just $ \b -> [(s, map toLower (show b))]
-allAreTagged (Tag s String) = Just $ \a -> [(s, a)]
-allAreTagged _ = Nothing
-         
-decodeState :: Monad m => Bool -> ExercisePackage a -> (XML -> m a) -> XML -> m (State a)
-decodeState b pkg f xmlTop = do
-   xml <- findChild "state" xmlTop
-   unless (name xml == "state") (fail "expected a state tag")
-   mpr  <- decodePrefix pkg xml
-   term <- decodeContext b pkg f xml
-   return (makeState pkg mpr term)
 
-decodePrefix :: Monad m => ExercisePackage a -> XML -> m (Maybe (Prefix (Context a)))
-decodePrefix pkg 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 
+        return Nothing
    | otherwise = do
         a  <- readM prefixText
         pr <- makePrefix a str
         return (Just pr)
  where
    prefixText = maybe "" getData (findChild "prefix" xml)
-   str = strategy (exercise pkg)
+   str = strategy ex
    a ~= b = g a == g b
    g = map toLower . filter (not . isSpace)
-   
-decodeContext :: Monad m => Bool -> ExercisePackage a -> (XML -> m a) -> XML -> m (Context a)
-decodeContext b pkg f xml = do
+
+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 (exercise pkg) env expr)
+   return (makeContext ex env expr)
 
 decodeEnvironment :: Monad m => Bool -> XML -> m Environment
 decodeEnvironment b xml =
-   case findChild "context" xml of 
+   case findChild "context" xml of
       Just this -> foldM add emptyEnv (children this)
       Nothing   -> return emptyEnv
  where
-   add env item = do 
-      unless (name item == "item") $ 
+   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 >>= omobjToTerm of
+            case xml2omobj this >>= fromOMOBJ of
                Left err -> fail err
-               Right term -> 
-                  return (storeEnv n term env)
+               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, XML)
+decodeConfiguration :: MonadPlus m => XML -> m StrategyConfiguration
 decodeConfiguration xml =
    case findChild "configuration" xml of
-      Just this -> mapM decodeAction (children this) >>= \xs -> return (xs, xml)
-      Nothing   -> fail "no strategy configuration" 
+      Just this -> mapM decodeAction (children this)
+      Nothing   -> fail "no strategy configuration"
  where
-   decodeAction item = do 
+   decodeAction item = do
       guard (null (children item))
-      action <- 
+      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)
 
-encodeState :: Monad m => Bool -> (a -> m XMLBuilder) -> State a -> m XMLBuilder
-encodeState b f state = do
-   body <- f (stateTerm state)
-   return $ element "state" $ do
-      encodePrefix (statePrefix state)
-      let env = getEnvironment (stateContext state)
-      encodeEnvironment b (location (stateContext state)) env
-      body
-
-encodePrefix :: Maybe (Prefix a) -> XMLBuilder
-encodePrefix = element "prefix"  . text . maybe "no prefix" show
-   
 encodeEnvironment :: Bool -> Location -> Environment -> XMLBuilder
 encodeEnvironment b loc env0
    | nullEnv env = return ()
    | otherwise   = element "context" $
         forM_ (keysEnv env) $ \k ->
-           element "item" $ do 
+           element "item" $ do
               "name"  .=. k
-              case lookupEnv k env of 
-                 Just term | b -> builder  (omobj2xml (termToOMOBJ term))
+              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
 
-encodeDiagnosis :: Monad m => Bool -> (a -> m XMLBuilder) -> Diagnosis a -> m XMLBuilder
-encodeDiagnosis mode f diagnosis =
-   case diagnosis of
-      Buggy r        -> return $ element "buggy" $ "ruleid" .=. showId r
-      NotEquivalent  -> return $ tag "notequiv"
-      Similar  b s   -> ok "similar"  b s Nothing
-      Expected b s r -> ok "expected" b s (Just (showId r))
-      Detour   b s r -> ok "detour"   b s (Just (showId r))
-      Correct  b s   -> ok "correct"  b s Nothing
- where
-   ok t b s mr = do
-      body <- encodeState mode f s
-      return $ element t $ do
-         "ready" .=. map toLower (show b)
-         maybe (return ()) ("ruleid" .=.) mr
-         body
-  
-encodeContext :: Monad m => Bool -> (a -> m XMLBuilder) -> Context a -> m XMLBuilder
+encodeContext :: Monad m => Bool -> (Context a -> m XMLBuilder) -> Context a -> m XMLBuilder
 encodeContext b f ctx = do
-   a   <- fromContext ctx
-   xml <- f a
-   return (xml >> encodeEnvironment b (location ctx) (getEnvironment ctx))+   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 view
@@ -0,0 +1,91 @@+{-# 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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,67 +9,58 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Service.ProblemDecomposition 
-   ( problemDecomposition
-   , replyType, replyTypeSynonym, encodeReply
+module Service.ProblemDecomposition
+   ( problemDecomposition, replyType
    ) where
 
 import Common.Library
 import Common.Utils
-import Control.Monad
 import Data.Maybe
-import Service.ExercisePackage
 import Service.State
 import Service.Types
-import Text.XML hiding (name)
 
-problemDecomposition :: Monad m => Maybe Id -> State a -> Maybe a -> m (Reply a)
-problemDecomposition msloc state answer 
+problemDecomposition :: Maybe Id -> State a -> Maybe a -> Either String (Reply a)
+problemDecomposition msloc state answer
    | isNothing $ subStrategy sloc (strategy ex) =
-        fail "request error: invalid location for strategy"
+        Left "request error: invalid location for strategy"
    | otherwise =
    let pr = fromMaybe (emptyPrefix $ strategy ex) (statePrefix state) in
-         case (runPrefixLocation sloc pr requestedTerm, maybe Nothing (Just . inContext ex) answer) of            
-            ([], _) -> fail "strategy error: not able to compute an expected answer"
+         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) -> return $
+               | not (null witnesses) -> Right $
                     Ok newLocation newState
-                  where 
-                    witnesses   = filter (similarityCtx ex answeredTerm . fst) $ take 1 answers
+                  where
+                    witnesses   = filter (similarity ex answeredTerm . fst) $ take 1 answers
                     (newCtx, newPrefix) = head witnesses
-                    newLocation = nextTaskLocation (strategy ex) sloc $ 
+                    newLocation = nextTaskLocation (strategy ex) sloc $
                                      fromMaybe topId $ nextMajorForPrefix newPrefix newCtx
-                    newState    = makeState pkg (Just newPrefix) newCtx
-            ((expected, pref):_, maybeAnswer) -> return $
+                    newState    = makeState ex (Just newPrefix) newCtx
+            ((expected, pref):_, maybeAnswer) -> Right $
                     Incorrect isEquiv newLocation expState arguments
              where
                newLocation = subTaskLocation (strategy ex) sloc loc
-               expState = makeState pkg (Just pref) expected
-               isEquiv  = maybe False (equivalenceContext ex expected) maybeAnswer
-               (loc, arguments) = fromMaybe (topId, []) $ 
+               expState = makeState ex (Just pref) expected
+               isEquiv  = maybe False (equivalence ex expected) maybeAnswer
+               (loc, arguments) = fromMaybe (topId, []) $
                                      firstMajorInPrefix pr pref requestedTerm
  where
-   pkg   = exercisePkg state
-   ex    = exercise pkg
+   ex    = exercise state
    topId = getId (strategy ex)
    sloc  = fromMaybe topId msloc
    requestedTerm = stateContext state
-   
-similarityCtx :: Exercise a -> Context a -> Context a -> Bool
-similarityCtx ex a b = fromMaybe False $
-   liftM2 (similarity ex) (fromContext a) (fromContext b)
 
 -- | 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 . 
+   concatMap (checkPair . f) . derivations .
    cutOnStep (stop . lastStepInPrefix) . prefixTree p0
  where
-   f d = (last (terms d), if isEmpty d then p0 else last (steps d))
+   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
@@ -77,7 +68,7 @@     where
       rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p
 
-firstMajorInPrefix :: Prefix a -> Prefix a -> a -> Maybe (Id, Args)
+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
@@ -87,17 +78,16 @@    firstLocation [] = Nothing
    firstLocation (Enter info:RuleStep r:_) | isMajorRule r = Just (getId info)
    firstLocation (_:rest) = firstLocation rest
- 
-argumentsForSteps :: a -> [Step l a] -> Args
+
+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 = let ds = map (\(Some d) -> labelArgument d) (getDescriptors r)
-                         in maybe [] (zip ds) (expectedArguments 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
@@ -107,62 +97,36 @@    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 = 
+runPrefixMajor p0 =
    map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree p0
  where
-   f d = (last (terms d), if isEmpty d then p0 else last (steps d))
+   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) Args
-
-type Args = [(String, String)]
+             | Incorrect Bool Id (State a) ArgValues
 
 ------------------------------------------------------------------------
--- Conversion functions to XML
-
-encodeReply :: Monad m => (State a -> m XMLBuilder) -> Reply a -> m XMLBuilder
-encodeReply showState reply = 
-   case reply of
-      Ok loc state -> do
-         stateXML <- showState state
-         return $
-            element "correct" $ do
-               element "location" (text $ show loc)
-               stateXML
-      Incorrect b loc state args -> do 
-         stateXML <- showState state 
-         return $ 
-            element "incorrect" $ do
-               "equivalent" .=. show b
-               element "location" (text $ show loc)
-               stateXML
-               let f (x, y) = element "elem" $ do 
-                     "descr" .=. x 
-                     text y
-               unless (null args) $
-                  element "arguments" $ mapM_ f args
+-- Type definition
 
 replyType :: Type a (Reply a)
-replyType = useSynonym replyTypeSynonym
-
-replyTypeSynonym :: TypeSynonym a (Reply a)
-replyTypeSynonym = typeSynonym "DecompositionReply" to from tp
+replyType = Iso (f <-> g) tp
  where
-   to (Left (a, b))        = Ok a b
-   to (Right (a, b, c, d)) = Incorrect a b c d
-   
-   from (Ok a b)            = Left (a, b)
-   from (Incorrect a b c d) = Right (a, b, c, d)
-   
-   tp  =  tuple2 Id stateTp
-      :|: tuple4 Bool Id stateTp argsTp
+   f (Left (a, b))        = Ok a b
+   f (Right (a, b, c, d)) = Incorrect a b c d
 
-   argsTp = List (Pair String String)+   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 view
@@ -1,44 +1,43 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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-   }-   deriving Show-   -data DataFormat = XML | JSON -   deriving Show--data Encoding = OpenMath | StringEncoding-   deriving Show-   -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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,83 +1,81 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Data.Char-import Control.Monad-import Text.OpenMath.Object-import Text.OpenMath.FMP-import Text.XML hiding (name)-import Service.ExercisePackage (termToOMOBJ)-import Service.Types-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_ (ruleGroups r) $ \s -> -         element "group" $ text (showId s)-      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 termToOMOBJ (ruleSpecTerm r)--type ExampleMap a = M.Map Id [(a, a)]--collectExamples :: Exercise a -> ExampleMap a-collectExamples ex = foldr add 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 (zip3 (terms d) (steps d) (drop 1 (terms d)))-                 g (x, r, y) = M.insertWith (++) (getId r) (liftM2 (,) (fromContext x) (fromContext y))-             in f (derivation tree) --rulesInfoType :: Type a ()-rulesInfoType = useSynonym (typeSynonym "RulesInfo" id id Unit)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,227 +1,237 @@-{-# LANGUAGE RankNTypes #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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)-import Common.Utils (Some(..))-import Data.List (sortBy)-import Data.Ord-import Service.FeedbackText-import Service.ProblemDecomposition (problemDecomposition, replyType)-import Service.ExercisePackage-import Service.Types-import Service.RulesInfo-import Service.State-import Service.BasicServices-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-   , 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." $ -   derivation ::: maybeTp StrategyCfg :-> stateTp :-> errorTp (List (tuple2 Rule 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 ::: stateTp :-> errorTp (List (tuple3 Rule Location stateTp))-        -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 ::: stateTp :-> elemTp (errorTp (tuple3 Rule Location stateTp))-  -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 ::: stateTp :-> 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 ::: stateTp :-> errorTp 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 :-> stateTp :-> List 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 strategys, others are not." $  -   allapplications ::: stateTp :-> List (tuple3 Rule Location stateTp)--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 :-> stateTp :-> errorTp stateTp--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. The meaning \-   \of the difficulty level (an integer) depends on the exercise at hand." $ -   generate ::: ExercisePkg :-> optionTp 5 Int :-> IO stateTp--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." $-   (examples . exercise) ::: ExercisePkg :-> List 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 ::: stateTp :-> Term :-> List Rule--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 ::: stateTp :-> 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 ::: stateTp :-> 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). \-   \The boolean in the result specifies whether a suggestion was available or \-   \not." $ -   onefirsttext ::: stateTp :-> maybeTp String :-> errorTp (elemTp (tuple3 Bool String stateTp))--submittextS :: Service-submittextS = 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 optional string is \-   \for announcing the event leading to this service call. The boolean in the \-   \result specifies whether the submitted term is accepted and incorporated \-   \in the new state." $ -   submittext ::: stateTp :-> String :-> maybeTp String :-> errorTp (elemTp (tuple3 Bool String stateTp))--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. The optional string is \-   \for announcing the event leading to this service call." $ -   derivationtext ::: stateTp :-> maybeTp String :-> errorTp (List (tuple2 String Context))----------------------------------------------------------- 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 ::: maybeTp Id  :-> stateTp :-> maybeTp (Tag "answer" Term) :-> errorTp replyType----------------------------------------------------------- Reflective services-   -exerciselistS :: [Some ExercisePackage] -> 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 ::: List (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 ::: ExercisePkg :-> List (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) ::: ExercisePkg :-> Strategy-   -allExercises :: [Some ExercisePackage] -> [(String, String, String)]-allExercises = map make . sortBy (comparing f)- where-   f (Some pkg) = showId (exercise pkg)-   make (Some pkg) = -      (showId pkg, description pkg, show (status (exercise pkg)))--allRules :: ExercisePackage a -> [(String, Bool, Bool)]-allRules = map make . ruleset . exercise- where  +{-# 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)-   -elemTp :: Type a t -> Type a t-elemTp = Tag "elem"
src/Service/State.hs view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -12,61 +12,69 @@ -- derivation.
 --
 -----------------------------------------------------------------------------
-module Service.State 
+module Service.State
    ( -- * Exercise state
-     State, makeState, empyStateContext, emptyState 
-   , exercisePkg, statePrefix, stateContext, stateTerm
+     State, makeState, empyStateContext, emptyState
+   , exercise, statePrefix, stateContext, stateTerm
      -- * Types
-   , stateTp, stateTypeSynonym
+   , stateType
    ) where
 
 import Common.Library
 import Common.Utils (readM)
-import Service.Types
 import Data.Maybe
-import Service.ExercisePackage
+import Service.Types
 
-data State a = State 
-   { exercisePkg  :: ExercisePackage a
+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 :: ExercisePackage a -> Maybe (Prefix (Context a)) -> Context a -> State a
+makeState :: Exercise a -> Maybe (Prefix (Context a)) -> Context a -> State a
 makeState = State
 
-empyStateContext :: ExercisePackage a -> Context a -> State a
-empyStateContext pkg = makeState pkg (Just pr)
+empyStateContext :: Exercise a -> Context a -> State a
+empyStateContext ex = makeState ex (Just pr)
  where
-   ex = exercise pkg
    pr = emptyPrefix (strategy ex)
 
-emptyState :: ExercisePackage a -> a -> State a
-emptyState pkg = empyStateContext pkg . inContext (exercise pkg)
+emptyState :: Exercise a -> a -> State a
+emptyState ex = empyStateContext ex . inContext ex
 
 --------------------------------------------------------------
 
-stateTp :: Type a (State a)
-stateTp = useSynonym stateTypeSynonym
-
-stateTypeSynonym :: TypeSynonym a (State a)
-stateTypeSynonym = typeSynonym "State" to from tp
+stateType :: Type a (State a)
+stateType = Tag "state" (Iso (f <-> g) tp)
  where
-   to (pkg, mp, ctx) =
-      let str = strategy (exercise pkg)
-          f   = fromMaybe [] . readM
-      in makeState pkg (mp >>= flip makePrefix str . f) ctx
-   from st = 
-      ( exercisePkg st
+   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 ExercisePkg prefixTp Context
+   tp = tuple3 Exercise prefixType Context
 
-prefixTp :: Type a (Maybe String)
-prefixTp = Tag "Prefix" (maybeTp String)+   -- iso prevents that prefix is turned into an (XML) attribute
+   prefixType = maybeType (Tag "prefix" (Iso identity String))
src/Service/StrategyInfo.hs view
@@ -1,165 +1,177 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Data.Char-import Data.Maybe-import Control.Monad-import Common.Library-import Common.Strategy.Core (Core(..), noLabels)-import Common.Strategy.Abstract-import Text.XML-import Common.Utils (readInt)---------------------------------------------------------------------------- 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-         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)-         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---------------------------------------------------------------------------- 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)-   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)-      , ("many",     comb1 Many)-      , ("repeat",   comb1 Repeat)-      , ("label",    join2 comb1 buildLabel)-      , ("rec",      join2 comb1 buildRec)-      , ("not",      comb1 (Not . noLabels))-      , ("rule",     join2 comb0 buildRule)-      , ("var",      join2 comb0 buildVar)-      , ("succeed",  comb0 Succeed)-      , ("fail",     comb0 Fail) +-----------------------------------------------------------------------------
+-- 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 view
@@ -1,75 +1,66 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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(..), getResultState-   , submitType, submitTypeSynonym-   ) where--import Common.Library-import qualified Service.Diagnose as Diagnose-import Service.Diagnose (Diagnosis, diagnose)-import Service.State-import Service.Types---- 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-          -submit :: State a -> a -> Result a -submit state = fromDiagnose . diagnose state-   -getResultState :: Result a -> Maybe (State a)-getResultState result =-   case result of-      Ok _ st     -> return st-      Detour _ st -> return st-      Unknown st  -> return st-      _           -> Nothing-      -submitType :: Type a (Result a)-submitType = useSynonym submitTypeSynonym--submitTypeSynonym :: TypeSynonym a (Result a)-submitTypeSynonym = typeSynonym "Result" to from tp- where-   to (Left rs) = Buggy rs-   to (Right (Left ())) = NotEquivalent-   to (Right (Right (Left (rs, s)))) = Ok rs s-   to (Right (Right (Right (Left (rs, s))))) = Detour rs s-   to (Right (Right (Right (Right s)))) = Unknown s--   from (Buggy rs)      = Left rs-   from (NotEquivalent) = Right (Left ())-   from (Ok rs s)       = Right (Right (Left (rs, s)))-   from (Detour rs s)   = Right (Right (Right (Left (rs, s))))-   from (Unknown s)     = Right (Right (Right (Right s))) --   tp  =  List Rule -      :|: Unit-      :|: Pair (List Rule) stateTp-      :|: Pair (List Rule) stateTp-      :|: stateTp+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,81 +1,81 @@-{-# LANGUAGE GADTs #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Data.Char-import Service.DomainReasoner-import Service.ModeXML-import Service.ExercisePackage-import Service.Evaluator-import Service.Types-import Common.Library-import Text.XML-   -typedExample :: ExercisePackage a -> Service -> [TypedValue a] -> DomainReasoner (XML, XML, Bool)-typedExample pkg service args = do-   -- Construct a request in xml-   request <- -      case makeArgType args of-         Nothing -> return $  -            stdReply (showId service) enc (exercise pkg) (return ())-         Just (reqTuple ::: reqTp) -> do-            xml <- encodeType (encoder evaluator) reqTp reqTuple-            return $ -               stdReply (showId service) enc (exercise pkg) 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)-      | withOpenMath pkg = (openMathConverterTp pkg, "openmath")-      | otherwise        = (stringFormatConverterTp pkg, "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 [_ ::: ExercisePkg] = 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+{-# 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 view
@@ -1,206 +1,210 @@-{-# LANGUAGE GADTs, Rank2Types #-}--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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, maybeTp, optionTp-   , errorTp, equal, isSynonym, useSynonym, TypeSynonym, typeSynonym-   , equalM-   ) where--import Common.Library-import Common.Utils (commaList)-import Control.Monad-import Data.Maybe-import Service.ExercisePackage---------------------------------------------------------------------------------- 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   ) -> equalPairs a b c d-      (a :|: b,     c :|: d    ) -> equalChoice a b c d-      (List a,      List b     ) -> liftM 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-      (ExercisePkg, ExercisePkg) -> Just id-      (Context,     Context    ) -> Just id-      (Bool,        Bool       ) -> Just id-      (String,      String     ) -> Just id-      (Int,         Int        ) -> Just id-      (Iso _ f a,   _          ) -> fmap (. f) (equal a type2)-      (_,           Iso f _ b  ) -> fmap (f .) (equal type1 b)-      (Tag s1 a,    Tag s2 b   ) -> guard (s1==s2) >> equal a b-      _                          -> Nothing- where-   equalPairs a b c d = -      liftM2 (\f g (x, y) -> (f x, g y)) (equal a c) (equal b d)-   -   equalChoice a b c d =-      liftM2 (\f g -> either (Left . f) (Right . g)) (equal a c) (equal b d)--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)))--maybeTp :: Type a t1 -> Type a (Maybe t1)-maybeTp t = Iso f g (t :|: Unit)- where-   f = either Just (const Nothing)-   g = maybe (Right ()) Left--optionTp :: t1 -> Type a t1 -> Type a t1-optionTp a t = Iso (fromMaybe a) Just (maybeTp t)--errorTp :: Type a t -> Type a (Either String t)-errorTp t = Iso f g (t :|: IO Unit)- where-   f = either Right (const (Left "errorTp"))-   g = either (Right . fail) Left--data Type a t where-   -- Type isomorphisms (for defining type synonyms)-   Iso          :: (t1 -> t2) -> (t2 -> t1) -> 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 ()-   IO           :: Type a t -> Type a (IO t)-   -- Exercise-specific types-   ExercisePkg  :: Type a (ExercisePackage a)-   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-   -- 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" (groundType 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]-   -groundType :: Type a t -> Maybe String-groundType tp =-   case tp of -      ExercisePkg  -> Just "ExercisePkg"-      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"+{-# 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-      --------------------------------------------------------------------------------- Type Synonyms--data TypeSynonym a t = TS -   { synonymName :: String -   , useSynonym  :: Type a t-   , isSynonym   :: Monad m => TypedValue a -> m t-   }-   -typeSynonym :: String -> (t2 -> t) -> (t -> t2) -> Type a t2 -> TypeSynonym a t-typeSynonym name to from tp = TS-   { synonymName = name-   , useSynonym  = Tag name (Iso to from tp)-   , isSynonym   = maybe (fail name) return . matchSynonym-   }- where-   matchSynonym (a ::: t0) = do-      (s, t) <- isTag t0-      guard (s == name)-      f <- equal t tp-      return (to (f a))--isTag :: Type a t -> Maybe (String, Type a t)-isTag (Tag s t) = Just (s, t)-isTag _         = Nothing
src/Text/HTML.hs view
@@ -1,165 +1,187 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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----------------------------------------------------------------------------------module Text.HTML -   ( HTML, HTMLBuilder, showHTML-   , htmlPage, errorPage, link, linkTitle-   , h1, h2, h3, h4, preText, ul, table-   , text, image, space, tt, spaces, highlightXML-   , font, bold, italic, para, ttText, hr, br, pre, center, bullet, divClass-   ) where--import Text.XML hiding (text)-import qualified Text.XML as XML-import Control.Monad-import Data.Char-import Data.List--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     --errorPage :: String -> HTML-errorPage s = htmlPage "Error" Nothing $ do-   h1 "Error"-   text s-   -link :: String -> HTMLBuilder -> HTMLBuilder-link url body = element "a" $ -   ("href" .=. url) >> body--linkTitle :: String -> String -> HTMLBuilder -> HTMLBuilder-linkTitle url title body = element "a" $ -   ("href" .=. url) >> ("title" .=. title) >> body--center :: HTMLBuilder -> HTMLBuilder-center = element "center"--h1 :: String -> HTMLBuilder-h1 = element "h1" . text--h2 :: String -> HTMLBuilder-h2 = element "h2" . text--h3 :: String -> HTMLBuilder-h3 = element "h3" . text--h4 :: String -> HTMLBuilder-h4 = element "h4" . text--font :: String -> HTMLBuilder -> HTMLBuilder-font n = element "font" . ("class" .=. n >>)--bold, italic :: HTMLBuilder -> HTMLBuilder-bold   = element "b" -italic = element "i"--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"--tt :: HTMLBuilder -> HTMLBuilder-tt = element "tt"--ttText :: String -> HTMLBuilder-ttText = tt . text--ul :: [HTMLBuilder] -> HTMLBuilder-ul = element "ul" . mapM_ (element "li")--table :: [[HTMLBuilder]] -> HTMLBuilder-table rows = element "table" $ do-   "border" .=. "1"-   forM_ (zip [0::Int ..] rows) $ \(i, r) ->-      element "tr" $ do-         "class" .=. getClass i-         mapM_ (element "td") r- where-   getClass i-      | i == 0    = "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 body = element "div" ("class" .=. n >> body)---- 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -8,11 +8,11 @@ -- 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. 
+-- Support for JavaScript Object Notation (JSON) and remote procedure calls using
+-- JSON. JSON is a lightweight alternative for XML.
 --
 -----------------------------------------------------------------------------
-module Text.JSON 
+module Text.JSON
    ( JSON(..), Key, Number(..)            -- types
    , InJSON(..)                           -- type class"
    , lookupM
@@ -20,14 +20,15 @@    , jsonRPC, JSON_RPC_Handler, propEncoding
    ) where
 
-import Text.Parsing
-import qualified Text.UTF8 as UTF8
-import Data.List (intersperse)
-import Data.Maybe
 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 
+data JSON
    = Number  Number        -- integer, real, or floating point
    | String  String        -- double-quoted Unicode with backslash escapement
    | Boolean Bool          -- true and false
@@ -37,31 +38,32 @@  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 $ concat $ intersperse ", " $ map showCompact xs
+      Array xs  -> squareBrackets $ intercalate ", " $ map showCompact xs
       Object xs -> let f (k, v) = show k ++ ": " ++ showCompact v
-                   in curlyBrackets  $ concat $ intersperse ", " $ map f xs
+                   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 
+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
@@ -69,11 +71,15 @@       Object xs -> let f (k, v) = show k ++ ": " ++ showPretty v
                    in curlyBrackets $ '\n' : indent 3 (commas (map f xs))
       _         -> showCompact json
- where      
+ 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
@@ -88,20 +94,20 @@    listFromJSON (Array xs) = mapM fromJSON xs
    listFromJSON _          = fail "expecting an array"
 
-instance InJSON Int where 
+instance InJSON Int where
    toJSON   = toJSON . toInteger
    fromJSON = liftM fromInteger . fromJSON
-   
-instance InJSON Integer where 
+
+instance InJSON Integer where
    toJSON                  = Number . I
    fromJSON (Number (I n)) = return n
    fromJSON _              = fail "expecting a number"
 
-instance InJSON Double where 
+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
@@ -110,12 +116,12 @@    listFromJSON (String s) = return s
    listFromJSON _ = fail "expecting a string"
 
-instance InJSON Bool where 
+instance InJSON Bool where
    toJSON = Boolean
    fromJSON (Boolean b) = return b
    fromJSON _           = fail "expecting a boolean"
 
-instance InJSON a => InJSON [a] where 
+instance InJSON a => InJSON [a] where
    toJSON   = listToJSON
    fromJSON = listFromJSON
 
@@ -133,34 +139,30 @@    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"
-    
-parseJSON :: Monad m => String -> m JSON
-parseJSON input = 
-   case parseWith jsonScanner json input of
-      Left err -> fail (show err)
-      Right a  -> return a
+
+--------------------------------------------------------
+-- Parser
+
+parseJSON :: String -> Either String JSON
+parseJSON = parseSimple json
  where
-   jsonScanner = specialSymbols ":" defaultScanner
-      { keywords   = ["true", "false", "null"]
-      , unaryMinus = True
-      }
- 
-   json :: TokenParser JSON
-   json =  (Number . I) <$> pInteger
-       <|> (Number . D) <$> pReal
-       <|> (String . fromMaybe [] . UTF8.decodeM) <$> pString
-       <|> Boolean True <$ pKey "true"
-       <|> Boolean False <$ pKey "false"
-       <|> Array <$> pBracks (pCommas json)
-       <|> Object <$> pCurly (pCommas keyValue)
-       <|> Null <$ pKey "null"
+   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 :: TokenParser (String, JSON)
-   keyValue = (,) <$> pString <* pSpec ':' <*> json
+   keyValue :: Parser (String, JSON)
+   keyValue = (,) <$> P.stringLiteral lexer <* P.colon lexer <*> json
 
-squareBrackets, curlyBrackets :: String -> String
-squareBrackets s = "[" ++ s ++ "]"
-curlyBrackets  s = "{" ++ s ++ "}"
+   lexer :: P.TokenParser a
+   lexer = P.makeTokenParser $ emptyDef
+      { reservedNames = ["true", "false", "null"] }
 
 --------------------------------------------------------
 -- JSON-RPC
@@ -170,7 +172,7 @@    , requestParams :: JSON
    , requestId     :: JSON
    }
-   
+
 data JSON_RPC_Response = Response
    { responseResult :: JSON
    , responseError  :: JSON
@@ -196,7 +198,7 @@       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)
@@ -208,14 +210,14 @@       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
@@ -235,10 +237,10 @@ 
 type JSON_RPC_Handler m = String -> JSON -> m JSON
 
-jsonRPC :: (MonadError a m, InJSON a) 
+jsonRPC :: (MonadError a m, InJSON a)
         => JSON -> JSON_RPC_Handler m -> m JSON_RPC_Response
-jsonRPC input handler = 
-   case fromJSON input of 
+jsonRPC input handler =
+   case fromJSON input of
       Nothing  -> return (errorResponse (String "Invalid request") Null)
       Just req -> do
          json <- handler (requestMethod req) (requestParams req)
@@ -252,25 +254,12 @@ instance Arbitrary JSON where
    arbitrary = sized arbJSON
 
-instance CoArbitrary JSON where
-   coarbitrary json = 
-      case json of
-         Number a  -> variant (0 :: Int) . coarbitrary a
-         String s  -> variant (1 :: Int) . coarbitrary s
-         Boolean b -> variant (2 :: Int) . coarbitrary b
-         Array xs  -> variant (3 :: Int) . coarbitrary xs
-         Object xs -> variant (4 :: Int) . coarbitrary xs
-         Null      -> variant (5 :: Int)
-
 instance Arbitrary Number where
    arbitrary = oneof [liftM I arbitrary, liftM (D . fromInteger) arbitrary]
-instance CoArbitrary Number where
-   coarbitrary (I n) = variant (0 :: Int) . coarbitrary n
-   coarbitrary (D d) = variant (1 :: Int) . coarbitrary d
 
 arbJSON :: Int -> Gen JSON
-arbJSON n 
-   | n == 0 = oneof 
+arbJSON n
+   | n == 0 = oneof
         [ liftM Number arbitrary, liftM String myStringGen
         , liftM Boolean arbitrary, return Null
         ]
@@ -286,13 +275,13 @@         ]
  where
    rec = arbJSON (n `div` 2)
-   
+
 myStringGen :: Gen String
-myStringGen = do 
+myStringGen = do
    n <- choose (1, 10)
-   replicateM n $ oneof $ map return $ 
+   replicateM n $ elements $
       ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9']
-   
+
 propEncoding :: Property
-propEncoding = property $ \a ->  
-   parseJSON (show a) == Just a+propEncoding = property $ \a ->
+   parseJSON (show a) == Right a
− src/Text/OpenMath/ContentDictionary.hs 
@@ -1,161 +0,0 @@------------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more 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.ContentDictionary 
-   ( -- data types
-     ContentDictionary(..), VersionNumber, Date
-   , ContentDictionaryStatus(..), Definition(..)
-     -- parsing and reading
-   , readContentDictionary, main, findOCDs
-   ) where
-
-import Text.OpenMath.Object (OMOBJ, xml2omobj)
-import Text.Scanning (scanInt, Pos(..))
-import Text.XML
-import Data.Char
-import Data.List
-import Data.Maybe
-import Control.Monad
-import System.Directory
-
-main :: IO ()
-main = do
-   let base = "lib/Dictionaries"
-       f x  = base ++ "/" ++ x
-   xs  <- findOCDs base
-   cds <- mapM (readContentDictionary . f) xs
-   let defs = concatMap definitions cds 
-   putStrLn $ show (length cds) ++ " valid dictionaries, with " ++ show (length defs) ++ " definitions"
-
-   -- print [ p | d <- defs, p <- formalProperties d ]
-
-findOCDs :: String -> IO [FilePath]
-findOCDs filepath = do
-   xs <- getDirectoryContents filepath
-   return $ filter (".ocd" `isSuffixOf`) xs
-
-readContentDictionary :: String -> IO ContentDictionary
-readContentDictionary filename = do
-   putStrLn $ "reading " ++ show filename ++ "..."
-   input <- readFile filename
-   case parseXML input of
-      Left s  -> err s
-      Right xml -> do 
-         guard (name xml == "CD") 
-         case buildContentDictionary xml of 
-            Left s -> err s
-            Right cd -> do
-               putStrLn $ "  found " ++ show (length $ definitions cd) ++ " definition(s)"
-               return cd
- `catch` (err . show)
- where
-   err s = fail $ "Content dictionary not found: " ++ s
-
-buildContentDictionary :: XML -> Either String ContentDictionary
-buildContentDictionary xml = do
-   cdname    <- extractText "CDName"       xml
-   descr     <- extractText "Description"  xml
-   revision  <- extractDate "CDDate"       xml
-   review    <- extractDate "CDReviewDate" xml
-   major     <- extractInt "CDVersion"     xml
-   minor     <- extractInt "CDRevision"    xml
-   theStatus <- extractStatus              xml
-   let theBase = extractText "CDBase"      xml
-   theURL    <- extractText "CDURL"        xml
-   defs      <- mapM buildDefinition [ d | d <- children xml, name d == "CDDefinition" ]
-   return CD
-      { dictionaryName = cdname
-      , description    = descr
-      , revisionDate   = revision
-      , reviewDate     = review
-      , versionNumber  = (major, minor)
-      , status         = theStatus
-      , base           = theBase
-      , url            = theURL
-      , definitions    = defs
-  }
-
-buildDefinition :: XML -> Either String Definition
-buildDefinition xml = do
-   theName    <- extractText "Name"        xml
-   descr      <- extractText "Description" xml
-   let theRole = extractText "Role"        xml
-       cmps    = [ getData a   | a <- children xml, name a == "CMP" ]
-       fmps    = [ head xs   | a <- children xml, name a == "FMP", let xs=children a, length xs==1 ]
-       exs     = [ children a | a <- children xml, name a == "Example" ]
-   return Definition
-      { symbolName          = theName
-      , symbolDescription   = descr
-      , role                = theRole
-      , commentedProperties = cmps
-      , formalProperties    = map (either error id . xml2omobj) fmps
-      , examples            = exs
-      }
-
-extractDate :: String -> XML -> Either String Date
-extractDate s xml = do
-   txt <- extractText s xml
-   case txt of 
-      [y1,y2,y3,y4,'-',m1,m2,'-',d1,d2] | all isDigit [y1,y2,y3,y4,m1,m2,d1,d2] -> 
-         return (read [y1,y2,y3,y4], read [m1,m2], read [d1,d2])
-      _ -> fail ("invalid date (YYYY-MM-DD): " ++ txt)
-
-extractInt :: String -> XML -> Either String Int
-extractInt s xml = do 
-   txt <- extractText s xml
-   case scanInt (Pos 0 0) txt of
-      Just (i, _, rest) | all isSpace rest
-         -> return i
-      _  -> fail "Not an int"
-
-extractStatus :: XML -> Either String ContentDictionaryStatus
-extractStatus xml = do
-   txt <- extractText "CDStatus" xml
-   let (hd, tl) = splitAt 1 txt
-       list     = [Official, Experimental, Private, Obsolete]
-       table    = [ (show s, s) | s <- list ]
-   case lookup (map toUpper hd ++ map toLower tl) table of
-      Just hd -> return hd
-      _       -> fail "Unknown status"
-
-extractText :: MonadPlus m => String -> XML -> m String
-extractText s xml = do
-   a <- findChild s xml
-   guard (null $ children a)
-   return (getData a)
-
-data ContentDictionary = CD 
-   { dictionaryName :: String
-   , description    :: String
-   , revisionDate   :: Date
-   , reviewDate     :: Date
-   , versionNumber  :: VersionNumber
-   , status         :: ContentDictionaryStatus
-   , base           :: Maybe String
-   , url            :: String
-   , definitions    :: [Definition]   
-   } deriving Show
-
-type VersionNumber = (Int, Int) -- major and minor part
-type Date = (Int, Int, Int) -- YYYY-MM-DD
-
-data ContentDictionaryStatus = Official | Experimental | Private | Obsolete 
-   deriving Show
-
-data Definition = Definition 
-   { symbolName          :: String
-   , symbolDescription   :: String
-   , role                :: Maybe String
-   , commentedProperties :: [String]
-   , formalProperties    :: [OMOBJ]
-   , examples            :: [[XML]]
-   } 
- deriving Show
src/Text/OpenMath/Dictionary/Arith1.hs view
@@ -76,5 +76,4 @@ 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"
-
+productSymbol = makeSymbol "arith1" "product"
src/Text/OpenMath/Dictionary/Calculus1.hs view
@@ -33,5 +33,4 @@ 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"
-
+defintSymbol = makeSymbol "calculus1" "defint"
src/Text/OpenMath/Dictionary/Fns1.hs view
@@ -70,5 +70,4 @@ 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"
-
+lambdaSymbol = makeSymbol "fns1" "lambda"
src/Text/OpenMath/Dictionary/Linalg2.hs view
@@ -21,5 +21,4 @@ {-| 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"
-
+matrixSymbol = makeSymbol "linalg2" "matrix"
src/Text/OpenMath/Dictionary/List1.hs view
@@ -25,5 +25,4 @@ {-| 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"
-
+listSymbol = makeSymbol "list1" "list"
src/Text/OpenMath/Dictionary/Logic1.hs view
@@ -47,5 +47,4 @@ 
 {-| This symbol represents the boolean value false. -}
 falseSymbol :: Symbol
-falseSymbol = makeSymbol "logic1" "false"
-
+falseSymbol = makeSymbol "logic1" "false"
src/Text/OpenMath/Dictionary/Nums1.hs view
@@ -51,5 +51,4 @@ {-| 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"
-
+naNSymbol = makeSymbol "nums1" "NaN"
src/Text/OpenMath/Dictionary/Quant1.hs view
@@ -19,5 +19,4 @@ argument is the bound variables (placed within an OMBVAR element), and the
 second is an expression. -}
 existsSymbol :: Symbol
-existsSymbol = makeSymbol "quant1" "exists"
-
+existsSymbol = makeSymbol "quant1" "exists"
src/Text/OpenMath/Dictionary/Relation1.hs view
@@ -41,5 +41,4 @@ {-| This symbol is used to denote the approximate equality of its two
 arguments. -}
 approxSymbol :: Symbol
-approxSymbol = makeSymbol "relation1" "approx"
-
+approxSymbol = makeSymbol "relation1" "approx"
src/Text/OpenMath/Dictionary/Transc1.hs view
@@ -146,5 +146,4 @@ {-| This symbol represents the arccoth function as described in Abramowitz and
 Stegun, section 4.6. -}
 arccothSymbol :: Symbol
-arccothSymbol = makeSymbol "transc1" "arccoth"
-
+arccothSymbol = makeSymbol "transc1" "arccoth"
src/Text/OpenMath/FMP.hs view
@@ -1,53 +1,53 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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.Object-import Text.OpenMath.Symbol-import Text.OpenMath.Dictionary.Quant1 (forallSymbol, existsSymbol)-import Text.OpenMath.Dictionary.Relation1 (eqSymbol, neqSymbol)--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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,93 +1,93 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Text.OpenMath.ContentDictionary hiding (main)-import Control.Monad-import Data.Char-import Data.List--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 ++ " = [" ++ concat (intersperse ", " 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-}
 -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -10,25 +10,24 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Text.OpenMath.Object 
+module Text.OpenMath.Object
    ( OMOBJ(..), getOMVs, xml2omobj, omobj2xml
    ) where
 
-import Data.Char (isSpace)
-import Data.Generics.Uniplate hiding (children)
+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.Scanning (scanInt, scanNumber, Pos(..))
 import Text.XML
 
 -- internal representation for OpenMath objects
-data OMOBJ = OMI Integer 
-           | OMF Double 
-           | OMV String 
-           | OMS Symbol 
-           | OMA [OMOBJ] 
+data OMOBJ = OMI Integer
+           | OMF Double
+           | OMV String
+           | OMS Symbol
+           | OMA [OMOBJ]
            | OMBIND OMOBJ [String] OMOBJ
    deriving (Show, Eq, Typeable)
 
@@ -39,51 +38,49 @@ instance Uniplate OMOBJ where
    uniplate omobj =
       case omobj of
-         OMA xs        -> (xs, OMA)
-         OMBIND a ss b -> ([a, b], \[x, y] -> OMBIND x ss y)
-         _             -> ([], \_ -> omobj)
+         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  
+   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) 
+            ys <- mapM rec (children xml)
             return (OMA ys)
-            
+
          [] | name xml == "OMS" -> do
             let mcd = findAttribute "cd" xml
             n <- findAttribute "name" xml
-            return (OMS (Symbol mcd n))
+            return (OMS (mcd, n))
 
          [Left s] | name xml == "OMI" ->
-            case scanInt (Pos 0 0) s of
-               Just (i, _, rest) | all isSpace rest
-                  -> return (OMI (toInteger i))
-               _  -> fail "invalid integer in 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 scanNumber (Pos 0 0) s of
-               Just (nr, _, rest) | all isSpace rest 
-                  -> return (OMF (either fromIntegral id nr))
-               _  -> fail "invalid floating-point in OMF"
-                    
+            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
@@ -91,15 +88,15 @@             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 = 
+      | otherwise =
            fail ("expected tag OMVAR, but found " ++ show (name xml))
-   
+
 omobj2xml :: OMOBJ -> XML
 omobj2xml object = makeXML "OMOBJ" $ do
    "xmlns"   .=. "http://www.openmath.org/OpenMath"
@@ -116,7 +113,17 @@          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+         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 view
@@ -1,33 +1,35 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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--data Symbol = Symbol-   { dictionary :: Maybe String-   , symbolName :: String-   }- deriving (Eq, Ord)--instance Show Symbol where-   show s = maybe "" (++".") (dictionary s) ++ symbolName s--instance Read Symbol where-   readsPrec _ s = -      case break (=='.') s of-         (xs,_:ys) -> [(makeSymbol xs ys, "")]-         _         -> [(extraSymbol s, "")]-               -makeSymbol :: String -> String -> Symbol-makeSymbol = Symbol . Just--extraSymbol :: String -> Symbol-extraSymbol = Symbol Nothing+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,50 +1,50 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Text.OpenMath.Object-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--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 OMF arbitrary)-      , (1, liftM OMV arbitrary)-      , (5, oneof $ map (return . 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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,7 +1,6 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
 -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -9,230 +8,111 @@ -- Stability   :  provisional
 -- Portability :  portable (depends on ghc)
 --
--- A simplified interface to the UU.Parsing library.
+-- Utility functions for parsing with Parsec library
 --
 -----------------------------------------------------------------------------
-module Text.Parsing 
-   ( -- * Scaning
-     module Text.Scanning
-     -- * Parsing
-   , Parser, CharParser, TokenParser
-   , parse, parseWith, parseWithM
-     -- * Primitive token parsers
-   , pVarid, pConid, pOpid, pQVarid, pQConid
-   , pKey, pSpec, pInt, pReal, pString
-     -- * Derived token parsers
-   , pParens, pBracks, pCurly, pCommas, pLines, pInteger
-     -- * UU parser combinators
-   , (<$>), (<$), (<*>), (*>), (<*), (<|>), optional, pList, pList1, pSepList
-   , pChainl, pChainr, pChoice, pFail
-    -- * Operator table (parser)
-   , OperatorTable, Associativity(..), pOperators
+module Text.Parsing
+   ( module Export
+   , (<*>), (*>), (<*), (<$>), (<$), (<**>)
+   , parseSimple, complete, skip, (<..>), ranges, stopOn
+   , naturalOrFloat, float
+   , UnbalancedError(..), balanced
    ) where
 
-import Data.Maybe
-import Text.Scanning
-import qualified UU.Parsing as UU
-
-----------------------------------------------------------
--- Parsing
-
--- | Abstract data type for a parser, where @s@ is the symbol type, and @a@ is 
--- the result type. This data type is an instance of the @IsParser@ type class
--- defined in the UU libraries.
-newtype Parser s a = P { unP :: UU.AnaParser [s] UU.Pair s (Maybe s) a }
+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
 
--- | A parser with characters as symbol type
-type CharParser  = Parser Char
+parseSimple :: Parser a -> String -> Either String a
+parseSimple p = left show . runParser (complete p) () ""
 
--- | A parser with tokens as symbol type
-type TokenParser = Parser Token
+complete :: Parser a -> Parser a
+complete p = spaces *> (p <* eof)
 
-instance (UU.Symbol s, Ord s) => UU.IsParser (Parser s) s where
-   ~(P p) <*>  ~(P q)  = P (p UU.<*> q)
-   ~(P p) <*   ~(P q)  = P (p UU.<*  q)
-   ~(P p)  *>  ~(P q)  = P (p  UU.*> q)
-   ~(P p) <|>  ~(P q)  = P (p UU.<|> q) 
-   a      <$>  ~(P p)  = P (a UU.<$> p)
-   a      <$   ~(P p)  = P (a UU.<$  p) 
-   pSucceed            = P . UU.pSucceed
-   pFail               = P UU.pFail
-   pLow                = P . UU.pLow
-   pSym                = P . UU.pSym
-   pRange a            = P . UU.pRange a
-   pCostRange a b      = P . UU.pCostRange a b
-   pCostSym a b        = P . UU.pCostSym a b
-   getfirsts           = UU.getfirsts . unP
-   setfirsts e         = P . UU.setfirsts e . unP
-   getzerop            = fmap P . UU.getzerop . unP
-   getonep             = fmap P . UU.getonep  . unP 
+skip :: Parser a -> Parser ()
+skip p = p >> return ()
 
-parse :: UU.Symbol s => Parser s a -> [s] -> Either (Maybe s) a
-parse (P p) input =
-   case messages of
-      []              -> Right result
-      UU.Msg _ ms _:_ -> Left ms 
+-- 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
-   steps    = UU.parse p input
-   messages = UU.getMsgs steps
-   result   = (\(UU.Pair a _) -> a) (UU.evalSteps steps)
-   
-parseWith :: Scanner -> TokenParser a -> String -> Either SyntaxError a
-parseWith scanner p = either f Right . parse p . scanWith scanner
- where 
-    f (Just s) = Left (Unexpected s)
-    f Nothing  = Left (ErrorMessage "Syntax error")
-
-parseWithM :: Monad m => Scanner -> TokenParser a -> String -> m a
-parseWithM scanner p = either (fail . show) return . parseWith scanner p
-
-----------------------------------------------------------
--- Primitive token parsers
-
-pVarid, pConid, pOpid :: TokenParser String
-pQVarid, pQConid      :: TokenParser (String, String)
-pString               :: TokenParser String
-pInt                  :: TokenParser Int
-pReal                 :: TokenParser Double
-
-pKey  :: String -> TokenParser String 
-pSpec :: Char   -> TokenParser Char
-
-pVarid  = makeTokS isTokenVarId  TokenVarId
-pConid  = makeTokS isTokenConId  TokenConId
-pOpid   = makeTokS isTokenOpId   TokenOpId
-pQVarid = makeTokT isTokenQVarId TokenQVarId
-pQConid = makeTokT isTokenQConId TokenQConId
-pString = makeTokS isTokenString TokenString
-pInt    = makeTokN isTokenInt    TokenInt
-pReal   = makeTokR isTokenReal   TokenReal
-pKey    = makeTokA TokenKeyword 
-pSpec   = makeTokA TokenSpecial
-
--- helpers
-makeTokS :: (Token -> Maybe a) -> (String -> Pos -> Token) -> TokenParser a
-makeTokS f con = makeTok (fromJust . f) (con minString) (con maxString)
-
-makeTokT :: (Token -> Maybe a) -> (String -> String -> Pos -> Token) -> TokenParser a
-makeTokT f con = makeTok (fromJust . f) (con minString minString) (con maxString maxString)
-
-makeTokN :: (Token -> Maybe Int) -> (Int -> Pos -> Token) -> TokenParser Int
-makeTokN f con = makeTok (fromJust . f) (con minBound) (con maxBound)
-
-makeTokR :: (Token -> Maybe Double) -> (Double -> Pos -> Token) -> TokenParser Double
-makeTokR f con = makeTok (fromJust . f) (con (-d)) (con d)
- where d = (10 :: Double) ^ (500 :: Int)
-
-makeTokA :: (a -> Pos -> Token) -> a -> TokenParser a
-makeTokA con a = makeTok (const a) (con a) (con a)
-
-makeTok :: (Token -> a) -> (Pos -> Token) -> (Pos -> Token) -> TokenParser a
-makeTok f con1 con2 = 
-   f UU.<$> con1 minPos UU.<..> con2 maxPos
-
-minPos, maxPos :: Pos
-minPos = Pos minBound minBound
-maxPos = Pos maxBound maxBound
-
-minString, maxString :: String
-minString = []
-maxString = replicate 100 maxBound
-
-----------------------------------------------------------
--- Derived token parsers
- 
-pParens, pBracks, pCurly :: TokenParser a -> TokenParser a
-pParens p = pSpec '(' UU.*> p UU.<* pSpec ')'
-pBracks p = pSpec '[' UU.*> p UU.<* pSpec ']'
-pCurly  p = pSpec '{' UU.*> p UU.<* pSpec '}'
-
-pCommas :: TokenParser a -> TokenParser [a]
-pCommas p = optional ((:) <$> p <*> pList ((\_ a -> a) <$> pSpec ',' <*> p)) []
+   nat = many1 digit
+   num = maybe id (:) <$> optionMaybe (char '-') <*> nat
+   readInt = foldl' op 0 -- '
+   op a b  = a*10+fromIntegral (ord b)-48
 
--- | Parse lines, separated by the newline character. The boolean argument indicates whether empy lines should 
--- be accepted or not. Make sure to configure the scanner to treat newlines as special characters!
-pLines :: Bool -> TokenParser a -> TokenParser [a]
-pLines allowEmptyLine p = catMaybes <$> pn 
+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
-   pOne | allowEmptyLine = optional (Just <$> p) Nothing
-        | otherwise      = Just <$> p
-   pn = (:) <$> pOne <*> pList (pSpec '\n' *> pOne)
-
-pInteger :: TokenParser Integer
-pInteger = fromIntegral <$> pInt
-
-----------------------------------------------------------
--- UU parser combinators
-
-infixl 3 <|>
-infixl 4 <$>, <$, <*>, <*, *>
-
-(<$>) :: (Ord s, UU.Symbol s) => (a -> b) -> Parser s a -> Parser s b
-(<$>) = (UU.<$>)
-
-(<$) :: (Ord s, UU.Symbol s) => a -> Parser s b -> Parser s a
-(<$) = (UU.<$)
-
-(<*>) :: (Ord s, UU.Symbol s) => Parser s (a -> b) -> Parser s a -> Parser s b
-(<*>) = (UU.<*>)
-
-(*>) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s b
-(*>) = (UU.*>)
-
-(<*) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s a
-(<*) = (UU.<*)
-
-(<|>) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s a -> Parser s a
-(<|>) = (UU.<|>)
-
-optional :: (Ord s, UU.Symbol s) => Parser s a -> a -> Parser s a
-optional = UU.opt
-
-pList, pList1 :: (Ord s, UU.Symbol s) => Parser s a -> Parser s [a]
-pList = UU.pList
-pList1 = UU.pList1
-
-pSepList :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s [a]
-pSepList p q = (:) <$> p <*> pList (q *> p)
-
-pChainl, pChainr :: (Ord s, UU.Symbol s) => Parser s (a -> a -> a) -> Parser s a -> Parser s a
-pChainl = UU.pChainl
-pChainr = UU.pChainr
+   nat = many1 digit
+   num = (:) <$> char '-' <*> nat
 
-pChoice :: (Ord s, UU.Symbol s) => [Parser s a] -> Parser s a
-pChoice = foldr (<|>) UU.pFail
+infix  6 <..>
 
-pFail :: (Ord s, UU.Symbol s) => Parser s a
-pFail = UU.pFail
+(<..>) :: Char -> Char -> Parser Char
+x <..> y = satisfy (\c -> c >= x && c <= y)
 
-----------------------------------------------------------
--- Operator table (parser)
+ranges :: [(Char, Char)] -> Parser Char
+ranges xs = choice [ a <..> b | (a, b) <- xs ]
 
--- | Type for an operator table. Operators with a low priority should appear in the front of the list.
-type OperatorTable a = [(Associativity, [(String, a -> a -> a)])]
+-- 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 []
 
--- | Data type to express the kind of associativity. The NoMix constructor expresses that the operators
--- in the list should not be mixed, but require extra parentheses in the input
-data Associativity = LeftAssociative | RightAssociative | NonAssociative | NoMix
+-- 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
 
--- | Construct a parser using an operator table
-pOperators :: OperatorTable a -> TokenParser a -> TokenParser a
-pOperators table p = foldr combine p table 
- where combine (a, ops) q = 
-          case a of
-             -- The NoMix variant is actually hard to define efficiently. Since we should not mix operators
-             -- that have the same priority, we have to inspect which operator we are dealing with before
-             -- we can use the chain combinator.
-             NoMix -> let make op = flip <$> f op <*> pChainr (f op) q
-                      in flip ($) <$> q <*> optional (pChoice $ map make ops) id
-             _     -> pChain a (pChoice $ map f ops) q
-       f (s, g) = g <$ pKey s
+   (opens, closes) = unzip table
 
+data UnbalancedError = NotClosed SourcePos Char
+                     | NotOpened SourcePos Char
 
--- local helper function
-pChain :: (Ord s, UU.Symbol s) => Associativity -> Parser s (a -> a -> a) -> Parser s a -> Parser s a
-pChain a p q = case a of
-                  LeftAssociative  -> pChainl p q
-                  RightAssociative -> pChainr p q
-                  NonAssociative   -> flip ($) <$> q <*> p <*> q
-                  NoMix            -> pChainr p q+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/Scanning.hs 
@@ -1,366 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 scanner with some configuration facilities----------------------------------------------------------------------------------module Text.Scanning -   ( -- Data types-     Pos(..), Token(..)-     -- Token selectors-   , isTokenConId, isTokenVarId, isTokenOpId, isTokenQConId-   , isTokenQVarId, isTokenKeyword, isTokenSpecial-   , isTokenString, isTokenInt, isTokenReal, tokenPosition-     -- Scanner configuration-   , Scanner(..), defaultScanner, specialSymbols  -     -- Scanning-   , scan, scanWith, scanInt, scanNumber-     -- Lexical analysis-   , SyntaxError(..), checkParentheses, errorPositions-   ) where--import Control.Monad-import Data.List-import Data.Char-import qualified UU.Parsing as UU--------------------------------------------------------------- * Data types--data Pos = Pos { line :: !Int, column :: !Int }-   deriving (Eq, Ord)---- position field in last position, needed for ranged parsing-data Token -   = TokenConId   String Pos-   | TokenVarId   String Pos-   | TokenOpId    String Pos-   | TokenQConId  String String Pos-   | TokenQVarId  String String Pos-   | TokenKeyword String Pos-   | TokenSpecial Char   Pos-   | TokenString  String Pos-   | TokenInt     Int    Pos-   | TokenReal    Double Pos- deriving (Eq, Ord)--instance UU.Symbol Token--instance Show Pos where-   show (Pos l c) = "(" ++ show l ++ "," ++ show c ++ ")"--instance Show Token where-   show token = -      case token of-         TokenConId    s _ -> "identifier " ++ s-         TokenVarId    s _ -> "identifier " ++ s-         TokenOpId     s _ -> "operator " ++ s-         TokenQConId q s _ -> "identifier " ++ q ++ "." ++ s-         TokenQVarId q s _ -> "identifier " ++ q ++ "." ++ s-         TokenKeyword  s _ -> "keyword " ++ s-         TokenSpecial  c _ -> "symbol " ++ [c]-         TokenString   s _ -> "string " ++ show s-         TokenInt      i _ -> "integer " ++ show i-         TokenReal     d _ -> "floating-point number " ++ show d--------------------------------------------------------------- * Token selectors--isTokenConId :: Token -> Maybe String-isTokenConId (TokenConId s _) = Just s-isTokenConId _                = Nothing--isTokenVarId :: Token -> Maybe String-isTokenVarId (TokenVarId s _) = Just s-isTokenVarId _                = Nothing--isTokenOpId :: Token -> Maybe String-isTokenOpId (TokenOpId s _) = Just s-isTokenOpId _               = Nothing--isTokenQConId :: Token -> Maybe (String, String)-isTokenQConId (TokenQConId q s _) = Just (q, s)-isTokenQConId _                   = Nothing--isTokenQVarId :: Token -> Maybe (String, String)-isTokenQVarId (TokenQVarId q s _) = Just (q, s)-isTokenQVarId _                   = Nothing--isTokenKeyword :: Token -> Maybe String-isTokenKeyword (TokenKeyword s _) = Just s-isTokenKeyword _                  = Nothing--isTokenSpecial :: Token -> Maybe Char-isTokenSpecial (TokenSpecial c _) = Just c-isTokenSpecial   _                = Nothing--isTokenString :: Token -> Maybe String-isTokenString (TokenString s _) = Just s-isTokenString  _                = Nothing--isTokenInt :: Token -> Maybe Int-isTokenInt (TokenInt i _) = Just i-isTokenInt _              = Nothing--isTokenReal :: Token -> Maybe Double-isTokenReal (TokenReal d _) = Just d-isTokenReal _               = Nothing-      -tokenPosition :: Token -> Pos-tokenPosition token =-   case token of-      TokenConId    _ p -> p-      TokenVarId    _ p -> p-      TokenOpId     _ p -> p-      TokenQConId _ _ p -> p-      TokenQVarId _ _ p -> p-      TokenKeyword  _ p -> p-      TokenSpecial  _ p -> p-      TokenString   _ p -> p-      TokenInt      _ p -> p-      TokenReal     _ p -> p--------------------------------------------------------------- * Scanner configuration---- | Data type to configure a scanner-data Scanner = Scanner-   { keywords              :: [String]-   , keywordOperators      :: [String]-   , isIdentifierCharacter :: Char -> Bool-   , specialCharacters     :: String-   , operatorCharacters    :: String-   , unaryMinus            :: Bool-   , qualifiedIdentifiers  :: Bool-   }---- | A default scanner configuration (using Haskell's special characters)-defaultScanner :: Scanner-defaultScanner = Scanner-   { keywords              = []-   , keywordOperators      = []-   , isIdentifierCharacter = \c -> isAlphaNum c || c `elem` "_'"-   , specialCharacters     = "(),;[]`{}"              -- Haskell's special characters -   , operatorCharacters    = "!#$%&*+./<=>?@\\^|-~"   -- The non-special characters-   , unaryMinus            = False      -   , qualifiedIdentifiers  = False-   }---- | Add characters to the list of special characters (and remove these from the list of operator characters)-specialSymbols :: String -> Scanner -> Scanner-specialSymbols cs scanner = scanner-   { specialCharacters = specialCharacters scanner `union` cs }--------------------------------------------------------------- * Scanning---- | Scan an input string with the default scanner configuration-scan :: String -> [Token]-scan = scanWith defaultScanner--scanWith :: Scanner -> String -> [Token]-scanWith scanner = rec (Pos 1 1)- where -   rec :: Pos -> String -> [Token]-   rec _ [] = []-   rec pos input@(x:rest) -      | isSpace x = -           let newp = advance [x] pos-           in if x `elem` specialCharacters scanner-              then TokenSpecial x pos : rec newp rest-              else rec newp rest-      | isAlpha x =-           case scanIdentifier scanner input of-              Just (Just q, s, xs) -                 | isLower (head s) -> make TokenQVarId-                 | otherwise        -> make TokenQConId-               where-                 make f = f q s pos : rec newp xs-                 newp   = incr (length q + length s + 1) pos-              Just (Nothing, s, xs)-                 | s `elem` keywords scanner -> make TokenKeyword-                 | isLower (head s)          -> make TokenVarId -                 | otherwise                 -> make TokenConId-               where -                 make f = f s pos : rec newp xs-                 newp   = incr (length s) pos-              _ -> error "unexpected case in scanner"-      | isNum input =-           case scanNumber pos input of-              Just (Left i,  newp, xs) -> TokenInt  i pos : rec newp xs-              Just (Right d, newp, xs) -> TokenReal d pos : rec newp xs-              _ -> error "unexpected case in scanner" -      | x == '"' = -           case scanString pos rest of-              Just (s, newp, xs) -> -                 TokenString s pos : rec newp xs-              Nothing -> -                 TokenSpecial x pos : rec (incr 1 pos) rest-      | x `elem` specialCharacters scanner = -           let newp = incr 1 pos -           in  if [x] `elem` keywordOperators scanner-               then TokenKeyword [x] pos : rec newp rest-               else TokenSpecial x pos : rec newp rest-      | x `elem` operatorCharacters scanner = -           let (xs, ys) = break stop rest-               newp     = incr (length (x:xs)) pos-               stop c   =  c `elem` specialCharacters scanner -                        || c `notElem` operatorCharacters scanner-           in if (x:xs) `elem` keywordOperators scanner-              then TokenKeyword (x:xs) pos : rec newp ys-              else TokenOpId (x:xs) pos : rec newp ys-      | otherwise = -           let newp = incr 1 pos-           in TokenSpecial x pos : rec newp rest--   isNum :: String -> Bool-   isNum ('-':x:_) = isDigit x && unaryMinus scanner-   isNum (x:_)     = isDigit x-   isNum _         = False--scanIdentifier :: Scanner -> String -> Maybe (Maybe String, String, String)-scanIdentifier scanner (x:rest) | isAlpha x = -   case span (isIdentifierCharacter scanner) rest of-      (xs, '.':y:rest2) | qualifiedIdentifiers scanner && isAlpha y -> -         let (ys, zs) = span (isIdentifierCharacter scanner) rest2-         in Just (Just (x:xs), y:ys, zs)-      (xs, ys) -> -         Just (Nothing, x:xs, ys)-scanIdentifier _ _ = Nothing--scanNumber :: Pos -> String -> Maybe (Either Int Double, Pos, String)-scanNumber pos input = do-   (i, p, xs) <- scanInt pos input-   case fractionPart p xs of-      Just (p1, ys) -> -         case powerPart p1 ys of-            Just (p2, zs) -> -               let txt = take (column p2 - column pos) input-               in return (Right (read txt), p2, zs)-            Nothing ->-               let txt = take (column p1 - column pos) input -               in return (Right (read txt), p1, ys)-      Nothing -> -         case powerPart p xs of   -            Just (p1, ys) -> -               let txt = take (column p1 - column pos) input-               in return (Right (read txt), p1, ys)-            Nothing -> -               return (Left i, p, xs)--fractionPart :: Pos -> String -> Maybe (Pos, String)-fractionPart pos ('.':rest) = do-   (_, p, ys) <- scanNatural pos rest-   return (incr 1 p, ys)-fractionPart _ _ = Nothing--powerPart :: Pos -> String -> Maybe (Pos, String)-powerPart pos (s:rest) | s `elem` "eE" = do-   (_, p, ys) <- scanInt pos rest-   return (incr 1 p, ys)-powerPart _ _ = Nothing--scanInt :: Pos -> String -> Maybe (Int, Pos, String)-scanInt pos ('-':xs) =-   do (nat, p, rest) <- scanNatural pos xs-      return (-nat, incr 1 p, rest)-scanInt pos xs = -   scanNatural pos xs--scanNatural :: Pos -> String -> Maybe (Int, Pos, String)-scanNatural pos input = do-   let (xs, ys) = span isDigit input-   guard (not (null xs))-   let nat = foldl' (\a b -> a*10+ord b-48) 0 xs-   return (nat, incr (length xs) pos, ys)--scanString :: Pos -> String -> Maybe (String, Pos, String)-scanString pos input =-   case input of -      []        -> Nothing -      '\\':x:xs -> add x (scanString (incr 2 pos) xs)-      '"':xs    -> Just ("",incr 1 pos,xs)-      x:xs      -> add x (scanString (incr 1 pos) xs)- where-   add c = fmap (\(s, np, t) -> (c:s, np, t))-   -advance :: String -> Pos -> Pos-advance [] = id-advance (x:xs)  -   | x == '\n' = advance xs . nextline-   | otherwise = advance xs . incr 1--incr :: Int -> Pos -> Pos-incr i p = p { column = column p + i }--nextline :: Pos -> Pos-nextline p = p { line = line p + 1, column = 1 }----------------------------------------------------------------- Lexical analysis--data SyntaxError -   = Unexpected Token-   | ParNotClosed Token -   | ParNoOpen Token -   | ParMismatch Token Token-   | ErrorMessage String--instance Show SyntaxError where-   show err = prefixPosition err ++-      case err of-         Unexpected t      -> "Unexpected " ++ show t-         ParNotClosed t    -> "Opening parenthesis " ++ show t ++ " is not closed"-         ParNoOpen t       -> "Closing parenthesis " ++ show t ++ " has no matching symbol"-         ParMismatch t1 t2 -> "Opening parenthesis " ++ show t1 ++ " is closed with " ++ show t2-         ErrorMessage msg  -> msg--prefixPosition :: SyntaxError -> String-prefixPosition err-   | null xs   = ""-   | otherwise = concat (intersperse "," xs) ++ ": "- where-   xs = map show (errorPositions err)--errorPositions :: SyntaxError -> [Pos]-errorPositions err = -   case err of-      Unexpected t      -> [tokenPosition t]-      ParNotClosed t    -> [tokenPosition t]-      ParNoOpen t       -> [tokenPosition t]-      ParMismatch t1 t2 -> [tokenPosition t1, tokenPosition t2]-      ErrorMessage _    -> []--checkParentheses :: [Token] -> Maybe SyntaxError-checkParentheses = rec []- where-   rec []    [] = Nothing-   rec (t:_) [] = Just (ParNotClosed t)-   rec stack (t:ts)-      | isOpening t =-           rec (t:stack) ts-      | isClosing t =-           case stack of-              [] -> Just (ParNoOpen t) -              x:xs-                 | match x t -> rec xs ts-                 | otherwise -> Just (ParMismatch x t)-      | otherwise =-           rec stack ts--isOpening, isClosing :: Token -> Bool-isOpening (TokenSpecial ('(') _) = True-isOpening _ = False-isClosing (TokenSpecial (')') _) = True-isClosing _ = False-            -match :: Token -> Token -> Bool-match (TokenSpecial ('(') _) (TokenSpecial (')') _) = True-match _ _ = False
src/Text/UTF8.hs view
@@ -1,123 +1,123 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Data.Char-import Data.Maybe-import Control.Monad.Error-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+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,6 +1,6 @@ -----------------------------------------------------------------------------
--- Copyright 2010, Open Universiteit Nederland. This file is distributed 
--- under the terms of the GNU General Public License. For more information, 
+-- 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.
 -----------------------------------------------------------------------------
 -- |
@@ -15,14 +15,13 @@ module Text.XML
    ( XML, Attr, AttrList, InXML(..), Element(..)
    , XMLBuilder, makeXML, text, unescaped, element, tag, attribute
-   , parseXML, showXML, compactXML, (.=.), findAttribute
+   , parseXML, showXML, compactXML, (.=.), findAttribute, updateLast
    , children, Attribute(..), builder, findChild, getData
    ) where
 
-import Control.Monad.Error ()
 import Control.Monad.State
+import Data.Char
 import Data.Monoid
-import Text.XML.Document (trim)
 import Text.XML.Interface hiding (parseXML)
 import qualified Text.XML.Interface as I
 
@@ -42,7 +41,8 @@    -- default definitions
    listToXML = Element "list" [] . map (Right . toXML)
    listFromXML xml
-      | name xml == "list" && noAttributes xml = mapM fromXML (children xml)
+      | name xml == "list" && null (attributes xml) =
+           mapM fromXML (children xml)
       | otherwise = fail "expecting a list tag"
 
 ----------------------------------------------------------------
@@ -54,21 +54,21 @@    return (ignoreLayout xml)
 
 ignoreLayout :: XML -> XML
-ignoreLayout (Element n as xs) = 
+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 
+ where
    rec i (Element n as xs) =
-      let ipl  = i+2 
+      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
 
@@ -104,13 +104,23 @@    m >>= f = XMLBuilder (unBuild m >>= (unBuild . f))
 
 makeXML :: String -> XMLBuilder -> XML
-makeXML s m = 
+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
@@ -139,50 +149,5 @@    f '&' = "&amp;"
    f c   = [c]
 
-----------------------------------------------------------------
--- XML utility functions
-
-{-
-children :: XML -> [XML]
-children (Element _ _ xs) = xs
-
-extract :: Monad m => String -> XML -> m [XML]
-extract n xml =
-   case filter (children xml) of --  [ xs | Tagged (Element m _ xs) <- children xml, n==m ] of
-      [hd] -> return hd
-      _    -> fail ("missing tag " ++ show n)
-
-extractText :: Monad m => String -> XML -> m String
-extractText n xml = do
-   xs <- extract n xml
-   case xs of
-      [hd] -> maybe (fail "extract text") return (isText hd)
-      _    -> fail ("invalid content for tag " ++ show n)
-
-isTag :: XML -> Maybe (String, AttrList, [XML])
-isTag = 
-isTag (Tagged (Element n as xs)) = 
-   let f (x := y) = (x, concatMap (either return g) y) 
-       g (CharRef n) = [chr n]
-       g (EntityRef n)
-          | otherwise = []
-   in Just (n, map f as, xs)
-isTag _ = Nothing 
-
-mkTag :: String -> AttrList -> Content -> XML
-mkTag n as = Element n (map f as)
- where
-   f (x, y) = x := y
-
-mkText :: String -> XML
-mkText = -- CharData
-
-isText :: XML -> Maybe String
-isText =
-isText (CharData s) = Just s
-isText (CDATA s)    = Just s
-isText _            = Nothing 
-
-findChild :: Monad m => String -> XML -> m XML
-findChild s e = maybe (fail "child not found") return . safeHead $ 
-   [ c | c <- children e, Just (n, _, _) <- [isTag c], s==n ]-}+trim :: String -> String
+trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
src/Text/XML/Document.hs view
@@ -1,259 +1,234 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 where--import Data.Char-import Data.List-import Data.Maybe--type Name = String--type Attributes = [Attribute]-data Attribute  = Name := AttValue deriving Eq--data Reference = CharRef Int | EntityRef String-   deriving Eq-   -data Parameter = Parameter String-   deriving Eq-   -data XMLDoc = XMLDoc -   { versionInfo :: Maybe String-   , encoding    :: Maybe String-   , standalone  :: Maybe Bool-   , dtd         :: Maybe DTD-   , externals   :: [(String, External)]-   , root        :: Element-   }-  deriving Eq--data XML = Tagged Element-         | CharData String-         | CDATA String-         | Reference Reference-   deriving Eq-            -data Element = Element -   { name       :: Name -   , attributes :: Attributes -   , content    :: Content-   }- deriving Eq-   -type Content = [XML]--data DTD = DTD Name (Maybe ExternalID) [DocTypeDecl]-   deriving Eq--data DocTypeDecl = ElementDecl Name ContentSpec-                 | AttListDecl Name [AttDef]-                 | EntityDecl Bool Name EntityDef-                 | NotationDecl Name (Either ExternalID PublicID)-                 | DTDParameter Parameter-                 | DTDConditional Conditional-   deriving Eq                -                 -data ContentSpec = Empty | Any | Mixed Bool [Name] | Children CP-   deriving Eq-   --- content particles-data CP = Choice [CP] | Sequence [CP] | QuestionMark CP | Star CP | Plus CP | CPName Name-   deriving Eq-   -data AttType = IdType | IdRefType | IdRefsType | EntityType | EntitiesType | NmTokenType | NmTokensType-             | StringType | EnumerationType [String] | NotationType [String]-   deriving Eq-   -data DefaultDecl = Required | Implied | Value AttValue | Fixed AttValue-   deriving Eq-   -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-   deriving Eq-   -type PublicID = String--data Conditional = Include [DocTypeDecl] | Ignore [String]-   deriving Eq-  -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 = concat (intersperse "|" ("#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 (concat (intersperse "|" (map show xs)))-         Sequence xs    -> parenthesize (concat (intersperse "," (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 (concat (intersperse "|" xs))-         NotationType xs    -> "NOTATION " ++ parenthesize (concat (intersperse "|" 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 ++ ")"--trim :: String -> String-trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse-------------------------------------------------------type M = [Either String Element]--refToString :: Reference -> String-refToString (CharRef c)   = [chr c]-refToString (EntityRef _) = undefined--attribute_ :: AttValue -> String-attribute_ = concatMap (either return refToString)+-----------------------------------------------------------------------------
+-- 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 view
@@ -1,193 +1,128 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 where--import Control.Arrow-import Text.XML.Document (Name)-import Text.XML.Unicode (decoding)-import Text.XML.Parser (document, extParsedEnt)-import Text.XML.ParseLib (parse)-import Control.Monad.Error ()-import qualified Text.XML.Document as D-import System.FilePath (takeDirectory, pathSeparator)-import Data.Char (chr, ord)-import Data.Maybe--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.XMLDoc-extend e = D.XMLDoc-   { D.versionInfo = Nothing-   , D.encoding    = Nothing-   , D.standalone  = Nothing-   , D.dtd         = Nothing-   , D.externals   = []-   , D.root        = toElement e-   }- where-   toElement :: Element -> D.Element-   toElement (Element n as c) =-      D.Element n (map toAttribute as) (concatMap toXML c)-   -   toAttribute :: Attribute -> D.Attribute-   toAttribute (n := s) = (D.:=) n (map Left s)-   -   toXML :: Either String Element -> [D.XML]-   toXML = either fromString (return . D.Tagged . toElement)-   -   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   <- parse document input-   return (normalize doc)--parseIO :: String -> IO Element-parseIO baseFile = do-   -- putStrLn $ "Reading " ++ show baseFile-   xs    <- readFile baseFile-   input <- decoding xs-   case parse document input of-      Left err  -> fail err-      Right doc -> do-         let exts = getExternals doc-         rs <- mapM (parseExternal . snd) exts-         let new = doc { D.externals = zip (map fst exts) rs }-         return (normalize new)-- where -   getExternals :: D.XMLDoc -> [(String, String)]-   getExternals doc =-      case D.dtd doc of -         Just (D.DTD _ _ decls) ->-            [ (n, s) | D.EntityDecl True n (Right (D.System s, Nothing)) <- decls ]  -         Nothing -> []- -   parseExternal :: String -> IO D.External-   parseExternal extFile = do-      let full = takeDirectory baseFile ++ [pathSeparator] ++ extFile-      -- putStrLn $ "Reading " ++ show full-      xs    <- readFile full-      input <- decoding xs-      case parse extParsedEnt input of-         Right doc -> return doc-         Left err  -> fail err---------------------------------------------------------noAttributes :: Element -> Bool-noAttributes = null . attributes--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+-----------------------------------------------------------------------------
+-- 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 ]--{--children :: D.Element -> [D.Element]-children (D.Element _ _ c) = [ e | D.Tagged e <- c ]--getAttributes :: D.Element -> [(String, String)]-getAttributes (D.Element _ as _) = -   [ (n, concatMap f av) | n D.:= av <- as ]- where -   f :: Either Char D.Reference -> String-   f (Left c)              = [c]-   f (Right (D.CharRef n))   = [chr $ fromIntegral n]-   f (Right (D.EntityRef _)) = []--findAttribute :: Monad m => String -> D.Element -> m String-findAttribute n e =-   case lookup n (getAttributes e) of-      Just a  -> return a-      Nothing -> fail $ "Attribute not found: " ++ show n--getData :: D.Element -> String-getData (D.Element _ _ c) = concat [ s | D.CharData s <- c ]--}
− src/Text/XML/ParseLib.hs 
@@ -1,111 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 interface to a parsing library. The Parsec library is used because--- we need the back-tracking facilities (try combinator) in order not to--- have to rewrite the complete grammar for XML. In addition, the stopOn--- combinator is hard (or impossible?) to write using the UU library. This--- abstraction should make it easier to switch to a different parsing library--- in future, in case we want to.----------------------------------------------------------------------------------module Text.XML.ParseLib -   ( Parser, (<|>), (<..>)-   , symbol, string, optionM, option, oneOf, ranges, many, doubleQuoted, bracketed-   , singleQuoted, stopOn, parenthesized, choice, many1, try-   , noneOf, chainr1, sepBy1, parse, accept, packed, recognize-   ) where--import qualified Text.ParserCombinators.Parsec as P--infix  6 <..>-infixr 4 <|>--type Parser a = P.CharParser () a--parse :: Parser a -> String -> Either String a-parse p = either (Left . show) Right . P.parse (p >>= \a -> P.eof >> return a) ""--accept :: Parser a -> String -> Bool-accept p = either (const False) (const True) . parse p-      -try :: Parser a -> Parser a-try = P.try--noneOf :: String -> Parser Char-noneOf = P.noneOf--(<|>) :: Parser a -> Parser a -> Parser a-(<|>) = (P.<|>)--(<..>) :: Char -> Char -> Parser Char-x <..> y = P.satisfy (\c -> c >= x && c <= y)--recognize :: Parser a -> Parser ()-recognize p = p >> return ()--stopOn :: [String] -> Parser String-stopOn list = many (try (noneOf hds <|> foldr1 (<|>) ps))- where -    (hds, ps) = unzip [ (x, make x xs) | x:xs <- list ]-    make x xs-       | null xs = fail "make"-       | otherwise = do -            symbol x-            P.notFollowedBy (P.try (string xs >> return ' '))-            return x-      -symbol :: Char -> Parser ()-symbol c = P.char c >> return ()--string :: String -> Parser ()-string s = P.string s >> return ()--ranges :: [(Char, Char)] -> Parser Char-ranges xs = P.choice [ a <..> b | (a, b) <- xs ]--oneOf :: String -> Parser Char-oneOf = P.oneOf--many :: Parser a -> Parser [a] -many = P.many--many1 :: Parser a -> Parser [a]-many1 = P.many1--sepBy1 :: Parser a -> Parser b -> Parser [a]-sepBy1 = P.sepBy1--chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a-chainr1 = P.chainr1--choice :: [Parser a] -> Parser a-choice = P.choice--optionM :: Parser a -> Parser (Maybe a)-optionM = P.optionMaybe--option :: a -> Parser a -> Parser a-option = P.option--doubleQuoted :: Parser a -> Parser a-doubleQuoted p = packed (symbol '"') p (symbol '"')--singleQuoted :: Parser a -> Parser a-singleQuoted p = packed (symbol '\'') p (symbol '\'')--parenthesized :: Parser a -> Parser a-parenthesized p = packed (symbol '(') p (symbol ')')-   -bracketed :: Parser a -> Parser a-bracketed p = packed (symbol '[') p (symbol ']')-   -packed :: Parser a -> Parser b -> Parser c -> Parser b-packed l p r = l >> p >>= \a -> r >> return a
src/Text/XML/Parser.hs view
@@ -1,688 +1,694 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 Prelude hiding (seq)-import Control.Monad-import Data.Char (toUpper, ord, isSpace)-import Data.List (foldl') -- '-import Data.Maybe (catMaybes)-import Text.XML.Unicode-import Text.XML.Document hiding (versionInfo, name, content)-import qualified Text.XML.Document as D-import Text.XML.ParseLib--letter, digit, combiningChar, extender :: Parser Char-letter        = ranges letterMap-digit         = ranges digitMap-combiningChar = ranges combiningCharMap-extender      = ranges extenderMap------------------------------------------------------- * 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 (symbol '\x20')--}---- [7]   	Nmtoken	   ::=   	(NameChar)+-nmtoken :: Parser String-nmtoken = many1 nameChar--{---- [8]   	Nmtokens	   ::=   	 Nmtoken (#x20 Nmtoken)*-nmtokens :: Parser [String]-nmtokens = sepBy1 nmtoken (symbol '\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 = symbol '\'' >> 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 = packed (string "<!--") (stopOn ["--"]) (string "-->")------------------------------------------------------- ** 2.6 Processing Instructions---- [16]   	PI	   ::=   	'<?' PITarget (S (Char* - (Char* '?>' Char*)))? '?>'-pInstr :: Parser String-pInstr = packed (string "<?") p (string "?>")- 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 = packed (string "<![CDATA[") p (string "]]>")- 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 <- optionM (try xmlDecl)-   miscs-   mb <- optionM $ try $ do -      mb <- doctypedecl-      miscs-      return mb-   return (ma, mb)---- [23]   	XMLDecl	   ::=   	'<?xml' VersionInfo EncodingDecl? SDDecl? S? '?>'-xmlDecl :: Parser XMLDecl-xmlDecl = do -   string "<?xml"-   x <- versionInfo-   y <- optionM (try encodingDecl)-   z <- optionM (try sdDecl)-   mspace-   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 = recognize (mspace >> symbol '=' >> mspace)---- [26]   	VersionNum	   ::=   	'1.0'-versionNum :: Parser String-versionNum = do-   string "1.0"-   return "1.0"---- [27]   	Misc	   ::=   	 Comment | PI | S-misc :: Parser ()-misc = try (recognize comment) <|> try (recognize pInstr) <|> recognize space--miscs :: Parser ()-miscs = recognize (many misc)---- [28]   	doctypedecl	   ::=   	'<!DOCTYPE' S Name (S ExternalID)? S? ('[' intSubset ']' S?)? '>'-doctypedecl :: Parser DTD-doctypedecl = do -   string "<!DOCTYPE" -   space-   x <- name-   y <- optionM (try (space >> externalID))-   mspace-   z <- option [] $ do -      z <- bracketed intSubset-      mspace-      return z-   symbol '>'-   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 <- optionM 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-   symbol '<'-   n  <- name-   as <- many (try (space >> attribute))-   mspace-   b  <- (symbol '>'  >> 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 -   string "</" -   n <- name -   mspace -   symbol '>'-   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 -   string "<!ELEMENT" -   space -   n <- name -   space -   cs <- contentspec-   mspace-   symbol '>'-   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 =  (symbol '?' >> return QuestionMark)-     <|> (symbol '*' >> return Star)-     <|> (symbol '+' >> 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 = parenthesized $ do-   mspace-   x  <- cp-   xs <- many1 (try (mspace >> symbol '|' >> mspace >> cp))-   mspace-   return (Choice (x:xs))---- [50]   	seq	   ::=   	'(' S? cp ( S? ',' S? cp )* S? ')'-cpSeq :: Parser CP-cpSeq = parenthesized $ do -   mspace-   x  <- cp-   xs <- many (try (mspace >> symbol ',' >> mspace >> cp))-   mspace-   return (Sequence (x:xs))---- [51]   	Mixed	   ::=   	'(' S? '#PCDATA' (S? '|' S? Name)* S? ')*'---                  | '(' S? '#PCDATA' S? ')'-mixed :: Parser ContentSpec-mixed = symbol '(' >> mspace >> string "#PCDATA" >> (rest1 <|> rest2)- where-   p = mspace >> symbol '|' >> mspace >> name-   rest1 = try $ do -       xs <- many (try p)-       mspace-       string ")*"-       return (Mixed True xs)-   rest2 = mspace >> symbol ')' >> return (Mixed False [])------------------------------------------------------- ** 3.3 Attribute-List Declarations---- [52]   	AttlistDecl	   ::=   	'<!ATTLIST' S Name AttDef* S? '>'-attlistDecl :: Parser DocTypeDecl-attlistDecl = do-   string "<!ATTLIST"-   space -   n  <- name-   ds <- many (try attDef)-   mspace -   symbol '>'-   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 >> parenthesized p- where -   p = do-      mspace -      n  <- name -      ns <- many (try (mspace >> symbol '|' >> mspace >> name))-      mspace-      return (NotationType (n:ns))---- [59]   	Enumeration	   ::=   	'(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')'-enumeration :: Parser AttType-enumeration = parenthesized $ do-   mspace-   x  <- nmtoken -   xs <- many (try (mspace >> symbol '|' >> 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 -   string "<![" -   mspace -   string "INCLUDE" -   mspace-   symbol '['-   ds <- extSubsetDecl-   string "]]>"-   return (Include ds)---- [63]   	ignoreSect	   ::=   	'<![' S? 'IGNORE' S? '[' ignoreSectContents* ']]>'-ignoreSect :: Parser Conditional-ignoreSect = do -   string "<![" -   mspace -   string "IGNORE" -   mspace-   symbol '['-   xss <- many ignoreSectContents -   string "]]>"-   return (Ignore (concat xss))---- [64]   	ignoreSectContents	   ::=   	 Ignore ('<![' ignoreSectContents ']]>' Ignore)*-ignoreSectContents :: Parser [String]-ignoreSectContents = -   do x   <- ignore  -      xss <- many $ do-         string "<![" -         ys <- ignoreSectContents-         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 -   string "&#"-   n <- p <|> (symbol 'x' >> q)-   symbol ';'-   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 = packed (symbol '&') (fmap EntityRef name) (symbol ';')---- [69]   	PEReference	   ::=   	'%' Name ';'-peReference :: Parser Parameter-peReference = packed (symbol '%') (fmap Parameter name) (symbol ';')------------------------------------------------------- ** 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 -   string "<!ENTITY" -   space -   n <- name -   space -   ed <- entityDef-   mspace-   symbol '>'-   return (EntityDecl True n ed)---- [72]   	PEDecl	   ::=   	'<!ENTITY' S '%' S Name S PEDef S? '>'-peDecl :: Parser DocTypeDecl-peDecl = do-   string "<!ENTITY"-   space -   symbol '%' -   space -   n <- name -   space-   e <- peDef-   mspace-   symbol '>'-   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 <- optionM (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-   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 -   string "<?xml" -   v <- optionM versionInfo-   e <- encodingDecl -   mspace -   string "?>"-   return (v, e)---- [78]   	extParsedEnt	   ::=   	 TextDecl? content-extParsedEnt :: Parser (Maybe TextDecl, Content)-extParsedEnt = do -   td <- optionM (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-   string "<!NOTATION" -   space -   n <- name -   space-   e <- fmap Left (try externalID) <|> fmap Right publicID-   mspace -   symbol '>' -   return (NotationDecl n e) ---- [83]   	PublicID	   ::=   	'PUBLIC' S PubidLiteral-publicID :: Parser PublicID+-----------------------------------------------------------------------------
+-- 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/TestSuite.hs 
@@ -1,95 +0,0 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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 XML specification comes with a test suite for testing the correctness--- of a parser. This module performs these tests.----------------------------------------------------------------------------------module Main (main) where--import Text.XML.Interface-import Text.XML.Document (trim)-import Control.Monad.Error-import Data.Maybe--{-testje = do-   xs <- readFile "tmp.xml" >>= decoding-   print xs-   --print (take 3 $ drop 318 $ lines xs)-   print (parse document xs)-   print (map (\x -> (x, ord x)) xs) -}--rootDir :: String-rootDir  = "D:/xmlts20080827/xmlconf"--main :: IO ()-main = parseIO (rootDir ++ "/xmlconf.xml") >>= runTestSuite--printProfile :: Element -> IO ()-printProfile =-   maybe (return ()) putStrLn . findAttribute "PROFILE"--runTestSuite :: Element -> IO ()-runTestSuite e-   | name e /= "TESTSUITE" = fail "expected TESTSUITE"-   | otherwise = do-        printProfile e-        is <- mapM (runTestCases ".") (children e)-        putStrLn (replicate 40 '*')-        putStrLn $ "Test cases failed: " ++ show (sum is)--runTestCases :: String -> Element -> IO Int-runTestCases base e-   | name e /= "TESTCASES" = fail "expected TESTCASES"-   | otherwise = do-        printProfile e-        let newbase = fromMaybe base (findAttribute "xml:base" e)-        is <- forM (children e) $ \x -> -           if name x == "TESTCASES" -           then runTestCases newbase x -           else do b <- runTest newbase x-                   return (if b then 0 else 1)-        return (sum is)--runTest :: String -> Element -> IO Bool-runTest base e-   | name e /= "TEST" = fail "expected TEST"-   | otherwise = do-        let filename = rootDir ++ "/" ++ base ++ "/" ++ uri-            uri      = fromMaybe "." (findAttribute "URI" e)-            testtype = fromMaybe ""  (findAttribute "TYPE" e)-            reccom   = findAttribute "RECOMMENDATION" e-        {-case reccom of -           Nothing -> return ()-           Just "XML1.1" -> return ()-           Just "XML1.0-errata2e" -> return ()-           Just "NS1.0" -> return ()-           Just "NS1.1" -> return ()-           Just "XML1.0-errata3e" -> return ()-           Just "XML1.0-errata4e" -> return ()-           Just "NS1.0-errata1e" -> return () -}-        if reccom /= Nothing then return True else do-        putChar '.'-        mdoc <- (do a <- parseIO filename; return (Just a)) -                   `catch` (\_ -> return Nothing)-        case mdoc of-           Just _-              --  not (accept document (show doc)) -> error ("pretty-print error: " ++ show doc)-              | testtype == "valid" -> return True-           Nothing -              | testtype == "not-wf"  -> return True-              | testtype == "error"   -> return True-              | testtype == "invalid" -> return True-           _  | testtype /= "valid" {- && testtype /= "not-wf" -} -> return True-           _ -> do-              putStrLn $ "\nFilename: " ++ show filename-              putStrLn $ "Test type: " ++ show testtype-              putStrLn $ "Description: " ++ trim (getData e)-              return False
src/Text/XML/Unicode.hs view
@@ -1,193 +1,193 @@--------------------------------------------------------------------------------- Copyright 2010, Open Universiteit Nederland. This file is distributed --- under the terms of the GNU General Public License. For more 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]+-----------------------------------------------------------------------------
+-- 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