packages feed

ideas 0.5.8 → 0.6

raw patch · 174 files changed

+11686/−4933 lines, 174 filesdep +directorydep +old-timedep ~QuickCheckdep ~basenew-uploader

Dependencies added: directory, old-time

Dependency ranges changed: QuickCheck, base

Files

CREDITS.txt view
@@ -1,6 +1,6 @@ AUTHORS -Bastiaan Heeren, Alex gerdes, Johan Jeuring+Bastiaan Heeren, Alex Gerdes, Johan Jeuring  CREDITS
ideas.cabal view
@@ -1,5 +1,5 @@ name:                   ideas-version:                0.5.8+version:                0.6 synopsis:               Feedback services for intelligent tutoring systems homepage:               http://ideas.cs.uu.nl/ description:@@ -9,7 +9,7 @@   and Activemath.   category:               Education-copyright:              (c) 2009 +copyright:              (c) 2010 license:                GPL license-file:           LICENSE.txt author:                 Bastiaan Heeren, Alex Gerdes, Johan Jeuring@@ -17,157 +17,192 @@ stability:              provisional extra-source-files:     CREDITS.txt build-type:             Simple-cabal-version:          >= 1.2.1-tested-with:            GHC == 6.10.1+cabal-version:          >= 1.8.0.2+tested-with:            GHC == 6.12.1  -------------------------------------------------------------------------------- -Executable	            ideas-  Main-is:				Service/Main.hs-  ghc-options:          -W -fwarn-tabs -fwarn-duplicate-exports-  hs-source-dirs:       src+Executable              ideas+  Main-is: Main.hs+  ghc-options: -W -fwarn-tabs -fwarn-duplicate-exports+  hs-source-dirs: src   other-modules:        -    Common.Apply ,-    Common.Context ,-    Common.Derivation ,-    Common.Exercise 	,-    Common.Grammar ,-    Common.Rewriting ,-    Common.Rewriting.AC ,-    Common.Rewriting.Confluence ,-    Common.Rewriting.Difference ,-    Common.Rewriting.MetaVar ,-    Common.Rewriting.RewriteRule ,-    Common.Rewriting.Substitution ,-    Common.Rewriting.Unification ,-    Common.Strategy ,-    Common.Transformation ,-    Common.Traversable ,-    Common.Uniplate ,-    Common.Utils ,-    Common.View ,-    Domain.LinearAlgebra ,-    Domain.LinearAlgebra.Checks ,-    Domain.LinearAlgebra.EquationsRules ,-    Domain.LinearAlgebra.Exercises ,-    Domain.LinearAlgebra.GramSchmidtRules ,-    Domain.LinearAlgebra.LinearSystem ,-    Domain.LinearAlgebra.LinearView ,-    Domain.LinearAlgebra.Matrix ,-    Domain.LinearAlgebra.MatrixRules ,-    Domain.LinearAlgebra.Parser ,-    Domain.LinearAlgebra.Strategies ,-    Domain.LinearAlgebra.Symbols ,-    Domain.LinearAlgebra.Vector ,-    Domain.Logic ,-    Domain.Logic.BuggyRules ,-    Domain.Logic.Exercises  ,-    Domain.Logic.FeedbackText ,-    Domain.Logic.Formula ,-    Domain.Logic.GeneralizedRules ,-    Domain.Logic.Generator ,-    Domain.Logic.Parser ,-    Domain.Logic.Rules ,-    Domain.Logic.Strategies ,-    Domain.Math.Approximation ,-    Domain.Math.Data.Equation ,-    Domain.Math.Data.OrList ,-    Domain.Math.Data.Polynomial ,-    Domain.Math.Data.PrimeFactors ,-    Domain.Math.Data.SquareRoot ,-    Domain.Math.DerivativeExercise ,-    Domain.Math.DerivativeRules ,-    Domain.Math.Equation.CoverUpExercise ,-    Domain.Math.Equation.CoverUpRules ,-    Domain.Math.Equation.Views ,-    Domain.Math.Examples.DWO1 ,-    Domain.Math.Examples.DWO2 ,-    Domain.Math.Expr ,-    Domain.Math.Expr.Conversion ,-    Domain.Math.Expr.Data ,-    Domain.Math.Expr.Parser ,-    Domain.Math.Expr.Symbolic ,-    Domain.Math.Expr.Symbols ,-    Domain.Math.Expr.Views ,-    Domain.Math.Numeric.Exercises ,-    Domain.Math.Numeric.Generators ,-    Domain.Math.Numeric.Laws ,-    Domain.Math.Numeric.Rules ,-    Domain.Math.Numeric.Strategies ,-    Domain.Math.Numeric.Views ,-    Domain.Math.Polynomial.BuggyRules ,-    Domain.Math.Polynomial.CleanUp ,-    Domain.Math.Polynomial.Exercises ,-    Domain.Math.Polynomial.Generators ,-    Domain.Math.Polynomial.Rules ,-    Domain.Math.Polynomial.Strategies ,-    Domain.Math.Polynomial.Views ,-    Domain.Math.Power.Views ,-    Domain.Math.Simplification ,-    Domain.Math.SquareRoot.Views ,-    Domain.Math.Strategy.BrokenEquations ,-    Domain.Math.Strategy.Modulus ,-    Domain.Math.Strategy.SquareRootEquations ,-    Domain.Math.Strategy.SquareRootSimplification ,-    Domain.Programming ,-    Domain.RelationAlgebra ,-    Domain.RelationAlgebra.Equivalence ,-    Domain.RelationAlgebra.Exercises ,-    Domain.RelationAlgebra.Formula ,-    Domain.RelationAlgebra.Generator ,-    Domain.RelationAlgebra.Parser ,-    Domain.RelationAlgebra.Rules ,-    Domain.RelationAlgebra.Strategies ,-    Service.ExerciseList ,-    Service.FeedbackText ,-    Service.LoggingDatabase ,-    Service.Main ,-    Service.ModeJSON ,-    Service.ModeXML ,-    Service.Options ,-    Service.ProblemDecomposition ,-    Service.Request ,-    Service.Revision ,-    Service.SearchSpace ,-    Service.ServiceList ,-    Service.TypedAbstractService ,-    Service.Types ,-    Text.HTML ,-    Text.JSON ,-    Text.OpenMath.ContentDictionary ,-    Text.OpenMath.Dictionary.Arith1 ,-    Text.OpenMath.Dictionary.Calculus1 ,-    Text.OpenMath.Dictionary.Fns1 ,-    Text.OpenMath.Dictionary.Linalg2 ,-    Text.OpenMath.Dictionary.List1 ,-    Text.OpenMath.Dictionary.Logic1 ,-    Text.OpenMath.Dictionary.Nums1 ,-    Text.OpenMath.Dictionary.Relation1 ,-    Text.OpenMath.Dictionary.Transc1 ,-    Text.OpenMath.MakeSymbols ,-    Text.OpenMath.Object ,-    Text.OpenMath.Reply ,-    Text.OpenMath.Request ,-    Text.OpenMath.Symbol ,-    Text.Parsing ,-    Text.UTF8 ,-    Text.XML ,-    Text.XML.Document ,-    Text.XML.Interface ,-    Text.XML.ParseLib ,-    Text.XML.Parser ,-    Text.XML.TestSuite ,-    Text.XML.Unicode -  build-depends:        base >= 3.0 && < 4.0,+    Common.Apply+    Common.Context+    Common.Derivation+    Common.Exercise+    Common.Navigator+    Common.Rewriting.AC+    Common.Rewriting.Difference+    Common.Rewriting.MetaVar+    Common.Rewriting.RewriteRule+    Common.Rewriting.Substitution+    Common.Rewriting.Term+    Common.Rewriting.Unification+    Common.Rewriting+    Common.Strategy.Abstract+    Common.Strategy.BiasedChoice+    Common.Strategy.Combinators+    Common.Strategy.Configuration+    Common.Strategy.Core+    Common.Strategy.Grammar+    Common.Strategy.Location+    Common.Strategy.Prefix+    Common.Strategy+    Common.Transformation+    Common.Traversable+    Common.Uniplate+    Common.Utils+    Common.View+    Documentation.DefaultPage+    Documentation.ExercisePage+    Documentation.LatexRules+    Documentation.Make+    Documentation.OverviewPages+    Documentation.SelfCheck+    Documentation.ServicePage+    Documentation.TestsPage+    Domain.LinearAlgebra.Checks+    Domain.LinearAlgebra.EquationsRules+    Domain.LinearAlgebra.Exercises+    Domain.LinearAlgebra.GramSchmidtRules+    Domain.LinearAlgebra.LinearSystem+    Domain.LinearAlgebra.LinearView+    Domain.LinearAlgebra.Matrix+    Domain.LinearAlgebra.MatrixRules+    Domain.LinearAlgebra.Parser+    Domain.LinearAlgebra.Strategies+    Domain.LinearAlgebra.Symbols+    Domain.LinearAlgebra.Vector+    Domain.LinearAlgebra+    Domain.Logic.BuggyRules+    Domain.Logic.Exercises+    Domain.Logic.FeedbackText+    Domain.Logic.Formula+    Domain.Logic.GeneralizedRules+    Domain.Logic.Generator+    Domain.Logic.Parser+    Domain.Logic.Rules+    Domain.Logic.Strategies+    Domain.Logic+    Domain.Math.Approximation+    Domain.Math.Clipboard+    Domain.Math.Data.Interval+    Domain.Math.Data.OrList+    Domain.Math.Data.Polynomial+    Domain.Math.Data.PrimeFactors+    Domain.Math.Data.Relation+    Domain.Math.Data.SquareRoot+    Domain.Math.DerivativeExercise+    Domain.Math.DerivativeRules+    Domain.Math.Equation.CoverUpExercise+    Domain.Math.Equation.CoverUpRules+    Domain.Math.Equation.Views+    Domain.Math.Examples.DWO1+    Domain.Math.Examples.DWO2+    Domain.Math.Examples.DWO3+    Domain.Math.Expr.Data+    Domain.Math.Expr.Parser+    Domain.Math.Expr.Symbolic+    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.BuggyRules+    Domain.Math.Polynomial.CleanUp+    Domain.Math.Polynomial.Equivalence+    Domain.Math.Polynomial.Exercises+    Domain.Math.Polynomial.Generators+    Domain.Math.Polynomial.IneqExercises+    Domain.Math.Polynomial.Rules+    Domain.Math.Polynomial.Strategies+    Domain.Math.Polynomial.Tests+    Domain.Math.Polynomial.Views+    Domain.Math.Power.Exercises+    Domain.Math.Power.Rules+    Domain.Math.Power.Strategies+    Domain.Math.Power.Views+    Domain.Math.Simplification+    Domain.Math.SquareRoot.Tests+    Domain.Math.SquareRoot.Views+    Domain.RegularExpr.Definitions+    Domain.RegularExpr.Exercises+    Domain.RegularExpr.Expr+    Domain.RegularExpr.Parser+    Domain.RegularExpr.Strategy+    Domain.RelationAlgebra.Equivalence+    Domain.RelationAlgebra.Exercises+    Domain.RelationAlgebra.Formula+    Domain.RelationAlgebra.Generator+    Domain.RelationAlgebra.Parser+    Domain.RelationAlgebra.Rules+    Domain.RelationAlgebra.Strategies+    Domain.RelationAlgebra+    Main.ExerciseList+    Main.LoggingDatabase+    Main.Options+    Main.Revision+    Main+    Service.Diagnose+    Service.DomainReasoner+    Service.ExercisePackage+    Service.FeedbackText+    Service.ModeJSON+    Service.ModeXML+    Service.ProblemDecomposition+    Service.Request+    Service.RulesInfo+    Service.ServiceList+    Service.StrategyInfo+    Service.Submit+    Service.TypedAbstractService+    Service.TypedExample+    Service.Types+    Text.HTML+    Text.JSON+    Text.OpenMath.ContentDictionary+    Text.OpenMath.Dictionary.Arith1+    Text.OpenMath.Dictionary.Calculus1+    Text.OpenMath.Dictionary.Fns1+    Text.OpenMath.Dictionary.Linalg2+    Text.OpenMath.Dictionary.List1+    Text.OpenMath.Dictionary.Logic1+    Text.OpenMath.Dictionary.Nums1+    Text.OpenMath.Dictionary.Quant1+    Text.OpenMath.Dictionary.Relation1+    Text.OpenMath.Dictionary.Transc1+    Text.OpenMath.FMP+    Text.OpenMath.MakeSymbols+    Text.OpenMath.Object+    Text.OpenMath.Symbol+    Text.Parsing+    Text.Scanning+    Text.UTF8+    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,+                        QuickCheck >= 2.1.0.3,                         random,                         uulib,                         filepath,-                        parsec+                        parsec,+                        old-time  --------------------------------------------------------------------------------
src/Common/Apply.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Common/Context.hs view
@@ -1,5 +1,6 @@+{-# OPTIONS -XDeriveDataTypeable #-} -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -8,191 +9,236 @@ -- Stability   :  provisional -- Portability :  portable (depends on ghc) ----- A context for a term that maintains a current focus and an environment of+-- 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, inContext, fromContext, showContext, parseContext-     -- * Variable environment-   , Var(..), intVar, integerVar, boolVar, get, set, change-     -- * Location (current focus)-   , Location, location, setLocation, changeLocation-   , currentFocus, changeFocus, locationDown, locationUp-   , makeLocation, fromLocation+     Context, fromContext, newContext, getEnvironment+     -- * Key-value pair environment (abstract)+   , Environment, emptyEnv, nullEnv, keysEnv, lookupEnv, storeEnv+   , diffEnv, deleteEnv+     -- * Variables+   , Var, newVar, makeVar      -- * Lifting-   , liftToContext, ignoreContext-   ) where+   , liftToContext, liftTransContext, contextView+     -- * Context Monad+   , ContextMonad, runCM, readVar, writeVar, modifyVar+   , maybeCM, withCM, evalCM -- , listCM, runListCM, withListCM+   ) where  +import Common.Navigator++import qualified Common.Navigator as Navigator import Common.Transformation-import Common.Uniplate-import Common.Utils+import Common.Utils (safeHead, commaList, readM)+import Common.View import Control.Monad-import Data.Char+import Data.Maybe import Data.Dynamic-import Data.List-import Test.QuickCheck 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 current focus (list of integers)-data Context a = C Location Environment a+-- | 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+   }  -instance Eq a => Eq (Context a) where-   x == y = fromContext x == fromContext y+fromContext :: Monad m => Context a -> m a+fromContext = leave . getNavigator -instance Ord a => Ord (Context a) where-   x `compare` y = fromContext x `compare` fromContext y+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 = showContext c ++ ";" ++ show (fromContext c)--instance Functor Context where-   fmap f (C loc env a) = C loc env (f a)+   show (C env a) = +      let rest | null (keysEnv env) = "" +               | otherwise = "  {" ++ show env ++ "}"+      in show a ++ rest  -instance Arbitrary a => Arbitrary (Context a) where-   arbitrary   = liftM inContext arbitrary-   coarbitrary = coarbitrary . fromContext+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) = Navigator.location a+   changeM f (C env a) = liftM (C env) (changeM f a) --- | Put a value into a (default) context-inContext :: a -> Context a-inContext = C (L []) M.empty+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) --- | Retrieve a value from its context-fromContext :: Context a -> a-fromContext (C _ _ a) = a+-- | Construct a context+newContext :: Environment -> Navigator a -> Context a+newContext = C  ------------------------------------------------------------- A simple parser and pretty-printer for contexts+-- Key-value pair environment (abstract) --- | Shows the context (without the embedded value)-showContext :: Context a -> String-showContext (C loc env _) = show loc ++ ";" ++ showEnv env+newtype Environment = Env { envMap :: M.Map String (Maybe Dynamic, String) } --- local helper function-showEnv :: Environment -> String-showEnv = concat . intersperse "," . map f . M.toList- where f (k, (_, v)) = k ++ "=" ++ v+instance Show Environment where+   show = +      let f (k, (_, v)) = k ++ "=" ++ v+      in commaList . map f . M.toList . envMap --- | Parses a context: on a successful parse, the unit value is returned --- in the parsed context-parseContext :: String -> Maybe (Context ())-parseContext s-   | all isSpace s = -        return (C (L []) M.empty ())-   | otherwise = do-        (locString, envString) <- splitAtElem ';' s-        loc <- case reads locString of-                  [(l, xs)] | all isSpace xs -> return l-                  _ -> Nothing-        env <- if all isSpace envString then return M.empty else do-                  pairs <- mapM (splitAtElem '=') (splitsWithElem ',' envString)-                  let f (k, v) = (k, (Nothing, v))-                  return $ M.fromList $ map f pairs-        return (C loc env ())+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)+ ------------------------------------------------------------- Manipulating the variable environment+-- Variables --- local type synonym: can probably be simplified-type Environment = M.Map String (Maybe Dynamic, String)+-- | 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+   } --- | A variable has a name (for showing) and a default value (for initializing)-data Var a = String := a -- ^ Constructs a new variable+-- | 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 --- | Make a new variable of type Int (initialized with 0)-intVar :: String -> Var Int-intVar = (:= 0)+-- | 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 --- | Make a new variable of type Integer (initialized with 0)-integerVar :: String -> Var Integer-integerVar = (:= 0)+----------------------------------------------------------+-- Lifting rewrite rules --- | Make a new variable of type Bool (initialized with True)-boolVar :: String -> Var Bool-boolVar = (:= True)+-- | Lift a rule to operate on a term in a context+liftToContext :: Rule a -> Rule (Context a)+liftToContext = liftRuleIn thisView --- | Returns the value of a variable stored in a context-get :: (Read a, Typeable a) => Var a -> Context b -> a-get (s := a) (C _ env _) = -   case M.lookup s env of-      Nothing           -> a           -- return default value-      Just (Just d,  _) -> fromDyn d a -- use the stored dynamic (default value as backup)-      Just (Nothing, s) -> -         case reads s of               -- parse the pretty-printed value (default value as backup)-            [(b, rest)] | all isSpace rest -> b-            _ -> a+liftTransContext :: Transformation a -> Transformation (Context a)+liftTransContext = liftTransIn thisView --- | Replaces the value of a variable stored in a context-set :: (Show a, Typeable a) => Var a -> a -> Context b -> Context b-set (s := _) a (C loc env b) = C loc (M.insert s (Just (toDyn a), show a) env) b+thisView :: View (Context a) (a, Context a)+thisView = makeView f g+ where+   f ctx = current ctx >>= \a -> Just (a, ctx)+   g = uncurry replace --- | Updates the value of a variable stored in a context-change :: (Show a, Read a, Typeable a) => Var a -> (a -> a) -> Context b -> Context b-change v f c = set v (f (get v c)) c-  +contextView :: MonadPlus m => ViewM m a b -> ViewM m (Context a) (Context b)+contextView v = makeView f g+ where+   f ca = do+      guard (isTop ca)+      a <- leave ca+      b <- match v a+      return (newContext (getEnvironment ca) (noNavigator b))+   g cb = fromJust $ do+      guard (isTop cb)+      b <- leave cb+      let a = build v b+      return (newContext (getEnvironment cb) (noNavigator a))+ ------------------------------------------------------------- Location (current focus)+-- Context monad --- | Type synonym for the current location (focus)-newtype Location = L [Int] deriving (Eq, Ord)+newtype ContextMonad a = CM (Environment -> [(a, Environment)]) -instance Show Location where-   show (L is) = show is-   -instance Read Location where-   readsPrec n s = [ (L is, rest) | (is, rest) <- readsPrec n s ]+withCM :: (a -> ContextMonad b) -> Context a -> Maybe (Context b)+withCM f c = fromContext c >>= \a -> runCM (f a) (getEnvironment c) --- | Returns the current location of a context-location :: Context a -> Location-location (C loc _ _) = loc+evalCM :: (a -> ContextMonad b) -> Context a -> Maybe b+evalCM f c = withCM f c >>= fromContext --- | Replaces the current location of a context-setLocation :: Location -> Context a -> Context a -setLocation loc (C _ env a) = C loc env a+runCM :: ContextMonad a -> Environment -> Maybe (Context a)+runCM (CM f) env = do+   (a, e) <- safeHead (f env)+   return (newContext e (noNavigator a)) --- | Updates the current location of a context-changeLocation :: (Location -> Location) -> Context a -> Context a-changeLocation f c = setLocation (f (location c)) c+instance Functor ContextMonad where+   fmap = liftM --- | Returns the term which has the current focus: Nothing indicates that the current --- focus is invalid-currentFocus :: Uniplate a => Context a -> Maybe a-currentFocus c = getTermAt (fromLocation $ location c) (fromContext c)+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) --- | Changes the term which has the current focus. In case the focus is invalid, then--- this function has no effect.-changeFocus :: Uniplate a => (a -> a) -> Context a -> Context a-changeFocus f c = fmap (applyAt (fromLocation $ location c) f) c+instance MonadPlus ContextMonad where+   mzero = CM (const mzero)+   mplus (CM f) (CM g) = CM (\env -> f env `mplus` g env) --- | Go down to a certain child-locationDown :: Int -> Location -> Location-locationDown i (L is) = L (is ++ [i])+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) --- | Go up: Nothing indicates that we were already at the top-locationUp :: Location -> Maybe Location-locationUp (L is)-   | null is   = Nothing-   | otherwise = Just (L (init is))+writeVar  :: Typeable a => Var a -> a -> ContextMonad ()+writeVar var a = +   let f = storeEnvWith (varShow var) (varName var) a+   in CM $ \env -> return ((), f env) -makeLocation :: [Int] -> Location-makeLocation = L+modifyVar :: Typeable a => Var a -> (a -> a) -> ContextMonad ()+modifyVar var f = readVar var >>= (writeVar var  . f) -fromLocation :: Location -> [Int]-fromLocation (L is) = is+maybeCM :: Maybe a -> ContextMonad a+maybeCM = maybe mzero return -------------------------------------------------------------- Lifting rewrite rules --- | Lift a rule to operate on a term in a context-liftToContext :: (Lift f, Uniplate a) => f a -> f (Context a)-liftToContext = lift $ makeLiftPair currentFocus (changeFocus . const)+{-+listCM :: [a] -> ContextMonad a+listCM = foldr (mplus . return) mzero --- | Lift a rule to operate on a term in a context by ignoring the context-ignoreContext :: Lift f => f a -> f (Context a)-ignoreContext = lift $ makeLiftPair (return . fromContext) (fmap . const)+withListCM :: (a -> ContextMonad b) -> Context a -> [Context b]+withListCM f c = runListCM (f (fromContext c)) (getEnvironment c)++runListCM :: ContextMonad a -> Environment -> [Context a]+runListCM (CM f) env = do+   (a, e) <- f env+   return (C e a) -}
src/Common/Derivation.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -16,24 +16,24 @@    ( -- * Data types       DerivationTree, Derivations, Derivation      -- * Constructors-   , singleNode, addBranch, addBranches+   , singleNode, addBranch, addBranches, newDerivation      -- * Query     , root, endpoint, branches, annotations, subtrees    , results, lengthMax      -- * Adapters    , restrictHeight, restrictWidth, commit-   , mergeSteps, cutOnStep+   , mergeSteps, cutOnStep, mapSteps, mergeMaybeSteps, changeLabel      -- * Query a derivation-   , isEmpty, derivationLength, terms, steps, filterDerivation+   , isEmpty, derivationLength, terms, steps, triples, filterDerivation      -- * Conversions-   , derivation, derivations+   , 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@@ -135,6 +135,19 @@          | 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 (\(l, st) -> (f l, rec st)) (branches t)}++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@@ -146,6 +159,9 @@ ----------------------------------------------------------------------------- -- 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@@ -162,6 +178,11 @@ 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)@@ -178,3 +199,24 @@ -- | 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 xs = +      case splitAt i xs 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,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -13,33 +13,41 @@ ----------------------------------------------------------------------------- module Common.Exercise     ( -- * Exercises-     Exercise, Status(..), testableExercise, makeExercise, emptyExercise+     Exercise, testableExercise, makeExercise, emptyExercise    , description, exerciseCode, status, parser, prettyPrinter-   , equivalence, similarity, isReady, isSuitable, strategy, extraRules+   , equivalence, similarity, isReady, isSuitable, eqWithContext+   , strategy, navigation, canBeRestarted, extraRules    , difference, ordering, testGenerator, randomExercise, examples, getRule    , simpleGenerator, useGenerator    , randomTerm, randomTermWith, ruleset+   , makeContext, inContext+     -- * Exercise status+   , Status(..), isPublic, isPrivate      -- * Exercise codes    , ExerciseCode, noCode, makeCode, readCode, domain, identifier      -- * Miscellaneous-   , restrictGenerator+   , equivalenceContext, restrictGenerator    , showDerivation, printDerivation    , checkExercise, checkParserPretty-   , checksForList+   , checkExamples, generate    ) where  import Common.Apply import Common.Context import Common.Strategy hiding (not, fail, replicate)+import qualified Common.Strategy as S import Common.Derivation+import Common.Navigator import Common.Transformation-import Common.Utils+import Common.Utils (putLabel)+import Common.View (makeView) import Control.Monad.Error import Data.Char import Data.List+import Data.Maybe import System.Random-import Test.QuickCheck hiding (label, arguments)-import Text.Parsing (SyntaxError(..))+import Test.QuickCheck hiding (label)+import Test.QuickCheck.Gen  data Exercise a = Exercise    { -- identification and meta-information@@ -47,7 +55,7 @@    , exerciseCode   :: ExerciseCode -- uniquely determines the exercise (in a given domain)    , status         :: Status      -- parsing and pretty-printing-   , parser         :: String -> Either SyntaxError a+   , parser         :: String -> Either String a    , prettyPrinter  :: a -> String      -- syntactic and semantic checks    , equivalence    :: a -> a -> Bool@@ -55,17 +63,18 @@    , 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-   , difference     :: Bool -> a -> a -> Maybe (a, a)       -- testing and exercise generation    , testGenerator  :: Maybe (Gen a)    , randomExercise :: Maybe (StdGen -> Int -> a)    , examples       :: [a]    }-   -data Status = Stable | Provisional | Experimental deriving (Show, Eq)  instance Eq (Exercise a) where    e1 == e2 = exerciseCode e1 == exerciseCode e2@@ -74,7 +83,7 @@    e1 `compare` e2 = exerciseCode e1 `compare` exerciseCode e2  instance Apply Exercise where-   applyAll e = map fromContext . applyAll (strategy e) . inContext+   applyAll ex = concatMap fromContext . applyAll (strategy ex) . inContext ex  testableExercise :: (Arbitrary a, Show a, Ord a) => Exercise a testableExercise = makeExercise@@ -95,7 +104,7 @@    , exerciseCode   = noCode    , status         = Experimental      -- parsing and pretty-printing-   , parser         = const $ Left $ ErrorMessage "<<no parser>>"+   , parser         = const (Left "<<no parser>>")    , prettyPrinter  = const "<<no pretty-printer>>"      -- syntactic and semantic checks    , equivalence    = \_ _ -> True@@ -103,16 +112,26 @@    , ordering       = \_ _ -> EQ    , isReady        = const True    , isSuitable     = const True+   , difference     = \_ _ _ -> Nothing+   , eqWithContext  = Nothing      -- strategies and rules-   , strategy       = label "Succeed" succeed+   , strategy       = label "Fail" S.fail+   , navigation     = noNavigator+   , canBeRestarted = True    , extraRules     = [] -   , difference     = \_ _ _ -> Nothing      -- 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 @@ -134,7 +153,13 @@       | otherwise = f (snd (next rng)) level     where       a = generate 100 rng (g level)+        where +generate :: Int -> StdGen -> Gen a -> a+generate n rnd (MkGen m) = m rnd' size+  where+    (size, rnd') = randomR (0, n) rnd+ restrictGenerator :: (a -> Bool) -> Gen a -> Gen a restrictGenerator p g = do    a <- g @@ -157,6 +182,24 @@        where xs = examples ex  ---------------------------------------------------------------+-- 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++--------------------------------------------------------------- -- Exercise codes (unique identification)  data ExerciseCode = EC String String | NoCode@@ -198,6 +241,17 @@ --------------------------------------------------------------- -- 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 -> String -> m (Rule (Context a)) getRule ex s =     case filter ((==s) . name) (ruleset ex) of @@ -206,10 +260,27 @@       _    -> fail $ "Ambiguous ruleid " ++ s  showDerivation :: Exercise a -> a -> String-showDerivation ex = -   let err = "<<no derivation>>"-       f   = show . fmap (Shown . prettyPrinter ex . fromContext) . filterDerivation (\r a -> isMajorRule r)-   in maybe err f . derivation . fullDerivationTree (strategy ex) . inContext+showDerivation ex a =+   case derivation tree of+      Just d  -> show (f d) ++ extra d+      Nothing -> prettyPrinterContext ex (root tree)+                 ++ "\n   =>\n<<no derivation>>"+ where+   tree = derivationTree (strategy ex) (inContext ex a)+   extra d =+      case fromContext (last (terms d)) of+         Nothing               -> "<<invalid term>>"+         Just a | isReady ex a -> ""+                | otherwise    -> "<<not ready>>"+   -- A bit of hack to show the delta between two environments, not including+   -- the location variable+   f d = let t:ts = map (Shown . prettyPrinterContext ex) (terms d)+             xs   = zipWith3 present (steps d) (drop 1 (terms d)) (terms d)+             present a x y = Shown (show a ++ extra)+              where env = deleteEnv "location" (diffEnv (getEnvironment x) (getEnvironment y))+                    extra | nullEnv env = "" +                          | otherwise   = "\n      " ++ show env+         in newDerivation t (zip xs ts)  -- local helper datatype data Shown = Shown String @@ -222,65 +293,187 @@           --------------------------------------------------------------- -- 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 :: Show a => Exercise a -> IO ()-checkExercise ex =+checkExercise :: Exercise a -> IO ()+checkExercise ex = do+   putStrLn ("** " ++ show (exerciseCode ex))+   checkExamples ex    case testGenerator ex of        Nothing  -> return ()       Just gen -> do-         putStrLn ("** " ++ show (exerciseCode ex))-         let check txt p = putLabel txt >> quickCheck p-         check "parser/pretty printer" $ forAll gen $-            checkParserPretty (equivalence ex) (parser ex) (prettyPrinter ex)   -         +         let showAsGen = showAs (prettyPrinter ex) gen+             check txt p = putLabel txt >> quickCheck p+         check "parser/pretty printer" $ forAll showAsGen $+            checkParserPrettyEx ex . from+          putStrLn "Soundness non-buggy rules"           forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r -> do              putLabel ("    " ++ name r)-            let eq f a b = fromContext a `f` fromContext b-            checkRuleSmart (eq (equivalence ex)) r (liftM inContext gen)+            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))+            testRuleSmart eq (liftRule myView r) myGen -         check "non-trivial terms" $ -            forAll gen $ \x -> -            let trivial  = isReady ex x-                rejected = not trivial-                suitable = not trivial in-            classify trivial  "trivial"  $-            classify rejected "rejected" $-            classify suitable "suitable" $ property True           check "soundness strategy/generator" $ -            forAll gen $-               isReady ex . fromContext . applyD (strategy ex) . inContext+            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 parser pretty p = -   either (const False) (eq p) (parser (pretty p))+checkParserPretty eq parser pretty a = +   either (const False) (eq a) (parser (pretty a)) -checksForList :: Exercise a -> IO ()-checksForList ex-   | status ex /= Experimental || null xs = return ()-   | otherwise = do-         let err s = putStrLn $ "Error: " ++ s-         putStrLn ("** " ++ show (exerciseCode ex))-         mapM_ (either err return . checksForTerm ex) xs- where xs = examples ex+checkParserPrettyEx :: Exercise a -> a -> Bool+checkParserPrettyEx ex = +   checkParserPretty (similarity ex) (parser ex) (prettyPrinter ex) -checksForTerm :: Monad m => Exercise a -> a -> m ()-checksForTerm ex a = -   let txt = prettyPrinter ex a in-   case derivation (derivationTree (strategy ex) (inContext a)) of-      Nothing -> fail $ "no derivation for " ++ txt-      Just theDerivation -> do-         unless (isReady ex (last as)) $-            fail $ "not solved: " ++ txt-         case [ (x, y) | x <- as, y <- as, not (equivalence ex x y) ] of-            (x, y):_ -> fail $ "not equivalent: " ++ prettyPrinter ex x ++ "  and  "-                                                  ++ prettyPrinter ex y-            _        -> return ()-         case filter (not . checkParserPretty (similarity ex) (parser ex) (prettyPrinter ex)) as of-            hd:_ -> let s = prettyPrinter ex hd in-                    fail $ "parse error for " ++ s ++ ": parsed as " ++-                           either show (prettyPrinter ex) (parser ex s)-            _    -> return ()-       where-         as = map fromContext (terms theDerivation)+checkExamples :: Exercise a -> IO ()+checkExamples ex = do+   let xs = examples ex+   unless (null xs) $ do+      putStrLn $ "Checking " ++ show (length xs) ++ " examples"+      bs <- forM xs $ \a -> checksForTerm True ex a+      when (and bs) $ +         putStrLn "Passed all tests"++checksForTerm :: Bool -> Exercise a -> a -> IO Bool+checksForTerm leftMost ex a = do+   let tree = derivationTree (strategy ex) (inContext ex a)+   -- Left-most derivation+   b1 <- if not leftMost then return True else+         case derivation tree of+            Just d  -> checksForDerivation ex d+            Nothing -> do +               report $ "no derivation for " ++ prettyPrinter ex a+               return False+   -- Random derivation+   g  <- getStdGen+   b2 <- case randomDerivation g tree of+            Just d  -> checksForDerivation ex d+            Nothing -> return True +   return $ and [b1, b2]+         +checksForDerivation :: Exercise a -> Derivation (Rule (Context a)) (Context a) -> IO Bool+checksForDerivation ex d = do+   -- Conditions on starting term+   let start = head (terms d)+   b1 <- do let b = maybe False (isSuitable ex) (fromContext start)+            unless b $ report $ +               "start term not suitable: " ++ prettyPrinterContext ex start+            return b+   {-+   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 -}+   b4 <- do let b = maybe False (isReady ex) (fromContext final)+            unless b $ report $ +               "final term not ready: " ++ prettyPrinterContext ex start+               ++ "  =>  " ++ prettyPrinterContext ex final+            return b+   -- Parser/pretty printer on terms+   let ts = terms d+       p  = maybe False (not . checkParserPrettyEx ex) . fromContext+   b5 <- case filter p ts of+            []   -> return True+            hd:_ -> do+               let s = prettyPrinterContext ex hd +               report $  "parse error for " ++ s ++ ": parsed as " +                      ++ either show (prettyPrinter ex) (parser ex s)+               return False+   -- Equivalences between terms+   let pairs    = [ (x, y) | x <- ts, y <- ts ]+       p (x, y) = not (equivalenceContext ex x y)+   b6 <- case filter p pairs of+            []       -> return True+            (x, y):_ -> do+               report $  "not equivalent: " ++ prettyPrinterContext ex x+                      ++ "  with  " ++ prettyPrinterContext ex y+               return False+   -- Similarity of terms+   {-+   let p (x, _, y) = fromMaybe False $ +                        liftM2 (similarity ex) (fromContext x) (fromContext y)+   b7 <- case filter p (triples d) of+            [] -> return True+            (x, r, y):_ -> do+               report $ "similar subsequent terms: " ++ prettyPrinterContext ex x+                      ++ "  with  " ++ prettyPrinterContext ex y+                      ++ "  using  " ++ show r+               return False -}+   let xs = [ x | cx <- terms d, x <- fromContext cx, not (similarity ex x x) ]+   b8 <- case xs of+            [] -> return True+            hd:_ -> do+               report $ "term not similar to itself: " ++ prettyPrinter ex hd+               return False+   -- Result+   return $ and [b1, b4, b5, b6, b8]++report :: String -> IO ()+report txt = putStrLn ("Error: " ++ txt)++{-+generateIO :: Int -> Gen a -> IO [a]+generateIO n gen = forM [0..n] $ \i -> do+   std <- newStdGen+   return (generate i std gen) -}
− src/Common/Grammar.hs 
@@ -1,366 +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)------ This module defines a set of combinators for context-free grammars. These--- grammars are the basis of the strategies. The fix-point combinator 'fix' --- makes it context-free. The code is based on the RTS'08 paper--- "Recognizing Strategies"----------------------------------------------------------------------------------module Common.Grammar-   ( -- * Abstract data type-     Grammar-     -- * Smart constructor functions-   , (<*>), (<|>), (<||>), var, rec, fix, many, succeed, fail, symbol-     -- * Elementary operations-   , empty, firsts, nonempty -     -- * Membership and generated language-   , member, language, languageBF-     -- * Additional functions-   , collectSymbols, join, withIndex-     -- * QuickCheck properties-   , checks-   ) where--import Common.Uniplate-import Control.Monad (liftM, liftM2)-import Data.List-import Prelude hiding (fail)-import Test.QuickCheck-import qualified Data.Set as S--------------------------------------------------------------------------- Abstract data type--data Grammar a  =  Grammar a :*:  Grammar a -                |  Grammar a :|:  Grammar a -                |  Grammar a :||: Grammar a-                |  Rec Int (Grammar a) -                |  Symbol a | Var Int | Succeed | Fail  deriving Show--infixr 3 :|:, <|>-infixr 4 :||:, <||>-infixr 5 :*:, <*>--------------------------------------------------------------------------- Smart constructor functions---- simple constructors-succeed, fail ::        Grammar a-var           :: Int -> Grammar a-symbol        :: a   -> Grammar a--succeed  = Succeed-fail     = Fail   -symbol   = Symbol-var      = Var---- | Smart constructor for sequences: removes fails and succeeds in the--- operands-(<*>) :: Grammar a -> Grammar a -> Grammar a-Succeed    <*> t        = t-s          <*> Succeed  = s-Fail       <*> _        = fail-_          <*> Fail     = fail-(s :*: t)  <*> u        = s :*: (t <*> u)-s          <*> t        = s :*: t---- | Smart constructor for alternatives: removes fails in the operands, and --- merges succeeds if present in both arguments-(<|>) :: Grammar a -> Grammar a -> Grammar a-Fail       <|> t       = t-s          <|> Fail    = s-(s :|: t)  <|> u       = s :|: (t <|> u)-Succeed    <|> Succeed = Succeed-s          <|> t       = s :|: t---- | Smart constructor for parallel execution: removes fails and succeeds in the operands-(<||>) :: Grammar a -> Grammar a -> Grammar a-Succeed     <||> t        = t-s           <||> Succeed  = s-Fail        <||> _        = fail-_           <||> Fail     = fail-(s :||: t)  <||> u        = s :||: (t <||> u)-s           <||> t        = s :||: t---- | For constructing a recursive grammar-rec :: Int -> Grammar a -> Grammar a-rec i s = if i `S.member` freeVars s then Rec i s else s----- | Fix-point combinator to model recursion. Be careful: this combinator is --- VERY powerfull, and it is your own responsibility that the result--- is a valid, non-left-recursive grammar-fix :: (Grammar a -> Grammar a) -> Grammar a-fix f = Rec i (f (Var i)) -- disadvantage: function f is applied twice- where-   s = allVars (f Succeed)-   i = if S.null s then 0 else S.findMax s + 1---- | Zero or more occurrences-many :: Grammar a -> Grammar a-many s = rec 0 (succeed <|> (nonempty s <*> var 0))-{- TODO: deal with free variables?-many s = rec i (succeed <|> (nonempty s <*> var i))- where-   vs = freeVars s-   i  = if S.null vs then 0 else 1 + S.findMax vs -}-   -------------------------------------------------------------------------- Elementary operations---- | Tests whether the grammar accepts the empty string-empty :: Grammar a -> Bool-empty (s :*: t)   =  empty s && empty t-empty (s :|: t)   =  empty s || empty t-empty (s :||: t)  =  empty s && empty t-empty (Rec _ s)   =  empty s-empty Succeed     =  True-empty _           =  False---- | Returns the firsts set of the grammar, where each symbol is--- paired with the remaining grammar-firsts :: Grammar a -> [(a, Grammar a)]-firsts (s :*: t)   =  [ (a, s' <*> t) | (a, s') <- firsts s ] ++-                      (if empty s then firsts t else [])-firsts (s :|: t)   =  firsts s ++ firsts t-firsts (s :||: t)  =  [ (a, s'  <||>  t   ) | (a, s') <- firsts s ] ++-                      [ (a, s   <||>  t'  ) | (a, t') <- firsts t]-firsts (Rec i s)   =  firsts (replaceVar i (Rec i s) s)-firsts (Symbol a)  =  [(a, succeed)]-firsts _           =  []---- | Returns the grammar without the empty string alternative-nonempty :: Grammar a -> Grammar a-nonempty s = foldr (<|>) fail [ symbol a <*> t | (a, t) <- firsts s ]--------------------------------------------------------------------------- Membership and generated language---- | Checks whether a string is member of the grammar's language-member :: Eq a => [a] -> Grammar a -> Bool-member [] g     = empty g-member (a:as) g = not $ null [ () | (b, t) <- firsts g, a==b, member as t ]---- | Generates the language of the grammar (list can be infinite). The sentences are --- returned sorted by length, thus in a breadth-first order. The integer that is passed--- is the cut-off depth (the maximal length of the sentences) needed to avoid non-termination-language :: Int -> Grammar a -> [[a]]-language n = concat . take n . languageBF---- | Generates the language of a grammar in a breadth-first manner, which is made explicit--- by the outermost list. Sentences are grouped by their length-languageBF :: Grammar a -> [[[a]]]-languageBF s = [ [] | empty s ] : merge [ map (map (a:)) $ languageBF t | (a, t) <- firsts s ]- where merge = map concat . transpose--------------------------------------------------------------------------- Additional functions---- | Collect all the symbols of the grammar-collectSymbols :: Grammar a -> [a]-collectSymbols (Symbol a) = [a]-collectSymbols g          = compos [] (++) collectSymbols g---- | The (monadic) join -join :: Grammar (Grammar a) -> Grammar a-join = mapSymbol id---- | Label all symbols with an index (from left to right)-withIndex :: Grammar a -> Grammar (Int, a)-withIndex = snd . rec 0- where-   rec :: Int -> Grammar a -> (Int, Grammar (Int, a))-   rec n grammar =-      case grammar of  -         p :*: q   -> let (n1, a) = rec n  p-                          (n2, b) = rec n1 q-                      in (n2, a :*: b)-         p :|: q   -> let (n1, a) = rec n  p-                          (n2, b) = rec n1 q-                      in (n2, a :|: b)-         p :||: q  -> let (n1, a) = rec n  p-                          (n2, b) = rec n1 q-                      in (n2, a :||: b)-         Rec i s   -> let (n1, a) = rec n s-                      in (n1, Rec i a)-         Var i     -> (n, Var i)-         Symbol a  -> (n+1, Symbol (n, a))-         Succeed   -> (n, Succeed)-         Fail      -> (n, Fail)--------------------------------------------------------------------------- Local helper functions and instances--instance Uniplate (Grammar a) where-   uniplate (s :*: t)  = ([s,t], \[a,b] -> a :*: b)-   uniplate (s :|: t)  = ([s,t], \[a,b] -> a :|: b)-   uniplate (s :||: t) = ([s,t], \[a,b] -> a :||: b)-   uniplate (Rec i s)  = ([s]  , \[a]   -> Rec i a)-   uniplate g          = ([]   , \[]    -> g)--instance Functor Grammar where-   fmap f = mapSymbol (symbol . f)--freeVars :: Grammar a -> S.Set Int-freeVars (Rec i s) = freeVars s S.\\ S.singleton i-freeVars (Var i)   = S.singleton i-freeVars g         = compos S.empty S.union freeVars g--allVars :: Grammar a -> S.Set Int-allVars (Var i) = S.singleton i-allVars g       = compos S.empty S.union allVars g--replaceVar :: Int -> Grammar a -> Grammar a -> Grammar a-replaceVar i new = rec - where-   rec g =-      case g of -         Var j   | i==j -> new-         Rec j _ | i==j -> g-         _              -> f $ map rec cs-          where (cs, f) = uniplate g--mapSymbol :: (a -> Grammar b) -> Grammar a -> Grammar b-mapSymbol f (p :*: q)   =  mapSymbol f p  <*>   mapSymbol f q-mapSymbol f (p :|: q)   =  mapSymbol f p  <|>   mapSymbol f q-mapSymbol f (p :||: q)  =  mapSymbol f p  <||>  mapSymbol f q-mapSymbol f (Rec i p)   =  Rec i (mapSymbol f p) -mapSymbol _ (Var i)     =  Var i-mapSymbol f (Symbol a)  =  f a-mapSymbol _ Succeed     =  Succeed-mapSymbol _ Fail        =  Fail------------------------------------------------------------- QuickCheck generator--instance Arbitrary a => Arbitrary (Grammar a) where-   arbitrary = sized (arbGrammar [])-   coarbitrary grammar =-      case grammar of-         p :*: q  -> variant 0 . coarbitrary p . coarbitrary q-         p :|: q  -> variant 1 . coarbitrary p . coarbitrary q-         p :||: q -> variant 2 . coarbitrary p . coarbitrary q-         Rec i p  -> variant 3 . coarbitrary i . coarbitrary p-         Var i    -> variant 4 . coarbitrary i-         Symbol a -> variant 5 . coarbitrary a-         Succeed  -> variant 6-         Fail     -> variant 7---- Use smart constructors here-arbGrammar :: Arbitrary a => [Grammar a] -> Int -> Gen (Grammar a)-arbGrammar xs n-   | n == 0 = oneof $-        liftM symbol arbitrary :-        map return ([succeed, fail] ++ xs)-   | otherwise = oneof-        [ arbGrammar xs 0-        , liftM2 (<*>)  rec rec-        , liftM2 (<|>)  rec rec-        , liftM2 (<||>) rec rec-        , liftM many rec---         , liftM fix (promote (\x -> arbGrammar (x:xs) (n `div` 2)))-{-        , do i <- oneof $ map return [1::Int ..5]-             x <- arbGrammar (Var i:xs) (n `div` 2)-             return $ Rec i x -}-        ]- where -   rec = arbGrammar xs (n `div` 2)-   ------------------------------------------------------------ QuickCheck properties                                                                 --propSymbols :: (Int -> Int) -> Grammar Int -> Bool-propSymbols f p = map f (collectSymbols p) == collectSymbols (fmap f p)--propIndexId :: Grammar Int -> Bool-propIndexId p = fmap snd (withIndex p) === p--propIndexUnique :: Grammar Int -> Bool-propIndexUnique p = is == nub is- where is = map fst $ collectSymbols $ withIndex p--propSound :: Grammar Int -> Property-propSound p = not (null xs) ==> all (`member` p) xs- where xs = take 20 $ language 10 p--propEmpty :: Grammar Int -> Bool-propEmpty s = empty s == member [] s--propNonEmpty :: Grammar Int -> Bool-propNonEmpty = not . member [] . nonempty--propSplitSucceed :: Grammar Int -> Bool-propSplitSucceed p = p === if empty p then succeed <|> new else new- where new = nonempty p--propFirsts :: Grammar Int -> Bool-propFirsts p = nonempty p === foldr op fail (firsts p)- where op (a, q) r = (symbol a <*> q) <|> r--propJoin :: Grammar Int -> Bool-propJoin p = join (fmap symbol p) === p-          -propMap :: (Int -> Int) -> (Int -> Int) -> Grammar Int -> Bool-propMap f g p = fmap (f . g) p === fmap (f . g) p--propRec :: Grammar Int -> Property-propRec this@(Rec i p) = property (replaceVar i this p === this)-propRec _              = False ==> True--propSucceed :: Grammar Int -> Bool-propSucceed p = empty p == member [] p--infixl 1 ===- -(===) :: Grammar Int -> Grammar Int -> Bool-p === q = all (`member` p) ys && all (`member` q) xs - where-   xs = take 20 $ language 10 p-   ys = take 20 $ language 10 q-   -associative op p q r  =  p `op` (q `op` r) === (p `op` q) `op` r-commutative op p q    =  p `op` q === q `op` p-idempotent  op p      =  p `op` p === p-leftUnit    op e p    =  e `op` p === p-rightUnit   op e p    =  p `op` e === p-unit        op e p    =  leftUnit op e p && rightUnit op e p-absorbe     op e p    =  (e `op` p === e) && (p `op` e === e)-propStar         p    =  many p === succeed <|> (p <*> many p)-propStarStar     p    =  many (many p) === many p--checks :: IO ()-checks = do-   putStrLn "** Grammar combinators"-   quickCheck propMap-   quickCheck propJoin-   quickCheck propSymbols-   quickCheck propIndexId-   quickCheck propIndexUnique-   quickCheck propSound-   quickCheck propEmpty-   quickCheck propNonEmpty-   quickCheck propSplitSucceed-   quickCheck propFirsts-   quickCheck propRec-   quickCheck propStar-   quickCheck propStarStar-   quickCheck propSucceed-   quickCheck $ associative (<|>)-   quickCheck $ commutative (<|>)-   quickCheck $ idempotent  (<|>)-   quickCheck $ unit (<|>) fail-   quickCheck $ associative (<*>)-   quickCheck $ unit (<*>) succeed-   quickCheck $ absorbe (<*>) fail-   quickCheck $ associative (<||>)-   quickCheck $ commutative (<||>)-   quickCheck $ unit (<||>) succeed-   quickCheck $ absorbe (<||>) fail
+ src/Common/Navigator.hs view
@@ -0,0 +1,261 @@+{-# OPTIONS -XExistentialQuantification #-}+-----------------------------------------------------------------------------+-- 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+     -- * Derived navigations+   , leave, replace, arity, isTop, isLeaf, ups, downs, navigateTo+   , top, leafs, downFirst, downLast, left, right+   ) where++import Common.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 =+      case changeM (Just . f) a of+         Just new -> new+         Nothing  -> 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"+   currentT _  = fail "currentT"+   leaveT _    = fail "leaveT"+   castT _ _   = fail "castT"++---------------------------------------------------------------+-- 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))++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 (UniplateType a) [(Int, a -> a)] a++type UniplateType a = a -> ([a], [a] -> a)++makeUN :: Uniplate a => a -> UniplateNav a+makeUN = UN uniplate []++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) = zipWith make [0..] cs+    where+      (cs, build) = uni a+      make i = UN uni ((i, build . flip (update i) cs):xs)+      update _ _ []  = []+      update i x (y:ys)+         | i == 0    = x:ys+         | otherwise = y:update (i-1) x ys+   +   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) +      | typeOf (getTp v) == typeOf (getTp v0) = +           return (VN (makeView f g) a)+      | otherwise = +           fail "castT"+    where+      f e = castM e >>= matchM v+      g   = fromMaybe (error "castT") . cast . build v+      +      getTp :: View a b -> a+      getTp = error "castT"++castM :: (Monad m, Typeable a, Typeable b) => a -> m b+castM = maybe (fail "castM") return . cast++---------------------------------------------------------------+-- 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++noNavigator :: a -> Navigator a+noNavigator = N . S . UN (\a -> ([], const a)) []++viewNavigator :: (Uniplate a, Typeable a) => a -> Navigator a+viewNavigator = N . VN identity . makeUN
src/Common/Rewriting.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -10,19 +10,15 @@ -- ----------------------------------------------------------------------------- module Common.Rewriting -   ( module Common.Rewriting.AC-   , module Common.Rewriting.Confluence-   , module Common.Rewriting.MetaVar-   , module Common.Rewriting.RewriteRule-   , module Common.Rewriting.Substitution-   , module Common.Rewriting.Difference-   , module Common.Rewriting.Unification+   ( RewriteRule, smartGenerator, rewriteRule, rewriteRules+   , Builder, rewriteM, RuleSpec((:~>)), rulePair, BuilderList, showRewriteRule+   , Rewrite(..), ShallowEq(..), Operator+   , associativeOperator, ruleName, Operators, collectWithOperator+   , equalWith, isOperator, constructor, difference, differenceMode+   , acOperator, normalizeWith, IsTerm(..), Different(..)    ) where  import Common.Rewriting.AC-import Common.Rewriting.Confluence-import Common.Rewriting.MetaVar-import Common.Rewriting.RewriteRule-import Common.Rewriting.Substitution import Common.Rewriting.Difference-import Common.Rewriting.Unification+import Common.Rewriting.RewriteRule+import Common.Rewriting.Term
src/Common/Rewriting/AC.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -17,6 +17,7 @@    , isOperator, findOperator    , normalizeWith, equalWith    , pairings, pairingsMatch+   , pairingsA2, onBoth    ) where  import Common.Uniplate@@ -118,7 +119,14 @@  -- associative pairings pairingsA :: Bool -> Operator a -> a -> a -> [[(a, a)]]-pairingsA matchMode op a b = rec (collectWithOperator op a) (collectWithOperator op b)+pairingsA matchMode op a b = map (map make) result+ where +   (as, bs) = onBoth (collectWithOperator op) (a, b)+   result   = pairingsA2 matchMode as bs+   make     = onBoth (buildWithOperator op)++pairingsA2 :: Bool -> [a] -> [a] -> [[([a], [a])]]+pairingsA2 matchMode = rec  where    rec [] [] = [[]]    rec as bs = @@ -128,8 +136,8 @@       , i==1 || j==1       , let (as1, as2) = splitAt i as       , let (bs1, bs2) = splitAt j bs-      , let a1 = buildWithOperator op as1-      , let b1 = buildWithOperator op bs1+      , let a1 = as1+      , let b1 = bs1       , ps <- rec as2 bs2       ] @@ -176,7 +184,10 @@       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) [[]]
− src/Common/Rewriting/Confluence.hs 
@@ -1,96 +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 Common.Rewriting.Confluence -   ( isConfluent, confluence, confluenceWith, confluentFunction-   , testConfluence, testConfluenceWith, testConfluentFunction-   ) where--import Common.Rewriting.AC-import Common.Rewriting.MetaVar-import Common.Rewriting.RewriteRule-import Common.Rewriting.Substitution-import Common.Rewriting.Unification-import Common.Uniplate (subtermsAt, applyAtM, somewhereM)-import Data.List-import Data.Maybe---------------------------------------------------------superImpose :: Rewrite a => RewriteRule a -> RewriteRule a -> [([Int], a)]-superImpose r1 r2 =-   [ (loc, s |-> lhs2) | (loc, a) <- subtermsAt lhs2, s <- make a ]- where-    lhs1 = lhs (rulePair r1 0)-    lhs2 = lhs (rulePair r2 (nrOfMetaVars r1))-    -    make a-       | isJust (isMetaVar a) = []-       | otherwise            = unifyM lhs1 a--criticalPairs :: (Rewrite a, Eq a) => [RewriteRule a] -> [(a, (RewriteRule a, a), (RewriteRule a, a))]-criticalPairs rs = -   [ (a, (r1, b1), (r2, b2)) -   | r1       <- rs-   , r2       <- rs-   , (loc, a) <- superImpose r1 r2-   , b1       <- rewriteM r1 a-   , b2       <- applyAtM loc (rewriteM r2) a-   , b1 /= b2 -   ]--noDiamondPairs :: (Rewrite a, Eq a) => (a -> a) -> [RewriteRule a] -> [(a, (RewriteRule a, a, a), (RewriteRule a, a, a))]-noDiamondPairs f rs =-   [ (a, (r1, e1, nf1), (r2, e2, nf2)) -   | (a, (r1, e1), (r2, e2)) <- criticalPairs rs-   , let (nf1, nf2) = (f e1, f e2)-   , nf1 /= nf2-   ]--reportPairs :: (Show a, Eq a) => [(a, (RewriteRule a, a, a), (RewriteRule a, a, a))] -> IO ()-reportPairs = putStrLn . unlines . zipWith f [1::Int ..]- where-   f i (a, (r1, e1, nf1), (r2, e2, nf2)) = unlines-      [ show i ++ ") " ++ show a-      , "  "   ++ show r1-      , "    " ++ show e1 ++ if e1==nf1 then "" else "   -->   " ++ show nf1-      , "  "   ++ show r2-      , "    " ++ show e2 ++ if e2==nf2 then "" else "   -->   " ++ show nf2-      ]--------------------------------------------------------isConfluent :: (Eq a, Show a, Rewrite a) => (a -> a) -> [RewriteRule a] -> Bool-isConfluent f = null . noDiamondPairs f--confluentFunction :: (Eq a, Show a, Rewrite a) => (a -> a) -> [RewriteRule a] -> IO ()-confluentFunction f = reportPairs . noDiamondPairs f--confluenceWith :: (Ord a, Show a, Rewrite a) => [Operator a] -> [RewriteRule a] -> IO ()-confluenceWith ops rs = confluentFunction (normalizeWith ops . normalFormWith ops rs) rs--confluence :: (Ord a, Show a, Rewrite a) => [RewriteRule a] -> IO ()-confluence = confluenceWith operators--------------------------------------------------------testConfluentFunction :: (Eq a, Rewrite a) => (a -> a) -> [RewriteRule a] -> a -> Bool-testConfluentFunction f rs a = -   case nub [ f b | r <- rs, b <- somewhereM (rewriteM r) a ] of-      _:_:_ -> False-      _     -> True-      -testConfluenceWith :: (Ord a, Rewrite a) => [Operator a] -> [RewriteRule a] -> a -> Bool-testConfluenceWith ops rs = testConfluentFunction (normalFormWith ops rs) rs--testConfluence :: (Ord a, Rewrite a) => [RewriteRule a] -> a -> Bool-testConfluence = testConfluenceWith operators
src/Common/Rewriting/Difference.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -17,28 +17,32 @@    ) where  import Common.Rewriting.AC-import Common.Rewriting.Unification+import Common.Rewriting.RewriteRule import Control.Monad import Common.Uniplate import Data.Maybe -differenceMode :: Rewrite a => (a -> a -> Bool) -> Bool -> a -> a -> Maybe (a, a)+differenceMode :: (Rewrite a, Uniplate a, ShallowEq 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 => (a -> a -> Bool) -> a -> a -> Maybe (a, a)+differenceEqual :: (Rewrite a, Uniplate a, ShallowEq 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 => a -> a -> Maybe (a, a)+difference :: (Rewrite a, Uniplate a, ShallowEq a) +           => a -> a -> Maybe (a, a) difference = diff (\_ _ -> True)  -- local implementation function-diff :: Rewrite a => (a -> a -> Bool) -> a -> a -> Maybe (a, a)+diff :: (Rewrite a, Uniplate a, ShallowEq a) +     => (a -> a -> Bool) -> a -> a -> Maybe (a, a) diff eq p q     | shallowEq p q =         case findOperator operators p of@@ -49,7 +53,8 @@            _ -> diffList eq (children p) (children q)    | otherwise = Just (p, q) -diffList :: Rewrite a => (a -> a -> Bool) -> [a] -> [a] -> Maybe (a, a)+diffList :: (Rewrite a, Uniplate a, ShallowEq a) +         => (a -> a -> Bool) -> [a] -> [a] -> Maybe (a, a) diffList eq xs ys    | length xs /= length ys = Nothing    | otherwise = @@ -57,7 +62,8 @@            [p] -> Just p            _   -> Nothing            -diffA :: Rewrite a => (a -> a -> Bool) -> Operator a -> [a] -> [a] -> Maybe (a, a)+diffA :: (Rewrite a, Uniplate a, ShallowEq a) +      => (a -> a -> Bool) -> Operator a -> [a] -> [a] -> Maybe (a, a) diffA eq op = curry (make . uncurry rev . f . uncurry rev . f)  where    f (p:ps, q:qs) | not (null ps || null qs) &&
src/Common/Rewriting/MetaVar.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeSynonymInstances #-} -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -14,10 +14,7 @@  import Common.Uniplate import Common.Utils (readInt)-import Data.Char (ord, isDigit)-import Data.List import qualified Data.IntSet as IS-  ----------------------------------------------------------- --- Meta variables
src/Common/Rewriting/RewriteRule.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, +      FunctionalDependencies, FlexibleInstances, UndecidableInstances,+      TypeSynonymInstances #-} -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -11,154 +13,159 @@ -- ----------------------------------------------------------------------------- module Common.Rewriting.RewriteRule -   ( RuleSpec(..), lhs, rhs-   , RewriteRule, Builder, rewriteRule, BuilderList, rewriteRules-   , ruleName, nrOfMetaVars, rulePair-   , inverse, bothWays, checkScope-   , rewrite, rewriteM, rewriteWith-   , normalForm, normalFormWith-   , smartGenerator, showRewriteRule, showRuleSpec+   ( -- * Supporting type classes+     Rewrite(..), ShallowEq(..), Different(..)+     -- * Rewrite rules and specs+   , RewriteRule(ruleName, rulePair), RuleSpec(..)+     -- * Compiling a rewrite rule+   , rewriteRule, rewriteRules, Builder, BuilderList+     -- * Using rewrite rules+   , rewrite, rewriteM, showRewriteRule, smartGenerator    ) where -import Common.Apply import Common.Rewriting.AC-import Common.Rewriting.MetaVar import Common.Rewriting.Substitution-import Common.Rewriting.Unification-import Common.Uniplate (transform)-import Common.Utils+import Common.Rewriting.Term import Control.Monad-import Data.List-import Data.Maybe import Test.QuickCheck+import Common.Apply+import Common.Rewriting.MetaVar (getMetaVars)+import Common.Rewriting.Unification import qualified Data.IntSet as IS+import qualified Data.Map as M --------------------------------------------------------------- Rewrite rules+------------------------------------------------------+-- Supporting type classes -infixl 1 :~>+class Different a where+   different :: (a, a) -data RuleSpec a = a :~> a-   deriving Show+class ShallowEq a where +   shallowEq :: a -> a -> Bool -lhs, rhs :: RuleSpec a -> a-lhs (x :~> _) = x-rhs (_ :~> y) = y+-- 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      :: [Operator a]+   associativeOps :: a -> [Symbol]+   -- default definition: no associative/commutative operators+   operators      = []+   associativeOps = const [] -data RewriteRule a = Rewrite a => R { ruleName :: String, nrOfMetaVars :: Int, rulePair :: Int -> RuleSpec a }+------------------------------------------------------+-- Rewrite rules and specs -instance Show (RewriteRule a) where-   show r = "[" ++ ruleName r ++ "]" +infixl 1 :~>+   +data RuleSpec a = a :~> a deriving Show -instance Eq (RewriteRule a) where-   r1 == r2 = ruleName r1 == ruleName r2+data RewriteRule a = Rewrite a => R +   { ruleName     :: String+   , nrOfMetaVars :: Int+   , rulePair     :: Int -> RuleSpec Term +   } -class Rewrite a => Builder t a | t -> a where-   buildSpec :: t -> Int -> RuleSpec a+instance Functor RuleSpec where+   fmap f (a :~> b) = f a :~> f b++------------------------------------------------------+-- Compiling a rewrite rule++class Builder t a | t -> a where+   buildSpec :: t -> Int -> RuleSpec Term    countVars :: t -> Int -instance Rewrite a => Builder (RewriteRule a) a where+instance IsTerm a => Builder (RewriteRule a) a where    buildSpec = rulePair    countVars = nrOfMetaVars -instance Rewrite a => Builder (RuleSpec a) a where-   buildSpec rp _ = rp+instance IsTerm a => Builder (RuleSpec a) a where+   buildSpec (a :~> b) _ = toTerm a :~> toTerm b    countVars _    = 0 -instance (Rewrite a, Builder b a) => Builder (a -> b) a where-   buildSpec f i = buildSpec (f (metaVar i)) (i+1)+instance (Different a, Builder t b) => Builder (a -> t) b where+   buildSpec f i = buildFunction i (\a -> buildSpec (f a) (i+1))    countVars f   = countVars (f $ error "countVars") + 1 -class Rewrite a => BuilderList t a | t -> a where-   getSpecNr   :: t -> Int -> Int -> RuleSpec a+class BuilderList t a | t -> a where+   getSpecNr   :: t -> Int -> Int -> RuleSpec Term    countSpecsL :: t -> Int    countVarsL  :: t -> Int-   + instance Rewrite a => BuilderList (RewriteRule a) a where    getSpecNr r n = if n==0 then rulePair r else error "getSpecNr"    countSpecsL _ = 1    countVarsL    = nrOfMetaVars-  -instance Rewrite a => BuilderList [RuleSpec a] a where+ +instance Builder t a => BuilderList [t] a where    getSpecNr rs = buildSpec . (rs !!)    countSpecsL  = length    countVarsL _ = 0 -instance BuilderList b a => BuilderList (a -> b) a where -   getSpecNr f n i = getSpecNr (f (metaVar i)) n (i+1)+instance (Different a, BuilderList t b) => BuilderList (a -> t) b where +   getSpecNr f n i = buildFunction i (\a -> getSpecNr (f a) n (i+1))    countSpecsL f   = countSpecsL (f $ error "countSpecsL")    countVarsL f    = countVarsL (f $ error "countSpecsL") + 1-   -rewriteRule :: Builder f a => String -> f -> RewriteRule a++buildFunction :: Different a => Int -> (a -> RuleSpec Term) -> RuleSpec Term+buildFunction n f = fill n a1 a2 :~> fill n b1 b2+ where+   a1 :~> b1 = f (fst different)+   a2 :~> b2 = f (snd different)++fill :: Int -> Term -> Term -> Term+fill i (App a1 a2) (App b1 b2) = App (fill i a1 b1) (fill i a2 b2)+fill i a b +   | a == b    = a+   | otherwise = Meta i++build :: Rewrite a => RuleSpec Term -> a -> [a]+build (lhs :~> rhs) a = do+   s <- match (getMatcher a) lhs (toTerm a)+   fromTermM (s |-> rhs)++rewriteRule :: (Builder f a, Rewrite a) => String -> f -> RewriteRule a rewriteRule s f = R s (countVars f) (buildSpec f) -rewriteRules :: BuilderList f a => String -> f -> [RewriteRule a]+rewriteRules :: (BuilderList f a, Rewrite a) => String -> f -> [RewriteRule a] rewriteRules s f = map (R s (countVarsL f) . getSpecNr f) [0 .. countSpecsL f-1] -inverse :: RewriteRule a -> Maybe (RewriteRule a)-inverse r@(R _ _ _) = if checkScope new then Just new else Nothing- where -   swap (x :~> y) = y :~> x-   new = R (ruleName r) (nrOfMetaVars r) (swap . rulePair r)+getMatcher :: Rewrite a => a -> Matcher+getMatcher = M.unions . map associativeMatcher . associativeOps -bothWays :: Rewrite a => [RewriteRule a] -> [RewriteRule a]-bothWays rs = rs ++ mapMaybe inverse rs -checkScope :: Rewrite a => RewriteRule a -> Bool-checkScope r = IS.null (getMetaVars rhs IS.\\ getMetaVars lhs)- where lhs :~> rhs = rulePair r 0+------------------------------------------------------+-- Using a rewrite rule --------------------------------------------------------------- Applying rewrite rules+instance Apply RewriteRule where +   applyAll = rewrite -instance Apply RewriteRule where-   applyAll = rewriteM-  rewrite :: RewriteRule a -> a -> [a]-rewrite r@(R _ _ _) = rewriteWith operators r+rewrite r@(R _ _ _) a = do+   ext <- extendContext (associativeOps a) r+   build (rulePair ext 0) a  rewriteM :: MonadPlus m => RewriteRule a -> a -> m a-rewriteM r@(R _ _ _) = msum . map return . rewriteWith operators r-      -rewriteWith :: Operators a -> RewriteRule a -> a -> [a]-rewriteWith ops r0@(R _ _ _) e = do-   r <- extendContext ops r0-   let lhs :~> rhs = rulePair r (nextMetaVar e)-   s <- matchWith ops lhs e-   return (s |-> rhs)---- Bug fix 4/3/2009: for associative operators, we need to extend rewrite--- rules to take "contexts" into account. In addition to a left and a right--- context, we also should consider a context on both sides. If not, we --- might miss some locations, as pointed out by Josje's bug report.-extendContext :: Operators a -> RewriteRule a -> [RewriteRule a]-extendContext ops r =-   case findOperator ops (lhs $ rulePair r 0) of-      Just op | isAssociative op -> -         [r, extend (leftContext op) r, extend (rightContext op) r -         , extend (rightContext op) (extend (leftContext op) r) ]-      _ -> [r]- where-   leftContext op a (x :~> y) =-      constructor op a x :~> constructor op a y-   -   rightContext op a (x :~> y) =-      constructor op x a :~> constructor op y a+rewriteM r = msum . map return . rewrite r -extend :: (a -> RuleSpec a -> RuleSpec a) -> RewriteRule a -> RewriteRule a-extend f (R s n g) = R s (n+1) (\i -> f (metaVar (i+n)) (g i))-       -------------------------------------------------------------- Normal forms+-- Pretty-print a rewriteRule -normalFormWith :: (Rewrite a, Ord a) => [Operator a] -> [RewriteRule a] -> a -> a-normalFormWith ops rs = fixpoint $ transform $ \a ->-   case [ b | r <- rs, b <- rewriteWith ops r a ] of-      hd:_ -> normalizeWith ops hd-      _    -> a-      -normalForm :: (Rewrite a, Ord a) => [RewriteRule a] -> a -> a-normalForm = normalFormWith operators+showRewriteRule :: Bool -> RewriteRule a -> Maybe String+showRewriteRule sound r@(R _ _ _) = do+   x <- fromTermTp r (sub |-> a)+   y <- fromTermTp r (sub |-> b)+   let op = if sound then "~>" else "/~>" +   return (show x ++ " " ++ op ++ " " ++ show y)+ where+   a :~> b = rulePair r 0+   vs  = IS.toList (getMetaVars a `IS.union` getMetaVars b)+   sub = listToSubst $ zip vs [ Var [c] | c <- ['a' ..] ]+   +   fromTermTp :: IsTerm a => RewriteRule a -> Term -> Maybe a+   fromTermTp _ = fromTerm  ----------------------------------------------------------- -- Smart generator that creates instantiations of the left-hand side@@ -166,19 +173,39 @@ smartGenerator :: RewriteRule a -> Gen a smartGenerator r@(R _ _ _) = do     let a :~> _ = rulePair r 0-   let vs      = getMetaVars a-   list <- vector (IS.size vs) -   let sub = listToSubst $ zip (IS.toList vs) list-   return (sub |-> a)-   --------------------------------------------------------------- Showing a rewrite-rule+   let vs      = IS.toList (getMetaVars a)+   list <- vector (length vs) +   let sub = listToSubst (zip vs (map (tpToTerm r) list))+   case fromTerm (sub |-> a) of+      Just a  -> return a+      Nothing -> arbitrary+ where+   tpToTerm :: IsTerm a => RewriteRule a -> a -> Term+   tpToTerm _ = toTerm -showRewriteRule :: Bool -> RewriteRule a -> String-showRewriteRule sound r@(R _ _ _) = ruleName r ++ ": " ++ showRuleSpec sound r -   -showRuleSpec :: Bool -> RewriteRule a -> String-showRuleSpec sound r@(R _ _ _) = show lhs ++ " " ++ leadsto ++ " " ++ show rhs+------------------------------------------------------++-- Bug fix 4/3/2009: for associative operators, we need to extend rewrite+-- rules to take "contexts" into account. In addition to a left and a right+-- context, we also should consider a context on both sides. If not, we +-- might miss some locations, as pointed out by Josje's bug report.+extendContext :: [Symbol] -> RewriteRule a -> [RewriteRule a]+extendContext ops r@(R _ _ _) =+   case getSpine (lhs $ rulePair r 0) of+      (Con s, [_, _]) | s `elem` ops -> r :+         [ extend (leftContext s) r+         , extend (rightContext s) r +         , extend (rightContext s) (extend (leftContext s) r) +         ]+      _ -> [r]  where-   leadsto = if sound then ":~>" else ":/~>" -   lhs :~> rhs = rulePair r 0 +   lhs (a :~> _) = a+ +   leftContext s a (x :~> y) =+      binary s a x :~> binary s a y+   +   rightContext s a (x :~> y) =+      binary s x a :~> binary s y a++extend :: (Term -> RuleSpec Term -> RuleSpec Term) -> RewriteRule a -> RewriteRule a+extend f (R s n g) = R s (n+1) (\i -> f (Meta (i+n)) (g i))
src/Common/Rewriting/Substitution.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -8,6 +8,8 @@ -- Stability   :  provisional -- Portability :  portable (depends on ghc) --+-- Substitutions+-- ----------------------------------------------------------------------------- module Common.Rewriting.Substitution     ( Substitution, emptySubst, singletonSubst, listToSubst, (@@), (@@@)@@ -18,24 +20,13 @@ import Common.Rewriting.MetaVar import qualified Data.IntMap as IM import qualified Data.IntSet as IS-import Data.List import Data.Maybe  ----------------------------------------------------------- --- Substitution - -- | Abstract data type for substitutions newtype Substitution a = S { unS :: IM.IntMap a }--invariant :: (Uniplate a, MetaVar a) => Substitution a -> Bool-invariant s = IS.null (dom s `IS.intersection` getMetaVarsList (ran s))--makeS :: (Uniplate a, MetaVar a) => IM.IntMap a -> Substitution a-makeS m | invariant new = new-        | otherwise     = error "Rewriting.Substitution: invariant was violated"- where-   new = S m     infixr 4 |-> infixr 5 @@, @@@@@ -45,27 +36,25 @@  -- | Returns the empty substitution emptySubst :: (Uniplate a, MetaVar a) => Substitution a-emptySubst = makeS IM.empty+emptySubst = S IM.empty  -- | Returns a singleton substitution singletonSubst :: (MetaVar a, Uniplate a) => Int -> a -> Substitution a-singletonSubst i a-   | isMetaVar a == Just i = emptySubst-   | otherwise             = makeS (IM.singleton i a)+singletonSubst i a = S (IM.singleton i a)  -- | Turns a list into a substitution listToSubst :: (Uniplate a, MetaVar a) => [(Int, a)] -> Substitution a-listToSubst = makeS . IM.fromListWith (error "Substitution: keys are not unique")+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 (@@) :: (Uniplate a, MetaVar a) => Substitution a -> Substitution a -> Substitution a-S a @@ S b = makeS $ a `IM.union` IM.map (S a |->) b+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 (@@@) :: (Uniplate a, MetaVar a) => Substitution a -> Substitution a -> Substitution a-S a @@@ S b = makeS (IM.unionWith err a b)+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
+ src/Common/Rewriting/Term.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE TypeSynonymInstances, 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 where++import Common.Utils (ShowString(..))+import Common.Uniplate+import Control.Monad+import Common.Rewriting.MetaVar+import Data.Typeable++-----------------------------------------------------------+-- * Data type for terms++data Symbol = S (Maybe String) String+   deriving (Eq, Ord)++data Term = Var   String +          | Con   Symbol +          | App   Term Term+          | Num   Integer +          | Float Double+          | Meta  Int+ deriving (Show, Eq, Ord, Typeable)++instance Show Symbol where+   show (S ma b) = maybe b (\a -> a++ "." ++ b) ma++instance MetaVar Term where +   metaVar = Meta+   isMetaVar (Meta n) = Just n+   isMetaVar _ = Nothing+ +instance Uniplate Term where+   uniplate (App f a) = ([f,a], \[g,b] -> App g b)+   uniplate term      = ([], \_ -> term)++-----------------------------------------------------------+-- * Type class for conversion to/from terms++class IsTerm a where+   toTerm   :: a -> Term+   fromTerm :: MonadPlus m => Term -> m a++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 = +   case getSpine a of +      (t, xs) -> isCon t >>= \s -> mapM fromTermM xs >>= f s++-----------------------------------------------------------+-- * Utility functions++getSpine :: Term -> (Term, [Term])+getSpine = rec []+ where+   rec xs (App f a) = rec (a:xs) f+   rec xs a         = (a, xs)++getConSpine :: Monad m => Term -> m (Symbol, [Term])+getConSpine a = liftM (\s -> (s, xs)) (isCon b)+ where (b, xs) = getSpine a++makeTerm :: Term -> [Term] -> Term+makeTerm = foldl App++makeConTerm :: Symbol -> [Term] -> Term+makeConTerm = makeTerm . Con++unary :: Symbol -> Term -> Term+unary = App . Con++binary :: Symbol -> Term -> Term -> Term+binary s = App . App (Con s)++isUnary :: Symbol -> Term -> Maybe Term+isUnary s term =+   case getSpine term of+      (t, [a]) | isCon t == Just s -> Just a+      _ -> Nothing++isBinary :: Symbol -> Term -> Maybe (Term, Term)+isBinary s term =+   case getSpine term of+      (t, [a, b]) | isCon t == Just s -> Just (a, b)+      _ -> Nothing++isVar :: Monad m => Term -> m String+isVar (Var s) = return s+isVar _       = fail "isVar"++isCon :: Monad m => Term -> m Symbol+isCon (Con s) = return s+isCon _       = fail "isCon"
src/Common/Rewriting/Unification.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -9,23 +9,19 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Common.Rewriting.Unification -   ( ShallowEq(..), Rewrite(..)-   , unify, unifyM, unifyWith-   , match, matchM, matchWith-   ) where+module Common.Rewriting.Unification (match, Matcher, associativeMatcher) where +import Common.Rewriting.Term import Common.Rewriting.AC import Common.Rewriting.MetaVar import Common.Rewriting.Substitution-import Common.Uniplate import Control.Monad-import Test.QuickCheck import qualified Data.IntSet as IS+import qualified Data.Map as M  ----------------------------------------------------------- -- Unification (in both ways)-+{- class ShallowEq a where     shallowEq :: a -> a -> Bool @@ -66,36 +62,55 @@       s2 <- recList (map (s1 |->) xs) (map (s1 |->) ys)       return (s2 @@ s1)    recList _ _ = []-+-} ----------------------------------------------------------- -- Matching (or: one-way unification) -match :: Rewrite a => a -> a -> [Substitution a]-match = matchWith operators--matchM :: (MonadPlus m, Rewrite a) => a -> a -> m (Substitution a)-matchM x y = msum $ map return $ match x y--matchWith :: Rewrite a => [Operator a] -> a -> a -> [Substitution a]-matchWith ops x y = do+match :: Matcher -> Term -> Term -> [Substitution Term]+match m x y = do    s <- rec x y    guard (IS.null $ dom s `IS.intersection` getMetaVars y)    return s  where-   rec x y =-      case isMetaVar x of-         Just i | not (hasMetaVar i y) -> return $ singletonSubst i y-         _ -> do-            guard (shallowEq x y) -            case findOperator ops x of-               Just op -> -                  concatMap (uncurry recList . unzip) (pairingsMatch op x y)-               Nothing -> -                  recList (children x) (children y)    +   rec (Meta i) y = do +      guard (not (hasMetaVar i y))+      return (singletonSubst i y) +   rec x y = do+      let (a, as) = getSpine x+          (b, bs) = getSpine y+      case isCon a >>= (`M.lookup` m) of+         Just f  -> +            concatMap (uncurry recList . unzip) (f x y)+         Nothing -> do+            guard (a == b)+            recList as bs+    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 _ _ = []++type Matcher = M.Map Symbol (Term -> Term -> [[(Term, Term)]])++associativeMatcher :: Symbol -> Matcher+associativeMatcher s = M.singleton s f+ where+   f a b = map (map make) result+    where+      (as, bs) = onBoth collect (a, b)+      result   = pairingsA2 True as bs+      make     = onBoth construct+   +   collect = ($ []) . rec+    where +      rec term =+         case isBinary s term of+            Just (a, b) -> rec a . rec b+            Nothing     -> (term:)+   +   construct xs +      | null xs   = error "associativeMatcher: empty list"+      | otherwise = foldr1 (binary s) xs
src/Common/Strategy.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -16,384 +16,36 @@ ----------------------------------------------------------------------------- module Common.Strategy     ( -- * Data types and type classes-     Strategy, LabeledStrategy, strategyName, unlabel+     Strategy, LabeledStrategy, strategyName    , IsStrategy(..)      -- * Running strategies    , fullDerivationTree, derivationTree      -- * Strategy combinators      -- ** Basic combinators-   , (<*>), (<|>), (<||>), succeed, fail, label, sequence, alternatives+   , (<*>), (<|>), succeed, fail, label, sequence, alternatives -- <||>      -- ** EBNF combinators    , many, many1, replicate, option      -- ** Negation and greedy combinators    , check, not, repeat, repeat1, try, (|>), exhaustive      -- ** Traversal combinators    , fix, once, somewhere, topDown, bottomUp+     -- * Configuration combinators+   , module Common.Strategy.Configuration      -- * Strategy locations-   , StrategyLocation, StrategyOrRule, strategyLocations, subStrategy-   , mapRules, rulesInStrategy, cleanUpStrategy+   , StrategyLocation, topLocation, nextLocation, downLocation+   , locationDepth+   , subTaskLocation, nextTaskLocation, parseStrategyLocation+   , StrategyOrRule, subStrategy, strategyLocations+   , mapRules, mapRulesS, rulesInStrategy, cleanUpStrategy      -- * Prefixes    , Prefix, emptyPrefix, makePrefix, prefixTree, Step(..)    , prefixToSteps, stepsToRules, lastStepInPrefix    ) where -import Common.Apply-import Common.Context-import Common.Derivation-import Common.Rewriting hiding (inverse)-import Common.Transformation-import Common.Uniplate (Uniplate, children)-import Common.Utils-import Prelude hiding (fail, not, repeat, replicate, sequence)-import qualified Common.Grammar as RE-import qualified Prelude as Prelude---------------------------------------------------------------- Data types and type classes---- | Abstract data type for a strategy-newtype Strategy a = S { unS :: RE.Grammar (Either (Rule a) (LabeledStrategy a)) }---- | A strategy which is labeled with a string-data LabeledStrategy a = LS -   { strategyName :: String  -- ^ Returns the label of the strategy-   , unlabel :: Strategy a   -- ^ Removes the label from a strategy-   }---- | Type class to turn values into strategies-class Apply f => IsStrategy f where-   toStrategy :: f a -> Strategy a-   --- instances for Show-instance Show a => Show (Strategy a) where-   show = show . unS--instance Show a => Show (LabeledStrategy a) where-   show s = -      strategyName s ++ ": " ++ show (unlabel s)---- instances for Apply-instance Apply Strategy where-   applyAll s = results . fullDerivationTree s--instance Apply LabeledStrategy where-   applyAll = applyAll . unlabel---- instances for IsStrategy-instance IsStrategy RewriteRule where-   toStrategy r = -      toStrategy (makeRule (ruleName r) (RewriteRule r))--instance IsStrategy Rule where-   toStrategy = S . RE.symbol . Left--instance IsStrategy Strategy where-   toStrategy = id-   -instance IsStrategy (LabeledStrategy) where-  toStrategy = S . RE.symbol . Right---- instances for Lift-instance Lift Strategy where-   lift lp (S re) = S (fmap (either (Left . lift lp) (Right . lift lp)) re)-   -instance Lift (LabeledStrategy) where-   lift lp (LS n s) = LS n (lift lp s)----------------------------------------------------------------- Running strategies---- | Returns the derivation tree for a strategy and a term, including all--- minor rules-fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a-fullDerivationTree = rec . noLabels . toStrategy- where-   rec s a  = addBranches (list s a) (singleNode a (RE.empty s))-   list s a = [ (f, rec rest b)-              | (f, rest) <- RE.firsts s-              , b <- applyAll f a -              ]---- | 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 = mergeSteps isMajorRule . fullDerivationTree s--noLabels :: Strategy a -> RE.Grammar (Rule a)-noLabels = RE.join . fmap (either RE.symbol (noLabels . unlabel)) . unS----------------------------------------------------------------- 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-s <*> t = S (unS (toStrategy s) RE.<*> unS (toStrategy t))---- | Choose between the two strategies (either do this or do that)-(<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a-s <|> t = S (unS (toStrategy s) RE.<|> unS (toStrategy t))---- | Run two strategies in parallel (with interleaving)-(<||>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a-s <||> t = S (unS (toStrategy s) RE.<||> unS (toStrategy t))---- | The strategy that always succeeds (without doing anything)-succeed :: Strategy a-succeed = S RE.succeed---- | The strategy that always fails-fail :: Strategy a-fail = S RE.fail---- | Labels a strategy with a string-label :: IsStrategy f => String -> f a -> LabeledStrategy a-label l = LS l . toStrategy---- | 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 = S . RE.many . unS . toStrategy---- | 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 ------------------------infixr 4 |>---- | 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 - where-   checkRule = minorRule $ makeSimpleRule "check" $ \a ->-                  if p a then Just a else Nothing---- | 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 s = check (Prelude.not . applicable (toStrategy s))--{- alternative definition, with an early commit. No performance gain was-measurable--applicableOne :: Strategy a -> a -> Bool-applicableOne s a = -   let tree = derivationTree s a-   in endpoint tree || Prelude.not (null (branches tree)) -}---- | Repeat a strategy zero or more times (greedy version of 'many')-repeat :: IsStrategy f => f a -> Strategy a-repeat s = many s <*> not s---- | Apply a certain strategy at least once (greedy version of 'many1')-repeat1 :: IsStrategy f => f a -> Strategy a-repeat1 s = many1 s <*> not s---- | Apply a certain strategy if this is possible (greedy version of 'option')-try :: IsStrategy f => f a -> Strategy a-try s = s <|> not s---- | 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-s |> t = s <|> (not s <*> t)---- | 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 = S $ RE.fix $ unS . f . S---- | Apply a strategy on (exactly) one of the term's direct children-once :: (IsStrategy f, Uniplate a) => f (Context a) -> Strategy (Context a)-once s = ruleMoveDown <*> s <*> ruleMoveUp- where-   ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" moveDown-   moveDown c = -      let n = maybe 0 (pred . length . children) (currentFocus c)-      in [ changeLocation (locationDown i) c | i <- [0 .. n] ]-   -   ruleMoveUp = minorRule $ makeSimpleRule "MoveUp" moveUp-   moveUp c   = do-      new <- locationUp (location c)-      return $ setLocation new c---- | Apply a strategy somewhere in the term-somewhere :: (IsStrategy f, Uniplate a) => f (Context a) -> Strategy (Context a)-somewhere s = fix $ \this -> s <|> once this---- | Search for a suitable location in the term to apply the strategy using a--- top-down approach-topDown :: (IsStrategy f, Uniplate a) => 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, Uniplate a) => f (Context a) -> Strategy (Context a)-bottomUp s = fix $ \this -> once this <|> (not (once (bottomUp s)) <*> s)--{- The ideal implementation does not yet work: there appears to be a strange-   interplay between the fixpoint operator (with variables) and the not combinator-   > bottomUp s = fix $ \this -> once this |> s -}-                      ---------------------------------------------------------------- Strategy locations---- | A strategy location corresponds to a substrategy or a rule-type StrategyLocation = [Int]--type StrategyOrRule a = Either (LabeledStrategy a) (Rule a)---- | Returns a list of all strategy locations, paired with the labeled --- substrategy or rule at that location-strategyLocations :: LabeledStrategy a -> [(StrategyLocation, Either (LabeledStrategy a) (Rule a))]-strategyLocations = rec [] - where-   rec loc ns = -      let f is = either (\r -> [ (is, Right r) | isMajorRule r ]) (rec is)-          xs   = RE.collectSymbols $ combine (,) loc $ unS $ unlabel ns-      in (loc, Left ns) : concatMap (uncurry f) xs---- | Returns the substrategy or rule at a strategy location. Nothing indicates that the location is invalid-subStrategy :: StrategyLocation -> LabeledStrategy a -> Maybe (StrategyOrRule a)-subStrategy loc s =-   case loc of-      []   -> return (Left s) -      n:ns -> -         case lookup n . RE.collectSymbols . RE.withIndex . unS . unlabel $ s of-            Just (Left r)  |  null ns -> return (Right r)-            Just (Right t) -> subStrategy ns t-            _ -> Nothing---- | Apply a function to all the rules that make up a labeled strategy-mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b-mapRules fun = f- where-   f (LS n s)    = LS n (g s)-   g (S expr)    = S (fmap h expr)-   h (Left r)    = Left (fun r)-   h (Right ls)  = Right (f ls)---- | Returns a list of all major rules that are part of a labeled strategy-rulesInStrategy :: LabeledStrategy a -> [Rule a]-rulesInStrategy s = [ r | (_, Right r) <- strategyLocations s ]---- local helper-function-combine :: ([Int] -> a -> b) -> [Int] -> RE.Grammar a -> RE.Grammar b-combine g is = fmap (\(i, a) -> g (is++[i]) a) . RE.withIndex---- | Use a function as do-after hook for all rules in a labeled strategy-cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a-cleanUpStrategy f s = mapRules g (label (strategyName s) (doAfter f idRule <*> unlabel s))- where-   g r | isMajorRule r = doAfter f r  -       | otherwise     = r----------------------------------------------------------------- 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 [(Int, Step a)] (RE.Grammar (Step a))--instance Show (Prefix a) where-   show (P xs _) = show (reverse (map fst xs))--instance Eq (Prefix a) where-   P xs _ == P ys _ = map fst xs == map fst ys---- | Construct the empty prefix for a labeled strategy-emptyPrefix :: LabeledStrategy a -> Prefix a-emptyPrefix = makePrefix []---- | Construct a prefix for a given list of integers and a labeled strategy.-makePrefix :: [Int] -> LabeledStrategy a -> Prefix a-makePrefix is ls = rec [] is start- where-   start = withSteps ls-   -   rec acc [] g = P acc g-   rec acc (n:ns) g = -      case drop n (RE.firsts g) of-         (z, h):_ -> rec ((n, z):acc) ns h-         _        -> P [] start---- | The @Step@ data type can be used to inspect the structure of the strategy-data Step a = Begin StrategyLocation -            | Step StrategyLocation (Rule a) -            | End StrategyLocation-   deriving (Show, Eq)--instance Apply Step where-   applyAll (Step _ r) = applyAll r-   applyAll (Begin _)  = return-   applyAll (End _)    = return--instance Apply Prefix where-   applyAll p = results . prefixTree p---- | Create a derivation tree with a "prefix" as annotation.-prefixTree :: Prefix a -> a -> DerivationTree (Prefix a) a-prefixTree (P xs g) a =-   addBranches list (singleNode a (RE.empty g))- where-   add (i, (step, rest)) = P ((i, step):xs) rest-   list = [ (newPrefix, prefixTree newPrefix b)-          | triple@(_, (step, _)) <- zip [0..] (RE.firsts g)-          , let newPrefix = add triple-          , b <- applyAll step a-          ]- --- | Returns the steps that belong to the prefix-prefixToSteps :: Prefix a -> [Step a]-prefixToSteps (P xs _) = map snd (reverse xs)- --- | Retrieves the rules from a list of steps-stepsToRules :: [Step a] -> [Rule a]-stepsToRules steps = [ r | Step _ r <- steps ]---- | Returns the last rule of a prefix (if such a rule exists)-lastStepInPrefix :: Prefix a -> Maybe (Step a)-lastStepInPrefix (P xs _) = safeHead (map snd xs)+import Common.Strategy.Abstract+import Common.Strategy.Combinators+import Common.Strategy.Prefix+import Common.Strategy.Location+import Common.Strategy.Configuration --- local helper function-withSteps :: LabeledStrategy a -> RE.Grammar (Step a)-withSteps = rec []- where-   rec is = mark is . RE.join . combine f is . unS . unlabel-   f   is = either (RE.symbol . Step is) (rec is)-   mark is g = -      let begin = RE.symbol (Begin is)-          end   = RE.symbol (End is) -      in begin RE.<*> g RE.<*> end+import qualified Prelude ()
+ src/Common/Strategy/Abstract.hs view
@@ -0,0 +1,218 @@+{-# OPTIONS -XFlexibleInstances #-}+-----------------------------------------------------------------------------+-- 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, fixCore, makeLabeledStrategy+   , toLabeledStrategy+   , LabelInfo, strategyName, processLabelInfo, changeInfo, makeInfo+   , removed, collapsed, hidden, labelName, IsLabeled(..)+   ) where++import Common.Utils (commaList)+import Common.Strategy.Core+import Common.Strategy.BiasedChoice+import Common.Apply+import Common.Rewriting (RewriteRule(..))+import Common.Transformation+import Common.Derivation+import Common.Uniplate++-----------------------------------------------------------+--- 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 s = results . fullDerivationTree s++-----------------------------------------------------------+--- The information used as label in a strategy++data LabelInfo = Info +   { labelName :: String +   , 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 show (labelName info) ++ if null ps then "" else extra++makeInfo :: String -> LabelInfo+makeInfo s = Info s False False False++-----------------------------------------------------------+--- Type class++-- | Type class to turn values into strategies+class Apply f => 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)) = +     case core of+        Rule Nothing r | name r == labelName info -> +             S (Rule (Just info) r)+        _ -> S (Label info core)++instance IsStrategy Rule where -- Major rules receive a label+   toStrategy r+      | isMajorRule r = toStrategy (toLabeled r)+      | otherwise     = S (Rule Nothing r)++instance IsStrategy RewriteRule where+   toStrategy r = +      toStrategy (makeRule (ruleName r) (RewriteRule 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"++strategyName :: LabeledStrategy a -> String+strategyName = getLabel++instance Show (LabeledStrategy a) where+   show s = show (labelInfo s) ++ ": " ++ show (unlabel s)++instance Apply LabeledStrategy where+   applyAll = applyAll . toStrategy++class IsLabeled f where+   toLabeled :: f a -> LabeledStrategy a+   +instance IsLabeled LabeledStrategy where+   toLabeled = id++instance IsLabeled Rule where+   toLabeled r = LS (makeInfo (name r)) (S (Rule Nothing r))++instance IsLabeled RewriteRule where+   toLabeled r = toLabeled (makeRule (ruleName r) (RewriteRule r))++-- | Labels a strategy with a string+label :: IsStrategy f => String -> f a -> LabeledStrategy a+label l = LS (makeInfo l) . toStrategy++getLabel :: IsLabeled f => f a -> String+getLabel = labelName . labelInfo . toLabeled++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 = mapCore forLabel forRule+ where+   forLabel l c +      | removed info   = Fail+      | collapsed info = Rule (Just l) asRule+      | otherwise      = new+    where +      new | hidden info = mapRule minorRule (Label l c)+          | otherwise   = Label l c+      info   = getInfo l+      asRule = makeSimpleRuleList (labelName info ++ " (collapsed)") (applyAll new)+   forRule (Just l) r +      | removed info = Fail+      | hidden info  = Rule (Just l) (minorRule r)+      | otherwise    = Rule (Just l) r+    where+      info = getInfo l+   forRule _ r = Rule Nothing r++-----------------------------------------------------------+--- Remaining functions++-- | Returns the derivation tree for a strategy and a term, including all+-- minor rules+fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a) a+fullDerivationTree = makeBiasedTree p . processLabelInfo id . toCore . toStrategy + where +   p t = endpoint t || any isMajorRule (annotations t) || any p (subtrees t)++-- | 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 = mergeSteps isMajorRule . fullDerivationTree s++-- | 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 Nothing (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+liftCore2 f = liftCore . f . toCore . toStrategy++fixCore :: (Core l a -> Core l a) -> Core l a+fixCore f = Rec i (f (Var i)) -- disadvantage: function f is applied twice+ where+    s = coreVars (f (Rule Nothing idRule))+    i = if null s then 0 else maximum s + 1
+ src/Common/Strategy/BiasedChoice.hs view
@@ -0,0 +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 Common.Strategy.BiasedChoice +   ( Bias(..), placeBiasLabels, biasTreeG, makeBiasedTree+   ) where++import Common.Apply+-- import Common.View+import Common.Derivation+import Common.Transformation+import Common.Strategy.Core+-- import Common.Uniplate++data Bias f a = TryFirst BiasId | OrElse BiasId | Normal (f a) deriving Show+type BiasId = Int++instance Apply f => Apply (Bias f) where+   applyAll (Normal r) = applyAll r+   applyAll _          = return++-- Disabled! +placeBiasLabels :: Core l a -> Core (Either (Bias f a) l) a+placeBiasLabels = {-fst . rec 0 . -}mapLabel Right+ where {-+   -- Left-biased choice+   rec n (a :|>: b) = +      let (ra, n1) = rec n  a+          (rb, n2) = rec n1 b+          left     = Label (Left (TryFirst n)) ra+          right    = Label (Left (OrElse n))   rb+      in (left :|: right, n2)+   -- All other cases+   rec n core = +      let (cs, f)  = uniplate core+      in first f (recList n cs)+      +   recList n [] = ([], n)+   recList n (x:xs) = +      let (a,  n1) = rec n x+          (as, n2) = recList n1 xs+      in (a:as, n2) -}++biasTranslation :: (Rule a -> f a) -> Translation (Either (Bias f a) l) a (Bias f a)+biasTranslation f = (either Before (const Skip), Normal . f)++biasTreeG :: (DerivationTree (f a, info) a -> Bool) -> DerivationTree (Bias f a, info) a -> DerivationTree (f a, info) a+biasTreeG success t = t {branches = f [] (branches t)}+ where+   f _ [] = []+   f env (((bias, info), st):xs) = +      case bias of+         TryFirst n+            | success new -> branches new ++ f (n:env) xs+            | otherwise   -> f env xs+          where new = biasTreeG success st+         OrElse n   +            | n `elem` env -> f env xs+            | otherwise    -> branches (biasTreeG success st) ++ f env xs+         Normal r   -> ((r, info), biasTreeG success st):f env xs++--   success :: DerivationTree s a -> Bool+--   success = isJust . derivation++biasTree :: (DerivationTree (f a) a -> Bool) -> DerivationTree (Bias f a) a -> DerivationTree (f a) a+biasTree success t = t {branches = f [] (branches t)}+ where+   f _ [] = []+   f env ((bias, st):xs) = +      case bias of+         TryFirst n+            | success new -> branches new ++ f (n:env) xs+            | otherwise   -> f env xs+          where new = biasTree success st+         OrElse n   +            | n `elem` env -> f env xs+            | otherwise    -> branches (biasTree success st) ++ f env xs+         Normal r   -> (r, biasTree success st):f env xs+{-+   success :: DerivationTree s a -> Bool+   success = isJust . derivation -}+   +makeBiasedTree :: (DerivationTree (Rule a) a -> Bool) -> Core l a -> a -> DerivationTree (Rule a) a+makeBiasedTree p core = +   biasTree p . changeLabel fst . runTree (strategyTree (biasTranslation id) (placeBiasLabels core))+    +-------------------------+{-+test = makeBiasedTree (maybe False (const True) . derivation) myCore 5++myCore = (r1 :|>: r2) :|: (r3 :|>: r4)+ where+   r1 = make "r1" $ \n -> trace "**1**" [n*n]+   r2 = make "r2" $ \n -> trace "**2**" [n+1]+   r3 = make "r3" $ \n -> trace "**3**" [n*2]+   r4 = make "r4" $ \n -> trace "**4**" [n `div` 2]+   trace _ = id+   make n = Rule Nothing . minorRule . makeSimpleRuleList n -}
+ src/Common/Strategy/Combinators.hs view
@@ -0,0 +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)+--+-- A collection of strategy combinators: all lifted to work on different+-- data types+--+-----------------------------------------------------------------------------+module Common.Strategy.Combinators where++import Prelude hiding (not, repeat, fail, sequence)+import Common.Context+import Common.Navigator+import Common.Transformation+import Common.Strategy.Core+import Common.Strategy.Abstract++-----------------------------------------------------------+--- 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 (:*:)++-- | Choose between the two strategies (either do this or do that)+(<|>) :: (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++-- | 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 (:|>:)++-- | 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 (fixCore (toCore . f . fromCore))++-- | Apply a strategy on (exactly) one of the term's direct children+once :: IsStrategy f => f (Context a) -> Strategy (Context a)+once s = ruleMoveDown <*> s <*> ruleMoveUp+ where+   ruleMoveDown = minorRule $ makeSimpleRuleList "MoveDown" allDowns   +   ruleMoveUp   = minorRule $ makeSimpleRule "MoveUp" up++-- | Apply a strategy somewhere in the term+somewhere :: IsStrategy f => f (Context a) -> Strategy (Context a)+somewhere s = fix $ \this -> s <|> once this++-- | 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 <|> (not (once (bottomUp s)) <*> s)++{- The ideal implementation does not yet work: there appears to be a strange+   interplay between the fixpoint operator (with variables) and the not combinator+   > bottomUp s = fix $ \this -> once this |> s -}
+ src/Common/Strategy/Configuration.hs view
@@ -0,0 +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 Common.Strategy.Configuration +   ( -- Types and constructors+     StrategyConfiguration, ConfigItem+   , ConfigLocation(..), ConfigAction(..), configActions+     --  Configure+  ,  configure+     -- Combinators+   , remove, reinsert, collapse, expand, hide, reveal+   ) where++import Common.Strategy.Abstract+import Common.Strategy.Core+import Common.Strategy.Location+import Common.Transformation++---------------------------------------------------------------------+-- Types and constructors++type StrategyConfiguration = [ConfigItem]+type ConfigItem = (ConfigLocation, ConfigAction)++data ConfigLocation+   = ByName     String+   | ByGroup    String+   | ByLocation StrategyLocation+ deriving Show+ +data ConfigAction = Remove | Reinsert | Collapse | Expand | Hide | Reveal+   deriving (Show, Enum)++configActions :: [ConfigAction]+configActions = [Remove .. ]++---------------------------------------------------------------------+-- Configure++configure :: StrategyConfiguration -> LabeledStrategy a -> LabeledStrategy a+configure cfg ls = +   label (strategyName ls) (configureCore cfg (toCore (unlabel ls)))++configureCore :: StrategyConfiguration -> Core LabelInfo a -> Core LabelInfo a+configureCore cfg = mapCore f g . addLocation+ where+   f pair        a = Label (change pair []) a+   g (Just pair) r = Rule (Just (change pair (ruleGroups r))) r+   g Nothing     r = Rule Nothing r+   +   change pair@(_, info) groups = +      let actions = getActions pair groups cfg+      in foldr doAction info actions+   +getActions :: (StrategyLocation, LabelInfo) -> [String] +           -> StrategyConfiguration -> [ConfigAction]+getActions (loc, info) groups = map snd . filter (select . fst)+ where+   select (ByName s)     = labelName info == s+   select (ByGroup s)    = s `elem` groups+   select (ByLocation l) = loc == l++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
@@ -0,0 +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)+--+-- 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(..)+   , strategyTree, runTree --, makeTree +   , mapRule, coreVars, noLabels, mapCore, mapCoreM --, catMaybeLabel --, , +   , mapLabel, Translation, ForLabel(..) --, simpleTranslation+   ) where++import qualified Common.Strategy.Grammar as Grammar+import Common.Strategy.Grammar (Grammar, (<*>), (<|>), symbol)+import Common.Apply+import Common.Derivation+import Common.Transformation+import Common.Uniplate+import Control.Monad.Identity++-----------------------------------------------------------------+-- 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 () a) -- proves that there are no labels inside+   | Label l (Core l a)+   | Succeed+   | Fail+   | Rule (Maybe l) (Rule a)+   | Var Int+   | Rec Int (Core l a)+ deriving Show++-----------------------------------------------------------------+-- Useful instances++instance Apply (Core l) where +   applyAll core = results . makeTree core++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     -> ([noLabels a], \[x] -> Not (noLabels x))+         _         -> ([],    \_     -> core)++-----------------------------------------------------------------+-- The strategy tree (static, no term)++strategyTree :: Translation l a b -> Core l a -> DerivationTree b ()+strategyTree t = grammarTree . toGrammar t++grammarTree :: Grammar a -> DerivationTree a ()+grammarTree gr = addBranches list node+ where +   node = singleNode () (Grammar.empty gr)+   list = [ (f, grammarTree rest) | (f, rest) <- Grammar.firsts gr ]++-----------------------------------------------------------------+-- Running a strategy++makeTree :: Core l a -> a -> DerivationTree (Rule a) a+makeTree c = changeLabel fst . runTree (strategyTree simpleTranslation c)++runTree :: Apply f => DerivationTree (f a) info -> a -> DerivationTree (f a, info) a+runTree t a = addBranches list (singleNode a (endpoint t))+ where+   list = concatMap make (branches t)+   make (f, st) = [ ((f, root st), runTree st b) | b <- applyAll f a ]++-----------------------------------------------------------------+-- Translation to Grammar data type++type Translation l a b = (l -> ForLabel b, Rule a -> b)++data ForLabel a = Skip | Before a | After a | Around a a++simpleTranslation :: Translation l a (Rule a)+simpleTranslation = (const Skip, id)++toGrammar :: Translation l a b -> Core l a -> Grammar b+toGrammar (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 :|: (Not (noLabels a) :*: b))+         Many a    -> Grammar.many (rec a)+         Repeat a  -> rec (Many a :*: Not (noLabels a))+         Succeed   -> Grammar.succeed+         Fail      -> Grammar.fail+         Label l a -> forLabel l (rec a)+         Rule ml r -> (maybe id forLabel ml) (symbol (g r))+         Var n     -> Grammar.var n+         Rec n a   -> Grammar.rec n (rec a)+         Not a     -> symbol (g (notRule a))+   +   forLabel l g =+      case f l of+         Skip       -> g+         Before s   -> symbol s <*> g+         After    t -> g <*> symbol t+         Around s t -> symbol s <*> g <*> symbol t++notRule :: Apply f => f a -> Rule a+notRule f = checkRule (not . applicable f)+   +-----------------------------------------------------------------+-- Utility functions++mapLabel :: (l -> m) -> Core l a -> Core m a+mapLabel f = mapCore (Label . f) (Rule . fmap f)++mapRule :: (Rule a -> Rule b) -> Core l a -> Core l b+mapRule f = mapCore Label (\ml -> Rule ml . f)++noLabels :: Core l a -> Core m a+noLabels = mapCore (const id) (const (Rule Nothing))+   +-- catMaybeLabel :: Core (Maybe l) a -> Core l a+-- catMaybeLabel = mapCore (maybe id Label) (Rule . join)+   +mapCore :: (l -> Core m b -> Core m b) -> (Maybe l -> Rule a -> Core m b) +        -> Core l a -> Core m b+mapCore f g = +   let fm l = return . f l . runIdentity+       gm l = return . g l+   in runIdentity . mapCoreM fm gm++-- The most primitive function that applies functions to the label and +-- rule alternatives. Monadic version.+mapCoreM :: Monad m => (k -> m (Core l b) -> m (Core l b)) +                   -> (Maybe k -> Rule a -> m (Core l b)) +                   -> Core k a -> m (Core l b)+mapCoreM f g = rec + where +   rec core =+      case core of+         a :*: b   -> liftM2 (:*:)  (rec a) (rec b)+         a :|: b   -> liftM2 (:|:)  (rec a) (rec b)+         a :|>: b  -> liftM2 (:|>:) (rec a) (rec b)+         Many a    -> liftM Many   (rec a)+         Repeat a  -> liftM Repeat (rec a)+         Succeed   -> return Succeed+         Fail      -> return Fail+         Label l a -> f l (rec a)+         Rule ml r -> g ml r+         Var n     -> return (Var n)+         Rec n a   -> liftM (Rec n) (rec a)+         Not a     -> do +            let recNot h = mapCoreM (const id) (const h)+            b <- recNot (g Nothing) a+            c <- recNot (return . Rule Nothing) b+            return (Not c)+      +coreVars :: Core l a -> [Int]+coreVars s = [ n | Rec n _ <- universe s ] ++ [ n | Var n <- universe s ]
+ src/Common/Strategy/Grammar.hs view
@@ -0,0 +1,367 @@+-----------------------------------------------------------------------------+-- 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 set of combinators for context-free grammars. These+-- grammars are the basis of the strategies. The fix-point combinator 'fix' +-- makes it context-free. The code is based on the RTS'08 paper+-- "Recognizing Strategies"+--+-----------------------------------------------------------------------------+module Common.Strategy.Grammar+   ( -- * Abstract data type+     Grammar+     -- * Smart constructor functions+   , (<*>), (<|>), (<||>), var, rec, fix, many, succeed, fail, symbol+     -- * Elementary operations+   , empty, firsts, nonempty +     -- * Membership and generated language+   , member, language, languageBF+     -- * Additional functions+   , collectSymbols, join, withIndex+     -- * QuickCheck properties+   , checks+   ) where++import Common.Uniplate+import Control.Monad (liftM, liftM2)+import Data.List+import Prelude hiding (fail)+import Test.QuickCheck+import qualified Data.Set as S++----------------------------------------------------------------------+-- Abstract data type++data Grammar a  =  Grammar a :*:  Grammar a +                |  Grammar a :|:  Grammar a +                |  Grammar a :||: Grammar a+                |  Rec Int (Grammar a) +                |  Symbol a | Var Int | Succeed | Fail  deriving Show++infixr 3 :|:, <|>+infixr 4 :||:, <||>+infixr 5 :*:, <*>++----------------------------------------------------------------------+-- Smart constructor functions++-- simple constructors+succeed, fail ::        Grammar a+var           :: Int -> Grammar a+symbol        :: a   -> Grammar a++succeed  = Succeed+fail     = Fail   +symbol   = Symbol+var      = Var++-- | Smart constructor for sequences: removes fails and succeeds in the+-- operands+(<*>) :: Grammar a -> Grammar a -> Grammar a+Succeed    <*> t        = t+s          <*> Succeed  = s+Fail       <*> _        = fail+_          <*> Fail     = fail+(s :*: t)  <*> u        = s :*: (t <*> u)+s          <*> t        = s :*: t++-- | Smart constructor for alternatives: removes fails in the operands, and +-- merges succeeds if present in both arguments+(<|>) :: Grammar a -> Grammar a -> Grammar a+Fail       <|> t       = t+s          <|> Fail    = s+(s :|: t)  <|> u       = s :|: (t <|> u)+Succeed    <|> Succeed = Succeed+s          <|> t       = s :|: t++-- | Smart constructor for parallel execution: removes fails and succeeds in the operands+(<||>) :: Grammar a -> Grammar a -> Grammar a+Succeed     <||> t        = t+s           <||> Succeed  = s+Fail        <||> _        = fail+_           <||> Fail     = fail+(s :||: t)  <||> u        = s :||: (t <||> u)+s           <||> t        = s :||: t++-- | For constructing a recursive grammar+rec :: Int -> Grammar a -> Grammar a+rec i s = if i `S.member` freeVars s then Rec i s else s+++-- | Fix-point combinator to model recursion. Be careful: this combinator is +-- VERY powerfull, and it is your own responsibility that the result+-- is a valid, non-left-recursive grammar+fix :: (Grammar a -> Grammar a) -> Grammar a+fix f = Rec i (f (Var i)) -- disadvantage: function f is applied twice+ where+   s = allVars (f Succeed)+   i = if S.null s then 0 else S.findMax s + 1++-- | Zero or more occurrences+many :: Grammar a -> Grammar a+many s = rec 0 (succeed <|> (nonempty s <*> var 0))+{- TODO: deal with free variables?+many s = rec i (succeed <|> (nonempty s <*> var i))+ where+   vs = freeVars s+   i  = if S.null vs then 0 else 1 + S.findMax vs -}+   +----------------------------------------------------------------------+-- Elementary operations++-- | Tests whether the grammar accepts the empty string+empty :: Grammar a -> Bool+empty (s :*: t)   =  empty s && empty t+empty (s :|: t)   =  empty s || empty t+empty (s :||: t)  =  empty s && empty t+empty (Rec _ s)   =  empty s+empty Succeed     =  True+empty _           =  False++-- | Returns the firsts set of the grammar, where each symbol is+-- paired with the remaining grammar+firsts :: Grammar a -> [(a, Grammar a)]+firsts (s :*: t)   =  [ (a, s' <*> t) | (a, s') <- firsts s ] +++                      (if empty s then firsts t else [])+firsts (s :|: t)   =  firsts s ++ firsts t+firsts (s :||: t)  =  [ (a, s'  <||>  t   ) | (a, s') <- firsts s ] +++                      [ (a, s   <||>  t'  ) | (a, t') <- firsts t]+firsts (Rec i s)   =  firsts (replaceVar i (Rec i s) s)+firsts (Symbol a)  =  [(a, succeed)]+firsts _           =  []++-- | Returns the grammar without the empty string alternative+nonempty :: Grammar a -> Grammar a+nonempty s = foldr (<|>) fail [ symbol a <*> t | (a, t) <- firsts s ]++----------------------------------------------------------------------+-- Membership and generated language++-- | Checks whether a string is member of the grammar's language+member :: Eq a => [a] -> Grammar a -> Bool+member [] g     = empty g+member (a:as) g = not $ null [ () | (b, t) <- firsts g, a==b, member as t ]++-- | Generates the language of the grammar (list can be infinite). The sentences are +-- returned sorted by length, thus in a breadth-first order. The integer that is passed+-- is the cut-off depth (the maximal length of the sentences) needed to avoid non-termination+language :: Int -> Grammar a -> [[a]]+language n = concat . take n . languageBF++-- | Generates the language of a grammar in a breadth-first manner, which is made explicit+-- by the outermost list. Sentences are grouped by their length+languageBF :: Grammar a -> [[[a]]]+languageBF s = [ [] | empty s ] : merge [ map (map (a:)) $ languageBF t | (a, t) <- firsts s ]+ where merge = map concat . transpose++----------------------------------------------------------------------+-- Additional functions++-- | Collect all the symbols of the grammar+collectSymbols :: Grammar a -> [a]+collectSymbols (Symbol a) = [a]+collectSymbols g          = compos [] (++) collectSymbols g++-- | The (monadic) join +join :: Grammar (Grammar a) -> Grammar a+join = mapSymbol id++-- | Label all symbols with an index (from left to right)+withIndex :: Grammar a -> Grammar (Int, a)+withIndex = snd . rec 0+ where+   rec :: Int -> Grammar a -> (Int, Grammar (Int, a))+   rec n grammar =+      case grammar of  +         p :*: q   -> let (n1, a) = rec n  p+                          (n2, b) = rec n1 q+                      in (n2, a :*: b)+         p :|: q   -> let (n1, a) = rec n  p+                          (n2, b) = rec n1 q+                      in (n2, a :|: b)+         p :||: q  -> let (n1, a) = rec n  p+                          (n2, b) = rec n1 q+                      in (n2, a :||: b)+         Rec i s   -> let (n1, a) = rec n s+                      in (n1, Rec i a)+         Var i     -> (n, Var i)+         Symbol a  -> (n+1, Symbol (n, a))+         Succeed   -> (n, Succeed)+         Fail      -> (n, Fail)++----------------------------------------------------------------------+-- Local helper functions and instances++instance Uniplate (Grammar a) where+   uniplate (s :*: t)  = ([s,t], \[a,b] -> a :*: b)+   uniplate (s :|: t)  = ([s,t], \[a,b] -> a :|: b)+   uniplate (s :||: t) = ([s,t], \[a,b] -> a :||: b)+   uniplate (Rec i s)  = ([s]  , \[a]   -> Rec i a)+   uniplate g          = ([]   , \[]    -> g)++instance Functor Grammar where+   fmap f = mapSymbol (symbol . f)++freeVars :: Grammar a -> S.Set Int+freeVars (Rec i s) = freeVars s S.\\ S.singleton i+freeVars (Var i)   = S.singleton i+freeVars g         = compos S.empty S.union freeVars g++allVars :: Grammar a -> S.Set Int+allVars (Var i) = S.singleton i+allVars g       = compos S.empty S.union allVars g++replaceVar :: Int -> Grammar a -> Grammar a -> Grammar a+replaceVar i new = rec + where+   rec g =+      case g of +         Var j   | i==j -> new+         Rec j _ | i==j -> g+         _              -> f $ map rec cs+          where (cs, f) = uniplate g++mapSymbol :: (a -> Grammar b) -> Grammar a -> Grammar b+mapSymbol f (p :*: q)   =  mapSymbol f p  <*>   mapSymbol f q+mapSymbol f (p :|: q)   =  mapSymbol f p  <|>   mapSymbol f q+mapSymbol f (p :||: q)  =  mapSymbol f p  <||>  mapSymbol f q+mapSymbol f (Rec i p)   =  Rec i (mapSymbol f p) +mapSymbol _ (Var i)     =  Var i+mapSymbol f (Symbol a)  =  f a+mapSymbol _ Succeed     =  Succeed+mapSymbol _ Fail        =  Fail++--------------------------------------------------------+-- QuickCheck generator++instance Arbitrary a => Arbitrary (Grammar a) where+   arbitrary = sized (arbGrammar [])+instance CoArbitrary a => CoArbitrary (Grammar a) where+   coarbitrary grammar =+      case grammar of+         p :*: q  -> variant 0 . coarbitrary p . coarbitrary q+         p :|: q  -> variant 1 . coarbitrary p . coarbitrary q+         p :||: q -> variant 2 . coarbitrary p . coarbitrary q+         Rec i p  -> variant 3 . coarbitrary i . coarbitrary p+         Var i    -> variant 4 . coarbitrary i+         Symbol a -> variant 5 . coarbitrary a+         Succeed  -> variant 6+         Fail     -> variant 7++-- Use smart constructors here+arbGrammar :: Arbitrary a => [Grammar a] -> Int -> Gen (Grammar a)+arbGrammar xs n+   | n == 0 = oneof $+        liftM symbol arbitrary :+        map return ([succeed, fail] ++ xs)+   | otherwise = oneof+        [ arbGrammar xs 0+        , liftM2 (<*>)  rec rec+        , liftM2 (<|>)  rec rec+        , liftM2 (<||>) rec rec+        , liftM many rec+--         , liftM fix (promote (\x -> arbGrammar (x:xs) (n `div` 2)))+{-        , do i <- oneof $ map return [1::Int ..5]+             x <- arbGrammar (Var i:xs) (n `div` 2)+             return $ Rec i x -}+        ]+ where +   rec = arbGrammar xs (n `div` 2)+   +--------------------------------------------------------+-- QuickCheck properties                                                                 ++propSymbols :: (Int -> Int) -> Grammar Int -> Bool+propSymbols f p = map f (collectSymbols p) == collectSymbols (fmap f p)++propIndexId :: Grammar Int -> Bool+propIndexId p = fmap snd (withIndex p) === p++propIndexUnique :: Grammar Int -> Bool+propIndexUnique p = is == nub is+ where is = map fst $ collectSymbols $ withIndex p++propSound :: Grammar Int -> Property+propSound p = not (null xs) ==> all (`member` p) xs+ where xs = take 20 $ language 10 p++propEmpty :: Grammar Int -> Bool+propEmpty s = empty s == member [] s++propNonEmpty :: Grammar Int -> Bool+propNonEmpty = not . member [] . nonempty++propSplitSucceed :: Grammar Int -> Bool+propSplitSucceed p = p === if empty p then succeed <|> new else new+ where new = nonempty p++propFirsts :: Grammar Int -> Bool+propFirsts p = nonempty p === foldr op fail (firsts p)+ where op (a, q) r = (symbol a <*> q) <|> r++propJoin :: Grammar Int -> Bool+propJoin p = join (fmap symbol p) === p+          +propMap :: (Int -> Int) -> (Int -> Int) -> Grammar Int -> Bool+propMap f g p = fmap (f . g) p === fmap (f . g) p++propRec :: Grammar Int -> Property+propRec this@(Rec i p) = property (replaceVar i this p === this)+propRec _              = False ==> True++propSucceed :: Grammar Int -> Bool+propSucceed p = empty p == member [] p++infixl 1 ===+ +(===) :: Grammar Int -> Grammar Int -> Bool+p === q = all (`member` p) ys && all (`member` q) xs + where+   xs = take 20 $ language 10 p+   ys = take 20 $ language 10 q+   +associative op p q r  =  p `op` (q `op` r) === (p `op` q) `op` r+commutative op p q    =  p `op` q === q `op` p+idempotent  op p      =  p `op` p === p+leftUnit    op e p    =  e `op` p === p+rightUnit   op e p    =  p `op` e === p+unit        op e p    =  leftUnit op e p && rightUnit op e p+absorbe     op e p    =  (e `op` p === e) && (p `op` e === e)+propStar         p    =  many p === succeed <|> (p <*> many p)+propStarStar     p    =  many (many p) === many p++checks :: IO ()+checks = do+   putStrLn "** Grammar combinators"+   quickCheck propMap+   quickCheck propJoin+   quickCheck propSymbols+   quickCheck propIndexId+   quickCheck propIndexUnique+   quickCheck propSound+   quickCheck propEmpty+   quickCheck propNonEmpty+   quickCheck propSplitSucceed+   quickCheck propFirsts+   quickCheck propRec+   quickCheck propStar+   quickCheck propStarStar+   quickCheck propSucceed+   quickCheck $ associative (<|>)+   quickCheck $ commutative (<|>)+   quickCheck $ idempotent  (<|>)+   quickCheck $ unit (<|>) fail+   quickCheck $ associative (<*>)+   quickCheck $ unit (<*>) succeed+   quickCheck $ absorbe (<*>) fail+   quickCheck $ associative (<||>)+   quickCheck $ commutative (<||>)+   quickCheck $ unit (<||>) succeed+   quickCheck $ absorbe (<||>) fail
+ src/Common/Strategy/Location.hs view
@@ -0,0 +1,120 @@+-----------------------------------------------------------------------------+-- 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 +   ( StrategyLocation, topLocation, nextLocation, downLocation+   , locationDepth+   , subTaskLocation, nextTaskLocation, parseStrategyLocation+   , StrategyOrRule, strategyLocations, subStrategy, addLocation+   ) where++import Common.Strategy.Abstract+import Common.Strategy.Core+import Common.Transformation+import Common.Uniplate+import Common.Utils (readM)+import Data.Foldable (toList)+import Data.Sequence hiding (take)+import Control.Monad.State++-----------------------------------------------------------+--- Strategy locations++-- | A strategy location corresponds to a substrategy or a rule+newtype StrategyLocation = SL (Seq Int)+   deriving Eq++instance Show StrategyLocation where+   show (SL xs) = show (toList xs)++type StrategyOrRule a = Either (LabeledStrategy a) (Rule a)++topLocation :: StrategyLocation +topLocation = SL empty++nextLocation :: StrategyLocation -> StrategyLocation+nextLocation (SL xs) =+   case viewr xs of+      EmptyR  -> topLocation -- invalid+      ys :> a -> SL (ys |> (a+1))++downLocation :: StrategyLocation -> StrategyLocation+downLocation (SL xs) = SL (xs |> 0)++locationDepth :: StrategyLocation -> Int+locationDepth (SL xs) = Data.Sequence.length xs++-- old (current) and actual (next major rule) location+subTaskLocation :: StrategyLocation -> StrategyLocation -> StrategyLocation+subTaskLocation (SL xs) (SL ys) = SL (rec xs ys)+ where+   rec xs ys =+      case (viewl xs, viewl ys) of+         (i :< is, j :< js) +            | i == j    -> i <| rec is js +            | otherwise -> empty+         (_, j :< _)    -> singleton j+         _              -> empty++-- old (current) and actual (next major rule) location+nextTaskLocation :: StrategyLocation -> StrategyLocation -> StrategyLocation+nextTaskLocation (SL xs) (SL ys) = SL (rec xs ys)+ where+   rec xs ys =+      case (viewl xs, viewl ys) of+         (i :< is, j :< js)+            | i == j    -> i <| rec is js+            | otherwise -> singleton j+         _              -> empty++parseStrategyLocation :: String -> Maybe StrategyLocation+parseStrategyLocation = fmap (SL . fromList) . readM++-- | Returns a list of all strategy locations, paired with the labeled +-- substrategy or rule at that location++strategyLocations :: LabeledStrategy a -> [(StrategyLocation, StrategyOrRule a)]+strategyLocations = collect . addLocation . toCore . toStrategy+ where+   collect core = +      case core of+         Label (loc, info) s -> +            let this = makeLabeledStrategy info (mapLabel snd s)+            in (loc, Left this) : collect s+         Rule (Just (loc, _)) r -> +            [(loc, Right r)]+         _ -> +            concatMap collect (children core)++-- | Returns the substrategy or rule at a strategy location. Nothing +-- indicates that the location is invalid+subStrategy :: StrategyLocation -> LabeledStrategy a -> Maybe (StrategyOrRule a)+subStrategy loc = lookup loc . strategyLocations +            +-- local helper functions that decorates interesting places with a +-- strategy lcations (major rules, and labels)+addLocation :: Core l a -> Core (StrategyLocation, l) a+addLocation = flip evalState topLocation . mapCoreM forLabel forRule+ where+   forLabel l ma = do+      loc <- get+      put (downLocation loc)+      rest <- ma+      put (nextLocation loc)+      return (Label (loc, l) rest)+   forRule (Just l) r = do+      loc <- get+      put (nextLocation loc)+      return (Rule (Just (loc, l)) r)+   forRule Nothing r =+      return (Rule Nothing r)
+ src/Common/Strategy/Prefix.hs view
@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------+-- 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+   , Step(..), prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix+   ) where++import Common.Apply+import Common.Utils+import Common.Strategy.Abstract+import Common.Strategy.Core+import Common.Transformation+import Common.Derivation+import Common.Strategy.Location+import Common.Strategy.BiasedChoice+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 [(Int, Bias Step a)] (DerivationTree (Bias Step a) ())++instance Show (Prefix a) where+   show (P xs _) = show (reverse (map fst xs))++instance Eq (Prefix a) where+   P xs _ == P ys _ = map fst xs == map fst ys++-- | 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 is ls = rec [] is start+ where+   mkCore = placeBiasLabels . processLabelInfo snd+          . addLocation . toCore . toStrategy+   start  = strategyTree biasT (mkCore ls)+ +   rec acc [] t = return (P acc t)+   rec acc (n:ns) t =+      case drop n (branches t) of+         (step, st):_ -> rec ((n, step):acc) ns st+         _            -> fail ("invalid prefix: " ++ show is)++   biasT :: Translation (Either (Bias Step a) (StrategyLocation, LabelInfo)) a (Bias Step a)+   biasT = (forLabel, Normal . Step)+   +   forLabel (Left bias)      = Before bias+   forLabel (Right (loc, i)) = Around (Normal (Begin loc i)) (Normal (End loc i))+      +-- | The @Step@ data type can be used to inspect the structure of the strategy+data Step a = Begin StrategyLocation LabelInfo+            | Step (Rule a) +            | End StrategyLocation LabelInfo+   deriving Show++instance Apply Step where+   applyAll (Step r)    = applyAll r+   applyAll (Begin _ _) = return+   applyAll (End _ _)   = return++instance Apply Prefix where+   applyAll p = results . prefixTree p++-- | Create a derivation tree with a "prefix" as annotation.+prefixTree :: Prefix a -> a -> DerivationTree (Prefix a) a+prefixTree (P xs t) = changeLabel snd . biasTreeG suc . runTree (decorate xs t)+ where+  suc t = endpoint t || any p (annotations t) || any suc (subtrees t)+  p (Step r, _) = isMajorRule r+  p _ = False+ +decorate :: [(Int, Bias Step a)] -> DerivationTree (Bias Step a) () -> DerivationTree (Bias Step a) (Prefix a)+decorate xs t =+   let list = zipWith make [0..] (branches t)+       make i (s, st) = (s, decorate ((i,s):xs) st)+   in addBranches list (singleNode (P xs t) (endpoint t))+ +-- | Returns the steps that belong to the prefix+prefixToSteps :: Prefix a -> [Step a]+prefixToSteps (P xs _) = [ step | (_, Normal step) <- reverse xs ]+ +-- | Retrieves the rules from a list of steps+stepsToRules :: [Step a] -> [Rule a]+stepsToRules steps = [ r | Step r <- steps ]++-- | Returns the last rule of a prefix (if such a rule exists)+lastStepInPrefix :: Prefix a -> Maybe (Step a)+lastStepInPrefix (P xs _) = safeHead [ step | (_, Normal step) <- xs ]
src/Common/Transformation.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-}  -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -18,23 +18,22 @@ module Common.Transformation     ( -- * Transformations      Transformation(RewriteRule), makeTrans, makeTransList-   , inverseTrans, getPatternPair      -- * Arguments    , ArgDescr(..), defaultArgDescr, Argument(..)    , supply1, supply2, supply3, supplyLabeled1, supplyLabeled2, supplyLabeled3, supplyWith1    , hasArguments, expectedArguments, getDescriptors, useArguments      -- * Rules    , Rule, name, isMinorRule, isMajorRule, isBuggyRule, isRewriteRule-   , ruleGroups, addRuleToGroup+   , ruleGroups, ruleDescription, ruleSiblings, addRuleToGroup, describe    , rule, ruleList, ruleListF    , makeRule, makeRuleList, makeSimpleRule, makeSimpleRuleList-   , idRule, emptyRule, minorRule, buggyRule, doBefore, doAfter-   , transformations, getRewriteRules+   , idRule, checkRule, emptyRule, minorRule, buggyRule, doBefore, doAfter+   , transformations, getRewriteRules, doBeforeTrans      -- * Lifting-   , LiftPair, liftPairGet, liftPairSet, liftPairChange, makeLiftPair, Lift(..)    , ruleOnce, ruleOnce2, ruleMulti, ruleMulti2, ruleSomewhere+   , liftRule, liftTrans, liftRuleIn, liftTransIn      -- * QuickCheck-   , checkRule, checkRuleSmart+   , testRule, testRuleSmart    ) where  import Common.Apply@@ -42,56 +41,39 @@ import Common.Traversable import Common.Uniplate (Uniplate, somewhereM) import Common.Utils+import Common.View import Control.Monad import Data.Char-import Data.List import Data.Maybe import Data.Ratio-import Test.QuickCheck hiding (arguments)-+import Test.QuickCheck  ----------------------------------------------------------- --- Transformations  -- | Abstract data type for representing transformations data Transformation a-   = Function String (a -> [a])+   = Function (a -> [a])    | RewriteRule (RewriteRule a)+   | Transformation a :*: Transformation a -- sequence    | forall b . Abstraction (ArgumentList b) (a -> Maybe b) (b -> Transformation a)-   | forall b . Lift (LiftPair b a) (Transformation b)+   | forall b c . LiftView (ViewList a (b, c)) (Transformation b)     instance Apply Transformation where-   applyAll (Function _ f)      = f+   applyAll (Function f)        = f    applyAll (RewriteRule r)     = rewriteM r    applyAll (Abstraction _ f g) = \a -> maybe [] (\b -> applyAll (g b) a) (f a)-   applyAll (Lift lp t )        = \b -> maybe [] (map (\new -> liftPairSet lp new b) . applyAll t) (liftPairGet lp b)+   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     -- | Turn a function (which returns its result in the Maybe monad) into a transformation -makeTrans :: String -> (a -> Maybe a) -> Transformation a-makeTrans s f = makeTransList s (maybe [] return . f)+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 :: String -> (a -> [a]) -> Transformation a+makeTransList :: (a -> [a]) -> Transformation a makeTransList = Function --- | Return the inverse of a transformation. Only transformation that are constructed with (|-) --- can be inversed-inverseTrans :: Transformation a -> Maybe (Transformation a)-inverseTrans trans = -   case trans of-      RewriteRule r -> fmap RewriteRule (inverse r)-      Lift lp t     -> fmap (Lift lp) (inverseTrans t)-      _ -> Nothing--getPatternPair :: a -> Transformation a -> Maybe (a, a)-getPatternPair _ (RewriteRule r) = let a :~> b = rulePair r 0 in Just (a, b)-getPatternPair a (Lift lp t) = do-   let f t = liftPairSet lp t a-   b      <- liftPairGet lp a-   (x, y) <- getPatternPair b t-   return (f x, f y)-getPatternPair _ _ = Nothing- ----------------------------------------------------------- --- Arguments @@ -106,11 +88,7 @@  -- | 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 parse show arbitrary- where -   parse s = case reads s of-                [(a, xs)] | all isSpace xs -> return a-                _ -> Nothing+defaultArgDescr descr = ArgDescr descr Nothing readM show arbitrary  -- | A type class for types which have an argument descriptor class Arbitrary a => Argument a where@@ -182,28 +160,35 @@ getDescriptors :: Rule a -> [Some ArgDescr] getDescriptors rule =    case transformations rule of-      [Abstraction args _ _] -> someArguments args-      [Lift _ t] -> getDescriptors $ rule -         { transformations = [t]-         , doBeforeHook    = id-         , doAfterHook     = id-         }-      _                      -> []+      [t] -> rec t+      _   -> []+ where +   rec :: Transformation a -> [Some ArgDescr]+   rec trans = +      case trans of+         Abstraction args _ _ -> someArguments args+         LiftView _ 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 rule a =    case transformations rule of-      [Abstraction args f _] -> -         fmap (showArguments args) (f a)-      [Lift lp t] -> do -         b <- liftPairGet lp a-         expectedArguments rule -            { transformations = [t]-            , doBeforeHook    = id-            , doAfterHook     = id-            } b-      _ -> Nothing+      [t] -> rec t a+      _   -> 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+          _ -> 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@@ -218,7 +203,9 @@    make trans =        case trans of          Abstraction args _ g -> fmap g (parseArguments args list)-         Lift lp t            -> fmap (Lift lp) (make t)     +         LiftView v t         -> fmap (LiftView v) (make t)+         s :*: t              -> fmap (:*: t) (make s) `mplus`+                                 fmap (s :*:) (make t)          _                    -> Nothing     -----------------------------------------------------------@@ -278,12 +265,12 @@ -- | Abstract data type for representing rules data Rule a = Rule     { name            :: String -- ^ Returns the name of the rule (should be unique)+   , ruleDescription :: String -- ^ A short description what the rule is doing    , 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      :: [String]-   , doBeforeHook    :: a -> a -- ^ Hook to perform an action before the rule is fired-   , doAfterHook     :: a -> a -- ^ Hook to perform an action after the rule has been fired+   , ruleSiblings    :: [String]    }  instance Show (Rule a) where@@ -294,33 +281,29 @@  instance Apply Rule where    applyAll r a = do -      let b = doBeforeHook r a       t <- transformations r-      c <- applyAll t b-      return (doAfterHook r c)+      applyAll t a  -- | Returns whether or not the rule is major (i.e., not minor) isMajorRule :: Rule a -> Bool isMajorRule = not . isMinorRule  isRewriteRule :: Rule a -> Bool-isRewriteRule = all p . transformations- where-   p :: Transformation a -> Bool-   p (RewriteRule _) = True-   p (Lift _ t)      = p t-   p _               = False+isRewriteRule = not . null . getRewriteRules +describe :: String -> Rule a -> Rule a+describe txt r = r { ruleDescription = txt ++ "\n" ++ ruleDescription r}+ addRuleToGroup :: String -> Rule a -> Rule a addRuleToGroup group r = r { ruleGroups = group : ruleGroups r } -ruleList :: Builder f a => String -> [f] -> Rule a+ruleList :: (Builder f a, Rewrite a) => String -> [f] -> Rule a ruleList s = makeRuleList s . map (RewriteRule . rewriteRule s) -ruleListF :: BuilderList f a => String -> f -> Rule a+ruleListF :: (BuilderList f a, Rewrite a) => String -> f -> Rule a ruleListF s = makeRuleList s . map RewriteRule . rewriteRules s -rule :: Builder f a => String -> f -> Rule a+rule :: (Builder f a, Rewrite a) => String -> f -> Rule a rule s = makeRule s . RewriteRule . rewriteRule s  -- | Turn a transformation into a rule: the first argument is the rule's name@@ -329,20 +312,26 @@  -- | Turn a list of transformations into a single rule: the first argument is the rule's name makeRuleList :: String -> [Transformation a] -> Rule a-makeRuleList n ts = Rule n ts False False [] id id+makeRuleList n ts = Rule 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 :: String -> (a -> Maybe a) -> Rule a-makeSimpleRule n = makeRule n . makeTrans n+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 :: String -> (a -> [a]) -> Rule a-makeSimpleRuleList n = makeRule n . makeTransList n+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)@@ -357,11 +346,16 @@  -- | Perform the function before the rule has been fired doBefore :: (a -> a) -> Rule a -> Rule a-doBefore f r = r { doBeforeHook = f }+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 { doAfterHook = f }+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)@@ -370,49 +364,13 @@    f trans =       case trans of          RewriteRule rr -> [(Some rr, not $ isBuggyRule r)]      -         Lift _ t       -> f t+         LiftView _ t   -> f t+         s :*: t        -> f s ++ f t          _              -> []  ----------------------------------------------------------- --- Lifting --- | A lift pair consists of two functions: the first to access a value in a context (this can fail,--- hence the Maybe), the second to update the value in its context-data LiftPair a b = LiftPair -   { liftPairGet :: b -> Maybe a -- ^ Returns the accessor function of a lift pair-   , liftPairSet :: a -> b -> b  -- ^ Returns the update function of a lift pair-   }--- | Update a value in a context-liftPairChange :: LiftPair a b -> (a -> Maybe a) -> b -> Maybe b-liftPairChange lp f b = do -   a   <- liftPairGet lp b-   new <- f a-   return (liftPairSet lp new b)---- | Constructor for a lift pair-makeLiftPair :: (b -> Maybe a) -> (a -> b -> b) -> LiftPair a b-makeLiftPair = LiftPair---- | A type class for functors that can be lifted with a lift pair-class Lift f where-   lift :: LiftPair a b -> f a -> f b--instance Lift Transformation where-   lift = Lift-   -instance Lift Rule where-   lift lp r = r -      { transformations = map (lift lp) (transformations r)-      , doBeforeHook    = liftFunction lp (doBeforeHook r)-      , doAfterHook     = liftFunction lp (doAfterHook r)-      }--liftFunction :: LiftPair a b -> (a -> a) -> b -> b-liftFunction lp f a =-   case liftPairGet lp a of -      Just b  -> liftPairSet lp (f b) a-      Nothing -> a- -- | Lift a rule using the Once type class ruleOnce :: Once f => Rule a -> Rule (f a) ruleOnce r = makeSimpleRuleList (name r) $ onceM $ applyAll r@@ -441,20 +399,35 @@ ruleSomewhere :: Uniplate a => Rule a -> Rule a ruleSomewhere r = makeSimpleRuleList (name r) $ somewhereM $ applyAll r +liftTrans :: View a b -> Transformation b -> Transformation a+liftTrans v = liftTransIn (v &&& identity) ++liftTransIn :: Crush 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 => 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-checkRule :: (Arbitrary a, Show a) => (a -> a -> Bool) -> Rule a -> IO ()-checkRule eq rule = +testRule :: (Arbitrary a, Show a) => (a -> a -> Bool) -> Rule a -> IO ()+testRule eq rule =     quickCheck (propRule eq rule 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)-checkRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> IO ()-checkRuleSmart eq rule gen =-   quickCheck (propRule eq rule (smartGen rule gen))+testRuleSmart :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> IO ()+testRuleSmart eq rule gen =+   let cfg = stdArgs {maxSize = 10, maxSuccess = 10, maxDiscard = 100}+   in quickCheckWith cfg (propRule eq rule (smartGen rule gen))    propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property propRule eq rule gen = @@ -466,17 +439,19 @@ smartGen r gen = frequency [(2, gen), (1, smart)]  where    smart = gen >>= \a -> -      oneof (gen : mapMaybe (smartGenTrans a) (transformations r))+      oneof (gen : concatMap (smartGenTrans a) (transformations r)) -smartGenTrans :: a -> Transformation a -> Maybe (Gen a)+smartGenTrans :: a -> Transformation a -> [Gen a] smartGenTrans a trans =    case trans of       RewriteRule r -> return (smartGenerator r)-      Lift lp t -> do -         b   <- liftPairGet lp a-         gen <- smartGenTrans b t-         return $ liftM (\c -> liftPairSet lp c a) gen-      _ -> Nothing+      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
src/Common/Traversable.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Common/Uniplate.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Common/Utils.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -24,20 +24,26 @@  data Some f = forall a . Some (f a) -thoroughCheck :: Testable a => a -> IO ()-thoroughCheck = check $ defaultConfig {configMaxTest = 1000, configMaxFail = 5000}+data ShowString = ShowString { fromShowString :: String }+   deriving (Eq, Ord) -generateStd :: Gen a -> IO a-generateStd gen = do -   stdgen <- newStdGen-   return (generate 100 stdgen gen)+instance Show ShowString where+   show = fromShowString +thoroughCheck :: Testable a => a -> IO ()+thoroughCheck = quickCheckWith $ stdArgs {maxSize = 500, maxSuccess = 500}+ 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@@ -57,13 +63,6 @@ isSubsetOf :: Eq a => [a] -> [a] -> Bool isSubsetOf xs ys = all (`elem` ys) xs -eqListBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool-eqListBy f = rec - where-   rec (x:xs) (y:ys) = f x y && rec xs ys-   rec [] [] = True-   rec _ _   = False- cartesian :: [a] -> [b] -> [(a, b)] cartesian as bs = [ (a, b) | a <- as, b <- bs ] @@ -78,6 +77,7 @@ 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@@ -99,70 +99,57 @@       Just (xs, ys) -> xs : splitsWithElem c ys       Nothing       -> [s] -{- safeIndex :: Int -> [a] -> Maybe a-safeIndex 0 (x:_)  = return x-safeIndex n (_:xs) = safeIndex (n-1) xs-safeIndex _ _      = Nothing -}- -- | Use a fixed standard "random" number generator. This generator is -- accessible by calling System.Random.getStdGen useFixedStdGen :: IO () useFixedStdGen = setStdGen (mkStdGen 280578) {- magic number -} -trim :: String -> String-trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse--isNatural :: String -> Bool-isNatural x = all isDigit x && not (null x)- fst3 (x, _, _) = x snd3 (_, x, _) = x thd3 (_, _, x) = x -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d-uncurry3 f (a, b, c) = f a b c--mapLeft :: (a -> b) -> Either a c -> Either b c-mapLeft f = either (Left . f) Right--mapRight :: (b -> c) -> Either a b -> Either a c-mapRight f = either Left (Right . f)- commaList :: [String] -> String commaList = concat . intersperse ", " -indent :: Int -> String -> String-indent n = unlines . map (\s -> replicate n ' ' ++ s) . lines- primes :: [Int] primes = rec [2..]  where+   rec []     = error "Common.Utils: empty list"    rec (x:xs) = x : rec (filter (\y -> y `mod` x /= 0) xs)-+    putLabel :: String -> IO ()-putLabel = putStr . take 40 . (++ repeat ' ')+putLabel s = +   let n = (40 - length s) `max` 3+   in putStr (s ++ replicate n ' ')  reportTest :: String -> Bool -> IO () reportTest s b = putLabel s >> putStrLn (if b then "OK" else "FAILED")  instance Show (a -> b) where    show _ = "<function>"-   ++{- instance Arbitrary Char where    arbitrary = let chars = ['a' .. 'z'] ++ ['A' .. 'Z']                in oneof (map return chars)+instance CoArbitrary Char where    coarbitrary = coarbitrary . ord-   +-}+ instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (M.Map k a) where    arbitrary   = liftM M.fromList arbitrary+instance (Ord k, CoArbitrary k, CoArbitrary a) => CoArbitrary (M.Map k a) where    coarbitrary = coarbitrary . M.toList-   ++{- -- Generating arbitrary random rational numbers instance Integral a => Arbitrary (Ratio a) where    arbitrary     = sized (\n -> ratioGen n (n `div` 4))+instance Integral a => CoArbitrary (Ratio a) where    coarbitrary r = f (numerator r) . f (denominator r)-    where f = variant . fromIntegral-   +     where f = variant . fromIntegral+-}+ -- | Prevents a bias towards small numbers ratioGen :: Integral a => Int -> Int -> Gen (Ratio a) ratioGen n m = do
src/Common/View.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -12,21 +12,30 @@ -- ----------------------------------------------------------------------------- module Common.View -   ( Match, View, makeView, Simplification, makeSimplification-   , match, matchM, build, canonical, canonicalM, canonicalWith-   , simplify, simplifyWith, isCanonical, isCanonicalWith-   , belongsTo, viewEquivalent, viewEquivalentWith-   , (>>>), Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..), identity-   , listView, conversion, ( #> )+   ( -- * Generalized monadic views+     ViewM, match, build, 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+   , listView, switchView, ( #> ), associativeView+     -- * Properties on views    , propIdempotence, propSoundness, propNormalForm    ) where +import Common.Traversable import Control.Arrow hiding ((>>>)) import Control.Monad import Data.Maybe import Test.QuickCheck import qualified Control.Category as C +----------------------------------------------------------------------------------+-- Generalized monadic view+ -- For all v::View the following should hold: --   1) simplify v a "is equivalent to" a --   2) match (build b) equals Just b  @@ -34,76 +43,38 @@ -- -- Derived property: simplification is idempotent -type Match a b = a -> Maybe b--data View a b = View -   { match :: Match a b+data ViewM m a b = ViewM+   { match :: a -> m b    , build :: b -> a    } -type Simplification a = View a a--matchM :: Monad m => View a b -> a -> m b-matchM v = maybe (Prelude.fail "no match") return . match v--makeView :: (a -> Maybe b) -> (b -> a) -> View a b-makeView = View+makeView :: Monad m => (a -> m b) -> (b -> a) -> ViewM m a b+makeView = ViewM -makeSimplification :: (a -> a) -> Simplification a-makeSimplification f = makeView (return . f) id+biArr :: Monad m => (a -> b) -> (b -> a) -> ViewM m a b+biArr f g = makeView (return . f) g -canonical :: View a b -> a -> Maybe a+canonical :: Monad m => ViewM m a b -> a -> m a canonical = canonicalWith id -canonicalM :: Monad m => View a b -> a -> m a-canonicalM v = maybe (Prelude.fail "no match") return . canonicalWith id v--canonicalWith :: (b -> b) -> View a b -> a -> Maybe a+canonicalWith :: Monad m => (b -> b) -> ViewM m a b -> a -> m a canonicalWith f view = liftM (build view . f) . match view -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)-      ---------------------------------------------------------------- -- Arrow combinators -identity :: View a a -identity = makeView Just id+identity :: Monad m => ViewM m a a +identity = makeView return id -(>>>) :: View a b -> View b c -> View a c+(>>>) :: Monad m => ViewM m a b -> ViewM m b c -> ViewM m a c v >>> w = makeView (\a -> match v a >>= match w) (build v . build w) -instance C.Category View where+instance Monad m => C.Category (ViewM m) where    id    = identity    v . w = w >>> v--instance Arrow View where-   arr f = makeView -      (return . f) -      (error "Control.View.arr: function is not invertible")+   +instance Monad m => Arrow (ViewM m) where+   arr f = biArr f (error "Control.View.arr: function is not invertible")     first v = makeView        (\(a, c) -> match v a >>= \b -> return (b, c)) @@ -122,7 +93,7 @@       (\a -> liftM2 (,) (match v a) (match w a))        (\(b, _) -> build v b) -instance ArrowChoice View where+instance Monad m => ArrowChoice (ViewM m) where    left v = makeView        (either (liftM Left . match v) (return . Right))        (either (Left . build v) Right)@@ -139,20 +110,70 @@    v ||| w = makeView        (either (match v) (match w))       (Left . build v)++---------------------------------------------------------------+-- 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 => ViewM m a b -> ViewList a b+viewList v = makeView (crush . match v) (build v)+ ------------------------------------------------------------------ More combinators+-- Some combinators -listView :: View a b -> View [a] [b]+listView :: Monad m => ViewM m a b -> ViewM m [a] [b] listView v = makeView (mapM (match v)) (map (build v)) -conversion :: (a -> b) -> (b -> a) -> View a b-conversion f g = makeView (Just . f) g+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)) -( #> ) :: (a -> Bool) -> View a b -> View a b+( #> ) :: MonadPlus m => (a -> Bool) -> ViewM m a b -> ViewM m a b p #> v = makeView f (build v)  where f a = guard (p a) >> match v a  +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
+ src/Documentation/DefaultPage.hs view
@@ -0,0 +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.DefaultPage where++import Common.Context+import Common.Exercise+import Common.Transformation+import Control.Monad+import Service.DomainReasoner+import Service.ServiceList+import System.Directory+import System.FilePath+import Text.HTML+import qualified Text.XML as XML+import Data.Char++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 = center $ do+   let f m = text "[" >> space >> m >> space >> text "]"+   f $ link (up level ++ exerciseOverviewPageFile) $ text "Exercises"+   replicateM_ 5 space+   f $ link (up level ++ "services.html")  $ text "Services"+   replicateM_ 5 space+   f $ link (up level ++ "tests.html")  $ text "Tests"+   replicateM_ 5 space+   f $ link (up level ++ "coverage/hpc_index.html")  $ text "Coverage"+   replicateM_ 5 space+   f $ link (up level ++ "api/index.html")  $ text "API"+   hr++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"++------------------------------------------------------------+-- Paths and files++ruleImagePath :: Exercise a -> String+ruleImagePath ex = "exercises/" ++ f (domain (exerciseCode ex)) ++ "/" ++ f (description ex) ++ "/"+ where f = filter isAlphaNum . map toLower++exercisePagePath :: ExerciseCode -> String+exercisePagePath code = "exercises/" ++ domain code ++ "/"++servicePagePath :: String+servicePagePath = "services/" ++ruleImageFile :: Exercise a -> Rule (Context a) -> String+ruleImageFile ex r = ruleImagePath ex ++ "rule" ++ name r ++ ".png"++ruleImageFileHere :: Exercise a -> Rule (Context a) -> String+ruleImageFileHere ex r = +   filter (not . isSpace) (identifier (exerciseCode ex)) +   ++ "/rule" ++ filter isAlphaNum (name r) ++ ".png"++exerciseOverviewPageFile :: String+exerciseOverviewPageFile = "exercises.html"++exerciseOverviewAllPageFile :: String+exerciseOverviewAllPageFile = "exercises-all.html"++serviceOverviewPageFile :: String+serviceOverviewPageFile = "services.html"++exercisePageFile :: ExerciseCode -> String+exercisePageFile code = +   exercisePagePath code +   ++ filter (not . isSpace) (identifier code) +   ++ ".html"++exerciseStrategyFile :: ExerciseCode -> String+exerciseStrategyFile code = +   exercisePagePath code+   ++ filter (not . isSpace) (identifier code)+   ++ "-strategy.html"++exerciseRulesFile :: ExerciseCode -> String+exerciseRulesFile code = +   exercisePagePath code+   ++ filter (not . isSpace) (identifier code)+   ++ "-rules.html"++exerciseDerivationsFile :: ExerciseCode -> String+exerciseDerivationsFile code = +   exercisePagePath code+   ++ filter (not . isSpace) (identifier code)+   ++ "-derivations.html"++servicePageFile :: Service -> String+servicePageFile srv = servicePagePath ++ serviceName srv ++ ".html"++------------------------------------------------------------+-- Utility functions++showBool :: Bool -> String +showBool b = if b then "yes" else "no"
+ src/Documentation/ExercisePage.hs view
@@ -0,0 +1,180 @@+-----------------------------------------------------------------------------+-- 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.Exercise+import Common.Strategy hiding (not, replicate)+import Common.Transformation+import Service.ExercisePackage+import Service.StrategyInfo+import Service.DomainReasoner+import Service.TypedAbstractService hiding (exercise)+import Control.Monad+import Data.List+import Common.Utils (commaList, Some(..))+import Data.Maybe+import System.Random+import qualified Data.Map as M+import Service.RulesInfo (rewriteRuleToFMP, collectExamples)+import Text.HTML+import Text.OpenMath.Object+import Text.OpenMath.FMP+import qualified Text.XML as XML+import Documentation.DefaultPage++makeExercisePage :: String -> ExercisePackage a -> DomainReasoner ()+makeExercisePage dir pkg = do+   let ex   = exercise pkg+       make = generatePageAt 2 dir . ($ (exerciseCode ex))+   make exercisePageFile     (exercisePage pkg)+   make exerciseStrategyFile (strategyPage ex)+   make exerciseRulesFile    (rulesPage ex)+   unless (null (examples (exercise pkg))) $+       make exerciseDerivationsFile (derivationsPage ex)++exercisePage :: ExercisePackage a -> HTMLBuilder+exercisePage pkg = do+   h1 (description ex)+   +   h2 "1. General information"+   table +      [ [bold $ text "Code",   ttText (show $ exerciseCode ex)]+      , [bold $ text "Status", text (show $ status ex)]+      , [ bold $ text "OpenMath support"+        , text $ showBool $ withOpenMath pkg+        ]+      , [ bold $ text "Textual feedback"+        , text $ showBool $ isJust $ getExerciseText pkg+        ]+      , [ bold $ text "Restartable strategy"+        , text $ showBool $ canBeRestarted ex+        ] +      , [ bold $ text "Exercise generator"+        , text $ showBool $ isJust $ randomExercise ex+        ]+      , [ bold $ text "Examples"+        , text $ show $ length $ examples ex+        ]+      ]+   +   para $ link (up 2 ++ exerciseStrategyFile code) $+      text "See strategy details"++   h2 "2. Rules"+   let rs = rulesInStrategy (strategy ex)+       f r = [ text (name r)+             , text $ showBool $ isBuggyRule r+             , text $ showBool $ hasArguments r+             , text $ showBool $ r `elem` rs+             , text $ concat $ intersperse "," (ruleGroups r)+             , when (isRewriteRule r) $+                  image (ruleImageFileHere 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)+         )+   para $ link (up 2 ++ exerciseRulesFile code) $+      text "See rule details"+   +   +   h2 "3. Example"+   let state = generateWith (mkStdGen 0) ex 5+   preText (showDerivation ex (term state))+   unless (null (examples ex)) $ +      link (up 2 ++ exerciseDerivationsFile code) (text "More examples")+ where+   ex   = exercise pkg+   code = exerciseCode ex++strategyPage :: Exercise a -> HTMLBuilder+strategyPage ex = do+   h1 title+   h2 "1. Representation in XML"+   preText (XML.showXML (strategyToXML (strategy ex)))+   h2 "2. Locations" +   let f (loc, e)  = [text (show loc), indent (locationDepth loc) >> g e]+       g (Left a)  = text (strategyName a)+       g (Right a) = text (name a ++ " (rule)") +       indent n    = text (replicate (3*n) '.')+   table ( [bold $ text "Location", bold $ text "Label"] +         : map f (strategyLocations (strategy ex))+         )+ where+   code  = exerciseCode ex+   title = "Strategy for " ++ show code++rulesPage :: Exercise a -> HTMLBuilder+rulesPage ex = do+   h1 title+   -- Groups+   let groups = sort (nub (concatMap ruleGroups (ruleset ex)))+   unless (null groups) $ do+      ul $ flip map groups $ \g -> do+         bold $ text $ g ++ ":"+         space+         let elems = filter ((g `elem`) . ruleGroups) (ruleset ex)+         text $ commaList $ map name elems+      +   -- General info+   forM_ (zip [1..] (ruleset ex)) $ \(i, r) -> do+      h2 (show i ++ ". " ++ show r)+      para $ text (ruleDescription r)+      para $ table +         [ [bold $ text "Buggy", text $ showBool (isBuggyRule r)]+         , [bold $ text "Rewrite rule", text $ showBool (isRewriteRule r)]+         , [bold $ text "Groups", text $ commaList $ ruleGroups r]+         , [bold $ text "Siblings", text $ commaList $ ruleSiblings r] +         ]+      when (isRewriteRule r) $ para $+         image (ruleImageFileHere ex r)+      -- Examples+      let ys = M.findWithDefault [] (name r) exampleMap+      unless (null ys) $ do+         h3 "Examples"+         forM_ (take 3 ys) $ \(a, b) -> para $ tt $ +            preText $ prettyPrinter ex a ++ "\n   =>\n" ++ prettyPrinter 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+            ttText $ show $ XML.makeXML "FMP" $ +               XML.builder (omobj2xml (toObject fmp))+ where+   code  = exerciseCode ex+   title = "Strategy for " ++ show code+   exampleMap = collectExamples ex++derivationsPage :: Exercise a -> HTMLBuilder+derivationsPage ex = do+   unless (errs==0) $ +      errorLine $ preText $ "Warning: " ++ show errs ++ " example(s) with an incorrect derivation"+   h1 "Examples"+   forM_ (zip [1 ..] ds) $ \(i, d) -> do+      h2 (show i ++ ".")+      preText d+ where+   ds   = map (showDerivation ex) (examples ex)+   errs = let p s =  "<<no derivation>>" `isSuffixOf` s +                  || "<<not ready>>" `isSuffixOf` s+          in length $ filter p ds+   +errorLine :: HTMLBuilder -> HTMLBuilder+errorLine b = XML.element "font" $ do+   "color" XML..=. "red"+   bold b
+ src/Documentation/LatexRules.hs view
@@ -0,0 +1,140 @@+-----------------------------------------------------------------------------
+-- 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.LatexRules (makeLatexRules) where
+
+import Common.Exercise
+import Common.Rewriting
+import Common.Transformation
+import Common.Utils
+import Control.Monad
+import Data.Char
+import Data.List
+import Data.Maybe
+import System.Directory
+import System.Time
+
+makeLatexRules :: String -> Exercise a -> IO ()
+makeLatexRules dir ex = do
+   let code = exerciseCode ex
+       path = dir ++ "/" ++ domain code ++ "/" ++ filter (/= ' ') (identifier code)
+   -- Exercise document
+   let rules = concatMap getRewriteRules (ruleset ex)
+   unless (null rules) $ do
+      createDirectoryIfMissing True path
+      doc <- makeDocument ex
+      let filename = path ++ "/overview.lhs"
+      putStrLn $ "Creating " ++ filename
+      writeFile filename doc
+   -- individual rules
+   forM_ (ruleset ex) $ \r ->
+       case makeSingleRule (domain code ++ "/" ++ domain code ++ ".fmt") r of
+          Nothing  -> return ()
+          Just txt -> do
+             let filename = path ++ "/rule" ++ filter isAlphaNum (name r) ++ ".lhs"
+             putStrLn $ "Creating " ++ filename
+             writeFile filename txt
+
+{- 
+exerciseRulesToTeX :: Exercise a -> String
+exerciseRulesToTeX ex = unlines . map ruleToTeX . concatMap getRewriteRules . ruleset $ ex
+-}
+
+ruleToTeX :: (Some RewriteRule, Bool) -> Maybe String
+ruleToTeX (Some r, sound) = do
+   txt <- showRewriteRule sound r
+   return $ "RewriteRule " ++ withoutDigits (ruleName r) 
+                           ++ " (" ++ txt ++ ")"
+
+   
+------------------------------------------------------
+
+makeSingleRule :: String -> Rule a -> Maybe String
+makeSingleRule dom r 
+   | null (getRewriteRules r) = Nothing
+   | otherwise = Just $ texHeader (Just dom) ++ texBody Nothing content
+ where
+   content = unlines $
+      [ "\\pagestyle{empty}"
+      , formatRuleName (name r)
+      , "\\begin{code}"
+      ] ++
+      map (filter (/= '"') . fromMaybe "" . ruleToTeX) (getRewriteRules r) ++
+      [ "\\end{code}"
+      ]
+
+
+makeDocument :: Exercise a -> IO String
+makeDocument ex = do
+   let code = exerciseCode ex
+   time <- getClockTime
+   return $ 
+      texHeader (Just $ domain code ++ "/" ++ domain code ++ ".fmt") ++ 
+      texBody (Just $ show time) (texSectionRules ex)
+
+------------------------------------------------------
+
+texHeader :: Maybe String -> String
+texHeader fmt = unlines
+   [ "\\documentclass{article}"
+   , ""
+   , "%include lhs2TeX.fmt"
+   , "%format RewriteRule (a) (b) = \"\\rewriterule{\"a\"}{\"b\"}\""
+   , "%format ~> = \"\\:\\leadsto\\:\""
+   , "%format /~> = \"\\:\\not\\leadsto\\:\""
+   , maybe "" ("%include "++) fmt
+   , "" 
+   , "\\newcommand{\\rewriterule}[2]{#1:\\quad #2}"
+   , "\\newcommand{\\rulename}[1]{\\mbox{\\sc #1}}"
+   ]
+   
+texBody :: Maybe String -> String -> String
+texBody date content = unlines
+   [ "\\begin{document}"
+   , content
+   , maybe "" (\s -> "\\par\\vspace*{5mm}\\noindent\\footnotesize{@(generated on " ++ s ++ ")@}") date
+   , "\\end{document}"
+   ]
+   
+texSectionRules :: Exercise a -> String
+texSectionRules ex = unlines 
+   [ "\\section{Rewrite rules}"
+   , formats
+   , makeGroup Nothing
+   , unlines $ map (makeGroup . Just) groups
+   ]
+ where
+   rules   = concatMap getRewriteRules (ruleset ex)
+   groups  = nub (concatMap ruleGroups (ruleset ex))
+   names   = let f (Some r, _) = ruleName r 
+             in nub (map f rules)
+   formats = unlines (map formatRuleName names)
+   
+   makeGroup :: Maybe String -> String
+   makeGroup mgroup = unlines 
+      [ maybe "" (\s -> "\\subsection{" ++ s ++ "}") mgroup
+      , "\\begin{code}"
+      , unlines $ map (filter (/= '"')) xs
+      , "\\end{code}"
+      ]
+    where
+      p x = maybe (null $ ruleGroups x) (`elem` ruleGroups x) mgroup
+      xs  = mapMaybe ruleToTeX $ concatMap getRewriteRules $ filter p $ ruleset ex
+      
+formatRuleName :: String -> String
+formatRuleName s = "%format " ++ withoutDigits s ++ " = \"\\rulename{" ++ s ++ "}\""
+
+withoutDigits :: String -> String
+withoutDigits = concatMap f 
+ where
+   f c | isAlpha c = [c]
+       | isDigit c = "QX" ++ [chr (ord c + 49)]
+       | otherwise = []
+ src/Documentation/Make.hs view
@@ -0,0 +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 Documentation.Make (DocItem(..), makeDocumentation) where
+
+import Common.Utils (Some(..))
+import Service.DomainReasoner
+import Documentation.SelfCheck
+import Documentation.LatexRules
+import Documentation.ExercisePage
+import Documentation.ServicePage
+import Documentation.OverviewPages
+
+data DocItem = Pages String | LatexRules String | SelfCheck String
+   deriving Eq
+
+makeDocumentation :: DocItem -> DomainReasoner ()
+makeDocumentation doc =
+   case doc of
+      Pages dir -> do 
+         makeOverviewExercises dir
+         makeOverviewServices  dir
+         getPackages >>= mapM_ (\(Some pkg) -> makeExercisePage dir pkg)
+         getServices >>= mapM_ (\s          -> makeServicePage dir s)
+      SelfCheck dir -> 
+         performSelfCheck dir
+      LatexRules dir ->
+         let f (Some ex) = makeLatexRules dir ex
+         in getExercises >>= liftIO . mapM_ f
+ src/Documentation/OverviewPages.hs view
@@ -0,0 +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 Control.Monad+import Common.Utils (Some(..))+import Common.Exercise+import Service.ServiceList+import Service.DomainReasoner+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..] groupedList) $ \(i, (dom, xs)) -> do+      h2 (show i ++ ". " ++ dom)+      noBorderTable (map makeRow xs) + where+   title | showAll   = "All exercises"+         | otherwise = "Exercises"+ +   makeRow (Some ex) = +      [ do tt bullet >> space+           link (exercisePageFile code) $ ttText (show code)+      , do spaces 10+           f (status ex)+           spaces 10+      , text $ description ex+      ]+    where+      code = exerciseCode ex+      f st = italic $ text ("(" ++ map toLower (show st) ++ ")")++   groupedList = process list+    where+      process = map g . groupBy eq . sortBy cmp . filter p+    +      cmp (Some a) (Some b) = exerciseCode a `compare` exerciseCode b+      eq a b      = f a == f b+      f (Some ex) = domain (exerciseCode ex)+      g xs = (f (head xs), xs)+      p (Some ex) = showAll || isPublic ex++serviceOverviewPage :: [Service] -> HTMLBuilder+serviceOverviewPage list = do+   h1 "Services"+   let sorted = sortBy (\x y -> serviceName x `compare` serviceName y) list+   ul $ flip map sorted $ \s -> do+      link (servicePageFile s) (ttText (serviceName s))+      when (serviceDeprecated s) $+         space >> text "(deprecated)"
+ src/Documentation/SelfCheck.hs view
@@ -0,0 +1,150 @@+-----------------------------------------------------------------------------+-- 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 (performSelfCheck) where++import Control.Monad.Trans+import System.Directory+import Common.Utils (reportTest, useFixedStdGen, Some(..), snd3)+import Common.Exercise+import Service.ExercisePackage+import qualified Common.Strategy.Grammar as Grammar+import Control.Monad+import Service.Request+import Service.DomainReasoner++import qualified Domain.LinearAlgebra.Checks as LA+import Service.ModeJSON+import Service.ModeXML++import qualified Domain.Math.Numeric.Tests as MathNum+import qualified Domain.Math.Polynomial.Tests as MathPoly+import qualified Domain.Math.SquareRoot.Tests as MathSqrt+import qualified Domain.Math.Data.Interval as MathInterval++import qualified Text.UTF8 as UTF8+import qualified Text.JSON as JSON+import Data.List+import System.Time++performSelfCheck :: String -> DomainReasoner ()+performSelfCheck dir = totalDiff $ do+   timeDiff $ liftIO $ do+      putStrLn "* 1. Domain checks"+      Grammar.checks+      MathNum.main+      MathPoly.tests+      MathSqrt.tests+      MathInterval.testMe+      LA.checks+      UTF8.testEncoding+      JSON.testMe++   liftIO $ putStrLn "* 2. Exercise checks"+   pkgs <- getPackages+   forM_ pkgs $ \(Some pkg) ->+      timeDiff $ liftIO $ checkExercise (exercise pkg)++   timeDiff $ do+      liftIO $ putStrLn "* 3. Unit tests"+      n <- unitTests dir+      liftIO $ putStrLn $ "** Number of unit tests: " ++ show n+   +-- Returns the number of tests performed+unitTests :: String -> DomainReasoner Int+unitTests = visit 0+ where+   visit i path = do+      valid <- liftIO $ doesDirectoryExist path+      if not valid then return 0 else do+         -- analyse content+         xs <- liftIO $ getDirectoryContents path+         let xml  = filter (".xml"  `isSuffixOf`) xs+             json = filter (".json" `isSuffixOf`) xs+         liftIO $ putStrLn $ replicate (i+1) '*' ++ " " ++ simplerDirectory path+         -- perform tests+         forM json $ \x -> +            performUnitTest JSON (path ++ "/" ++ x)+         forM xml $ \x -> +            performUnitTest XML (path ++ "/" ++ x)+         -- recursively visit subdirectories+         is <- forM (filter ((/= ".") . take 1) xs) $ \x -> +                  visit (i+1) (path ++ "/" ++ x)+         return (length (xml ++ json) + sum is)++performUnitTest :: DataFormat -> FilePath -> DomainReasoner ()+performUnitTest format path = do+   liftIO useFixedStdGen -- fix the random number generator+   txt <- liftIO $ readFile path+   exp <- liftIO $ readFile expPath+   out <- case format of +             JSON -> liftM snd3 (processJSON txt)+             XML  -> liftM snd3 (processXML txt) +                        `catchError` \_ -> return "Error"+   liftIO $ reportTest (stripDirectoryPart path) (out ~= exp)+ 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 ]+-}++-- Helper functions+showDiffWith :: MonadIO m => (TimeDiff -> IO ()) -> m a -> m a+showDiffWith f action = do+   t0 <- liftIO getClockTime+   a  <- action+   t1 <- liftIO getClockTime+   liftIO (f (diffClockTimes t1 t0))+   return a++totalDiff :: MonadIO m => m a -> m a+totalDiff = showDiffWith (putStrLn . ("*** Total time: "++) . formatDiff)+   +timeDiff :: MonadIO m => m a -> m a+timeDiff = showDiffWith (putStrLn . ("+++ Time: "++) . formatDiff) ++formatDiff :: TimeDiff -> String+formatDiff d@(TimeDiff z1 z2 z3 h m s p)+   | any (/=0) [z1,z2,z3] = timeDiffToString d+   | s >= 60      = formatDiff (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+   digSec = (if s < 10 then ('0' :) else id) (show s)+   timeDiff n p = +      let (rest, s) = n `divMod` 60+          (h, m)    = rest `divMod` 60+      in TimeDiff 0 0 0 h m s p
+ src/Documentation/ServicePage.hs view
@@ -0,0 +1,99 @@+-----------------------------------------------------------------------------+-- 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.ServiceList+import Service.TypedExample+import Service.Types+import Service.DomainReasoner+import Service.TypedAbstractService (emptyState)+import Text.HTML+import qualified Text.XML as XML+import Text.XML (XML, showXML)+import Domain.Logic+import Domain.Math.Polynomial.Exercises+import Domain.Math.Data.Relation+import Domain.Math.Expr.Symbolic+import Control.Monad+import Common.Utils (ShowString(..))++makeServicePage :: String -> Service -> DomainReasoner ()+makeServicePage dir s = do+   xs <- examplesFor (serviceName s)+   generatePageAt 1 dir (servicePageFile s)  (servicePage xs s)++servicePage :: [Example] -> Service -> HTMLBuilder+servicePage examples s = do+   h1 (serviceName s)++   para $ do+      bold $ text "Signature:"+      space+      case serviceFunction s of+         _ ::: t -> ttText (show t)+   para $ do+      bold $ text "Description: "+      br+      text $ serviceDescription s++   when (serviceDeprecated s) $ +      para $ bold $ text "Warning: this service is deprecated!"+   +   unless (null examples) $ do+      h2 $ "XML examples (" ++ show (length examples) ++ ")"+      forM_ (zip [1..] examples) $ +         \(i, (msg, (xmlRequest, xmlReply, xmlTest))) -> do+            h2 $ show i ++ ". " ++ msg+            bold $ text "Request:"+            preText $ showXML xmlRequest+            bold $ text "Reply:"+            preText $ showXML 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 = sequence [ m | (t, m) <- list, s == t ]+ where+   list = +      [ logic "derivation" [Nothing ::: Maybe StrategyCfg, stLogic1]+      , lineq "derivation" [Nothing ::: Maybe StrategyCfg, stLineq1]+      , logic "allfirsts" [stLogic2]+      , lineq "allfirsts" [stLineq2]+      , logic "onefirst" [stLogic2]+      , lineq "onefirst" [stLineq2]+--      , logic "applicable" [[] ::: Location, stLogic1]+      , lineq "rulesinfo" []+      , lineq "rulelist" [linearExercise ::: Exercise]+      , lineq "strategyinfo" [linearExercise ::: Exercise]+      ]+   strVar   = Var . ShowString+   stLogic1 = emptyState dnfExercise (Not (strVar "p" :&&: Not (strVar "q"))) ::: State+   stLogic2 = emptyState dnfExercise (Not (Not (strVar "p")) :&&: Not T) ::: State+   stLineq1 = emptyState linearExercise (5*(variable "x"+1) :==: 11) ::: State+   stLineq2 = emptyState linearExercise (5*(variable "x"+1) :==: (variable "x"-1)/2) ::: State+   +   logic = make "Logic" (package dnfExercise)+   lineq = make "Linear equation" (termPackage linearExercise)+      +   make msg pkg fs args = (fs, do+      srv <- findService fs+      tr  <- typedExample pkg srv args+      return (msg, tr))
+ src/Documentation/TestsPage.hs view
@@ -0,0 +1,88 @@+-----------------------------------------------------------------------------+-- 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 (main) where++import Control.Monad+import Data.Char+import Data.List+import Documentation.DefaultPage+import Service.DomainReasoner+import System.Environment+import Main.Revision+import Text.HTML+import qualified Text.XML as XML++main :: IO ()+main = do+   args <- getArgs+   case args of+      [fileIn, fileOut] -> do+         input <- readFile fileIn+         runDomainReasoner $ do+            setFullVersion fullVersion+            generatePage "docs" (up 1 ++ fileOut) (testsPage input)+      _ -> fail "Invalid invocation"++fullVersion :: String+fullVersion = "version " ++ version ++ "  (revision " ++ show revision ++ ", " ++ lastChanged ++ ")"++testsPage :: String -> HTMLBuilder+testsPage input = do +   h1 "Tests"+   let (hs, bs) = unzip (map format (lines input))+   bold (text "Failures: ") +   text $ show $ length $ filter not bs+   brs hs+ where+   format :: String -> (HTMLBuilder, Bool)+   format s+      | any (`elem` ws) ["failed", "error", "error:", "falsifiable"] =+           (errorLine (ttText s), False)+      | "* " `isPrefixOf` s =+           (h2 (drop 2 s), True)+      | "** " `isPrefixOf` s =+           (br >> bold (text (drop 3 s)), True)+      | "*** " `isPrefixOf` s =+           (br >> bold (text (drop 4 s)), True)+      | otherwise = +           (fromString s, True)+    where+      ws = map (map toLower . filter isAlpha) (words s)+      +      +brs :: [HTMLBuilder] -> HTMLBuilder+brs = mapM_ (>> br)++fromString :: String -> HTMLBuilder+fromString = f []+ where+   f acc []     = ttText (reverse acc)+   f acc list@(x:xs) +      | "+++" `isPrefixOf` list = do+           f acc [] +           unless (null acc) (spaces 3)+           okLine (ttText (drop 3 list))+      | "*** Gave up!" `isPrefixOf` list = do+           f acc []+           unless (null acc) (spaces 3)+           ttText (drop 3 list)+      | otherwise = f (x:acc) xs++errorLine :: HTMLBuilder -> HTMLBuilder+errorLine b = XML.element "font" $ do+   "color" XML..=. "red"+   bold b+   +okLine :: HTMLBuilder -> HTMLBuilder+okLine b = XML.element "font" $ do+   "color" XML..=. "gray"+   b
src/Domain/LinearAlgebra.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -17,14 +17,12 @@    , module Domain.LinearAlgebra.Strategies
    , module Domain.LinearAlgebra.LinearSystem
    , module Domain.LinearAlgebra.Exercises
-   , module Domain.LinearAlgebra.Symbols
    ) where
    
 import Domain.LinearAlgebra.Matrix
 import Domain.LinearAlgebra.Parser
 import Domain.LinearAlgebra.MatrixRules
-import Domain.LinearAlgebra.EquationsRules hiding (changeCover)
+import Domain.LinearAlgebra.EquationsRules hiding (changeCover, findIndexM)
 import Domain.LinearAlgebra.Strategies
 import Domain.LinearAlgebra.LinearSystem
-import Domain.LinearAlgebra.Exercises
-import Domain.LinearAlgebra.Symbols+import Domain.LinearAlgebra.Exercises
src/Domain/LinearAlgebra/Checks.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -11,14 +11,14 @@ -----------------------------------------------------------------------------
 module Domain.LinearAlgebra.Checks (checks) where
 
-import Domain.Math.Simplification (simplify)
-import Domain.LinearAlgebra hiding (getSolution)
-import Test.QuickCheck
-import Control.Monad
-import Common.Utils
-import Data.List
 import Common.Apply
 import Common.Context
+import Common.Exercise
+import Common.Utils
+import Domain.LinearAlgebra hiding (getSolution)
+import Domain.Math.Expr
+import Domain.Math.Simplification (simplify)
+import Test.QuickCheck
 
 -----------------------------------------------------------
 --- QuickCheck properties
@@ -33,28 +33,34 @@ 
 propEchelon :: Matrix Rational -> Bool
 propEchelon =
-   inRowEchelonForm . matrix . applyD forwardPass . inContext . fmap fromRational
+   withoutContext inRowEchelonForm . applyD forwardPass . gaussContext
 
 propReducedEchelon :: Matrix Rational -> Bool
 propReducedEchelon = 
-   inRowReducedEchelonForm . matrix . applyD gaussianElimStrategy . inContext . fmap fromRational
+   withoutContext inRowReducedEchelonForm . applyD gaussianElimStrategy . gaussContext
    
 propSound :: Matrix Rational -> Bool
 propSound m =
-   (matrix . applyD gaussianElimStrategy . inContext . fmap fromRational) m
-   == fmap fromRational (reduce m)
+   (fromContext . applyD gaussianElimStrategy . gaussContext) m
+   == Just (fmap fromRational (reduce m))
 
 propSolution :: Matrix Rational -> Property
 propSolution m1 =
    forAll (arbSolution m1) $ \(solution, m2) -> 
-      let m3  = (matrix . applyD gaussianElimStrategy . inContext . fmap fromRational) m2
+      let m3  = (fromContext . applyD gaussianElimStrategy . gaussContext) m2
           p r = simplify (sum (zipWith g (solution ++ [-1]) r)) == 0
           g   = (*) . fromRational
-      in all p (rows m3)
+      in maybe False (all p . rows) m3
 
 arbSolution :: (Arbitrary a, Num a) => Matrix a -> Gen ([a], Matrix a)
 arbSolution m = do
    solution <- vector (snd $ dimensions m)
    let finalCol  = map (return . sum . zipWith (*) solution) (rows m)
        newMatrix = makeMatrix $ zipWith (++) (rows m) finalCol
-   return (solution, newMatrix)+   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,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -15,12 +15,13 @@ import Common.Context import Common.Transformation import Common.Utils+import Common.Navigator import Common.View hiding (simplify) import Control.Monad import Data.List hiding (repeat) import Data.Maybe import Domain.Math.Expr-import Domain.Math.Data.Equation+import Domain.Math.Data.Relation import Domain.Math.Simplification (simplify) import Domain.LinearAlgebra.LinearView import Domain.LinearAlgebra.LinearSystem@@ -37,70 +38,79 @@  ruleExchangeEquations :: Rule (Context (LinearSystem Expr)) ruleExchangeEquations = simplifySystem $ makeRule "Exchange" $ -   supplyLabeled2 descr args (\x y -> liftSystemTrans $ exchange x y)+   supplyLabeled2 descr args (\x y -> liftTransContext $ exchange x y)  where-   descr  = ("equation 1", "equation 2")-   args c = do mv <- minvar c-               i  <- findIndex (elem mv . getVarsSystem . return) (remaining c)-               return (get covered c, get covered c + i)+   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 = simplifySystem $ makeRule "Eliminate variable" $ -   supplyLabeled3 descr args (\x y z -> liftSystemTrans $ addEquations x y z)+   supplyLabeled3 descr args (\x y z -> liftTransContext $ addEquations x y z)  where-   descr  = ("equation 1", "equation 2", "scale factor")-   args c = do -      mv <- minvar c-      let hd:rest = remaining c-          getCoef = coefficientOf mv . getLHS-      (i, coef) <- safeHead [ (i, c) | (i, eq) <- zip [0..] rest, let c = getCoef eq, c /= 0 ]+   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-      return ( i + get covered c + 1, get covered c, v)+      cov <- readVar covered+      return (i + cov + 1, cov, v)  ruleDropEquation :: Rule (Context (LinearSystem Expr))-ruleDropEquation = simplifySystem $ makeSimpleRule "Drop (0=0) equation" $ -   \c -> do i <- findIndex (fromMaybe False . testConstants (==)) (equations c)-            return $ change covered (\n -> if i < n then n-1 else n)-                   $ fmap (deleteIndex i) c+ruleDropEquation = simplifySystem $ makeSimpleRule "Drop (0=0) equation" $ 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 = simplifySystem $ makeSimpleRule "Inconsistent system (0=1)" $ -   \c -> do let stop = [0 :==: 1]-            guard $ invalidSystem (equations c) && equations c /= stop-            return $ set covered 1 (fmap (const stop) c)+ruleInconsistentSystem = simplifySystem $ makeSimpleRule "Inconsistent system (0=1)" $ withCM $ \ls -> do+   let stop = [0 :==: 1]+   guard (invalidSystem ls && ls /= stop)+   writeVar covered 1+   return stop  ruleScaleEquation :: Rule (Context (LinearSystem Expr)) ruleScaleEquation = simplifySystem $ makeRule "Scale equation to one" $ -   supplyLabeled2 descr args (\x y -> liftSystemTrans $ scaleEquation x y)+   supplyLabeled2 descr args (\x y -> liftTransContext $ scaleEquation x y)  where-   descr  = ("equation", "scale factor")-   args c = do eq <- safeHead $ drop (get covered c) (equations c)-               let expr = getLHS eq-               mv <- minvar c-               guard (coefficientOf mv expr /= 0)-               let coef = 1 / coefficientOf mv expr-               return (get covered c, coef)+   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 = simplifySystem $ makeRule "Back substitution" $ -   supplyLabeled3 descr args (\x y z -> liftSystemTrans $ addEquations x y z)+   supplyLabeled3 descr args (\x y z -> liftTransContext $ addEquations x y z)  where-   descr  = ("equation 1", "equation 2", "scale factor")-   args c = do eq <- safeHead $ drop (get covered c) (equations c)-               let expr = getLHS eq-               mv <- safeHead (getVars expr)-               i  <- findIndex ((/= 0) . coefficientOf mv . getLHS) (take (get covered c) (equations c))-               let coef = negate $ coefficientOf mv (getLHS (equations c !! i))-               return (i, get covered c, coef)+   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 (getVars 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 = minorRule $ makeSimpleRule "Identify free variables" $-   \c ->  let vars = [ head ys | ys <- map (getVars . getLHS) (equations c), not (null ys) ]-              change eq =-                 let (e1, e2) = splitLinearExpr (`notElem` vars) (getLHS eq) -- constant ends up in e1-                 in e2 :==: getRHS eq - e1-          in return (fmap (map change) c)+ruleIdentifyFreeVariables = minorRule $ makeSimpleRule "Identify free variables" $ withCM $ \ls ->+   let vars = [ head ys | ys <- map (getVars . leftHandSide) ls, not (null ys) ]+       change eq =+          let (e1, e2) = splitLinearExpr (`notElem` vars) (leftHandSide eq) -- constant ends up in e1+          in e2 :==: rightHandSide eq - e1+   in return (map change ls)  ruleCoverUpEquation :: Rule (Context (LinearSystem a)) ruleCoverUpEquation = minorRule $ makeRule "Cover up first equation" $ changeCover (+1)@@ -109,8 +119,9 @@ ruleUncoverEquation = minorRule $ makeRule "Uncover one equation" $ changeCover (\x -> x-1)  ruleCoverAllEquations :: Rule (Context (LinearSystem a))-ruleCoverAllEquations = minorRule $ makeSimpleRule "Cover all equations" $ -   \c -> return (set covered (length $ equations c) c)+ruleCoverAllEquations = minorRule $ makeSimpleRule "Cover all equations" $ withCM $ \ls -> do+   writeVar covered (length ls)+   return ls  -- local helper functions deleteIndex :: Int -> [a] -> [a]@@ -124,7 +135,7 @@  -- simplify a linear system simplifySystem :: Rule (Context (LinearSystem Expr)) -> Rule (Context (LinearSystem Expr))-simplifySystem = doAfter $ fmap (map (fmap f))+simplifySystem = doAfter $ change (map (fmap f))  where f = simplifyWith (fmap simplify) linearView  ---------------------------------------------------------------------------------@@ -133,54 +144,54 @@ exchange :: Int -> Int -> Transformation [a] exchange i j     | i >  j    = exchange j i-   | otherwise = makeTrans "exchange" $ \xs -> do+   | 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 "scaleEquation" $ \xs -> do+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 "addEquations" $ \xs -> do+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 "changeCover" $ \c -> do-   let new = f (get covered c)-   guard (new >= 0 && new <= length (equations c))-   return (set covered new c)+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 -equations :: Context (LinearSystem a) -> LinearSystem a-equations = fromContext- -- | The equations that remain to be solved-remaining :: Context (LinearSystem a) -> Equations a-remaining c = drop (get covered c) (equations c)+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 => Context (LinearSystem a) -> Maybe String-minvar c | null list = Nothing-         | otherwise = Just (minimum list)- where-   list = getVarsSystem (remaining c) -   -liftSystemTrans :: Transformation (LinearSystem a) -> Transformation (Context (LinearSystem a))-liftSystemTrans = lift $ makeLiftPair (return . equations) (fmap . const)+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@@ -192,3 +203,6 @@  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,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -27,41 +27,43 @@ import Domain.LinearAlgebra.Parser
 import Domain.LinearAlgebra.Strategies
 import Domain.LinearAlgebra.Vector
-import Domain.Math.Data.Equation
+import Domain.Math.Data.Relation
 import Domain.Math.Expr
 import Domain.Math.Simplification
 import Test.QuickCheck
-import Text.Parsing (SyntaxError(..))
 
 gramSchmidtExercise :: Exercise (VectorSpace (Simplified Expr))
-gramSchmidtExercise = testableExercise
+gramSchmidtExercise = makeExercise
    { description    = "Gram-Schmidt"
    , exerciseCode   = makeCode "linalg" "gramschmidt"
-   , status         = Provisional
+   , status         = Alpha
    , parser         = \s -> case parseVectorSpace s of
-                               (a, [])  -> Right (fmap simplified a)
-                               (_, m:_) -> Left $ ErrorMessage $ show m
+                              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
                               in f x == f y
    , extraRules     = rulesGramSchmidt
    , isReady        = orthonormalList . filter (not . isZero) . vectors
    , strategy       = gramSchmidtStrategy
-   , randomExercise = simpleGenerator arbitrary
+   , randomExercise = let f = simplified . fromInteger . (`mod` 25)
+                      in simpleGenerator (liftM (fmap f) arbitrary)
    }
 
 linearSystemExercise :: Exercise (Equations Expr)
-linearSystemExercise = testableExercise
+linearSystemExercise = makeExercise
    { description    = "Solve Linear System"
    , exerciseCode   = makeCode "linalg" "linsystem"
    , status         = Stable
    , parser         = \s -> case parseSystem s of
-                               (a, [])  -> Right (simplify a)
-                               (_, m:_) -> Left $ ErrorMessage $ show m
+                               Right a  -> Right (simplify a)
+                               Left msg -> Left msg
    , prettyPrinter  = unlines . map show
-   , equivalence    = \x y -> let f = getSolution . equations . applyD linearSystemStrategy 
-                                    . inContext . map toStandardForm
-                              in f x == f y
+   , equivalence    = \x y -> let f = fromContext . applyD linearSystemStrategy 
+                                    . inContext linearSystemExercise . map toStandardForm
+                              in case (f x, f y) of  
+                                    (Just a, Just b) -> getSolution a == getSolution b
+                                    _ -> False 
    , extraRules     = equationsRules
    , isReady        = inSolvedForm
    , strategy       = linearSystemStrategy
@@ -69,13 +71,13 @@    }
    
 gaussianElimExercise :: Exercise (Matrix Expr)
-gaussianElimExercise = testableExercise
+gaussianElimExercise = makeExercise
    { description    = "Gaussian Elimination"
    , exerciseCode   = makeCode "linalg" "gaussianelim"
    , status         = Stable
    , parser         = \s -> case parseMatrix s of
-                               (a, [])  -> Right (simplify a)
-                               (_, m:_) -> Left $ ErrorMessage $ show m
+                               Right a  -> Right (simplify a)
+                               Left msg -> Left msg
    , prettyPrinter  = ppMatrixWith show
    , equivalence    = \x y -> fmap simplified x === fmap simplified y
    , extraRules     = matrixRules
@@ -84,23 +86,31 @@    , randomExercise = simpleGenerator arbMatrix
    }
  
-systemWithMatrixExercise :: Exercise (Either (LinearSystem Expr) (Matrix Expr))
-systemWithMatrixExercise = testableExercise
+systemWithMatrixExercise :: Exercise Expr
+systemWithMatrixExercise = makeExercise
    { description    = "Solve Linear System with Matrix"
    , exerciseCode   = makeCode "linalg" "systemwithmatrix"
    , status         = Provisional
    , parser         = \s -> case (parser linearSystemExercise s, parser gaussianElimExercise s) of
-                               (Right ok, _) -> Right $ Left  ok
-                               (_, Right ok) -> Right $ Right ok
-                               (Left _, Left _) -> Left $ ErrorMessage "Syntax error" -- FIX THIS
-   , prettyPrinter  = either (unlines . map show) ppMatrix
-   , equivalence    = \x y -> let f = either id matrixToSystem
-                              in equivalence linearSystemExercise (f x) (f y)
-   , extraRules     = map liftRuleContextLeft equationsRules ++ map liftRuleContextRight matrixRules
-   , isReady        = either inSolvedForm (const False)
+                               (Right ok, _) -> Right $ toExpr ok
+                               (_, Right ok) -> Right $ toExpr ok
+                               (Left _, Left _) -> Left "Syntax error"
+   , prettyPrinter  = \expr -> case (fromExpr expr, fromExpr expr) of
+                                  (Just ls, _) -> (unlines . map show) (ls :: Equations Expr)
+                                  (_, Just m)  -> ppMatrix (m :: Matrix Expr)
+                                  _            -> show expr
+   , equivalence    = \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
+                                    _ -> False
+   , extraRules     = map liftExpr equationsRules ++ map liftExpr (matrixRules :: [Rule (Context (Matrix Expr))])
+   , isReady        = inSolvedForm . (fromExpr :: Expr -> Equations Expr)
    , strategy       = systemWithMatrixStrategy
-   , randomExercise = simpleGenerator (fmap (Left . matrixToSystem) arbMatrix)
-   , testGenerator  = fmap (liftM Left) (testGenerator linearSystemExercise)
+   , randomExercise = simpleGenerator (fmap (toExpr . matrixToSystem) (arbMatrix :: Gen (Matrix Expr)))
+   , testGenerator  = fmap (liftM toExpr) (testGenerator linearSystemExercise)
    }
  
 --------------------------------------------------------------
@@ -108,6 +118,7 @@                   
 instance Arbitrary a => Arbitrary (Vector a) where
    arbitrary   = liftM fromList $ oneof $ map vector [0..2]
+instance CoArbitrary a => CoArbitrary (Vector a) where
    coarbitrary = coarbitrary . toList
 
 instance Arbitrary a => Arbitrary (VectorSpace a) where
@@ -116,21 +127,17 @@       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
 
 arbMatrix :: Num a => Gen (Matrix a)
 arbMatrix = fmap (fmap fromInteger) arbNiceMatrix
 
-liftRuleContextLeft :: Rule (Context a) -> Rule (Context (Either a b))
-liftRuleContextLeft = lift $ makeLiftPair (maybeInContext . fmap isLeft) (\a _ -> fmap Left a)
-
-liftRuleContextRight :: Rule (Context b) -> Rule (Context (Either a b))
-liftRuleContextRight = lift $ makeLiftPair (maybeInContext . fmap isRight) (\b _ -> fmap Right b)
-
 instance Arbitrary a => Arbitrary (Matrix a) where
    arbitrary = do
       (i, j) <- arbitrary
       arbSizedMatrix (i `mod` 5, j `mod` 5)
+instance CoArbitrary a => CoArbitrary (Matrix a) where
    coarbitrary = coarbitrary . rows
    
 arbSizedMatrix :: Arbitrary a => (Int, Int) -> Gen (Matrix a)
src/Domain/LinearAlgebra/GramSchmidtRules.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -13,14 +13,14 @@ 
 import Common.Context
 import Common.Transformation
+import Common.Navigator hiding (current)
 import Common.Utils
 import Domain.LinearAlgebra.Vector
 import Control.Monad
-import Data.List
 
 varI, varJ :: Var Int
-varI = "considered" := 0
-varJ = "j"          := 0
+varI = newVar "considered" 0
+varJ = newVar "j" 0
 
 rulesGramSchmidt :: Floating a => [Rule (Context (VectorSpace a))]
 rulesGramSchmidt = [ruleNormalize, ruleOrthogonal, ruleNext]
@@ -28,51 +28,60 @@ -- Make the current vector of length 1
 -- (only applicable if this is not already the case)
 ruleNormalize :: Floating a => Rule (Context (VectorSpace a))
-ruleNormalize = makeSimpleRule "Turn into unit Vector" $
-   \c -> do v <- current c
-            guard (norm v `notElem` [0, 1])
-            setCurrent (toUnit v) c
+ruleNormalize = makeSimpleRule "Turn into unit Vector" $ withCM $ \vs -> do
+   v <- current vs
+   guard (norm v `notElem` [0, 1])
+   setCurrent (toUnit v) vs
 
 -- Make the current vector orthogonal with some other vector
 -- that has already been considered
 ruleOrthogonal :: Floating a => Rule (Context (VectorSpace a))
 ruleOrthogonal = makeRule "Make orthogonal" $ supplyLabeled2 descr args transOrthogonal
  where
-   descr  = ("vector 1", "vector 2")
-   args c = do let i = get varI c-1
-                   j = get varJ c-1
-               guard (i>j)
-               return (j, i)
+   descr = ("vector 1", "vector 2")
+   args  = evalCM $ \_ -> do
+              i <- liftM pred (readVar varI)
+              j <- liftM pred (readVar varJ)
+              guard (i>j)
+              return (j, i)
 
 -- Variable "j" is for administrating which vectors are already orthogonal 
 ruleNextOrthogonal :: Rule (Context (VectorSpace a))
-ruleNextOrthogonal = minorRule $ makeSimpleRule "Orthogonal to next" $
-   \c -> do guard (get varJ c + 1 < get varI c)
-            return (change varJ (+1) c)
+ruleNextOrthogonal = minorRule $ makeSimpleRule "Orthogonal to next" $ withCM $ \vs -> do
+   i <- readVar varI
+   j <- liftM succ (readVar varJ)
+   guard (j < i)
+   writeVar varJ j
+   return vs
 
 -- Consider the next vector 
 -- This rule should fail if there are no vectors left
 ruleNext :: Rule (Context (VectorSpace a))
-ruleNext = minorRule $ makeSimpleRule "Consider next vector" $
-   \c -> do guard (get varI c < length (vectors (fromContext c)))
-            return $ change varI (+1) $ set varJ 0 c 
+ruleNext = minorRule $ makeSimpleRule "Consider next vector" $ withCM $ \vs -> do
+   i <- readVar varI
+   guard (i < length (vectors vs))
+   writeVar varI (i+1)
+   writeVar varJ 0
+   return vs
 
-current :: Context (VectorSpace a) -> Maybe (Vector a)
-current c = 
-   case drop (get varI c - 1) (vectors (fromContext c)) of
-      v:_ -> Just v
-      _   -> Nothing
+current :: VectorSpace a -> ContextMonad (Vector a)
+current vs = do
+   i <- readVar varI
+   case drop (i-1) (vectors vs) of
+      v:_ -> return v
+      _   -> mzero
 
-setCurrent :: Vector a -> Context (VectorSpace a) -> Maybe (Context (VectorSpace a))
-setCurrent v c = 
-   case splitAt (get varI c - 1) (vectors (fromContext c)) of
-      (xs, _:ys) -> Just $ fmap (makeVectorSpace . const (xs ++ v:ys)) c 
-      _          -> Nothing
+setCurrent :: Vector a -> VectorSpace a -> ContextMonad (VectorSpace a)
+setCurrent v vs = do
+   i <- readVar varI 
+   case splitAt (i-1) (vectors vs) of
+      (xs, _:ys) -> return $ makeVectorSpace (xs ++ v:ys)
+      _          -> mzero
 
 -- Two indices, change the second vector and make it orthogonal
 -- to the first
 transOrthogonal :: Floating a => Int -> Int -> Transformation (Context (VectorSpace a))
-transOrthogonal i j = contextTrans "transOrthogonal" $ \xs ->
+transOrthogonal i j = contextTrans $ \xs ->
    do guard (i /= j && i >=0 && j >= 0)
       u <- safeHead $ drop i (vectors xs)
       guard (isUnit u)
@@ -81,7 +90,8 @@          _ -> Nothing 
 
 -- Find proper abstraction, and move this function to transformation module
-contextTrans :: String -> (a -> Maybe a) -> Transformation (Context a)
-contextTrans s f = makeTrans s $ \c -> do
-   new <- f (fromContext c)
-   return (fmap (const new) c)+contextTrans :: (a -> Maybe a) -> Transformation (Context a)
+contextTrans f = makeTrans $ \c -> do
+   a   <- fromContext c
+   new <- f a
+   return (replace new c)
src/Domain/LinearAlgebra/LinearSystem.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -11,7 +11,7 @@ -----------------------------------------------------------------------------
 module Domain.LinearAlgebra.LinearSystem where
 
-import Domain.Math.Data.Equation
+import Domain.Math.Data.Relation
 import Domain.LinearAlgebra.Matrix (Matrix, makeMatrix, rows)
 import Domain.LinearAlgebra.LinearView
 import Data.List
@@ -26,7 +26,9 @@ getVarsSystem = foldr (\(lhs :==: rhs) xs -> getVars lhs `union` getVars rhs `union` xs) []
 
 evalSystem :: (Uniplate a, IsLinear a) => (String -> a) -> LinearSystem a -> Bool
-evalSystem = all . evalEquationWith . evalLinearExpr
+evalSystem f = 
+   let eval (x :==: y) = x==y
+   in all (eval . fmap (evalLinearExpr f))
 
 invalidSystem :: IsLinear a => LinearSystem a -> Bool
 invalidSystem = any invalidEquation
@@ -40,8 +42,8 @@    guard (null (vars `intersect` frees))
    mapM make xs
  where
-   vars  = concatMap (getVars . getLHS) xs
-   frees = concatMap (getVars . getRHS) xs
+   vars  = concatMap (getVars . leftHandSide) xs
+   frees = concatMap (getVars . rightHandSide) xs
    make (lhs :==: rhs) = do
       v <- isVar lhs
       return (v, rhs)
@@ -60,7 +62,7 @@ inSolvedForm xs = invalidSystem xs || isJust (getSolution xs)
 
 homogeneous :: IsLinear a => LinearSystem a -> Bool
-homogeneous = all ((== 0) . getRHS)
+homogeneous = all ((== 0) . rightHandSide)
 
 -- Conversions
 systemToMatrix :: IsLinear a => LinearSystem a -> (Matrix a, [String])
src/Domain/LinearAlgebra/LinearView.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -18,10 +18,8 @@ import Control.Monad
 import Data.List
 import Common.Uniplate
-import Data.Maybe 
 import Common.View hiding (simplify)
-import GHC.Real
-import Domain.Math.Expr
+import Domain.Math.Expr hiding (isVariable)
 import qualified Data.Map as M
 
 data LinearMap a = LM { lmMap :: M.Map String a, lmConstant :: a }
@@ -35,7 +33,7 @@    -- compositional (sumView would be a more restrictive alternative)
    f expr = 
       case expr of
-         Nat n    -> return $ LM M.empty (fromInteger n)
+         Nat _    -> return $ LM M.empty expr
          Var s    -> return $ LM (M.singleton s 1) 0
          a :+: b  -> liftM2 plusLM  (f a) (f b)
          a :-: b  -> liftM2 plusLM  (f a) (liftM negateLM (f b))
@@ -43,6 +41,7 @@          a :*: b  -> join $ liftM2 timesLM (f a) (f b)
          a :/: b  -> join $ liftM2 divLM (f a) (f b)
          Sqrt a   -> join $ liftM sqrtLM (f a)
+         Number _ -> return $ LM M.empty expr
          Sym s as -> mapM f as >>= symLM s
        
    g (LM m c) = build sumView (concatMap make (M.toList m) ++ [c | c /= 0])
src/Domain/LinearAlgebra/Matrix.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
src/Domain/LinearAlgebra/MatrixRules.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -13,14 +13,13 @@ 
 import Domain.Math.Simplification
 import Domain.LinearAlgebra.Matrix
+import Domain.LinearAlgebra.Symbols ()
 import Common.Context
+import Common.Navigator
 import Common.Transformation
 import Control.Monad
 import Data.List
 
-instance Simplify a => Simplify (Matrix a) where
-   simplify = fmap simplify
-
 matrixRules :: (Argument a, Fractional a) => [Rule (Context (Matrix a))]
 matrixRules = 
    let noArgs f = f (const Nothing)
@@ -30,43 +29,51 @@       ]
 
 ruleFindColumnJ :: Num a => Rule (Context (Matrix a))
-ruleFindColumnJ = minorRule $ makeSimpleRule "FindColumnJ" $ \c -> do
-   let cols = columns (subMatrix c)
-   i <- findIndex nonZero cols
-   return (set columnJ i c)
+ruleFindColumnJ = minorRule $ makeSimpleRule "FindColumnJ" $ withCM $ \m -> do
+   cols <- liftM columns (subMatrix m)
+   i    <- findIndexM nonZero cols
+   writeVar columnJ i
+   return m
    
 ruleExchangeNonZero :: (Simplify a, Num a) => Rule (Context (Matrix a))
-ruleExchangeNonZero = simplify $ ruleExchangeRows $ \c -> do
-   nonEmpty c
-   let col = column (get columnJ c) (subMatrix c)
-   i   <- findIndex (/= 0) col
-   return (get covered c, i + get covered c)
+ruleExchangeNonZero = simplify $ ruleExchangeRows $ evalCM $ \m -> do
+   nonEmpty m
+   j   <- readVar columnJ
+   col <- liftM (column j) (subMatrix m)
+   i   <- findIndexM (/= 0) col
+   cov <- readVar covered
+   return (cov, i + cov)
 
 ruleScaleToOne :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a))
-ruleScaleToOne = simplify $ ruleScaleRow $ \c -> do
-   nonEmpty c
-   let pv = entry (0, get columnJ c) (subMatrix c)
+ruleScaleToOne = simplify $ ruleScaleRow $ evalCM $ \m -> do
+   nonEmpty m
+   j   <- readVar columnJ
+   pv  <- liftM (entry (0, j)) (subMatrix m)
    guard (pv /= 0)
-   return (get covered c, 1 / pv)
+   cov <- readVar covered
+   return (cov, 1 / pv)
 
 ruleZerosFP :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a))
-ruleZerosFP = simplify $ ruleAddMultiple $ \c -> do
-   nonEmpty c
-   let col = drop 1 $ column (get columnJ c) (subMatrix c)
-   i   <- findIndex (/= 0) col
+ruleZerosFP = simplify $ ruleAddMultiple $ evalCM $ \m -> do
+   nonEmpty m
+   j   <- readVar columnJ
+   col <- liftM (drop 1 . column j) (subMatrix m)
+   i   <- findIndexM (/= 0) col
+   cov <- readVar covered
    let v = negate (col!!i)
-   return (i + get covered c + 1, get covered c, v)
+   return (i + cov + 1, cov, v)
    
 ruleZerosBP :: (Argument a, Simplify a, Fractional a) => Rule (Context (Matrix a))
-ruleZerosBP = simplify $ ruleAddMultiple $ \c -> do
-   nonEmpty c
-   let ri  = row 0 (subMatrix c)
-       j   = length $ takeWhile (==0) ri
-       col = column j (matrix c)
+ruleZerosBP = simplify $ ruleAddMultiple $ evalCM $ \m -> do
+   nonEmpty m
+   ri <- liftM (row 0) (subMatrix m)
+   let j   = length $ takeWhile (==0) ri
+       col = column j m
    guard (any (/= 0) ri)
-   k <- findIndex (/= 0) col
+   k <- findIndexM (/= 0) col
    let v = negate (col!!k)
-   return (k, get covered c, v)
+   cov <- readVar covered
+   return (k, cov, v)
 
 ruleCoverRow :: Rule (Context (Matrix a))
 ruleCoverRow = minorRule $ makeRule "CoverRow" $ changeCover (+1)
@@ -93,42 +100,48 @@ -- Parameterized transformations
 
 rowExchange :: Int -> Int -> Transformation (Context (Matrix a))
-rowExchange i j = matrixTrans "rowExchange" $ \m -> do
+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 "rowScale" $ \m -> do
+rowScale i k = matrixTrans $ \m -> do
    guard (k `notElem` [0, 1] && validRow i m)
    return (scaleRow i k m)
 
 rowAdd :: Num a => Int -> Int -> a -> Transformation (Context (Matrix a))
-rowAdd i j k = matrixTrans "rowAdd" $ \m -> do
+rowAdd i j k = matrixTrans $ \m -> do
    guard (k /= 0 && i /= j && validRow i m && validRow j m)
    return (addRow i j k m)
 
 changeCover :: (Int -> Int) -> Transformation (Context (Matrix a))
-changeCover f = makeTrans "changeCover" $ \c -> do
-   let new = f (get covered c)
-   guard (new >= 0 && new <= fst (dimensions (matrix c)))
-   return $ set covered new c --  c {get covered = new}
+changeCover f = makeTrans $ withCM $ \m -> do
+   new <- liftM f (readVar covered)
+   guard (new >= 0 && new <= fst (dimensions m))
+   writeVar covered new
+   return m
    
-matrixTrans ::  String -> (Matrix a -> Maybe (Matrix a)) -> Transformation (Context (Matrix a))
-matrixTrans s f = makeTrans s $ \c -> do
-   new <- f (fromContext c)
-   return (fmap (const new) c)
+matrixTrans ::  (Matrix a -> Maybe (Matrix a)) -> Transformation (Context (Matrix a))
+matrixTrans f = makeTrans $ \c -> do
+   a   <- fromContext c
+   new <- f a
+   return (replace new c)
 
 -- local helper function
 validRow :: Int -> Matrix a -> Bool
 validRow i m = i >= 0 && i < fst (dimensions m)
    
-nonEmpty :: Context (Matrix a) -> Maybe ()
-nonEmpty = guard . not . isEmpty . subMatrix
+nonEmpty :: Matrix a -> ContextMonad ()
+nonEmpty m = subMatrix m >>= guard . not . isEmpty
 
 covered, columnJ :: Var Int
-covered = "covered" := 0
-columnJ = "columnJ" := 0
+covered = newVar "covered" 0
+columnJ = newVar "columnJ" 0
 
-matrix, subMatrix :: Context (Matrix a) -> Matrix a
-matrix = fromContext
-subMatrix c = makeMatrix $ drop (get covered c) $ rows $ matrix c+subMatrix :: Matrix a -> ContextMonad (Matrix a)
+subMatrix m = do 
+   cov <- readVar covered
+   return $ makeMatrix $ drop cov $ rows $ m
+   
+findIndexM :: MonadPlus m => (a -> Bool) -> [a] -> m Int
+findIndexM p = maybe mzero return . findIndex p
src/Domain/LinearAlgebra/Parser.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -14,29 +14,25 @@    , parseSystem
    ) where
 
-import Domain.Math.Data.Equation
+import Domain.Math.Data.Relation
 import Domain.LinearAlgebra.Matrix
 import Domain.LinearAlgebra.LinearSystem
 import Domain.LinearAlgebra.LinearView (isLinear)
 import Domain.LinearAlgebra.Vector
-import Control.Monad
-import Data.List
-import Data.Char
 import Domain.Math.Expr
-import Domain.Math.Expr.Parser
 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 -> (LinearSystem Expr, [String])
-parseSystem = f . parse pSystem . scanWith s
+parseSystem :: String -> Either String (LinearSystem Expr)
+parseSystem = either Left f . parseWithM s pSystem
  where
-   s0 = newlinesAsSpecial scannerExpr
+   s0 = specialSymbols "\n" scannerExpr
    s  = s0 {keywordOperators = "==" : keywordOperators s0 }
-   f (Nothing, xs) = ([], "System is not linear" : map show xs)
-   f (Just m, xs)  = (m, map show xs)
+   f Nothing  = Left "System is not linear"
+   f (Just m) = Right m
 
 pSystem :: TokenParser (Maybe (LinearSystem Expr))
 pSystem = convertSystem <$> pEquations pExpr
@@ -51,23 +47,23 @@ -----------------------------------------------------------
 --- Parser
 
-parseMatrix :: String -> (Matrix Expr, [String])
-parseMatrix = f . parse p . scanWith s
+parseMatrix :: String -> Either String (Matrix Expr)
+parseMatrix = either Left f . parseWithM s p
  where
-   s = newlinesAsSpecial scannerExpr
+   s = specialSymbols "\n" scannerExpr
    p = pMatrix pFractional
-   f (Nothing, xs) = (makeMatrix [], "Matrix is not rectangular" : map show xs)
-   f (Just m, xs)  = (m, map show xs)
+   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 
 
-parseVectorSpace :: String -> (VectorSpace Expr, [Message Token])
-parseVectorSpace = parse p . scanWith s
+parseVectorSpace :: String -> Either String (VectorSpace Expr)
+parseVectorSpace = parseWithM s p
  where
-   s = newlinesAsSpecial scannerExpr
+   s = specialSymbols "\n" scannerExpr
    p = makeVectorSpace <$> pVectors pExpr
 
 pVectors :: TokenParser a -> TokenParser [Vector a]
src/Domain/LinearAlgebra/Strategies.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -13,18 +13,21 @@    ( gaussianElimStrategy, linearSystemStrategy
    , gramSchmidtStrategy, systemWithMatrixStrategy
    , forwardPass
-   , isLeft, isRight, maybeInContext
+   , liftExpr
    ) where
 
 import Prelude hiding (repeat)
 import Domain.Math.Expr
+import Common.Rewriting
 import Domain.Math.Simplification
 import Domain.LinearAlgebra.Matrix
 import Domain.LinearAlgebra.MatrixRules
 import Domain.LinearAlgebra.EquationsRules
 import Domain.LinearAlgebra.GramSchmidtRules
 import Domain.LinearAlgebra.LinearSystem
+import Domain.LinearAlgebra.Symbols ()
 import Common.Apply
+import Common.Navigator
 import Common.Strategy hiding (not)
 import Common.Transformation
 import Common.Context
@@ -70,7 +73,7 @@    label "System to Echelon Form (EEO)" $
    simplifyFirst <*>
    repeat  (  dropEquation
-          <|> check (not . null . remaining)
+          <|> check (maybe False (not . null) . evalCM remaining)
           <*> label "Exchange equations"        (try ruleExchangeEquations)
           <*> label "Scale equation to one"     (option ruleScaleEquation)
           <*> label "Eliminate variable"        (repeat ruleEliminateVar)
@@ -87,13 +90,13 @@ linearSystemStrategy = label "General solution to a linear system" $
    systemToEchelonWithEEO <*> backSubstitution
 
-systemWithMatrixStrategy :: LabeledStrategy (Context (Either (LinearSystem Expr) (Matrix Expr)))
+systemWithMatrixStrategy :: LabeledStrategy (Context Expr)
 systemWithMatrixStrategy = label "General solution to a linear system (matrix approach)" $
-       repeat (liftLeft dropEquation) 
+       repeat (mapRules liftExpr dropEquation) 
    <*> conv1 
-   <*> liftRight gaussianElimStrategy 
+   <*> mapRules liftExpr gaussianElimStrategy 
    <*> conv2 
-   <*> repeat (liftLeft dropEquation)
+   <*> repeat (mapRules liftExpr dropEquation)
 
 gramSchmidtStrategy :: LabeledStrategy (Context (VectorSpace (Simplified Expr)))
 gramSchmidtStrategy =
@@ -103,45 +106,28 @@    <*> label "Normalize"              (try ruleNormalize)
 
 vars :: Var [String]
-vars = "variables" := []
+vars = newVar "variables" []
 
 simplifyFirst :: Rule (Context (LinearSystem Expr))
 simplifyFirst = simplifySystem idRule
 
-conv1 :: Rule (Context (Either (LinearSystem Expr) (Matrix Expr)))
-conv1 = translationToContext "Linear system to matrix" $ \c -> 
-   let (m, vs) = systemToMatrix (fromContext c)
-   in return $ set vars vs $ fmap (const (simplify m)) c
+conv1 :: Rule (Context Expr)
+conv1 = makeSimpleRule "Linear system to matrix" $ withCM $ \expr -> do
+   ls <- fromExpr expr
+   let (m, vs) = systemToMatrix ls
+   writeVar vars vs
+   return (toExpr (simplify (m :: Matrix Expr)))
  
-conv2 :: Rule (Context (Either (LinearSystem Expr) (Matrix Expr)))
-conv2 = translationFromContext "Matrix to linear system" $ \c -> 
-   let linsys = matrixToSystemWith (get vars c) (fromContext c)
-   in return $ applyD simplifyFirst $  fmap (const linsys) c 
-   
-liftLeft :: (IsStrategy f, Lift f) => f (Context a) -> f (Context (Either a b))
-liftLeft = lift $ makeLiftPair (maybeInContext . fmap isLeft) (\a _ -> fmap Left a)
-
-liftRight :: (IsStrategy f, Lift f) => f (Context b) -> f (Context (Either a b))
-liftRight = lift $ 
-   makeLiftPair (maybeInContext . fmap isRight) (\b _ -> fmap Right b)
-
-maybeInContext :: Context (Maybe a) -> Maybe (Context a)
-maybeInContext c = fmap (\a -> fmap (const a) c) (fromContext c)
-
-isLeft :: Either a b -> Maybe a
-isLeft = either Just (const Nothing)
-
-isRight :: Either a b -> Maybe b
-isRight = either (const Nothing) Just
-
-translationToContext :: String -> (Context a -> Maybe (Context b)) -> Rule (Context (Either a b))
-translationToContext s f = makeSimpleRule s (maybe Nothing (fmap (fmap Right) . f) . maybeInContext . fmap isLeft)
+conv2 :: Rule (Context Expr)
+conv2 = makeSimpleRule "Matrix to linear system" $ withCM $ \expr -> do
+   vs <- readVar vars
+   m  <- fromExpr expr
+   let linsys = matrixToSystemWith vs (m :: Matrix Expr)
+   a  <- fromContext $ applyD simplifyFirst $ newContext emptyEnv (noNavigator linsys) -- !!
+   return $ toExpr a
 
-translationFromContext :: String -> (Context b -> Maybe (Context a)) -> Rule (Context (Either a b))
-translationFromContext s f = makeSimpleRule s (maybe Nothing (fmap (fmap Left) . f) . maybeInContext . fmap isRight)
-   
-instance Simplify a => Simplify (Vector a) where
-   simplify = fmap simplify
-   
-instance Simplify a => Simplify (VectorSpace a) where
-   simplify = fmap simplify+liftExpr :: IsTerm a => Rule (Context a) -> Rule (Context Expr)
+liftExpr r = makeSimpleRuleList (name r) $ \a -> do
+   b <- castT exprView a 
+   c <- applyAll r b
+   castT exprView c
src/Domain/LinearAlgebra/Symbols.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -9,42 +9,57 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Domain.LinearAlgebra.Symbols -   ( -- linalg2-     matrixSymbol, matrixrowSymbol, vectorSymbol-   ) where+module Domain.LinearAlgebra.Symbols () where -import Domain.Math.Expr.Conversion import Domain.Math.Expr.Symbolic+import Domain.Math.Simplification import Domain.LinearAlgebra.Matrix import Domain.LinearAlgebra.Vector import Control.Monad-import Text.OpenMath.Dictionary.Linalg2+import qualified Text.OpenMath.Dictionary.Linalg2 as Linalg2+import Common.Rewriting.Term +vectorSymbol, matrixSymbol, matrixrowSymbol :: Symbol+vectorSymbol    = toSymbol Linalg2.vectorSymbol+matrixSymbol    = toSymbol Linalg2.matrixSymbol+matrixrowSymbol = toSymbol Linalg2.matrixrowSymbol+ ------------------------------------------------------- -- Conversion to the Expr data type -instance IsExpr a => IsExpr (Matrix a) where-   toExpr = -      let f = function matrixrowSymbol . map toExpr+instance IsTerm a => IsTerm (Matrix a) where+   toTerm = +      let f = function matrixrowSymbol . map toTerm       in function matrixSymbol . map f . rows-   fromExpr a = do+   fromTerm a = do       rs  <- isSymbol matrixSymbol a       xss <- mapM (isSymbol matrixrowSymbol) rs-      yss <- mapM (mapM fromExpr) xss+      yss <- mapM (mapM fromTerm) xss       guard (isRectangular yss)       return (makeMatrix yss)-      -instance IsExpr a => IsExpr (Vector a) where-   toExpr = function vectorSymbol . map toExpr . toList-   fromExpr expr = do-      xs <- isSymbol vectorSymbol expr-      ys <- mapM fromExpr xs++instance IsTerm a => IsTerm (Vector a) where+   toTerm = function vectorSymbol . map toTerm . toList+   fromTerm a = do+      xs <- isSymbol vectorSymbol a+      ys <- mapM fromTerm xs       return (fromList ys)       -instance IsExpr a => IsExpr (VectorSpace a) where-   toExpr = toExpr . vectors-   fromExpr expr = do-      xs <- fromExpr expr+instance IsTerm a => IsTerm (VectorSpace a) where+   toTerm = toTerm . vectors+   fromTerm a = do+      xs <- fromTerm a       guard (sameDimension xs)       return (makeVectorSpace xs)++-------------------------------------------------------+-- Simplification++instance Simplify a => Simplify (Matrix a) where+   simplify = fmap simplify++instance Simplify a => Simplify (Vector a) where+   simplify = fmap simplify+   +instance Simplify a => Simplify (VectorSpace a) where+   simplify = fmap simplify
src/Domain/LinearAlgebra/Vector.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
src/Domain/Logic.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -18,7 +18,6 @@    , module Domain.Logic.BuggyRules
    , module Domain.Logic.GeneralizedRules
    , module Domain.Logic.Exercises
-   , module Domain.Logic.FeedbackText
    ) where
    
 import Domain.Logic.Formula
@@ -29,5 +28,4 @@ import Domain.Logic.BuggyRules
 import Domain.Logic.GeneralizedRules
 import Domain.Logic.Exercises
-import Domain.Logic.FeedbackText
src/Domain/Logic/BuggyRules.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Domain/Logic/Exercises.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -19,6 +19,7 @@ import Common.Context
 import Common.Derivation
 import Common.Exercise
+import Common.Navigator
 import Common.Rewriting (differenceMode)
 import Common.Strategy
 import Data.Maybe
@@ -29,15 +30,14 @@ import Domain.Logic.Rules
 import Domain.Logic.Strategies
 import Test.QuickCheck
-import Text.Parsing (fromRanged)
-   
+
 -- Currently, we use the DWA strategy
 dnfExercise :: Exercise SLogic
 dnfExercise = makeExercise
    { description    = "Proposition to DNF"
    , exerciseCode   = makeCode "logic" "dnf"
    , status         = Stable
-   , parser         = either Left (Right . fromRanged) . parseLogicPars
+   , parser         = parseLogicPars
    , prettyPrinter  = ppLogicPars
    , equivalence    = eqLogic
    , similarity     = equalLogicA
@@ -45,8 +45,9 @@    , isSuitable     = suitable
    , extraRules     = map liftToContext (logicRules ++ buggyRules)
    , strategy       = dnfStrategyDWA
+   , navigation     = navigator
    , difference     = differenceMode eqLogic
-   , testGenerator  = Just (restrictGenerator suitable generateLogic)
+   , testGenerator  = Just (restrictGenerator suitable arbitrary)
    , randomExercise = useGenerator (const True) logicExercise
    }
 
@@ -55,7 +56,7 @@ dnfUnicodeExercise = dnfExercise
    { description   = description dnfExercise ++ " (unicode support)"
    , exerciseCode  = makeCode "logic" "dnf-unicode"
-   , parser        = either Left (Right . fromRanged) . parseLogicUnicodePars
+   , parser        = parseLogicUnicodePars
    , prettyPrinter = ppLogicUnicodePars
    }
 
@@ -74,7 +75,7 @@ 
 stepsRemaining :: Int -> SLogic -> Maybe Int
 stepsRemaining i = 
-   lengthMax i . derivationTree dnfStrategyDWA . inContext
+   lengthMax i . derivationTree dnfStrategyDWA . inContext dnfExercise
 
 -- QuickCheck property to monitor the number of steps needed 
 -- to normalize a random proposition (30-40% is ok)
@@ -86,9 +87,6 @@    
 testme :: IO ()
 testme = quickCheck testGen 
-
-
-import Service.TypedAbstractService
 
 start = ((r :<->: p) :||: (q :->: s)) :&&: (Not s :<->: (p :||: r))
  where
src/Domain/Logic/FeedbackText.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -12,35 +12,19 @@ -- by Josje Lodder. -- ------------------------------------------------------------------------------module Domain.Logic.FeedbackText -   ( feedbackSyntaxError, ruleText, appliedRule-   , feedbackBuggy, feedbackNotEquivalent-   , feedbackSame-   , feedbackOk, feedbackDetour, feedbackUnknown-   ) where+module Domain.Logic.FeedbackText where +import Data.List import Data.Maybe-import Text.Parsing import Common.Transformation import Domain.Logic.Rules import Domain.Logic.BuggyRules --- This is more general than the logic domain. Perhaps it should--- be defined elsewhere-feedbackSyntaxError :: SyntaxError -> String-feedbackSyntaxError syntaxError =-   case syntaxError of-      ParNotClosed token -> -         "Opening parenthesis symbol '(' at position " ++ tokenPos token ++ " is not closed."-      ParNoOpen token -> -         "Closing parenthesis symbol ')' at position " ++ tokenPos token ++ " has no matching opening parenthesis."-      ParMismatch token1 token2 -> -         "The openening parenthesis at position " ++ tokenPos token1 ++ -         " does not match with the closing parenthesis at position " ++ tokenPos token2 ++ "."-      ErrorMessage txt -> -         txt-      Unexpected token -> -         "Unexpected " ++ showToken token+feedbackSyntaxError :: String -> String +feedbackSyntaxError msg+   | take 1 msg == "("               = "Syntax error at " ++ msg+   | "Syntax error" `isPrefixOf` msg = msg+   | otherwise                       = "Syntax error: " ++ msg  feedbackBuggy :: Bool -> [Rule a] -> String feedbackBuggy ready [br] @@ -185,12 +169,3 @@ inGroup r n =     let rs = filter (~= r) (logicRules ++ buggyRules)    in n `elem` concatMap ruleGroups rs--showToken :: Token -> String-showToken token = tokenText token ++ " at position " ++ tokenPos token--tokenPos :: Token -> String-tokenPos token = -   let p@(l, c) = toPosition token-   in if l==1 then show c else show p -
src/Domain/Logic/Formula.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -11,11 +11,14 @@ ----------------------------------------------------------------------------- module Domain.Logic.Formula where +import Domain.Math.Expr.Symbolic+import Text.OpenMath.Dictionary.Logic1 import Common.Uniplate (Uniplate(..), universe) import Common.Rewriting-import Common.Utils+import Common.Traversable+import Common.Utils (ShowString, subsets) import Data.List-import Data.Maybe+import Control.Monad  infixr 2 :<->: infixr 3 :->: @@ -32,14 +35,26 @@              | Not (Logic a)                    -- not              | T                                -- true              | F                                -- false- deriving (Show, Eq, Ord)+ deriving (Eq, Ord)  -- | For simple use, we assume the variables to be strings-type SLogic = Logic String+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)@@ -58,7 +73,23 @@          Not p     -> not (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 n p = foldLogic (pp . show, binop 3 "->", binop 0 "<->", binop 2 "/\\", binop 1 "||", nott, pp "T", pp "F") p n ""+ where+   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@@ -151,10 +182,30 @@          (F        , F        ) -> True          _                      -> False -instance MetaVar a => MetaVar (Logic a) where-   isMetaVar (Var a) = isMetaVar a-   isMetaVar _       = Nothing-   metaVar           = Var . metaVar+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+      , nullary trueSymbol, nullary 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)+         | s == andSymbol        = return (x :&&: y)+         | s == orSymbol         = return (x :||: y)+      f _ _ = fail "fromTerm"  logicOperators :: Operators (Logic a) logicOperators = [andOperator, orOperator]
src/Domain/Logic/GeneralizedRules.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Domain/Logic/Generator.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeSynonymInstances #-}
 -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -14,19 +14,23 @@    ( generateLogic, generateLevel, equalLogicA, Level(..)
    ) where
 
+import Common.Utils (ShowString(..))
 import Domain.Logic.Formula
 import Control.Monad
 import Data.Char
-import Test.QuickCheck hiding (defaultConfig)
+import Test.QuickCheck
 import Common.Rewriting
 import Common.Uniplate
+import Domain.Math.Expr.Symbolic
+import Text.OpenMath.Dictionary.Logic1
 
 -------------------------------------------------------------
 -- Code that doesn't belong here, but the arbitrary instance
 -- is needed for the Rewrite instance.
 
 instance Rewrite SLogic where
-   operators = logicOperators
+   operators      = logicOperators
+   associativeOps = const $ map toSymbol [andSymbol, orSymbol]
 
 -- | Equality modulo associativity of operators
 equalLogicA:: SLogic -> SLogic -> Bool
@@ -65,16 +69,16 @@ -- Use the propositions with 7-18 steps
 difficultGenerator :: Gen SLogic
 difficultGenerator = do
-   let vars = "s" : varList
+   let vars = ShowString "s" : varList
    n  <- return 4 -- oneof [return 4, return 8]
    p0 <- sizedGen False (oneof $ map return vars) n
    p1 <- preventSameVar vars p0
    return (removePartsInDNF p1)
 
-varList :: [String]
-varList = ["p", "q", "r"]
+varList :: [ShowString]
+varList = map ShowString ["p", "q", "r"]
 
-varGen :: Gen String
+varGen :: Gen ShowString
 varGen = oneof $ map return varList
 
 sizedGen :: Bool -> Gen a -> Int -> Gen (Logic a)
@@ -122,10 +126,11 @@ --- QuickCheck generator
 
 instance Arbitrary SLogic where
-   arbitrary = sized (sizedGen True varGen)
+   arbitrary = sized (\i -> sizedGen True varGen (i `min` 4))
+instance CoArbitrary SLogic where
    coarbitrary logic = 
       case logic of
-         Var x     -> variant 0 . coarbitrary (map ord x)
+         Var x     -> variant 0 . coarbitrary (map ord (fromShowString x))
          p :->: q  -> variant 1 . coarbitrary p . coarbitrary q
          p :<->: q -> variant 2 . coarbitrary p . coarbitrary q
          p :&&: q  -> variant 3 . coarbitrary p . coarbitrary q
src/Domain/Logic/Parser.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -11,21 +11,22 @@ -----------------------------------------------------------------------------
 module Domain.Logic.Parser
    ( parseLogic, parseLogicPars, parseLogicUnicodePars
-   , ppLogic, ppLogicPrio, ppLogicPars, ppLogicUnicodePars
+   , ppLogicPars, ppLogicUnicodePars
    ) where
 
+import Common.Utils (ShowString(..))
 import Text.Parsing
 import Control.Arrow
 import Domain.Logic.Formula
    
 logicScanner :: Scanner
-logicScanner = (makeCharsSpecial "~" defaultScanner)
+logicScanner = (specialSymbols "~" defaultScanner)
    { keywords         = ["T", "F"]
    , keywordOperators = "~" : concatMap (map fst . snd) operatorTable
    }
 
 logicUnicodeScanner :: Scanner
-logicUnicodeScanner = (makeCharsSpecial (concat unicodeSyms) defaultScanner)
+logicUnicodeScanner = (specialSymbols (concat unicodeSyms) defaultScanner)
    { keywords         = ["T", "F"]
    , keywordOperators = unicodeSyms
    }
@@ -43,7 +44,7 @@ 
 -- | Parser for logic formulas that respects all associativity and priority laws 
 -- | of the constructors
-parseLogic :: String -> Either SyntaxError (Ranged SLogic)
+parseLogic :: String -> Either String SLogic
 parseLogic = analyseAndParse pLogic . scanWith logicScanner
  where
    pLogic = pOperators operatorTable (basicWithPos pLogic)
@@ -52,14 +53,14 @@ -- | 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
-parseLogicPars :: String -> Either SyntaxError (Ranged SLogic)
+parseLogicPars :: String -> Either String SLogic
 parseLogicPars s
    = either Left suspiciousVariable 
    $ left (ambiguousOperators parseLogic s)
    $ analyseAndParse (pLogicGen asciiTuple)
    $ scanWith logicScanner s
 
-parseLogicUnicodePars :: String -> Either SyntaxError (Ranged SLogic)
+parseLogicUnicodePars :: String -> Either String SLogic
 parseLogicUnicodePars s 
    = either Left suspiciousVariable 
    $ left (ambiguousOperators (parseLogic . concatMap f) s)
@@ -78,43 +79,44 @@  where
    pLogic = flip ($) <$> basic <*> optional composed id
    basic     =  basicWithPosGen (nt, tr, fl) pLogic
-   composed  =  flip (binaryOp (:<->:)) <$ pKey equiv <*> basic
-            <|> flip (binaryOp (:->:))  <$ pKey impl  <*> basic
-            <|> (\xs p -> foldr1 (binaryOp (:&&:)) (p:xs)) <$> pList1 (pKey and *> basic)
-            <|> (\xs p -> foldr1 (binaryOp (:||:)) (p:xs)) <$> pList1 (pKey or  *> basic)
+   composed  =  flip (:<->:) <$ pKey equiv <*> basic
+            <|> flip (:->:)  <$ pKey impl  <*> basic
+            <|> (\xs p -> foldr1 (:&&:) (p:xs)) <$> pList1 (pKey and *> basic)
+            <|> (\xs p -> foldr1 (:||:) (p:xs)) <$> pList1 (pKey or  *> basic)
  
-basicWithPos :: Parser Token (Ranged SLogic) -> Parser Token (Ranged SLogic)
+basicWithPos :: Parser Token SLogic -> Parser Token SLogic
 basicWithPos = basicWithPosGen ("~", "T", "F")
 
 basicWithPosGen t@(nt, tr, fl) p = 
-   (\(s, r) -> toRanged (Var s) r) <$> pVarid
+       (Var . ShowString) <$> pVarid
    <|> pParens p
-   <|> toRanged T  <$> pKey tr
-   <|> toRanged F  <$> pKey fl
-   <|> unaryOp Not <$> pKey nt <*> basicWithPosGen t p
+   <|> T  <$ pKey tr
+   <|> F  <$ pKey fl
+   <|> Not <$ pKey nt <*> basicWithPosGen t p
 
 -----------------------------------------------------------
 --- Helper-functions for syntax warnings
 
 -- analyze parentheses
-analyseAndParse :: Parser Token a -> [Token] -> Either SyntaxError a
+analyseAndParse :: Parser Token a -> [Token] -> Either String a
 analyseAndParse p ts =
    case checkParentheses ts of
-      Just err -> Left err
-      Nothing  -> case parse p ts of
-                     (_, m:_) -> Left (fromMessage m)
-                     (a, _)   -> Right a
+      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 -> SyntaxError -> SyntaxError
+ambiguousOperators :: (String -> Either a b) -> String -> String -> String
 ambiguousOperators p s err =
-   let msg = ErrorMessage "Ambiguous use of operators (write parentheses)"
+   let msg = "Ambiguous use of operators (write parentheses)"
    in either (const err) (const msg) (p s)
 
 -- Report variables 
-suspiciousVariable :: Ranged SLogic -> Either SyntaxError (Ranged SLogic)
+suspiciousVariable :: SLogic -> Either String SLogic
 suspiciousVariable r =
-   case filter p (varsLogic (fromRanged r)) of
-      v:_ -> Left $ ErrorMessage $ "Unexpected variable " ++ v
+   case filter p (map fromShowString (varsLogic r)) of
+      v:_ -> Left $ "Unexpected variable " ++ v
                  ++ ". Did you forget an operator?" 
       _   -> Right r
  where
@@ -123,17 +125,6 @@ -----------------------------------------------------------
 --- Pretty-Printer
 
-ppLogic :: SLogic -> String
-ppLogic = ppLogicPrio 0
-        
-ppLogicPrio :: Int -> SLogic -> String
-ppLogicPrio n p = foldLogic (var, binop 3 "->", binop 0 "<->", binop 2 "/\\", binop 1 "||", nott, var "T", var "F") p n ""
- where
-   binop prio op p q n = parIf (n > prio) (p (prio+1) . ((" "++op++" ")++) . q prio)
-   var       = const . (++)
-   nott p _  = ("~"++) . p 4
-   parIf b f = if b then ("("++) . f . (")"++) else f
-
 -- | Pretty printer that produces extra parentheses: also see parseLogicPars
 ppLogicPars :: SLogic -> String
 ppLogicPars = ppLogicParsGen asciiTuple
@@ -144,10 +135,10 @@ 
 ppLogicParsGen (impl, equiv, and, or, nt, tr, fl) p = foldLogic alg p 0 ""
  where
-   alg = (var, binop 3 impl, binop 3 equiv, binop 1 and, binop 2 or, nott, var tr, var fl)
+   alg = (pp . fromShowString, binop 3 impl, binop 3 equiv, binop 1 and, binop 2 or, nott, pp tr, pp fl)
    binop prio op p q n = parIf (n/=0 && (n==3 || prio/=n)) 
                                (p prio . ((" "++op++" ")++) . q prio)
-   var       = const . (++)
+   pp s = const (s++)
    nott  p _ = (nt++) . p 3
    parIf b f = if b then ("("++) . f . (")"++) else f
src/Domain/Logic/Rules.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -262,4 +262,4 @@ 
 ruleImplSame :: Rule SLogic 
 ruleImplSame = rule "ImplSame" $
-   \x -> x :->: x  :~>  T+   \x -> x :->: (x::SLogic)  :~>  T
src/Domain/Logic/Strategies.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -16,10 +16,11 @@ import Domain.Logic.Rules
 import Domain.Logic.GeneralizedRules
 import Domain.Logic.Formula
-import Common.Context (Context, liftToContext, currentFocus)
+import Common.Context (Context, liftToContext)
 import Common.Rewriting (isOperator)
 import Common.Transformation
 import Common.Strategy
+import Common.Navigator
 
 -----------------------------------------------------------------------------
 -- To DNF, with priorities (the "DWA" approachs)
@@ -57,9 +58,14 @@ -- the strategy only at (top-level) disjuncts 
 somewhereOr :: IsStrategy g => g (Context SLogic) -> Strategy (Context SLogic)
 somewhereOr s =
-   let isOr = maybe False (isOperator orOperator) . currentFocus
+   let isOr = maybe False (isOperator orOperator) . current
    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
src/Domain/Math/Approximation.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -18,6 +18,13 @@ type Function = Double -> Double  type Approximation = [Double]++------------------------------------------------------------+-- Precision of a floating-point number++precision :: Int -> Double -> Double+precision n = (/a) . fromIntegral . round . (*a)+ where a = 10 Prelude.^ (max 0 n)  ------------------------------------------------------------ -- Stop criteria
+ src/Domain/Math/Clipboard.hs view
@@ -0,0 +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)+--+-- 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+   ) where++import Common.Context+import Control.Monad+import Common.Rewriting+import Common.Rewriting.Term (Term)+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 f a = fromMaybe a (f 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+   +lookupListClipboardG :: IsTerm a => [String] -> ContextMonad [a]+lookupListClipboardG = mapM lookupClipboardG
− src/Domain/Math/Data/Equation.hs 
@@ -1,72 +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)
---
--- Mathematical equations
---
------------------------------------------------------------------------------
-module Domain.Math.Data.Equation where
-
-import Common.Uniplate
-import Common.Rewriting
-import Common.Traversable
-import Test.QuickCheck
-import Control.Monad
-
-infix 1 :==:
-
-type Equations a = [Equation a]
-
-data Equation  a = a :==: a
-   deriving (Eq, Ord)
-   
-instance Functor Equation where
-   fmap f (x :==: y) = f x :==: f y
-   
-instance Once Equation where 
-   onceM f (lhs :==: rhs) = 
-      liftM (:==: rhs) (f lhs) `mplus` liftM (lhs :==:) (f rhs)
-
-instance Switch Equation where 
-   switch (ma :==: mb) = liftM2 (:==:) ma mb
-   
-instance Crush Equation where
-   crush (a :==: b) = [a, b]
-   
-instance Show a => Show (Equation a) where
-   show (x :==: y) = show x ++ " == " ++ show y
- 
-getLHS, getRHS :: Equation a -> a
-getLHS (x :==: _) = x
-getRHS (_ :==: y) = y
-
-evalEquation :: Eq a => Equation a -> Bool
-evalEquation = evalEquationWith id
-
-evalEquationWith :: Eq b => (a -> b) -> Equation a -> Bool
-evalEquationWith f (x :==: y) = f x == f y
-
-substEquation :: (Uniplate a, MetaVar a) => Substitution a -> Equation a -> Equation a
-substEquation sub (x :==: y) = (sub |-> x) :==: (sub |-> y)
-
-substEquations :: (Uniplate a, MetaVar a) => Substitution a -> Equations a -> Equations a
-substEquations = map . substEquation
-
-combineWith :: (a -> a -> a) -> Equation a -> Equation a -> Equation a
-combineWith f (x1 :==: x2) (y1 :==: y2) = f x1 y1 :==: f x2 y2
-
-flipSides :: Equation a -> Equation a
-flipSides (x :==: y) = y :==: x
-
------------------------------------------------------
--- QuickCheck generators
-
-instance Arbitrary a => Arbitrary (Equation a) where
-   arbitrary = liftM2 (:==:) arbitrary arbitrary
-   coarbitrary (x :==: y) = coarbitrary x . coarbitrary y
+ src/Domain/Math/Data/Interval.hs view
@@ -0,0 +1,363 @@+-----------------------------------------------------------------------------+-- 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.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 b c) = f GT b && f LT c+ where+   f value x = +      let g c = (c==EQ && isIncluding x) || c==value +      in maybe True (g . compare a) (getPoint x)++---------------------------------------------------------------------+-- 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 . coarbitrary a+   coarbitrary (Including a) = variant 1 . coarbitrary a+   coarbitrary Unbounded     = variant 2++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+   coarbitrary (I a b) = variant 1 . 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 :: IO ()+testMe = do+   putStrLn "** Intervals"+   -- Constructor functions+   quickCheck $ op0 empty     (const False)+   quickCheck $ op0 unbounded (const True)+   +   quickCheck $ op1 greaterThan (>)+   quickCheck $ op1 greaterThanOrEqualTo (>=)+   quickCheck $ op1 lessThan (<)+   quickCheck $ op1 lessThanOrEqualTo (<=)+   quickCheck $ op1 singleton (==)+   +   quickCheck $ op2 open      (<)  (<)+   quickCheck $ op2 closed    (<=) (<=)+   quickCheck $ op2 leftOpen  (<)  (<=)+   quickCheck $ op2 rightOpen (<=) (<)+   +   -- From/to lists+   quickCheck fromTo1+   quickCheck fromTo2+   +   -- Combinators+   quickCheck defExcept+   quickCheck defUnion+   quickCheck defIntersect+   quickCheck defComplement+   +   -- Combinator properties+   quickCheck $ selfInverse complement+   quickCheck $ transitive  union+   quickCheck $ commutative union+   quickCheck $ absorption  union+   quickCheck $ transitive  intersect+   quickCheck $ commutative intersect+   quickCheck $ 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
src/Domain/Math/Data/OrList.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -14,10 +14,15 @@    , orList, (\/), true, false    , isTrue, isFalse    , disjunctions, normalize, idempotent+   , orView    ) where +import Common.View import Control.Monad import Common.Traversable+import Common.Rewriting.Term+import qualified Domain.Logic.Formula as Logic+import Domain.Logic.Formula (Logic((:||:))) import Test.QuickCheck import Data.List (intersperse, nub, sort) @@ -96,11 +101,16 @@       rec (x:xs) = liftM (\/ orList xs) (f x) `mplus`                    liftM (return x \/) (rec xs) +instance IsTerm a => IsTerm (OrList a) where+   toTerm = toTerm . build orView+   fromTerm expr = fromTerm expr >>= matchM orView+ 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    coarbitrary (OrList xs) = variant 1 . coarbitrary xs @@ -109,3 +119,20 @@    show (OrList xs)        | null xs   = "false"       | otherwise = unwords (intersperse "or" (map show xs))++------------------------------------------------------------+-- View to the logic data type+ +orView :: View (Logic a) (OrList a)+orView = 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)
src/Domain/Math/Data/Polynomial.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -143,8 +143,12 @@  -- polynomial division, no remainder division :: Fractional a => Polynomial a -> Polynomial a -> Maybe (Polynomial a)-division p1 p2 = if b==0 then return a else Nothing - where (a, b) = longDivision p1 p2+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)@@ -155,7 +159,7 @@ monicLongDivision :: Num a => Polynomial a -> Polynomial a -> (Polynomial a, Polynomial a) monicLongDivision p1 p2    | d1 >= d2 && isMonic p2 = (toP quot, toP rem)-   | otherwise = error "invalid monic division"+   | otherwise = error $ "invalid monic division" ++ show (p1, p2)  where    d1 = degree p1    d2 = degree p2
src/Domain/Math/Data/PrimeFactors.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -64,6 +64,7 @@ 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
+ src/Domain/Math/Data/Relation.hs view
@@ -0,0 +1,280 @@+-----------------------------------------------------------------------------
+-- 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)
+--
+-- Mathematical relations
+--
+-----------------------------------------------------------------------------
+module Domain.Math.Data.Relation 
+   ( -- * Type class
+     Relational(..), mapLeft, mapRight, updateLeft, updateRight
+     -- * Relation data type
+   , Relation, relationType, RelationType(..), relationSymbols
+     -- * Constructor functions
+   , makeType, (.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.)
+     -- * Equation (or equality)
+   , Equations, Equation(..), equationView
+     -- * Inequality
+   , Inequality(..), inequalityView
+   ) where
+
+import Common.View
+import Common.Rewriting (IsTerm(..), Rewrite)
+import Common.Traversable
+import Domain.Math.Expr.Symbolic
+import qualified Text.OpenMath.Dictionary.Relation1 as Relation1
+import Data.Maybe
+import Test.QuickCheck
+import Control.Monad
+
+-----------------------------------------------------------------------------
+-- Type class for relations
+
+class Functor f => Relational f where
+   leftHandSide  :: f a -> a
+   rightHandSide :: f a -> a
+   flipSides     :: f a -> f a -- possibly also flips operator 
+   constructor   :: f a -> (b -> b -> f b)
+   isSymmetric   :: f a -> Bool
+   -- default definitions
+   isSymmetric _ = False
+
+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
+
+data Relation a = R { lhs :: a, relationType :: RelationType, rhs :: a }
+   deriving (Eq, Ord)
+
+-- Corresponds exactly to the symbols in the relation1 OpenMath dictionary
+data RelationType = EqualTo | NotEqualTo | LessThan | GreaterThan 
+                  | LessThanOrEqualTo | GreaterThanOrEqualTo | Approximately
+   deriving (Show, Eq, Ord, Enum)
+
+instance Show a => Show (Relation a) where
+   show r = unwords [show (lhs r), showRelType (relationType r), show (rhs r)]
+
+instance Functor Relation where
+   fmap f (R x rt y) = R (f x) rt (f y)
+
+instance Relational Relation where
+   leftHandSide  = lhs
+   rightHandSide = rhs
+   flipSides (R x rt y) = R y (flipRelType rt) x
+   constructor (R _ rt _) x y = R x rt y
+   isSymmetric = (`elem` [EqualTo, NotEqualTo, Approximately]) . relationType
+
+instance IsTerm a => IsTerm (Relation a) where
+   toTerm p = 
+      let op  = relationType p
+          sym = maybe (toSymbol (show op)) snd (lookup op relationSymbols)
+      in binary sym (toTerm (leftHandSide p)) (toTerm (rightHandSide p))
+   fromTerm a = 
+      let f (relType, (_, s)) = do
+             (e1, e2) <- isBinary s a
+             liftM2 (makeType relType) (fromTerm e1) (fromTerm e2)
+      in msum (map f relationSymbols) 
+
+instance Rewrite a => Rewrite (Relation a)
+
+relationSymbols :: [(RelationType, (String, Symbol))]
+relationSymbols =
+   [ (EqualTo, ("==", eqSymbol)), (NotEqualTo, ("/=", neqSymbol))
+   , (LessThan, ("<", ltSymbol)), (GreaterThan, (">", gtSymbol))
+   , (LessThanOrEqualTo, ("<=", leqSymbol))
+   , (GreaterThanOrEqualTo, (">=", geqSymbol))
+   , (Approximately, ("~=", approxSymbol))
+   ]
+
+-- helpers   
+showRelType :: RelationType -> String
+showRelType = fst . (? relationSymbols)
+
+flipRelType :: RelationType -> RelationType
+flipRelType relType = fromMaybe relType (lookup relType table)
+ where
+   table = pairs ++ map (\(a,b) -> (b,a)) pairs
+   pairs = [(LessThan, GreaterThan), (LessThanOrEqualTo, GreaterThanOrEqualTo)]
+
+(?) :: Eq a => a -> [(a, b)] -> b
+a ? xs = fromMaybe (error "Relation: Error in lookup") (lookup a xs)
+
+-----------------------------------------------------------------------------
+-- Traversable instance declarations
+
+instance Once   Relation where onceM  = onceMRelation
+instance Switch Relation where switch = switchRelation
+instance Crush  Relation where crush  = crushRelation
+
+switchRelation :: (Relational f, Monad m) => f (m a) -> m (f a)
+switchRelation p =
+   liftM2 (constructor p) (leftHandSide p) (rightHandSide p)
+ 
+onceMRelation :: (Relational f, MonadPlus m) => (a -> m a) -> f a -> m (f a)
+onceMRelation f p =
+   liftM (`updateLeft` p) (f (leftHandSide p)) `mplus` 
+   liftM (`updateRight` p) (f (rightHandSide p))
+            
+crushRelation :: Relational f => f a -> [a]
+crushRelation 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)
+   
+instance Arbitrary RelationType where
+   arbitrary = oneof $ map return [EqualTo .. Approximately]
+instance CoArbitrary RelationType where
+   coarbitrary op = variant (fromEnum op)
+
+-----------------------------------------------------------------------------
+-- Constructor functions
+
+infix 1 .==., ./=., .<., .>., .<=., .>=., .~=.
+
+(.==.), (./=.), (.<.), (.>.), (.<=.), (.>=.), (.~=.) :: a -> a -> Relation a
+(.==.) = makeType EqualTo
+(./=.) = makeType NotEqualTo
+(.<.)  = makeType LessThan 
+(.>.)  = makeType GreaterThan 
+(.<=.) = makeType LessThanOrEqualTo
+(.>=.) = makeType GreaterThanOrEqualTo
+(.~=.) = makeType Approximately
+
+makeType :: RelationType -> a -> a -> Relation a
+makeType = flip R
+
+-----------------------------------------------------------------------------
+-- Equation data type (view on Relation)
+
+infix 1 :==:
+
+type Equations a = [Equation a]
+
+data Equation  a = a :==: a
+   deriving (Eq, Ord)
+
+instance Show a => Show (Equation a) where
+   show = show . build equationView
+
+instance Functor Equation where
+   fmap f (x :==: y) = f x :==: f y
+   
+instance Relational Equation where
+   leftHandSide  = leftHandSide  . build equationView
+   rightHandSide = rightHandSide . build equationView
+   flipSides     = \(x :==: y) -> y :==: x
+   constructor   = const (:==:)
+   isSymmetric   = const True
+
+instance Once   Equation where onceM  = onceMRelation
+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
+
+instance IsTerm a => IsTerm (Equation a) where
+   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
+   f (R x op y)
+      | op == EqualTo = return (x :==: y)
+      | otherwise     = Nothing
+   g (x :==: y) = x .==. y
+
+-----------------------------------------------------------------------------
+-- Inequality (view on Relation)
+
+infix 1 :<:, :>:, :<=:, :>=:
+   
+data Inequality a = a :<: a | a :>: a | a :<=: a | a :>=: a
+
+instance Show a => Show (Inequality a) where
+   show = show . build inequalityView
+
+instance Functor Inequality where
+   fmap f ineq = 
+      let a = leftHandSide ineq
+          b = rightHandSide ineq
+      in constructor ineq (f a) (f b)
+   
+instance Relational Inequality where
+   leftHandSide  = leftHandSide  . build inequalityView
+   rightHandSide = rightHandSide . build inequalityView
+   flipSides = fromMaybe (error "inequality: flipSides") . matchM inequalityView 
+             . flipSides . build inequalityView
+   constructor ineq = 
+      let relType = relationType (build inequalityView ineq)
+      in fst (relType ? inequalityTable)
+
+instance Once   Inequality where onceM  = onceMRelation
+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
+      liftM2 op arbitrary arbitrary
+instance CoArbitrary a => CoArbitrary (Inequality a) where
+   coarbitrary = coarbitrary . build inequalityView
+
+instance IsTerm a => IsTerm (Inequality a) where
+   toTerm = toTerm . build inequalityView
+   fromTerm a = fromTerm a >>= matchM inequalityView
+
+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 
+         x :>:  y -> x .>.  y
+         x :<=: y -> x .<=. y
+         x :>=: y -> x .>=. y
+
+inequalityTable :: [(RelationType, (a -> a -> Inequality a, a -> a -> Relation a))]
+inequalityTable = 
+   [ (LessThan, ((:<:), (.<.))), (LessThanOrEqualTo, ((:<=:), (.<=.)))
+   , (GreaterThan, ((:>:), (.>.))), (GreaterThanOrEqualTo, ((:>=:), (.>=.)))
+   ]
+
+-----------------------------------------------------------------------------
+-- OpenMath symbols
+
+eqSymbol, ltSymbol, gtSymbol, neqSymbol, leqSymbol, 
+   geqSymbol, approxSymbol :: Symbol
+eqSymbol         = toSymbol Relation1.eqSymbol
+ltSymbol         = toSymbol Relation1.ltSymbol
+gtSymbol         = toSymbol Relation1.gtSymbol
+neqSymbol        = toSymbol Relation1.neqSymbol
+leqSymbol        = toSymbol Relation1.leqSymbol
+geqSymbol        = toSymbol Relation1.geqSymbol
+approxSymbol     = toSymbol Relation1.approxSymbol
src/Domain/Math/Data/SquareRoot.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Domain/Math/DerivativeExercise.hs view
@@ -1,6 +1,6 @@ {-# OPTIONS -fno-case-merge #-}
 -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -17,14 +17,13 @@ import Domain.Math.DerivativeRules 
 import Common.Strategy (Strategy, somewhere, (<*>), alternatives, label, LabeledStrategy, try)
 import qualified Common.Strategy
+import Common.Navigator
 import Common.Context (Context, liftToContext)
 import Common.Exercise
 import Common.Transformation
 import Control.Monad
 import Domain.Math.Simplification
 import Domain.Math.Expr
-import Domain.Math.Expr.Symbols
-import Domain.Math.Expr.Parser
 
 derivativeExercise :: Exercise Expr
 derivativeExercise = makeExercise
@@ -35,6 +34,7 @@    , isReady      = noDiff
    , extraRules   = map liftToContext derivativeRules ++ [tidyup]
    , strategy     = derivativeStrategy
+   , navigation   = navigator
    , examples     = [ex1, ex2, ex3, ex4]
    }
src/Domain/Math/DerivativeRules.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -14,8 +14,6 @@ import Prelude hiding ((^))
 import Common.Transformation
 import Domain.Math.Expr
-import Domain.Math.Expr.Symbolic
-import Domain.Math.Expr.Symbols
 import Common.Rewriting
 
 derivativeRules :: [Rule Expr]
src/Domain/Math/Equation/CoverUpExercise.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -19,7 +19,7 @@ import Common.View import Control.Monad import Data.Ratio-import Domain.Math.Data.Equation+import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Equation.CoverUpRules import Domain.Math.Equation.Views@@ -36,10 +36,10 @@    { description  = "solve an equation by covering up"    , exerciseCode = makeCode "math" "coverup"    , status       = Provisional-   , parser       = parseWith (pOrList (pEquation pExpr))+   , parser       = parseExprWith (pOrList (pEquation pExpr))    , equivalence  = \_ _ -> True    , isReady      = solvedEquations-   , extraRules   = map ignoreContext coverUpRulesOr+   , extraRules   = map liftToContext coverUpRulesOr    , strategy     = coverUpStrategy    , examples     = map (orList . return) (concat (fillInResult ++ coverUpEquations))    }@@ -49,7 +49,7 @@     coverUpStrategy :: LabeledStrategy (Context (OrList (Equation Expr))) coverUpStrategy = label "Cover-up" $ -   repeat (alternatives $ map (ignoreContext . cleanUp) coverUpRulesOr)+   repeat (alternatives $ map (liftToContext . cleanUp) coverUpRulesOr)  cleanUp :: Rule (OrList (Equation Expr)) -> Rule (OrList (Equation Expr)) cleanUp = doAfter $ fmap $ fmap cleanUpExpr
src/Domain/Math/Equation/CoverUpRules.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -20,24 +20,25 @@    , coverUpPowerWith, coverUpTimesWith, coverUpNegateWith    , coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith    , coverUpNumeratorWith, coverUpDenominatorWith, coverUpSqrtWith+     -- temporarily exported+   , coverUpBinaryRule, commOp, flipOp    ) where  import Common.View import Domain.Math.Expr-import Domain.Math.Data.Equation+import Domain.Math.Data.Relation import Control.Monad.Identity import Common.Transformation-import Domain.Math.Expr.Symbols import Domain.Math.Data.OrList import Common.Traversable-import Domain.Math.Expr.Symbolic  --------------------------------------------------------------------- -- Constructors for cover-up rules -coverUpBinary2Rule :: (OnceJoin f, Switch f) => String -> (Expr -> [(Expr, Expr)]) +coverUpBinary2Rule :: (OnceJoin f, Switch f, Relational r) +                   => String -> (Expr -> [(Expr, Expr)])                     -> (Expr -> Expr -> [f Expr])-                   -> ConfigCoverUp -> Rule (f (Equation Expr))+                   -> ConfigCoverUp -> Rule (f (r Expr)) coverUpBinary2Rule opName fm fb cfg =     makeSimpleRuleList name $ onceJoinM $ \eq ->        (guard (coverLHS cfg) >> coverLeft eq) ++ @@ -46,22 +47,23 @@    name       = coverUpRuleName opName (configName cfg)    coverRight = map (fmap flipSides) . coverLeft . flipSides    -   coverLeft (lhs :==: rhs) = do-      (e1, e2) <- fm lhs+   coverLeft eq = do+      (e1, e2) <- fm (leftHandSide eq)       guard (predicateCovered  cfg e1)-      new <- fb rhs e2+      new <- fb (rightHandSide eq) e2       switch $ fmap (guard . predicateCombined cfg) new-      return (fmap (e1 :==:) new)+      return (fmap (constructor eq e1) new) -coverUpBinaryRule :: String -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr) -                  -> ConfigCoverUp -> Rule (Equation Expr)+coverUpBinaryRule :: Relational r => String +                  -> (Expr -> [(Expr, Expr)]) -> (Expr -> Expr -> Expr) +                  -> ConfigCoverUp -> Rule (r Expr) coverUpBinaryRule opName fm fb =-   let lp = makeLiftPair (return . Identity) (const . runIdentity) +   let v = makeView (return . Identity) runIdentity        fbi x y = [Identity (fb x y)]-   in lift lp . coverUpBinary2Rule opName fm fbi+   in liftRule v . coverUpBinary2Rule opName fm fbi       -coverUpUnaryRule :: String -> (Expr -> [Expr]) -> (Expr -> Expr) -               -> ConfigCoverUp -> Rule (Equation Expr)+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)  @@ -106,8 +108,8 @@    fb rhs e2 = do       n <- isNat e2       guard (n > 0)-      new1 <- canonicalM identity (makeRoot n rhs)-      new2 <- canonicalM identity (negate (makeRoot n rhs))+      let new1 = root rhs (fromIntegral n)+          new2 = (neg new1)       return $ orList $ new1 : [ new2 | new1 /= new2, even n ]        coverUpPlusWith :: ConfigCoverUp -> Rule (Equation Expr)@@ -183,9 +185,3 @@ isNat :: MonadPlus m => Expr -> m Integer isNat (Nat n) = return n isNat _       = mzero--makeRoot :: Integer -> Expr -> Expr-makeRoot n a -   | n == 1    = a-   | n == 2    = sqrt a-   | otherwise = root (fromInteger n) a
src/Domain/Math/Equation/Views.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -10,13 +10,35 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Equation.Views -   ( equationSolvedForm, solvedEquation, solvedEquations ) where+   ( solvedRelations, solvedRelation+   , equationSolvedForm, solvedEquation, solvedEquations +   , solvedRelationWith+   ) where  import Domain.Math.Expr import Domain.Math.Data.OrList-import Domain.Math.Data.Equation+import Domain.Math.Data.Relation import Common.View import Common.Traversable++-- 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) -> x `notElem` collectVars (rightHandSide r)+      (Nothing, Just x) -> x `notElem` collectVars (leftHandSide r)+      _ -> noVars (leftHandSide r) && noVars (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
src/Domain/Math/Examples/DWO1.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -14,16 +14,14 @@ module Domain.Math.Examples.DWO1    ( calculateResults, fillInResult    , coverUpEquations, linearEquations-   , quadraticEquations, higherDegreeEquations +   , quadraticEquations, findFactors    , modulusEquations, sqrtEquations, sqrtSubstEquations, brokenEquations    , simplerSqrt, simplerSqrt2, simplerSqrt3    ) where  import Prelude hiding ((^))-import Domain.Math.Data.Equation+import Domain.Math.Data.Relation import Domain.Math.Expr-import Domain.Math.Expr.Symbolic-import Domain.Math.Expr.Symbols  calculateResults :: [[Expr]] calculateResults = [level1, level2, level3]@@ -296,21 +294,23 @@       , (1-x)^2     :==: x+2       ] -higherDegreeEquations :: [Equation Expr]-higherDegreeEquations = +-- Ontbinden in factoren (VWO B, hoofdstuk 1)+findFactors :: [[Expr]]+findFactors =    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+   [ -- (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
src/Domain/Math/Examples/DWO2.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -15,17 +15,31 @@  import Prelude hiding ((^)) import Domain.Math.Expr-import Domain.Math.Data.Equation+import Domain.Math.Data.Relation -data InEq a = a :<: a | a :>: a+--------------------------------------------------------------------+-- Algemene applet -infix 1 :<:, :>:+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 :: [[InEq Expr]]+ineqLin1 :: [[Inequality Expr]] ineqLin1 =    let a = Var "a" in    let x = Var "x" in@@ -49,8 +63,8 @@ -- Havo B Voorkennis: kwadratische ongelijkheden  -- (door eerst gelijkheid op te lossen) -- (level 2 uit Hoofdstuk 3)-ineqKwad1 :: [[InEq Expr]]-ineqKwad1 =+ineqQuad1 :: [[Inequality Expr]]+ineqQuad1 =    let x = Var "x" in    [ [ x^2 +3*x-4 :<: 0      , x^2-4*x-12 :>: 0@@ -70,7 +84,7 @@  -- Havo B hoofdstuk 3, hogeregraadsongelijkheid exact -- (door eerst gelijkheid op te lossen)-ineqHigh :: [InEq Expr]+ineqHigh :: [Inequality Expr] ineqHigh =     let x = Var "x" in    [ 2*x^3 :>: 54@@ -111,8 +125,8 @@ -- VWO A/C applets  -- hoofdstuk 2-ineqKwad2 :: [InEq Expr]-ineqKwad2 =+ineqQuad2 :: [Inequality Expr]+ineqQuad2 =    let x = Var "x" in    [ x^2 + 9*x :<: 3*x - 5    , x^2 - x :>: 12@@ -209,3 +223,13 @@       , 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 view
@@ -0,0 +1,481 @@+-----------------------------------------------------------------------------+-- 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 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/Expr.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -15,7 +15,6 @@    , module Domain.Math.Expr.Symbolic    , module Domain.Math.Expr.Symbols    , module Domain.Math.Expr.Views-   , module Domain.Math.Expr.Conversion    ) where  import Domain.Math.Expr.Data@@ -23,4 +22,3 @@ import Domain.Math.Expr.Symbolic import Domain.Math.Expr.Symbols import Domain.Math.Expr.Views-import Domain.Math.Expr.Conversion
− src/Domain/Math/Expr/Conversion.hs 
@@ -1,105 +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 Domain.Math.Expr.Conversion where--import Domain.Math.Expr.Data-import Domain.Math.Expr.Symbolic-import Domain.Math.Expr.Symbols-import Domain.Math.Data.Equation-import Domain.Math.Data.OrList-import Text.OpenMath.Object-import Common.View-import Control.Monad-import Data.Maybe-import Data.List---------------------------------------------------------------------------- Type class for expressions--class IsExpr a where-   toExpr   :: a -> Expr-   fromExpr :: MonadPlus m => Expr -> m a-   exprView :: View Expr a--   -- default definitions-   toExpr   = build exprView-   fromExpr = maybe (fail "not an expression") return . match exprView-   exprView = makeView fromExpr toExpr--instance IsExpr Expr where-   exprView = identity-   -instance IsExpr a => IsExpr [a] where-   toExpr = function listSymbol . map toExpr-   fromExpr expr = isSymbol listSymbol expr >>= mapM fromExpr--instance (IsExpr a, IsExpr b) => IsExpr (Either a b) where-   toExpr = either toExpr toExpr-   fromExpr expr =-      liftM Left  (fromExpr expr) `mplus`-      liftM Right (fromExpr expr)-   ----------------------------------------------------------------- Conversions to the Expr data type--instance IsExpr a => IsExpr (Equation a) where-   toExpr (x :==: y) = binary eqSymbol (toExpr x) (toExpr y)-   fromExpr expr = do-      (e1, e2) <- isBinary eqSymbol expr-      liftM2 (:==:) (fromExpr e1) (fromExpr e2)-   -instance IsExpr a => IsExpr (OrList a) where-   toExpr ors = -      case disjunctions ors of-         Just []  -> symbol falseSymbol-         Just [x] -> toExpr x-         Just xs  -> function orSymbol (map toExpr xs)-         Nothing  -> symbol trueSymbol --   fromExpr expr = do-      xs <- isSymbol orSymbol expr-      ys <- mapM fromExpr xs-      return (orList ys)-    `mplus` do-      guard (isConst falseSymbol expr) >> return false-    `mplus` do-      guard (isConst trueSymbol  expr) >> return true-    `mplus`-      liftM return (fromExpr expr)-      ----------------------------------------------------------------- Symbol Conversion to/from OpenMath--toOMOBJ :: Expr -> OMOBJ-toOMOBJ (Var x) = OMV x-toOMOBJ (Nat n) = OMI n-toOMOBJ expr    =-   case getFunction expr of-      Just (s, []) -> -         OMS s  -      Just (s, [Var x, e]) | s == lambdaSymbol -> -         OMBIND (OMS lambdaSymbol) [x] (toOMOBJ e)-      Just (s, xs) -> -         OMA (OMS s:map toOMOBJ xs)-      Nothing -> -         error $ "toOMOBJ: " ++ show expr--fromOMOBJ :: OMOBJ -> Expr-fromOMOBJ omobj =-   case omobj of-      OMI n -> fromInteger n-      OMV x -> Var x-      OMS s -> symbol s-      OMA (OMS s:xs) -> function s (map fromOMOBJ xs)-      OMBIND (OMS s) [x] body ->-         binary s (Var x) (fromOMOBJ body)-      _ -> symbol $ Symbol Nothing $ show omobj
src/Domain/Math/Expr/Data.hs view
@@ -1,5 +1,6 @@+{-# OPTIONS -XDeriveDataTypeable #-} -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -11,15 +12,20 @@ ----------------------------------------------------------------------------- module Domain.Math.Expr.Data where -import Data.Char  (isDigit, isAlphaNum)+import Data.Char (isAlphaNum) import Data.Ratio+import Data.Typeable import Test.QuickCheck import Control.Monad import Common.Uniplate-import Common.Rewriting hiding (operators, match)+import Common.Utils (commaList)+import Common.View+import Common.Rewriting hiding (operators) import Domain.Math.Expr.Symbolic import Domain.Math.Expr.Symbols +import qualified Common.Rewriting.Term as Term+ ----------------------------------------------------------------------- -- Expression data type @@ -29,13 +35,15 @@           | Expr :-: Expr           | Negate Expr           | Nat Integer-            -- Fractional & Floating+            -- Fractional           | Expr :/: Expr+            -- Floating-point           | Sqrt Expr+          | Number Double -- positive only             -- Symbolic           | Var String           | Sym Symbol [Expr]-   deriving (Eq, Ord)+   deriving (Eq, Ord, Typeable)  ----------------------------------------------------------------------- -- Numeric instances (and symbolic)@@ -109,6 +117,11 @@          Sym s as -> return (s, as)          _ -> mzero +fromDouble :: Double -> Expr+fromDouble d+   | d < 0     = negate (Number (abs d))+   | otherwise = Number d+ ----------------------------------------------------------------------- -- Uniplate instance @@ -128,6 +141,7 @@       {-       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 . coarbitrary a . coarbitrary b@@ -136,9 +150,10 @@          Negate a -> variant 3 . coarbitrary a          Nat n    -> variant 4 . coarbitrary n          a :/: b  -> variant 5 . coarbitrary a . coarbitrary b-         Sqrt a   -> variant 6 . coarbitrary a-         Var s    -> variant 7 . coarbitrary s-         Sym f xs -> variant 8 . coarbitrary (show f) . coarbitrary xs+         Number d -> variant 6 . coarbitrary d+         Sqrt a   -> variant 7 . coarbitrary a+         Var s    -> variant 8 . coarbitrary s+         Sym f xs -> variant 9 . coarbitrary (show f) . coarbitrary xs    symbolGenerator :: (Int -> [Gen Expr]) -> [(Symbol, Maybe Int)] -> Int -> Gen Expr symbolGenerator extras syms = f @@ -169,7 +184,8 @@ showExpr :: OperatorTable -> Expr -> String showExpr table = rec 0   where-   rec _ (Nat n) = show n+   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 ++ "\""@@ -178,32 +194,36 @@          -- To do: remove special case for sqrt          Just (s, [a, b]) | s == rootSymbol && 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) $ concat [rec n x, op, rec (n+1) y]                (Just (InfixRight, n, op), [x, y]) ->                    parIf (i>n) $ concat [rec (n+1) x, op, rec n y]-               (Just (Prefix, n, op), [x]) -> -- i>=5 prevents "3--5"+               (Just (InfixNon, n, op), [x, y]) -> +                  parIf (i>n) $ concat [rec (n+1) x, op, rec (n+1) y]+               (Just (PrefixNon, n, op), [x]) ->                   parIf (i>=n) $ concat [op, rec (n+1) x]                _ -> -                  parIf (not (null as) && i>10000) $ unwords (show s : map (rec 10001) as)+                  parIf (not (null as) && i>10000) $ unwords (showSymbol s : map (rec 10001) as)          Nothing ->              error "showExpr" +   showSymbol s+      | s == rootSymbol = "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 ++ ")" -instance MetaVar Expr where-   metaVar n = Var ('_' : show n)-   isMetaVar (Var ('_':is)) | not (null is) && all isDigit is = Just (read is)-   isMetaVar _ = Nothing- instance ShallowEq Expr where    shallowEq (Nat a) (Nat b) = a == b    shallowEq (Var a) (Var b) = a == b+   shallowEq (Number a) (Number b) = a == b    shallowEq expr1 expr2 =       case (getFunction expr1, getFunction expr2) of          (Just (s1, as), Just (s2, bs)) -> @@ -211,6 +231,44 @@          _ -> False   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) -> Term.makeConTerm 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 Term.getSpine t of+         (Term.Con 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 = isSymbol listSymbol a >>= mapM fromTerm++toExpr :: IsTerm a => a -> Expr+toExpr a =+   case fromTerm (toTerm a) of+      Just expr -> expr+      Nothing   -> error "Invalid term"++fromExpr :: (MonadPlus m, IsTerm a) => Expr -> m a+fromExpr = fromTerm . toTerm++exprView :: IsTerm a => View Expr a+exprView = makeView fromExpr toExpr  ----------------------------------------------------------------------- -- AC Theory for expression
src/Domain/Math/Expr/Parser.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -10,58 +10,37 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Expr.Parser -   ( scannerExpr, parseExpr, parseWith, pExpr+   ( scannerExpr, parseExpr, parseExprWith, pExpr    , pEquations, pEquation, pOrList, pFractional+   , pRelation, pLogic, pLogicRelation    ) where  import Prelude hiding ((^))-import Text.Parsing hiding (pParens)+import Text.Parsing import Control.Monad-import Data.List-import Data.Maybe import Common.Transformation-import Domain.Math.Data.Equation+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.Symbolic import Domain.Math.Expr.Symbols import Domain.Math.Data.OrList import Test.QuickCheck (arbitrary) -import Text.OpenMath.Dictionary.Arith1-import Text.OpenMath.Dictionary.Logic1-import Text.OpenMath.Dictionary.Relation1-import Text.OpenMath.Dictionary.Calculus1-import Text.OpenMath.Dictionary.Fns1-import Text.OpenMath.Dictionary.Transc1--symbols :: [Symbol]-symbols = nubBy (\x y -> symbolName x == symbolName y) $ -   concat dictionaries--dictionaries :: [[Symbol]]-dictionaries = -   [ arith1List, logic1List, relation1List, calculus1List-   , fns1List, transc1List-   ]--dictionaryNames :: [String]-dictionaryNames = mapMaybe dictionary (concatMap (take 1) dictionaries)- scannerExpr :: Scanner scannerExpr = defaultScanner -   { keywords          = "sqrt" : map symbolName symbols ++ dictionaryNames-   , keywordOperators  = ["==" ]-   , specialCharacters = "+-*/^()[]{},."+   { keywords             = ["sqrt", "root", "and", "or", "true", "false"]+   , keywordOperators     = ["==", "<=", ">=", "<", ">", "~=", "+", "-", "*", "^", "/"]+   , operatorCharacters   = "+-*/^.=<>~"+   , qualifiedIdentifiers = True    } -parseWith :: TokenParser a -> String -> Either SyntaxError a-parseWith p = f . parse p . scanWith scannerExpr- where -   f (e, []) = Right e-   f (_, xs) = Left $ ErrorMessage $ unlines $ map show xs+parseExprWith :: TokenParser a -> String -> Either String a+parseExprWith = parseWithM scannerExpr -parseExpr :: String -> Either SyntaxError Expr-parseExpr = parseWith pExpr+parseExpr :: String -> Either String Expr+parseExpr = parseExprWith pExpr  pExpr :: TokenParser Expr pExpr = expr6@@ -69,7 +48,7 @@ -- 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 -- flip ($) <$> expr6u <*> optional (flip (/) <$ pKey "/" <*> expr6u) id+pFractional = expr6u   expr6, expr6u, expr7, expr8, term, atom :: TokenParser Expr expr6  =  pChainl ((+) <$ pKey "+" <|> (-) <$ pKey "-") expr6u@@ -79,25 +58,18 @@ term   =  symb <*> pList atom       <|> atom atom   =  fromInteger <$> pInteger-      <|> (Var . fst) <$> pVarid+      <|> Number <$> pReal +      <|> Var <$> pVarid       <|> pParens pExpr  symb :: TokenParser ([Expr] -> Expr)-symb =  unqualifiedSymb-    <|> qualifiedSymb+symb = qualifiedSymb     -- To fix: sqrt expects exactly one argument     <|> (\xs -> function rootSymbol (xs ++ [2])) <$ pKey "sqrt" --unqualifiedSymb :: TokenParser ([Expr] -> Expr)-unqualifiedSymb = pChoice (map (\s -> function s <$ pKey (symbolName s)) symbols)+    <|> function rootSymbol <$ pKey "root"  qualifiedSymb :: TokenParser ([Expr] -> Expr)-qualifiedSymb = pChoice (map f dictionaries)- where-   f xs = case map dictionary xs of-             Just d:_ -> pKey d <* pSpec '.' *> pChoice (map g xs)-             _        -> pFail-   g s  = function s <$ pKey (symbolName s)+qualifiedSymb = (function . uncurry makeSymbol) <$> (pQVarid <|> pQConid)  pEquations :: TokenParser a -> TokenParser (Equations a) pEquations = pLines True . pEquation@@ -105,6 +77,24 @@ 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 @@ -113,8 +103,20 @@         <|> false  <$  pKey "false"    pSepList p q = (:) <$> p <*> pList (q *> p) -pParens :: TokenParser a -> TokenParser a-pParens p = pKey "(" *> p <* pKey ")"+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)
src/Domain/Math/Expr/Symbolic.hs view
@@ -1,5 +1,6 @@+{-# LANGUAGE TypeSynonymInstances #-} -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -10,13 +11,41 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Expr.Symbolic -   ( Symbol(..)-   , module Domain.Math.Expr.Symbolic+   ( module Domain.Math.Expr.Symbolic, Symbol    ) where  import Control.Monad-import Text.OpenMath.Symbol+import Data.Maybe+import Common.Rewriting.Term+import qualified Text.OpenMath.Symbol as OM +makeSymbol :: String -> String -> Symbol+makeSymbol = S . Just++class IsSymbol a where+   toSymbol   :: a -> Symbol+   fromSymbol :: Symbol -> a++instance IsSymbol Symbol where+   toSymbol   = id+   fromSymbol = id++instance IsSymbol String where+   toSymbol = S Nothing+   fromSymbol (S (Just a) b) = a ++ "." ++ b+   fromSymbol (S Nothing  b) = b++instance IsSymbol OM.Symbol where+   toSymbol s = S (OM.dictionary s) (OM.symbolName s) +   fromSymbol (S (Just a) b) = OM.makeSymbol a b+   fromSymbol (S Nothing  b) = OM.extraSymbol b++stringToSymbol :: String -> Symbol+stringToSymbol s = +   case break (=='.') s of+      (xs, _:ys) -> S (Just xs) ys+      _          -> S Nothing s+ ------------------------------------------------------------------- -- Type class for symbolic representations @@ -41,31 +70,52 @@       guard (s==t)       return as    -unary :: Symbolic a => Symbol -> a -> a-unary f a = function f [a]+instance Symbolic Term where +   variable    = Var+   symbol      = Con+   function    = makeConTerm+   getVariable = isVar+   getSymbol   = isCon+   getFunction = getConSpine+   +nullary :: (IsSymbol s, Symbolic a) => s -> a+nullary = symbol . toSymbol+   +unary :: (IsSymbol s, Symbolic a) => s -> a -> a+unary f a = function (toSymbol f) [a] -binary :: Symbolic a => Symbol -> a -> a -> a-binary f a b = function f [a, b]+binary :: (IsSymbol s, Symbolic a) => s -> a -> a -> a+binary f a b = function (toSymbol f) [a, b] -isConst :: Symbolic a => Symbol -> a -> Bool-isConst s = maybe False null . isSymbol s +isConst :: (IsSymbol s, Symbolic a) => s -> a -> Bool+isConst s = maybe False null . isSymbol (toSymbol s)  -isUnary :: (Symbolic a, MonadPlus m) => Symbol -> a -> m a+isVariable :: Symbolic a => a -> Bool+isVariable = isJust . getVariable++isUnary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m a isUnary s a = -   case isSymbol s a of+   case isSymbol (toSymbol s) a of       Just [x] -> return x       _ -> mzero -isBinary :: (Symbolic a, MonadPlus m) => Symbol -> a -> m (a, a)+isBinary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m (a, a) isBinary s a = -   case isSymbol s a of+   case isSymbol (toSymbol s) a of       Just [x, y] -> return (x, y)       _ -> mzero  -- left-associative by default-isAssoBinary :: (Symbolic a, MonadPlus m) => Symbol -> a -> m (a, a)+isAssoBinary :: (IsSymbol s, Symbolic a, MonadPlus m) => s -> a -> m (a, a) isAssoBinary s a =-   case isSymbol s a of+   case isSymbol (toSymbol s) a of       Just [x, y] -> return (x, y)-      Just (x:xs) | length xs > 1 -> return (x, function s xs)+      Just (x:xs) | length xs > 1 -> return (x, function (toSymbol s) xs)       _ -> mzero+      +fromTermWith :: (MonadPlus m, IsSymbol s, IsTerm a) +             => (s -> [a] -> m a) -> Term -> m a+fromTermWith f term = do+   (s, xs) <- getFunction term+   ys <- mapM fromTermM xs+   f (fromSymbol s) ys
src/Domain/Math/Expr/Symbols.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -8,54 +8,62 @@ -- Stability   :  provisional -- Portability :  portable (depends on ghc) --+-- Exports relevant OpenMath symbols, converted to the +-- Symbol data type from @Common.Rewriting@.+-- ------------------------------------------------------------------------------module Domain.Math.Expr.Symbols -   ( module Domain.Math.Expr.Symbols-     -- arith1-   , plusSymbol, timesSymbol, minusSymbol, divideSymbol-   , rootSymbol, powerSymbol-     -- logic1-   , orSymbol, trueSymbol, falseSymbol-     -- list1-   , listSymbol-     -- relation1-   , eqSymbol-     -- calculus1-   , diffSymbol-     -- nusm1-   , piSymbol-     -- fns1-   , lambdaSymbol-     -- transc1-   , sinSymbol, cosSymbol, lnSymbol-   ) where+module Domain.Math.Expr.Symbols where  import Control.Monad import Domain.Math.Expr.Symbolic-import Text.OpenMath.Symbol-import Text.OpenMath.Dictionary.Arith1-import Text.OpenMath.Dictionary.Logic1-import Text.OpenMath.Dictionary.List1-import Text.OpenMath.Dictionary.Relation1-import Text.OpenMath.Dictionary.Calculus1-import Text.OpenMath.Dictionary.Nums1-import Text.OpenMath.Dictionary.Fns1-import Text.OpenMath.Dictionary.Transc1+import Domain.Math.Data.Relation (relationSymbols) --- Check (rationalSymbol  , oms "nums1" "rational")+-- OpenMath dictionaries+import qualified Text.OpenMath.Dictionary.Arith1    as Arith1+import qualified Text.OpenMath.Dictionary.Calculus1 as Calculus1+import qualified Text.OpenMath.Dictionary.Fns1      as Fns1+import qualified Text.OpenMath.Dictionary.List1     as List1+import qualified Text.OpenMath.Dictionary.Nums1     as Nums1+import qualified Text.OpenMath.Dictionary.Transc1   as Transc1  -------------------------------------------------------------+-- Converted OpenMath symbols++plusSymbol, timesSymbol, minusSymbol, divideSymbol,+   rootSymbol, powerSymbol, negateSymbol :: Symbol+plusSymbol       = toSymbol Arith1.plusSymbol+timesSymbol      = toSymbol Arith1.timesSymbol+minusSymbol      = toSymbol Arith1.minusSymbol +divideSymbol     = toSymbol Arith1.divideSymbol+rootSymbol       = toSymbol Arith1.rootSymbol+powerSymbol      = toSymbol Arith1.powerSymbol+negateSymbol     = toSymbol Arith1.unaryMinusSymbol++sinSymbol, cosSymbol, lnSymbol :: Symbol+sinSymbol        = toSymbol Transc1.sinSymbol+cosSymbol        = toSymbol Transc1.cosSymbol+lnSymbol         = toSymbol Transc1.lnSymbol++diffSymbol, piSymbol, lambdaSymbol, listSymbol :: Symbol+diffSymbol       = toSymbol Calculus1.diffSymbol+piSymbol         = toSymbol Nums1.piSymbol+lambdaSymbol     = toSymbol Fns1.lambdaSymbol+listSymbol       = toSymbol List1.listSymbol++------------------------------------------------------------- -- Operator fixities  type OperatorTable = [(Associativity, [(Symbol, String)])] -data Associativity = InfixLeft | InfixRight | Prefix -- InfixNon | Postfix+data Associativity = InfixLeft | InfixRight | PrefixNon+                   | InfixNon    deriving (Show, Eq)  operatorTable :: OperatorTable operatorTable =+     (InfixNon, [ (s, op) | (_, (op, s)) <- relationSymbols]) :    [ (InfixLeft,  [(plusSymbol, "+"), (minusSymbol, "-")])    -- 6-   , (Prefix,     [(negateSymbol, "-")])                      -- 6++   , (PrefixNon,  [(negateSymbol, "-")])                      -- 6+    , (InfixLeft,  [(timesSymbol, "*"), (divideSymbol, "/")])  -- 7    , (InfixRight, [(powerSymbol, "^")])                       -- 8    ]@@ -63,25 +71,22 @@ ------------------------------------------------------------- -- Extra math symbols --- rename-negateSymbol = unaryMinusSymbol--absSymbol    = extraSymbol "abs"   -signumSymbol = extraSymbol "signum" -logSymbol    = extraSymbol "log"            -- in Haskell, logbase e = log-expSymbol    = extraSymbol "exp"            -- exp 1 ~= 2.718-tanSymbol    = extraSymbol "tan"       -asinSymbol   = extraSymbol "asin"   -atanSymbol   = extraSymbol "atan"   -acosSymbol   = extraSymbol "acos"   -sinhSymbol   = extraSymbol "sinh"   -tanhSymbol   = extraSymbol "tanh"   -coshSymbol   = extraSymbol "cosh"   -asinhSymbol  = extraSymbol "asinh"  -atanhSymbol  = extraSymbol "atanh" -acoshSymbol  = extraSymbol "acosh"  -bottomSymbol = extraSymbol "error"-fcompSymbol  = extraSymbol "compose"+absSymbol    = toSymbol "abs"   +signumSymbol = toSymbol "signum" +logSymbol    = toSymbol "log"            -- in Haskell, logbase e = log+expSymbol    = toSymbol "exp"            -- exp 1 ~= 2.718+tanSymbol    = toSymbol "tan"       +asinSymbol   = toSymbol "asin"   +atanSymbol   = toSymbol "atan"   +acosSymbol   = toSymbol "acos"   +sinhSymbol   = toSymbol "sinh"   +tanhSymbol   = toSymbol "tanh"   +coshSymbol   = toSymbol "cosh"   +asinhSymbol  = toSymbol "asinh"  +atanhSymbol  = toSymbol "atanh" +acoshSymbol  = toSymbol "acosh"  +bottomSymbol = toSymbol "error"+fcompSymbol  = toSymbol "compose"  ------------------------------------------------------------- -- Some match functions
src/Domain/Math/Expr/Views.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -15,7 +15,6 @@ import Common.View import Domain.Math.Expr.Data import Domain.Math.Expr.Symbols-import Control.Monad import Data.List (nub)  ------------------------------------------------------------@@ -54,6 +53,7 @@ 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@@ -141,7 +141,10 @@ productView = makeView (Just . second ($ []) . f False) g  where    f r (a :*: b)  = f r a &&& f r b-   f r (a :/: b)  = f r a &&& f (not 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:))
src/Domain/Math/Numeric/Exercises.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -18,7 +18,6 @@ import Common.Strategy import Common.View import Domain.Math.Expr-import Domain.Math.Expr.Parser import Domain.Math.Numeric.Strategies import Domain.Math.Numeric.Views import Domain.Math.Numeric.Generators@@ -30,10 +29,10 @@  numericExercise :: LabeledStrategy Expr -> Exercise Expr numericExercise s = makeExercise -   { status        = Provisional+   { status        = Alpha    , parser        = parseExpr    , equivalence   = viewEquivalent rationalView-   , strategy      = liftToContext s+   , strategy      = mapRules liftToContext s    }  naturalExercise :: Exercise Expr
src/Domain/Math/Numeric/Generators.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -20,8 +20,6 @@ import Domain.Math.Numeric.Views import Test.QuickCheck import Domain.Math.Expr-import Domain.Math.Expr.Symbols-import Domain.Math.Expr.Symbolic  ------------------------------------------------------------------- -- Generators@@ -80,6 +78,5 @@ 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))+numSymbols = (negateSymbol, Just 1)+           : zip [plusSymbol, timesSymbol, minusSymbol] (repeat (Just 2))
src/Domain/Math/Numeric/Laws.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Domain/Math/Numeric/Rules.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -14,7 +14,6 @@ import Common.Transformation import Control.Monad import Domain.Math.Expr-import Domain.Math.Expr.Symbols import Domain.Math.Numeric.Views import Common.View
src/Domain/Math/Numeric/Strategies.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
+ src/Domain/Math/Numeric/Tests.hs view
@@ -0,0 +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)+--+-----------------------------------------------------------------------------+module Domain.Math.Numeric.Tests (main) where++import Common.Apply+import Common.View+import Control.Monad+import Domain.Math.Expr+import Domain.Math.Numeric.Generators+import Domain.Math.Numeric.Strategies+import Domain.Math.Numeric.Views+import Test.QuickCheck++main :: IO ()+main = do+   putStrLn "** Correctness numeric views"+   let f v = forM_ numGenerators $ \g -> do+          quickCheck $ propIdempotence g v+          quickCheck $ propSoundness semEqDouble g v+   f integerView+   f rationalView+   f integerNormalForm+   f rationalNormalForm+   f rationalRelaxedForm+   +   putStrLn "** Normal forms"+   let f v = forM_ numGenerators $ \g ->+          quickCheck $ propNormalForm g v+   f integerNormalForm+    -- f rationalNormalForm -- no longer a normal form++   putStrLn "** Correctness generators"+   let f g v = quickCheck $ forAll (sized g) (`belongsTo` v)+   f integerGenerator integerView+   f rationalGenerator rationalView+   f ratioExprGen rationalNormalForm+   f ratioExprGenNonZero rationalNormalForm+   +   putStrLn "** View relations"+   let va .>. vb = forM_ numGenerators $ \g -> +          quickCheck $ forAll g $ \a -> +             not (a `belongsTo` va) || a `belongsTo` vb+   integerNormalForm .>. integerView+   rationalNormalForm .>. rationalRelaxedForm+   rationalRelaxedForm .>. rationalView+   integerNormalForm .>. rationalNormalForm+   integerView .>. rationalView+   +   putStrLn "** Pre/post conditions strategies"+   let f s pre post = forM_ numGenerators $ \g -> +          quickCheck $ forAll g $ \a ->+             not (a `belongsTo` pre) || applyD s a `belongsTo` post+   f naturalStrategy  integerView  integerNormalForm+   f integerStrategy  integerView  integerNormalForm+   f rationalStrategy rationalView rationalNormalForm+   f 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 a, Just b)   -> a ~= b+      (Nothing, Nothing) -> True+      _                  -> False+ where+   delta = 0.0001+ +   (~=) :: Double -> Double -> Bool+   a ~= b | abs a < delta || abs b < delta = True+          | otherwise = abs (1 - (a/b)) < delta
src/Domain/Math/Numeric/Views.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -11,8 +11,9 @@ ----------------------------------------------------------------------------- module Domain.Math.Numeric.Views    ( integralView, realView-   , integerView, rationalView, doubleView-   , integerNormalForm, rationalNormalForm, rationalRelaxedForm, fractionForm+   , integerView, rationalView, doubleView, mixedFractionView+   , integerNormalForm, rationalNormalForm, mixedFractionNormalForm+   , rationalRelaxedForm, fractionForm    , intDiv, fracDiv, exprToNum    ) where @@ -44,7 +45,8 @@       | s == powerSymbol = do            let ry = toRational y            guard (denominator ry == 1)-           return (x Prelude.^ numerator ry)+           let a = x Prelude.^ abs (numerator ry)+           return (if numerator ry < 0 then 1/a else a)    f _ _ = Nothing     integerView :: View Expr Integer@@ -53,10 +55,23 @@ rationalView :: View Expr Rational rationalView = makeView (match realView) fromRational --- No floating view+mixedFractionView :: View Expr Rational+mixedFractionView = makeView (match realView) 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 = makeView (exprToNum doubleSym)-                      (fromRational . flip approxRational 0.0001)+doubleView = makeView 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 @@ -68,15 +83,36 @@    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 = makeView (optionNegate f) fromRational+rationalNormalForm = makeView f fromRational  where   -   f (Nat a :/: Nat b) = do-      guard (a > 0 && b > 1 && gcd a b == 1)-      Just (fromInteger a / fromInteger b)-   f (Nat n) = Just (fromInteger n)-   f _       = Nothing+   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 = makeView 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 = makeView f (\(a, b) -> (fromInteger a :/: fromInteger b))  where@@ -119,17 +155,22 @@ exprToNum :: (Monad m, Num a) => (Symbol -> [a] -> m a) -> Expr -> m a exprToNum f = rec   where-   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  -> do x <- rec a; y <- rec b; f divideSymbol [x, y]-         Sqrt a   -> do x <- rec a; f rootSymbol [x, 2]-         Var _    -> fail "exprToNum: variable"+   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
src/Domain/Math/Polynomial/BuggyRules.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -14,9 +14,10 @@ module Domain.Math.Polynomial.BuggyRules where  import Domain.Math.Expr-import Domain.Math.Data.Equation+import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Polynomial.Views+import Domain.Math.Polynomial.Rules (abcFormula) import Domain.Math.Numeric.Views import Common.View import Common.Transformation@@ -24,11 +25,13 @@ import Control.Monad  abcBuggyRules :: [Rule (OrList (Equation Expr))]-abcBuggyRules = [ minusB, twoA, minus4AC, oneSolution ]+abcBuggyRules = map f [ minusB, twoA, minus4AC, oneSolution ]+ where+   f r = r { ruleSiblings = [name abcFormula] }  abcMisconception :: (String -> Rational -> Rational -> Rational -> [OrList (Equation Expr)])                  -> Transformation (OrList (Equation Expr))-abcMisconception f = makeTransList "abc misconception" $ +abcMisconception f = makeTransList $     onceJoinM $ \(lhs :==: rhs) -> do       guard (rhs == 0)       (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs
src/Domain/Math/Polynomial/CleanUp.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -10,30 +10,46 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.CleanUp -   ( cleanUp, cleanUpExpr, cleanUpExpr2, cleanUpSimple, collectLikeTerms+   ( cleanUp, cleanUpRelation, cleanUpExpr, cleanUpExpr2+   , cleanUpSimple, collectLikeTerms    , normalizeSum, normalizeProduct    ) where -import qualified Prelude-import Prelude hiding ((^), recip)-import Domain.Math.Data.SquareRoot-import Data.Maybe-import Common.Utils-import Data.Ratio-import Data.List-import Control.Monad+import Common.Uniplate import Common.View-import Domain.Math.Numeric.Views+import Control.Monad+import Data.List+import Data.Maybe+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.Views-import Domain.Math.SquareRoot.Views-import Common.Uniplate import Domain.Math.Simplification (smartConstructors)-import Domain.Math.Data.Equation-import Domain.Math.Data.OrList-import qualified Domain.Math.Data.SquareRoot as SQ+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)+      | a Prelude.^ y == x  = fromIntegral a+      | otherwise           = root (fromIntegral x) (fromIntegral y)+    where+      a = round (fromIntegral x ** (1 / fromIntegral y))++---------------------------------------------------------------------- -- Expr normalization  collectLikeTerms :: Expr -> Expr@@ -76,6 +92,7 @@ ------------------------------------------------------------ -- Testing +{- -- List with hard cases hardCases = map cleanUpExpr $ let x=Var "x" in   [ -1/2*x*(x/1)@@ -93,7 +110,7 @@   , (-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-  ]+  ] -}            ------------------------------------------------------------ -- Cleaning up@@ -105,7 +122,10 @@    f1    = simplify rationalView    f2    = use identity    f4    = smartConstructors-   ++cleanUpRelation :: OrList (Relation Expr) -> OrList (Relation Expr)+cleanUpRelation = simplifyWith cleanUp (switchView equationView)+ cleanUp :: OrList (Equation Expr) -> OrList (Equation Expr) cleanUp = idempotent . join . fmap (keepEquation . fmap cleanUpExpr) @@ -139,7 +159,7 @@        ------------------------------------------------------------ -- Technique 1: fixed points of views-+{- cleanUpFix :: Expr -> Expr cleanUpFix = fixpoint (f4 . f3 . f2 . f1)  where@@ -149,7 +169,7 @@    f2 = use (squareRootViewWith rationalView)    f3 = use (powerFactorViewWith rationalView)    f4 = smartConstructors-+-} assoPlus :: View Expr a -> [Expr] -> [Expr] assoPlus v = rec . map (simplify v)  where@@ -161,7 +181,7 @@  ------------------------------------------------------------ -- Technique 2a: one bottom-up traversal-+{- cleanUpBU :: Expr -> Expr cleanUpBU = transform (f4 . f3 . f2 . f1)  where@@ -171,7 +191,7 @@    f2 = simplify (squareRootViewWith rationalView)    f3 = use (powerFactorViewWith rationalView)    f4 = smartConstructors-+-} ------------------------------------------------------------ -- Technique 2b: one bottom-up traversal @@ -203,17 +223,19 @@ smart :: Expr -> Expr smart (a :*: b) = a .*. b smart (a :/: b) = a ./. b-smart (Sym s [x, y]) | s == powerSymbol = x .^. y+smart expr@(Sym s [x, y]) +   | s == powerSymbol = x .^. y+   | s == rootSymbol  = 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)) | i*i == n = fromInteger i- where i = SQ.isqrt n  +smart (Sqrt (Nat n)) = simplerRoot (fromIntegral n) 2 smart e = e  ------------------------------------------------------------ -- Technique 3: lattice of views-   +{- data T = R Rational         | S (SquareRoot Rational)        | P String Rational Int@@ -322,4 +344,4 @@       _ -> E e upgr (S a) = maybe (S a) R (fromSquareRoot a) upgr (P _ a n) | n==0 = R a-upgr t = t+upgr t = t -}
+ src/Domain/Math/Polynomial/Equivalence.hs view
@@ -0,0 +1,308 @@+{-# OPTIONS -XGeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- 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.Context+import Common.Traversable+import Common.View+import Data.Maybe+import Domain.Math.Data.Polynomial hiding (eval)+import Data.List (sort, nub)+import Domain.Math.Polynomial.Views+import Prelude hiding ((^), sqrt)+import Domain.Logic.Formula hiding (Var, disjunctions)+import qualified Domain.Logic.Formula as Logic+import Domain.Math.Polynomial.CleanUp+import Domain.Math.Numeric.Views+import Domain.Math.Data.Relation+import Domain.Math.Data.Interval+import Domain.Math.SquareRoot.Views+import Domain.Math.Expr+import Domain.Math.Data.SquareRoot+import Control.Monad+import Domain.Math.Clipboard+import Common.Rewriting hiding (constructor)+import Common.Uniplate++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 = f a `compare` f 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 eq a b = isJust $ do+   termA <- fromContext a+   termB <- fromContext b+   guard $ +      case (ineqOnClipboard a, ineqOnClipboard b) of +         (Just a,  Just b)  -> eq a b && eq termA termB+         (Just a,  Nothing) -> eq (fmap toEq a) termA && eq a termB+         (Nothing, Just b)  -> eq (fmap toEq b) termB && eq termA b+         (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 (noVars b && noVars (rightHandSide rel))+   return $ constructor rel a (rightHandSide rel - b)+ `mplus` do+   (a, b) <- match plusView (leftHandSide rel)+   guard (noVars a && noVars (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 && noVars (rightHandSide rel))+   let expr = cleanUpExpr2 (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 a b = rec (fmap f a) (fmap f b)+ where+   rec a b   +      | isOperator orOperator a =+           let collect = nub . sort . trueOr . collectOr+           in recList (collect a) (collect b)+      | isOperator andOperator 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+   +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 = f (map (substitute pair) cs)+ where +   (cs, f) = uniplate 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/Exercises.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -11,22 +11,29 @@ ----------------------------------------------------------------------------- module Domain.Math.Polynomial.Exercises where -import Domain.Math.Polynomial.Rules-import Domain.Math.Polynomial.Strategies-import Domain.Math.Polynomial.Views-import Domain.Math.Polynomial.CleanUp-import Domain.Math.Polynomial.BuggyRules+import Domain.Math.Approximation+import Common.Context import Common.Exercise import Common.Rewriting-import Domain.Math.Data.Equation-import Domain.Math.Equation.Views-import Domain.Math.Expr+import Common.Strategy+import Common.Traversable+import Common.Transformation+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.Expr.Parser-import Common.View-import Common.Context-import Data.List+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 Control.Monad  ------------------------------------------------------------ -- Exercises@@ -36,64 +43,185 @@    { description  = "solve a linear equation"    , exerciseCode = makeCode "math" "lineq"    , status       = Provisional-   , parser       = parseWith (pEquation pExpr)-   , similarity   = eqEquation cleanUpSimple+   , parser       = parseExprWith (pEquation pExpr)+   , similarity   = eqRelation cleanUpSimple    , equivalence  = viewEquivalent linearEquationView-   , isReady      = solvedEquation-   , extraRules   = linearRules-   , strategy     = ignoreContext linearStrategy-   , examples     = concat linearEquations+   , isSuitable   = (`belongsTo` linearEquationView)+   , isReady      = solvedRelationWith $ \a -> +                       a `belongsTo` mixedFractionNormalForm || +                       a `belongsTo` rationalNormalForm+   , extraRules   = liftToContext buggyPlus : linearRules+   , strategy     = mapRules liftToContext linearStrategy+   , 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 +   { description  = "solve a linear equation with mixed fractions"+   , exerciseCode = makeCode "math" "lineq-mixed"+   , isReady      = solvedRelationWith (`belongsTo` mixedFractionNormalForm)+   , strategy     = mapRules liftToContext linearMixedStrategy+   }  -quadraticExercise :: Exercise (OrList (Equation Expr))+quadraticExercise :: Exercise (OrList (Relation Expr)) quadraticExercise = makeExercise     { description  = "solve a quadratic equation"    , exerciseCode = makeCode "math" "quadreq"    , status       = Provisional-   , parser       = parseWith (pOrList (pEquation pExpr))+   , parser       = \input -> case parseExprWith (pOrList (pEquation pExpr)) input of+                                 Left err -> Left err+                                 Right xs -> Right (build (switchView equationView) xs)    , similarity   = eqOrList cleanUpExpr2-   , equivalence  = viewEquivalent quadraticEquationsView-   , isReady      = solvedEquations-   , extraRules   = map ignoreContext $ quadraticRules ++ abcBuggyRules-   , strategy     = ignoreContext quadraticStrategy-   , examples     = map (orList . return) (concat quadraticEquations)+   , equivalence  = equivalentRelation (viewEquivalent quadraticEquationsView)+   , isSuitable   = (`belongsTo` (switchView equationView >>> quadraticEquationsView))+   , isReady      = solvedRelations+   , extraRules   = map (liftToContext . liftRule (switchView equationView)) $ +                       quadraticRules ++ abcBuggyRules+   , strategy     = quadraticStrategy+   , examples     = map (orList . return . build equationView) (concat quadraticEquations)    }    -higherDegreeExercise :: Exercise (OrList (Equation Expr))+higherDegreeExercise :: Exercise (OrList (Relation Expr)) higherDegreeExercise = makeExercise -   { description  = "solve an equation (higher degree)"-   , exerciseCode = makeCode "math" "higherdegree"+   { description   = "solve an equation (higher degree)"+   , exerciseCode  = makeCode "math" "higherdegree"+   , status        = Provisional+   , parser        = parser quadraticExercise+   , similarity    = eqOrList cleanUpExpr2+   , eqWithContext = Just $ eqAfterSubstitution $ +                        equivalentRelation (viewEquivalent higherDegreeEquationsView)+   , isSuitable    = (`belongsTo` (switchView equationView >>> higherDegreeEquationsView))+   , isReady       = solvedRelations+   , extraRules    = map (liftToContext . liftRule (switchView equationView)) higherDegreeRules+   , strategy      = higherDegreeStrategy+   , examples      = map (orList . return . build equationView) +                        (concat $ higherEq1 ++ higherEq2 ++ [higherDegreeEquations])+   }+   +quadraticNoABCExercise :: Exercise (OrList (Relation Expr))+quadraticNoABCExercise = quadraticExercise+   { description  = "solve a quadratic equation without abc-formula"+   , exerciseCode = makeCode "math" "quadreq-no-abc"+   , status       = Alpha+   , strategy     = configure cfg quadraticStrategy+   }+ where+   cfg = [ (ByName (name prepareSplitSquare), Reinsert)+         , (ByName (name bringAToOne), Reinsert)+         , (ByName "abc form", Remove)+         , (ByName (name simplerPoly), Remove)+         ]+         +quadraticWithApproximation :: Exercise (OrList (Relation Expr))+quadraticWithApproximation = quadraticExercise+   { description  = "solve a quadratic equation with approximation"+   , exerciseCode = makeCode "math" "quadreq-with-approx"+   , status       = Alpha+   , parser       = parseExprWith (pOrList (pRelation pExpr))+   , strategy     = configure cfg quadraticStrategy+   , equivalence  = equivalentApprox+   }+ where+   cfg = [ (ByName "approximate result", Reinsert)+         , (ByName "square root simplification", Remove)+         ]++-- fixMe = checksForList quadraticWithApproximation++findFactorsExercise :: Exercise Expr+findFactorsExercise = makeExercise+   { description  = "factorize the expression"+   , exerciseCode = makeCode "math" "factor"    , status       = Provisional-   , parser       = parseWith (pOrList (pEquation pExpr))-   , similarity   = eqOrList cleanUpExpr2-   , equivalence  = viewEquivalent higherDegreeEquationsView-   , isReady      = solvedEquations-   , extraRules   = map ignoreContext higherDegreeRules-   , strategy     = ignoreContext higherDegreeStrategy-   , examples     = map (orList . return) higherDegreeEquations+   , parser       = parseExprWith pExpr+   , similarity   = \a b -> cleanUpExpr a == cleanUpExpr b+   , equivalence  = viewEquivalent (polyViewWith rationalView)+   , isReady      = (`belongsTo` linearFactorsView)+   , strategy     = mapRules liftToContext findFactorsStrategy+   , 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 -eqOrList :: (Expr -> Expr) -> OrList (Equation Expr) -> OrList (Equation Expr) -> Bool+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 (a :==: b) =+      let f x = case match doubleView x of+                   Just d  -> Number (precision 4 d)+                   Nothing -> x+      in f a .~=. f b+      +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)+   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 -eqEquation :: (Expr -> Expr) -> Equation Expr -> Equation Expr -> Bool-eqEquation f x y = normEquation f x == normEquation f y+eqRelation :: (Relational f, Eq (f Expr)) => +                 (Expr -> Expr) -> f Expr -> f Expr -> Bool+eqRelation f x y = normRelation f x == normRelation f y -normOrList :: (Expr -> Expr) -> OrList (Equation Expr) -> OrList (Equation Expr)-normOrList f = normalize . fmap (normEquation f)+normOrList :: (Relational f, Ord (f Expr)) => +                 (Expr -> Expr) -> OrList (f Expr) -> OrList (f Expr)+normOrList f = normalize . fmap (normRelation f) -normEquation :: (Expr -> Expr) -> Equation Expr -> Equation Expr-normEquation f eq-   | a <= b    = a :==: b-   | otherwise = b :==: a+normRelation :: Relational f => (Expr -> Expr) -> f Expr -> f Expr+normRelation f rel+   | leftHandSide new > rightHandSide new && isSymmetric new = flipSides new+   | otherwise = new  where-   a :==: b = fmap (normExpr f) eq+   new = fmap (normExpr f) rel  normExpr :: (Expr -> Expr) -> Expr -> Expr normExpr f = normalizeWith [plusOperator, timesOperator] . f  where    plusOperator  = acOperator (+) isPlus    timesOperator = acOperator (*) isTimes+   +-- TODO: move this definition+buggyPlus :: Rule (Equation Expr)+buggyPlus = buggyRule $ makeSimpleRuleList "buggy 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 ]
src/Domain/Math/Polynomial/Generators.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -16,7 +16,6 @@ 
 import Prelude hiding ((^))
 import Domain.Math.Expr
-import Domain.Math.Expr.Symbols
 import Domain.Math.Numeric.Generators
 import Test.QuickCheck
 import Control.Monad
+ src/Domain/Math/Polynomial/IneqExercises.hs view
@@ -0,0 +1,301 @@+-----------------------------------------------------------------------------+-- 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.Strategy hiding (not)+import Common.Transformation+import Common.Uniplate (uniplate)+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((:||:), (:&&:)))+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, normRelation)+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++ineqLinearExercise :: Exercise (Relation Expr)+ineqLinearExercise = makeExercise +   { description  = "solve a linear inequation"+   , exerciseCode = makeCode "math" "linineq"+   , status       = Provisional+   , parser       = parseExprWith (pRelation pExpr)+   , isReady      = solvedRelation+   , equivalence  = linEq+   , similarity   = eqRelation cleanUpExpr2+   , strategy     = mapRules liftToContext ineqLinear+   , 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 +   { description   = "solve a quadratic inequation"+   , exerciseCode  = makeCode "math" "quadrineq"+   , status        = Provisional+   , parser        = parseExprWith (pLogicRelation pExpr)+   , prettyPrinter = showLogicRelation+   , isReady       = solvedRelations+   , eqWithContext = Just quadrEqContext+   , similarity    = simLogic (normRelation cleanUpExpr2 . flipGT)+   , strategy      = ineqQuadratic+   , examples      = map (Logic.Var . build inequalityView) +                         (concat $ ineqQuad1 ++ [ineqQuad2, extraIneqQuad])+   }++ineqHigherDegreeExercise :: Exercise (Logic (Relation Expr))+ineqHigherDegreeExercise = makeExercise +   { description   = "solve an inequation of higher degree"+   , exerciseCode  = makeCode "math" "ineqhigherdegree"+   , status        = Provisional+   , parser        = parseExprWith (pLogicRelation pExpr)+   , prettyPrinter = showLogicRelation+   , isReady       = solvedRelations+   , eqWithContext = Just highEqContext+   , similarity    = simLogic (normRelation cleanUpExpr2 . flipGT)+   , strategy      = ineqHigherDegree+   , examples      = map (Logic.Var . build inequalityView) ineqHigh+   }++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 ineq       = ineq+      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 f b = if b then (.<=.) else (.<.)+      in Logic.Var (f o1 x y) :&&: Logic.Var (f o2 y z)+++ineqLinear :: LabeledStrategy (Relation Expr)+ineqLinear = cleanUpStrategy (fmap cleanUpSimple) $+   label "Linear inequation" $+      label "Phase 1" (repeat (+             removeDivision+         <|> ruleMulti (ruleSomewhere distributeTimes)+         <|> ruleMulti merge))+      <*>  +      label "Phase 2" (+         try varToLeft +         <*> try (coverUpPlus id)+         <*> try flipSign+         <*> try coverUpTimesPositive)++-- helper strategy+coverUpPlus :: (Rule (Relation Expr) -> Rule a) -> Strategy a+coverUpPlus f = alternatives $ map (f . ($ oneVar))+   [ coverUpBinaryRule "plus" (commOp . isPlus) (-) +   , coverUpBinaryRule "minus left" isMinus (+)+   , coverUpBinaryRule "minus right" (flipOp . isMinus) (flip (-))+   ] -- [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith]+   +coverUpTimesPositive :: Rule (Relation Expr)+coverUpTimesPositive = coverUpBinaryRule "times positive" (commOp . m) (/) varConfig+ where+   m expr = do+      (a, b) <- matchM timesView expr+      r <- matchM rationalView a+      guard (r>0)+      return (a, b)+      +flipSign :: Rule (Relation Expr)+flipSign = makeSimpleRule "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 = label "Quadratic inequality" $ +   try (liftRule (contextView (orView >>> justOneView)) turnIntoEquation) +   <*> mapRules (liftRule (contextView orView)) quadraticStrategy+   <*> solutionInequation++ineqHigherDegree :: LabeledStrategy (Context (Logic (Relation Expr)))+ineqHigherDegree = label "Inequality of a higher degree" $ +   try (liftRule (contextView (orView >>> justOneView)) turnIntoEquation) +   <*> mapRules (liftRule (contextView orView)) higherDegreeStrategy+   <*> solutionInequation++justOneView :: View (OrList a) a+justOneView = makeView (f . disjunctions) return+ where+   f (Just [r]) = Just r+   f _          = Nothing++turnIntoEquation :: Rule (Context (Relation Expr))+turnIntoEquation = makeSimpleRule "turn into 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 = makeSimpleRule "solution inequation" $ withCM $ \r -> do+   ineq <- lookupClipboard "ineq" >>= fromExpr+   removeClipboard "ineq"+   orv  <- maybeCM (matchM orView r)+   case disjunctions orv of +      Nothing -> -- both sides are the same+         if relationType ineq `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]+         then return Logic.T+         else return Logic.F+      Just [] -> do -- no solutions found for equations+         let vs = collectVars (toExpr ineq)+         guard (not (null vs))+         if evalIneq ineq (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 ineq `elem` [GreaterThanOrEqualTo, LessThanOrEqualTo]+         return $ fromIntervals v fromDExpr $ +            fromList [ this | (d, isP, this) <- rs, isP || evalIneq ineq 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)) (use leftHandSide) (use rightHandSide)+    where+      use 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 = build (map sub cs)+       where (cs, build) = uniplate 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/Rules.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -13,33 +13,37 @@  import Common.Apply import Common.Context+import Common.Rewriting import Common.Transformation import Common.Traversable-import Common.Uniplate (universe)+import Common.Uniplate (universe, uniplate) import Common.Utils-import Common.View+import Common.View hiding (simplify) import Control.Monad import Data.List (nub, (\\), sort, sortBy) import Data.Maybe import Data.Ratio-import Domain.Math.Data.Equation+import Domain.Math.Approximation (precision)+import Domain.Math.Clipboard 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.CleanUp import Domain.Math.Polynomial.Views import Domain.Math.Power.Views+import Domain.Math.Simplification import Prelude hiding (repeat, (^), replicate)+import qualified Domain.Math.Data.Polynomial as P import qualified Domain.Math.SquareRoot.Views as SQ-import qualified Prelude  ------------------------------------------------------------ -- Rule collection  linearRules :: [Rule (Context (Equation Expr))]-linearRules = map ignoreContext $-   [ removeDivision, ruleMulti merge, ruleMulti distributeTimes+linearRules = map liftToContext $+   [ removeDivision, ruleMulti merge, ruleMulti distributeTimesSomewhere    , varToLeft, coverUpNegate, coverUpTimes    ] ++    map ($ oneVar) @@ -47,22 +51,23 @@   quadraticRules :: [Rule (OrList (Equation Expr))]-quadraticRules = +quadraticRules = -- abcFormula    [ ruleOnce commonFactorVar, ruleOnce noLinFormula, ruleOnce niceFactors-   , ruleOnce simplerA, abcFormula, mulZero, coverUpPower, squareBothSides+   , ruleOnce simplerPoly, mulZero, coverUpPower, squareBothSides    ] ++    map (ruleOnce . ($ oneVar))       [coverUpPlusWith, coverUpMinusLeftWith, coverUpMinusRightWith] ++    [ ruleOnce coverUpTimes, ruleOnce coverUpNegate, ruleOnce coverUpNumerator+   , ruleOnce prepareSplitSquare, ruleOnce factorLeftAsSquare    , ruleOnce2 (ruleSomewhere merge), ruleOnce cancelTerms-   , ruleOnce2 (ruleSomewhere distributeTimes)+   , ruleOnce2 distributeTimesSomewhere    , ruleOnce2 (ruleSomewhere distributionSquare), ruleOnce flipEquation     , ruleOnce moveToLeft, ruleMulti2 (ruleSomewhere simplerSquareRoot)    ]     higherDegreeRules :: [Rule (OrList (Equation Expr))] higherDegreeRules = -   [ allPowerFactors, ruleOnce2 powerFactor, sameFactor+   [ allPowerFactors, sameFactor    ] ++ quadraticRules  ------------------------------------------------------------@@ -70,14 +75,17 @@  -- ax^2 + bx = 0  commonFactorVar :: Rule (Equation Expr) -commonFactorVar = makeSimpleRule "common factor var" $ \(lhs :==: rhs) -> do-   guard (rhs == 0)-   (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs+commonFactorVar = rhsIsZero commonFactorVarNew++commonFactorVarNew :: Rule Expr+commonFactorVarNew = makeSimpleRule "common factor var" $ \expr -> do+   (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) expr    guard (c == 0 && b /= 0)    -- also search for constant factor-   let d = gcdFrac a b-   return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d)) :==: 0)+   let d = (if a<0 && b<0 then negate else id) (gcdFrac a b)+   return (fromRational d .*. Var x .*. (fromRational (a/d) .*. Var x .+. fromRational (b/d))) + -- ax^2 + c = 0 noLinFormula :: Rule (Equation Expr) noLinFormula = makeSimpleRule "no linear term b" $ \(lhs :==: rhs) -> do@@ -90,43 +98,62 @@  -- search for (X+A)*(X+B) decomposition  niceFactors :: Rule (Equation Expr)-niceFactors = makeSimpleRuleList "nice factors" $ \(lhs :==: rhs) -> do-   guard (rhs == 0)+niceFactors = rhsIsZero niceFactorsNew++-- search for (X+A)*(X+B) decomposition +niceFactorsNew :: Rule Expr+niceFactorsNew = makeSimpleRuleList "nice factors" $ \expr -> do    let sign t@(x, (a, b, c)) = if a== -1 then (x, (1, -b, -c)) else t -   (x, (a, rb, rc)) <- liftM sign (matchM (polyNormalForm rationalView >>> second quadraticPolyView) lhs)+   (x, (a, rb, rc)) <- liftM sign (matchM (polyNormalForm rationalView >>> second quadraticPolyView) expr)    guard (a==1)    b <- isInt rb    c <- isInt rc    let ok (i, j) = i+j == b        f  (i, j)            | i == j = -- special case-              (Var x + fromInteger i) ^ 2 :==: 0+              (Var x + fromInteger i) ^ 2           | otherwise =-              (Var x + fromInteger i) * (Var x + fromInteger j) :==: 0+              (Var x + fromInteger i) * (Var x + fromInteger j)    map f (filter ok (factors c)) -simplerA :: Rule (Equation Expr)-simplerA = makeSimpleRule "simpler polynomial" $ \(lhs :==: rhs) -> do+rhsIsZero :: Rule Expr -> Rule (Equation Expr)+rhsIsZero r = makeSimpleRuleList (name r) $ \(lhs :==: rhs) -> do    guard (rhs == 0)-   (x, (ra, rb, rc)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs-   [a, b, c] <- mapM isInt [ra, rb, rc] -   let d = a `gcd` b `gcd` c+   a <- applyAll r lhs+   return (a :==: rhs)++-- 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)+simplerPoly :: Rule (Equation Expr)+simplerPoly = makeSimpleRuleList "simpler polynomial" $ \(lhs :==: rhs) -> do+   guard (rhs == 0)+   let thisView = polyNormalForm rationalView >>> second quadraticPolyView+   (x, (a, b, c)) <- matchM thisView lhs+   r <- findFactor [a, b, c]+   d <- if a >= 0 then [r] else [-r, r]    guard (d `notElem` [0, 1])-   return (build quadraticView (x, fromInteger (a `div` d), fromInteger (b `div` d), fromInteger (c `div` d)) :==: 0)+   return (build thisView (x, (a*d, b*d, c*d)) :==: 0)+ where+   findFactor :: Monad m => [Rational] -> m Rational+   findFactor rs+      | null rs || any (==0) 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 -abcFormula :: Rule (OrList (Equation Expr))-abcFormula = makeSimpleRule "abc formula" $ onceJoinM $ \(lhs :==: rhs) -> do+-- Simplified variant of simplerPoly: just bring a to 1.+-- Needed for quadratic strategy without square formula+bringAToOne :: Rule (Equation Expr)+bringAToOne = makeSimpleRule "bring a to one" $ \(lhs :==: rhs) -> do    guard (rhs == 0)-   (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) lhs-   let discr = sqrt (fromRational (b*b - 4 * a * c))-   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 + discr) / (2 * fromRational a)-         , Var x :==: (-fromRational b - discr) / (2 * fromRational a)-         ]+   let thisView = polyNormalForm rationalView >>> second quadraticPolyView+   (x, (a, b, c)) <- matchM thisView lhs+   guard (a `notElem` [0, 1])+   return (build thisView (x, (1, b/a, c/a)) :==: 0)  ------------------------------------------------------------ -- General form rules: expr = 0@@ -141,7 +168,8 @@       (_, xs) <- matchM productView lhs       guard (length xs > 1)       let f e = case match (polyNormalForm rationalView >>> second linearPolyView) e of-                   Just (x, (a, b)) -- special cases (simplify immediately)+                   -- special cases (simplify immediately, as in G&R)+                   Just (x, (a, b))                        | a == 1 ->                             Var x :==: fromRational (-b)                       | a == -1 -> @@ -157,11 +185,17 @@ oneVar :: ConfigCoverUp oneVar = configCoverUp    { configName        = Just "one var"-   , predicateCovered  = (==1) . length . collectVars+   , predicateCovered  = \a -> p1 a || p2 a    , predicateCombined = noVars    , coverLHS          = True    , coverRHS          = True    }+ where +   p1 = (==1) . length . collectVars+   -- 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 (hasVars x /= hasVars y)  ------------------------------------------------------------ -- Top form rules: expr1 = expr2@@ -208,12 +242,35 @@       return $ orList [a :==: b, a :==: -b]    f _ = Nothing --- Afterwards, merge, sort, and (possibly) change sign+-- prepare splitting a square; turn lhs into x^2+bx+c such that (b/2)^2 is c+prepareSplitSquare :: Rule (Equation Expr)+prepareSplitSquare = makeSimpleRule "prepare split square" $ \(lhs :==: rhs) -> do+   d <- match rationalView rhs+   let myView = polyNormalForm rationalView >>> second quadraticPolyView+   (x, (a, b, c)) <- match myView lhs+   let newC   = (b/2)*(b/2)+       newRHS = d + newC - c+   guard (a==1 && b/=0 && c /= newC)+   return (build myView (x, (a, b, newC)) :==: build rationalView newRHS)++-- factor left-hand side into (ax + c)^2+factorLeftAsSquare :: Rule (Equation Expr)+factorLeftAsSquare = makeSimpleRule "factor left as square" $ \(lhs :==: rhs) -> do+   guard (noVars rhs)+   (x, (a, b, c)) <- match (polyNormalForm rationalView >>> second quadraticPolyView) 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 = makeSimpleRule "flip equation" $ \(lhs :==: rhs) -> do-   guard (hasVars rhs && noVars lhs)-   let new = fmap (applyListD [sortT, mergeT]) (rhs :==: lhs)-   return $ applyD signT new+flipEquation = doBeforeTrans condition $+   rule "flip equation" $ \a b ->+      (a :==: b) :~> (b :==: a)+ where+   condition = makeTrans $ \eq@(lhs :==: rhs) -> do+      guard (hasVars rhs && noVars lhs)+      return eq  -- Afterwards, merge and sort moveToLeft :: Rule (Equation Expr)@@ -226,6 +283,29 @@    let new = applyD mergeT $ applyD sortT $ lhs - rhs    return (new :==: 0) +ruleApproximate :: Rule (Relation Expr)+ruleApproximate = makeSimpleRule "approximate" $ \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 = +   ruleFromView "normalize rational number" rationalView++ruleNormalizeMixedFraction :: Rule Expr+ruleNormalizeMixedFraction = +   ruleFromView "normalize mixed fraction" mixedFractionView++ruleFromView :: Eq a => String -> View a b -> Rule a+ruleFromView s v = makeSimpleRuleList s $ \a -> do+   b <- canonicalM v a+   guard (a /= b)+   return b+ ------------------------------------------------------------ -- Helpers and Rest @@ -261,23 +341,6 @@          return $ orList [Var s :==: 0, make xs :==: make ys]       _ -> Nothing --- Factor-out variable-powerFactor :: Rule Expr-powerFactor = makeSimpleRule "power factor" $ \e -> do-   xs <- match sumView e >>= mapM (match powerFactorView)-   let (vs, as, ns) = unzip3 xs-       r = minimum ns-       v = Var (head vs)-       f a n = a*v^fromIntegral (n-r)-   unless (length xs > 1 && length (nub vs) == 1 && r >= 1) Nothing-   -- also search for gcd constant-   case mapM (match integerView) as of -      Just is | g > 1 -> -         return (fromInteger g * v^fromIntegral r * foldr1 (+) (zipWith f (map (fromIntegral . (`div` g)) is) ns))-       where g = foldr1 gcd is-      _ -> -         return (v^fromIntegral r * build sumView (zipWith f as ns))- -- A*B = A*C  implies  A=0 or B=C sameFactor :: Rule (OrList (Equation Expr)) sameFactor = makeSimpleRule "same factor" $ onceJoinM $ \(lhs :==: rhs) -> do@@ -285,7 +348,95 @@    (b2, ys) <- match productView rhs    (x, y) <- safeHead [ (x, y) | x <- xs, y <- ys, x==y, hasVars 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 = makeSimpleRule "same constant factor" $ \(lhs :==: rhs) -> do+   xs <- match sumView lhs+   ys <- match sumView rhs+   ps <- mapM (match productView) (xs ++ ys) +   let (bs, zs) = unzip ps+       (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+   con <- whichCon rs+   guard (con /= 1)+   let make b r e = build productView (b, (fromRational (r/con):e))+       (newLeft, newRight) = splitAt (length xs) (zipWith3 make bs rs es)+   return (build sumView newLeft :==: build sumView newRight)+ where+   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 = makeSimpleRule "abc formula" $ withCM $ onceJoinM $ \(lhs :==: rhs) -> do+   guard (rhs == 0)+   (x, (a, b, c)) <- matchM (polyNormalForm rationalView >>> second quadraticPolyView) 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 = makeSimpleRule "higher 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 :: (Crush f, Crush g) => Rule (Context (f (g Expr)))+substBackVar = makeSimpleRule "subst back var" $ withCM $ \a -> do+   expr <- lookupClipboard "subst"+   case fromExpr expr of+      Just (Var p :==: rhs) -> do+         guard (p `elem` concatMap collectVars (concatMap crush (crush a)))+         return (fmap (fmap (subst p rhs)) a)+      _ -> fail "no subst in clipboard"+ where+   subst a b (Var c) | a==c = b+   subst a b expr = build (map (subst a b) cs)+    where (cs, build) = uniplate expr++exposeSameFactor :: Rule (Equation Expr)+exposeSameFactor = makeSimpleRuleList "expose same factor" $ \(lhs :==: rhs) -> do +   (bx, xs) <- matchM (productView) lhs+   (by, ys) <- matchM (productView) rhs+   (nx, ny) <- [ (xs, new) | x <- xs, suitable x, new <- exposeList x ys ] +++               [ (new, ys) | y <- ys, suitable y, new <- exposeList y xs ]+   return (build productView (bx, nx) :==: build productView (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)+      case P.division p2 p1 of+         Just p3 -> return $ map (\p -> build (polyViewWith rationalView) (s1,p)) [p1, p3]+         Nothing -> []  --------------------------------------------------------- -- From LinearEquations@@ -293,18 +444,18 @@ ------------------------------------------------------- -- Transformations -plusT, minusT :: Expr -> Transformation (Equation Expr)-plusT  e = makeTrans "plus"  $ return . fmap (applyD mergeT . (.+. e))-minusT e = makeTrans "minus" $ return . fmap (applyD mergeT . (.-. e))+plusT, minusT :: Functor f => Expr -> Transformation (f Expr)+plusT  e = makeTrans $ return . fmap (applyD mergeT . (.+. e))+minusT e = makeTrans $ return . fmap (applyD mergeT . (.-. e)) -timesT :: Expr -> Transformation (Equation Expr)-timesT e = makeTrans "times" $ \eq -> do +timesT :: Functor f => Expr -> Transformation (f Expr)+timesT e = makeTrans $ \eq -> do     r <- match rationalView e    guard (r /= 0)    return $ fmap (applyD mergeT . applyD distributionOldT . (e .*.)) eq  divisionT :: Expr -> Transformation (Equation Expr)-divisionT e = makeTrans "division" $ \eq -> do+divisionT e = makeTrans $ \eq -> do    r <- match rationalView e    guard (r /= 0)    return $ fmap (applyD mergeT . applyD distributionOldT . (./. e)) eq@@ -313,7 +464,7 @@ -- 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 "distributeT" f+distributionT = makeTransList f  where    f expr = do       (b, xs) <- matchM simpleProductView expr@@ -332,63 +483,57 @@        g :: Expr -> Expr -> [Expr]    g a b = do -      as     <- matchM sumView a-      bs     <- matchM sumView b+      as <- matchM sumView a+      bs <- matchM sumView b       guard (length as > 1 || length bs > 1)       return $ build sumView [ a .*. b | a <- as, b <- bs ]  mergeT :: Transformation Expr-mergeT = makeTrans "merge" $ return . collectLikeTerms+mergeT = makeTrans $ return . collectLikeTerms  -- high exponents first, non power-factor terms at the end sortT :: Transformation Expr-sortT = makeTrans "sort" $ \e -> do+sortT = makeTrans $ \e -> do    xs <- match sumView e    let f  = fmap (negate . thd3) . match powerFactorView        ps = sortBy cmp $ zip xs (map f xs)        cmp (_, ma) (_, mb) = compare ma mb    return $ build sumView $ map fst ps    -signT :: Transformation (Equation Expr)-signT = makeTrans "sign" $ \(lhs :==: rhs) -> do-   a <- match sumView lhs >>= safeHead-   p <- match productView a-   guard (fst p)-   return (-lhs :==: -rhs)-    ------------------------------------------------------- -- Rewrite Rules -varToLeft :: Rule (Equation Expr)+varToLeft :: Relational f => Rule (f Expr) varToLeft = makeRule "variable to left" $ flip supply1 minusT $ \eq -> do-   (x, a, _) <- match (linearViewWith rationalView) (getRHS eq)+   (x, a, _) <- match (linearViewWith rationalView) (rightHandSide eq)    guard (a/=0)    return (fromRational a * Var x) -{--conToRight :: Rule (Equation Expr)-conToRight = makeRule "constant to right" $ flip supply1 minusT $ \eq -> do-   (_, _, b) <- match (linearViewWith rationalView) (getLHS eq)-   guard (b/=0)-   return (fromRational b)--scaleToOne :: Rule (Equation Expr)-scaleToOne = makeRule "scale to one" $ flip supply1 divisionT $ \eq -> do-   (_, a, _) <- match (linearViewWith rationalView) (getLHS eq)-   guard (a `notElem` [0, 1])-   return (fromRational a) -}--removeDivision :: Rule (Equation Expr)-removeDivision = makeRule "remove division" $ flip supply1 timesT $ \(lhs :==: rhs) -> do-   xs <- match sumView lhs-   ys <- match sumView rhs+-- factor is always positive due to lcm function+removeDivision :: Relational r => Rule (r Expr)+removeDivision = makeRule "remove division" $ flip supply1 timesT $ \eq -> do+   xs <- match sumView (leftHandSide eq)+   ys <- match sumView (rightHandSide eq)    -- also consider parts without variables-   zs <- mapM (fmap snd . match productView) (xs ++ ys)-   let f = fmap snd . match (divView >>> second integerView)+   -- (but at least one participant should have a variable)+   zs <- forM (xs ++ ys) $ \a -> do+            (_, list) <- match productView a+            return [ (hasVars 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-      ns -> return (fromInteger (foldr1 lcm ns))+      ps -> let (bs, ns) = unzip ps+            in if or bs then return (fromInteger (foldr1 lcm ns))+                        else Nothing +-- Bug fix for distribution in -2*(x+1)    (duplicate result)+-- This should be a temporary fix+distributeTimesSomewhere :: Rule Expr+distributeTimesSomewhere = makeSimpleRuleList (name distributeTimes) $+   nub . map cleanUpSimple . applyAll (ruleSomewhere distributeTimes)+ distributeTimes :: Rule Expr distributeTimes = makeSimpleRuleList "distribution multiplication" $ \expr -> do    new <- applyAll distributionT expr@@ -415,7 +560,7 @@ -- Temporary fix: here we don't care about the terms we apply it to. Only -- use for cleaning up distributionOldT :: Transformation Expr-distributionOldT = makeTrans "distributeT" f +distributionOldT = makeTrans f   where    f (a :*: b) =       case (match sumView a, match sumView b) of
src/Domain/Math/Polynomial/Strategies.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -10,19 +10,23 @@ -- ----------------------------------------------------------------------------- module Domain.Math.Polynomial.Strategies -   ( linearStrategy, quadraticStrategy-   , higherDegreeStrategy +   ( linearStrategy, linearMixedStrategy, quadraticStrategy+   , higherDegreeStrategy, findFactorsStrategy    ) where -import Prelude hiding (repeat, replicate)+import Prelude hiding (repeat, replicate, fail)+import Common.Apply import Common.Strategy+import Common.Navigator import Common.Transformation+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.Polynomial.Views+import Domain.Math.Numeric.Views import Domain.Math.Data.OrList-import Domain.Math.Data.Equation+import Domain.Math.Data.Relation import Domain.Math.Expr import Domain.Math.Polynomial.CleanUp @@ -30,17 +34,32 @@ -- Linear equations  linearStrategy :: LabeledStrategy (Equation Expr)-linearStrategy = cleanUpStrategy (fmap cleanUpSimple) $+linearStrategy = linearStrategyWith False++linearMixedStrategy :: LabeledStrategy (Equation Expr)+linearMixedStrategy = linearStrategyWith True++linearStrategyWith :: Bool -> LabeledStrategy (Equation Expr)+linearStrategyWith mixed = cleanUpStrategy (fmap clean) $    label "Linear Equation"      $  label "Phase 1" (repeat (-          removeDivision -          <|> ruleMulti (ruleSomewhere distributeTimes)+              removeDivision +          <|> ruleMulti distributeTimesSomewhere           <|> ruleMulti merge))-   <*> label "Phase 2" (-          try varToLeft -          <*> try (coverUpPlus id) -          <*> try (coverUpTimes |> try coverUpNegate))-+   <*> label "Phase 2" (repeat (+          (flipEquation |> varToLeft)+          <|> coverups))+   <*> try (ruleMulti final)+ where+   coverups = coverUpPlus id <|> coverUpTimes <|> coverUpNegate+   (clean, final) +      | mixed = +           ( transform (simplify mixedFractionView) . cleanUpSimple+           , ruleNormalizeMixedFraction+           )+      | otherwise = +          (cleanUpSimple, ruleNormalizeRational)+       -- helper strategy coverUpPlus :: (Rule (Equation Expr) -> Rule a) -> Strategy a coverUpPlus f = alternatives $ map (f . ($ oneVar))@@ -49,50 +68,114 @@ ------------------------------------------------------------ -- Quadratic equations -quadraticStrategy :: LabeledStrategy (OrList (Equation Expr))-quadraticStrategy = cleanUpStrategy cleanUp $ +quadraticStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))+quadraticStrategy = cleanUpStrategy (change cleanUpRelation) $     label "Quadratic Equation Strategy" $ -   repeat $ -         -- general form-      (  label "general form" $ -         ( ruleOnce commonFactorVar <|> ruleOnce noLinFormula{- or coverup -}-           <|> ruleOnce niceFactors <|> ruleOnce simplerA -           <|> coverUpPower) -- to deal with special case x^2=0-         |> abcFormula-      )-      |> -- zero form-      (  label "zero form"-         mulZero-      )-      |> -- constant form-      (  label "constant form" $ -         coverUpPower <|> ruleOnce coverUpTimes <|> coverUpPlus ruleOnce-         <|> ruleOnce coverUpNegate <|> ruleOnce coverUpNumerator -         <|> squareBothSides-      )-      |> -- simplification -      (  label "square root simplification" $ -         ruleMulti2 (ruleSomewhere simplerSquareRoot)-      )-      |> -- top form-      (  label "top form" $ -         ( ruleOnce2 (ruleSomewhere merge) -           <|> ruleOnce cancelTerms  -           <|> ruleMulti2 (ruleSomewhere distributionSquare)-           <|> ruleMulti2 (ruleSomewhere distributeTimes) -           <|> ruleMulti2 (ruleSomewhere distributeDivision)-           <|> ruleOnce flipEquation)-         |> ruleOnce moveToLeft-      )+   repeat $  -- Relaxed strategy: even if there are "nice" factors, allow use of square formula+          (  fromEquation generalForm+         <|> mapRules (liftRule (contextView (switchView equationView))) generalABCForm+          )+          |> fromEquation zeroForm +          |> fromEquation constantForm+          |> simplifyForm+          |> fromEquation topForm + where+   fromEquation = mapRules (liftToContext . liftRule (switchView equationView))+ +   -- ax^2 + bx + c == 0, without square formula+   generalForm = label "general form" $ +      ruleOnce commonFactorVar +      <|> ruleOnce noLinFormula{- or coverup -}+      <|> ruleOnce simplerPoly <|> remove (ruleOnce bringAToOne)+      <|> ruleOnce niceFactors +      <|> coverUpPower -- to deal with special case x^2=0+      +   generalABCForm = label "abc form" abcFormula+ +   zeroForm = label "zero form" $+      toStrategy mulZero+    +   -- expr == c+   constantForm = label "constant form" $ +      -- coverUpPower <|> -- never used, see coverUpPower rule in general form+      ruleOnce coverUpTimes <|> coverUpPlus ruleOnce+      <|> ruleOnce coverUpNegate <|> ruleOnce coverUpNumerator +      <|> squareBothSides <|> ruleOnce factorLeftAsSquare  +   -- simplifies square roots, or do an approximation +   simplifyForm = (fromEquation $ +      label "square root simplification" $ +           toStrategy (ruleMulti2 (ruleSomewhere simplerSquareRoot)))+        <|> remove (label "approximate result" $ +            toStrategy $ liftToContext (ruleMulti ruleApproximate))++   topForm = label "top form" $+      ( ruleOnce2 (ruleSomewhere merge) +        <|> ruleOnce cancelTerms  +        <|> sameFactor <|> ruleOnce sameConFactor+        <|> ruleMulti2 (ruleSomewhere distributionSquare)+        <|> ruleMulti2 distributeTimesSomewhere +        <|> ruleMulti2 (ruleSomewhere distributeDivision)+        <|> ruleOnce flipEquation)+      |> (ruleOnce moveToLeft <|> remove (ruleOnce prepareSplitSquare))+   -- to do: find a better location in the strategy for splitting the square+    ----------------------------------------------------------- -- Higher degree equations -higherDegreeStrategy :: LabeledStrategy (OrList (Equation Expr))-higherDegreeStrategy = cleanUpStrategy cleanUp $+higherDegreeStrategy :: LabeledStrategy (Context (OrList (Relation Expr)))+higherDegreeStrategy =    label "higher degree" $ -      repeat (allPowerFactors |> (mulZero <|> ruleOnce2 powerFactor <|> sameFactor))-      <*> check isQ <*> quadraticStrategy- +      higherForm <*> label "quadratic" ({-option (check isQ2 <*> -} quadraticStrategy)+      <*> +      cleanUpStrategy (change cleanUpRelation) (label "afterwards" (try (substBackVar <*> f (repeat coverUpPower))))+ where+   higherForm = cleanUpStrategy (change cleanUpRelation) $ +      label "higher degree form" $+      repeat (f (toStrategy allPowerFactors) |> +         (f (alternatives list) <|> liftRule specialV (ruleOrCtxOnce higherSubst))+            |> f (toStrategy (ruleOnce moveToLeft)))+   list = map toStrategy  +             [ coverUpPower, ruleOnce coverUpTimes+             , mulZero, {-ruleOnce2 powerFactor,-} sameFactor+             , ruleOnce exposeSameFactor+             ] ++ [coverUpPlus ruleOnce] ++ [toStrategy (ruleOnce sameConFactor)]+   f = mapRulesS (liftToContext . liftRule (switchView equationView))+   +   specialV :: View (Context (OrList (Relation Expr))) (Context (OrList (Equation Expr)))+   specialV = contextView (switchView equationView)++{-+isQ2 :: Context (OrList (Relation Expr)) -> Bool+isQ2 = maybe False isQ . match (switchView equationView) . fromContext+ isQ :: OrList (Equation Expr) -> Bool isQ = (`belongsTo` quadraticEquationsView)+-}++-- like ruleOnce: TODO, replace!+ruleOrCtxOnce :: Rule (Context a) -> Rule (Context (OrList a))+ruleOrCtxOnce r = makeSimpleRuleList (name r) $ \ctx -> do+   let env = getEnvironment ctx+   a <- fromContext ctx+   case disjunctions a of+      Just xs -> f [] env xs+      Nothing -> []+ where+   f _   _   [] = []+   f acc env (a:as) = +      case applyAll r (newContext env (noNavigator a)) of+         []  -> f (a:acc) env as+         new -> concatMap (fmapC $ \na -> orList (reverse acc++na:as)) new+   fmapC g c = +      case fromContext c of+         Just a  -> [newContext (getEnvironment c) (noNavigator (g a))]+         Nothing -> []++-----------------------------------------------------------+-- Finding factors in an expression++findFactorsStrategy :: LabeledStrategy Expr+findFactorsStrategy = cleanUpStrategy cleanUpSimple $+   label "find factors" $+   repeat (niceFactorsNew <|> commonFactorVarNew)
+ src/Domain/Math/Polynomial/Tests.hs view
@@ -0,0 +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 Domain.Math.Polynomial.Tests where++import Control.Monad+import Common.Apply+import Common.Exercise+import Common.Context+import Common.Strategy+import Common.Derivation+import Common.View+import Domain.Math.Data.Relation+import Domain.Math.Data.OrList+import Domain.Math.Clipboard+import Domain.Math.Expr+import Domain.Math.Examples.DWO1+import Domain.Math.Examples.DWO2+import Domain.Math.Polynomial.Exercises+import Domain.Math.Polynomial.IneqExercises+import Domain.Math.Polynomial.Generators+import Domain.Math.Polynomial.Views+import Domain.Math.Numeric.Laws+import Domain.Math.Numeric.Views+import Domain.Logic.Formula+import Test.QuickCheck+import Data.Maybe++------------------------------------------------------------+-- Testing instances++tests :: IO ()+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 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 = do+   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) -> do+            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
src/Domain/Math/Polynomial/Views.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -22,18 +22,20 @@  import Prelude hiding ((^)) import Control.Monad-import Data.List+import Common.Apply import Common.View import Common.Traversable+import Common.Uniplate (transform, uniplate, children) import Common.Utils (distinct) import Domain.Math.Data.Polynomial-import Domain.Math.Data.Equation+import Domain.Math.Data.Relation import Domain.Math.Data.OrList import Domain.Math.Expr import Domain.Math.Numeric.Views+import Domain.Math.Equation.CoverUpRules+import Domain.Math.Polynomial.CleanUp import Data.Maybe import qualified Domain.Math.Data.SquareRoot as SQ-import Domain.Math.Expr.Symbols import Domain.Math.SquareRoot.Views import Domain.Math.Power.Views (powerFactorViewForWith) @@ -73,13 +75,18 @@             p <- f a             return (fmap (/c) p)          Sym s [a, n] | s == powerSymbol ->-           liftM2 power (f a) (match integralView n) -- non-negative??+           liftM2 power (f a) (matchNat n)          _ -> do              guard (pv `notElem` collectVars expr)             liftM con (match v expr)        g        = build sumView . map h . reverse . terms    h (a, n) = build v a .*. (Var pv .^. fromIntegral n)+   +   matchNat expr = do+      n <- match integralView expr+      guard (n >= 0)+      return n  ------------------------------------------------------------------- -- Quadratic view@@ -243,15 +250,41 @@ higherDegreeEquationsView :: View (OrList (Equation Expr)) (OrList Expr) higherDegreeEquationsView = makeView f (fmap g)  where-   f = let make (a :==: b) = orList (normHDE (a-b))-       in Just . normalize . join . fmap make+   f = let make (a :==: b) = orList (filter (not . hasNegSqrt) $ map cleanUpExpr2 (normHDE (a-b)))+       in Just . normalize . join . fmap make . cuRules     g = (:==: 0)    +   cuRules :: OrList (Equation Expr) -> OrList (Equation Expr)+   cuRules xs = +      let new = fmap (fmap (cleanUpExpr2 . distr)) xs in+      case msum (map (`apply` new) coverUpRulesOr) of+         Just ys -> cuRules ys+         Nothing -> new++hasNegSqrt :: Expr -> Bool+hasNegSqrt (Sqrt a) = +   case match rationalView a of+      Just r | r < 0 -> True+      _ -> hasNegSqrt a+hasNegSqrt (Sym s [a, b]) | s == rootSymbol = +   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)++distr :: Expr -> Expr+distr = transform f+ where+   f ((a :+: b) :/: c) = (a ./. c) .+. (b ./. c)+   f ((a :-: b) :/: c) = (a ./. c) .-. (b ./. c)+   f a = a+ normHDE :: Expr -> [Expr] normHDE e =    case match (polyViewWith rationalView) e of-      Just (x, p)  -> concatMap (g x) $ factorize p+      Just (x, p)  -> g x p       Nothing -> fromMaybe [e] $ do          (x, a) <- match (linearEquationViewWith (squareRootViewWith rationalView)) (e :==: 0)          return [ Var x .+. build (squareRootViewWith rationalView) (-a) ] @@ -269,5 +302,31 @@                    [ SQ.scale (1/(2*a)) (SQ.con b + sdiscr)                    , SQ.scale (1/(2*a)) (SQ.con b - sdiscr)                    ]-       | otherwise     = [build (polyViewWith rationalView) (x, p)]-    where d = degree p+       | 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 (\(x, y) -> scale x (power var y)) list)+                      sub  = map (substitute (x, Var x^fromIntegral e1))+                  in concatMap normHDE (sub (g 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 (g x) ps+                     _ -> [build (polyViewWith rationalView) (x, p)]+    where +      d = degree p+      +substitute :: (String, Expr) -> Expr -> Expr+substitute (s, a) (Var b) | s==b = a+substitute pair expr = f (map (substitute pair) cs)+ where +   (cs, f) = uniplate expr
+ src/Domain/Math/Power/Exercises.hs view
@@ -0,0 +1,125 @@+-----------------------------------------------------------------------------+-- 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    +   ( simplifyPowerExercise+   , powerOfExercise +   , nonNegExpExercise+   , calcPowerExercise+   ) where++import Common.Apply +import Common.Context+import Common.Exercise+import Common.Navigator+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+import Domain.Math.Numeric.Views+import Domain.Math.Power.Rules+import Domain.Math.Power.Strategies+import Domain.Math.Power.Views+import Prelude hiding ( (^) )++------------------------------------------------------------+-- Exercises++powerExercise :: LabeledStrategy (Context Expr) -> Exercise Expr+powerExercise s = makeExercise +   { status        = Provisional+   , parser        = parseExpr+   , navigation    = navigator                     +   , strategy      = s+   }++simplifyPowerExercise :: Exercise Expr+simplifyPowerExercise = (powerExercise powerStrategy)+   { description  = "simplify expression (powers)"+   , exerciseCode = makeCode "math" "simplifyPower"+   , isReady      = isPowerAdd+   , isSuitable   = (`belongsTo` normPowerView')+   , equivalence  = viewEquivalent normPowerView'+   , examples     = concat $  simplerPowers ++ powers1 ++ powers2 +                           ++ negExp1 ++ negExp2+                           ++ normPower1 ++ normPower2 ++ normPower3+   }++powerOfExercise :: Exercise Expr+powerOfExercise = (powerExercise powerOfStrategy)+   { description  = "write as a power of a"+   , exerciseCode = makeCode "math" "powerOf"+   , isReady      = isSimplePower+   , isSuitable   = (`belongsTo` normPowerView)+   , equivalence  = viewEquivalent normPowerNonNegRatio+   , examples     = concat $  powersOfA ++ powersOfX ++ brokenExp1' +                           ++ brokenExp2 ++ brokenExp3 ++ normPower5'+                           ++ normPower6+   }++nonNegExpExercise :: Exercise Expr+nonNegExpExercise = (powerExercise nonNegExpStrategy)+   { description  = "write with a non-negative exponent"+   , exerciseCode = makeCode "math" "nonNegExp"+   , isReady      = isPower natView+   , isSuitable   = (`belongsTo` normPowerNonNegDouble)+   , equivalence  = viewEquivalent normPowerNonNegDouble+   , examples     = concat $  nonNegExp ++ nonNegExp2 ++ negExp4 ++ negExp5 +                           ++ brokenExp1 ++ normPower4' ++ normPower5+   }++calcPowerExercise :: Exercise Expr+calcPowerExercise = (powerExercise calcPowerStrategy)+   { description  = "simplify expression (powers)"+   , exerciseCode = makeCode "math" "calcPower"+   , isReady      = isPowerAdd+   , isSuitable   = (`belongsTo` normPowerView')+   , equivalence  = viewEquivalent normPowerView'+   , examples     = concat $ negExp3 ++ normPower3' ++ normPower4+   }+++----------------------------------------------------------------------+-- Ready checks++isSimplePower :: Expr -> Bool+isSimplePower (Sym s [Var _,y]) | s==powerSymbol = 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]) | s==powerSymbol = isJust (match v a)+         g (Sym s [x, Nat _]) | s==rootSymbol = isPower v x +         g (Sqrt x) = g x+         g (Var _) = True+         g a = a `belongsTo` rationalView+     in distinct (concatMap collectVars xs) && all f xs+     +isPowerAdd :: Expr -> Bool+isPowerAdd expr =+  let Just xs = match sumView expr+  in all (isPower rationalView) xs && not (applicable calcPowerPlus expr)++-- test stuff+{-+showDerivations ex = mapM_ (putStrLn . showDerivation ex)++showAllDerivations ex = +  mapM_ (\es -> putStrLn (replicate 80 '-') >> showDerivations ex es)+                        +a = Var "a"+b = Var "b"+-}
+ src/Domain/Math/Power/Rules.hs view
@@ -0,0 +1,283 @@+-----------------------------------------------------------------------------+-- 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, zeroPower, reciprocal+  , reciprocalInv+    -- * Root rules+  , power2root, root2power, distributeRoot, mulRoot, mulRootCom, divRoot+  , simplifyRoot+    -- * Common rules+  , myFractionTimes, simplifyFraction, pushNegOut+    -- * Help functions+  , smartRule+  ) where++import Prelude hiding ( (^) )+import qualified Prelude+import Common.Apply+import Control.Arrow ( (>>^) )+import Common.Transformation+import Common.View+import Control.Monad+import Data.List+import Data.Maybe+import Domain.Math.Expr+import Domain.Math.Numeric.Views+import Domain.Math.Power.Views+import Domain.Math.Polynomial.CleanUp+++-- | Power rules --------------------------------------------------------------++calcPower :: Rule Expr +calcPower = makeSimpleRule "calculate power" $ \ expr -> do +  (e1, e2) <- match simplePowerView expr+  a        <- match rationalView e1+  x        <- match integralView e2+  if x > 0 +    then return $ fromRational $ a Prelude.^ x+    else return $ 1 ./. (e1 .^. neg e2)++calcPowerPlus :: Rule Expr +calcPowerPlus = +  makeCommutative sumView (.+.) $ calcBinPowerRule "plus" (.+.) isPlus ++calcPowerMinus :: Rule Expr +calcPowerMinus = +   makeCommutative sumView (.+.) $ calcBinPowerRule "minus" (.-.) isMinus++-- | a*x^y * b*x^q = a*b * x^(y+q)+addExponents :: Rule Expr +addExponents = makeSimpleRuleList "add exponents" $ \ expr -> do+  case match (powerFactorisationView unitPowerView) expr of+    Just (s, fs) -> do +      (e, es) <- split (*) fs+      case apply addExponents' e of+        Just e' -> return $ build productView (s, e' : es)+        Nothing -> fail ""  +    Nothing -> fail ""++-- | a*x^y * b*x^q = a*b * x^(y+q)+addExponents' :: Rule Expr +addExponents' = makeSimpleRule "add exponents" $ \ expr -> do+  x        <- selectVar expr+  (e1, e2) <- match timesView expr+  (a, y)   <- match (unitPowerForView x) e1+  (b, q)   <- match (unitPowerForView x) e2+  return $ build (unitPowerForView x) (a .*. b, y + q)+  +-- | a*x^y / b*x^q = a/b * x^(y-q)+subExponents :: Rule Expr+subExponents = forallVars rule+  where+    rule x = makeSimpleRule "sub exponents" $ \ expr -> do+      (e1, e2) <- match divView expr+      (a, y)   <- match (unitPowerForView x) e1+      (b, q)   <- match (unitPowerForView x) e2+      return $ build (unitPowerForView x) (a ./. b, y - q)++-- | (c*a^x)^y = c*a^(x*y)+mulExponents :: Rule Expr +mulExponents = makeSimpleRule "mul exponents" $ \ expr -> do+  (cax, y)    <- match simplePowerView expr+  (c, (a, x)) <- match strictPowerView cax+  guard (c == 1 || c == -1)+  selectVar a+  return $ build strictPowerView (c, (a, x .*. y))++-- | c*(a0..an)^y = c * a0^y * a1^y .. * an^y+distributePower :: Rule Expr+distributePower = makeSimpleRule "distribute power" $ \ expr -> do+  (c, (as', y)) <- match strictPowerView expr+  y'            <- match integerView y+  (sign, as)    <- match productView as'+  guard (length as > 1)+  return $ build productView +   (if sign then odd y' else False, c : map (\a -> a .^. y) as)++-- | c * (a/b)^y = c * (a^y / b^y)+distributePowerDiv :: Rule Expr+distributePowerDiv = makeSimpleRule "distribute power" $ \ expr -> do+  (c, (ab, y)) <- match strictPowerView expr+  match integerView y+  (a, b)       <- match divView ab+  return $ c .*. build divView (a .^. y, b .^. y)++-- | c*a^0 = c+zeroPower :: Rule Expr+zeroPower = makeSimpleRule "zero power" $ \ expr -> do+  (_, (c, y)) <- match strictPowerView expr+  y' <- match integerView y+  guard (y'==0)+  return c++-- | d/c*a^x = d*a^(-x)/c+reciprocal :: Rule Expr+reciprocal = makeSimpleRule "reciprocal" $ \ expr -> do+  a        <- selectVar expr+  (d, cax) <- match divView expr+  (c, x)   <- match (unitPowerForView a) cax+  return $ build (unitPowerForView a) (d ./. c, negate x)++-- | c*a^x = c/a^(-x)+reciprocalInv :: (Expr -> Bool) -> Rule Expr+reciprocalInv p = makeSimpleRule "reciprocal" $ \ expr -> do+  guard (p expr)+--  a        <- selectVar expr+  (c, (a, x))   <- match strictPowerView expr+  return $ c ./. build strictPowerView (1, (a, neg x))+++-- | Root rules ----------------------------------------------------------------++-- | a^(p/q) = root (a^p) q+power2root :: Rule Expr +power2root = makeSimpleRule "write as root" $ \ expr -> do+  (a, pq) <- match simplePowerView expr+  (p, q)  <- match (rationalView >>> ratioView) pq  +  guard (q /= 1)  +  return $ let n =  Nat . fromIntegral in root (a .^. n p) $ n q+  +-- | root (a^p) q = a^(p/q)+root2power :: Rule Expr +root2power = makeSimpleRule "write as power" $ \ expr -> do+  (ap, q) <- match rootView expr+  a       <- selectVar ap+  p       <- match (powerViewFor' a) ap+  return $ build (powerViewFor' a) (fromRational (p /  q))++-- | root (a/b) x = root a x / root b x+distributeRoot :: Rule Expr+distributeRoot = makeSimpleRule "distribute root" $ \ expr -> do+  (ab, x) <- match rootView expr+  (a, b)  <- match divView ab+  return $ build divView (build rootView (a, x), build rootView (b, x))  ++-- | c1 root a x * c2 root b x = c1*c2 * root (a*b) x+mulRoot :: Rule Expr+mulRoot = makeSimpleRule "multipy base of root" $ \ expr -> do+  (r1, r2)      <- match timesView expr+  (c1, (a, x))  <- match rootConsView r1+  (c2, (b, x')) <- match rootConsView r2+  guard (x == x')+  return $ build rootConsView (c1 .*. c2, (a .*. b, x))++-- | commutative version of the mulRoot rule+mulRootCom :: Rule Expr+mulRootCom = makeCommutative (myProductView (powerFactorisationView rootView)) (.*.) mulRoot+ where+   myProductView :: View Expr (Bool, [Expr]) -> View Expr [Expr]+   myProductView v = v >>> makeView f g+     where+       f (s, (x:xs)) = return $ if s then neg x : xs else x:xs+       f _           = fail ""+       g = (,) False ++-- | c1 * root a x / c2 * root b x = c1*c2 * root (a/b) x+divRoot :: Rule Expr+divRoot = makeSimpleRule "divide base of root" $ \ expr -> do+  (r1, r2) <- match divView expr+  (c1, (a, x))  <- match rootConsView r1+  (c2, (b, x')) <- match rootConsView r2+  guard (x == x' && b /= 0)+  return $ build rootConsView (c1 .*. c2, (a ./. b, x))++-- | root 0 x = 0  ;  root 1 x = 1  ;  root a 1 = a+simplifyRoot :: Rule Expr+simplifyRoot = makeSimpleRule "simplify root" $ \e -> f e `mplus` g e+ where+  f expr = do+    (e1, _) <- match rootView expr+    x       <- match integerView e1+    case x of+      0 -> Just 0+      1 -> Just 1+      _ -> Nothing+  g expr = do+    (e1, e2) <- match rootView expr+    if e2 == 1 then Just e1 else Nothing+++-- | Common rules --------------------------------------------------------------++-- | a/b * c/d = a*c / b*d  (b or else d may be one)  +myFractionTimes :: Rule Expr+myFractionTimes = smartRule $ makeSimpleRule "fraction times" $ \ expr -> do+  (e1, e2) <- match timesView expr+  guard $ isJust $ match divView e1 `mplus` match divView e2+  (a, b)   <- match (divView <&> (identity >>^ \e -> (e,1))) e1+  (c, d)   <- match (divView <&> (identity >>^ \e -> (e,1))) e2+--  (a, b)   <- match divView e1+--  (c, d)   <- match divView e2+  return $ build divView (a .*. c, b .*. d)++-- | simplify expression+simplifyFraction :: Rule Expr+simplifyFraction = makeSimpleRule "simplify fraction" $ \ expr -> do+  let expr' = simplifyWith (second normalizeProduct) productView $ expr+  guard (expr /= expr')+  guard $ not $ applicable myFractionTimes expr' -- a hack, need to come up with a constructive solution+  return expr'++-- | (-a)^x = (-)a^x+pushNegOut :: Rule Expr+pushNegOut = makeSimpleRule "push negation out" $ \ expr -> do+  (a, x) <- match simplePowerView expr+  a'     <- isNegate a+  x'     <- match integerView x+  return $ (if odd x' then neg else id) $ build simplePowerView (a', x)+++-- | Help 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+   +calcBinPowerRule :: String -> (Expr -> Expr -> Expr) -> (Expr -> Maybe (Expr, Expr)) -> Rule Expr   +calcBinPowerRule opName op m = +   makeSimpleRule ("calculate power " ++ opName) $ \e -> do+     (e1, e2)     <- m e+     (a, (c1, x)) <- match unitPowerView e1+     (b, (c2, y)) <- match unitPowerView e2+     guard (a == b && x == y)+     return (build unitPowerView (a, ((op c1 c2), x)))++makeCommutative :: View Expr [Expr] -> (Expr -> Expr -> Expr) -> Rule Expr -> Rule Expr+makeCommutative view op rule = +  makeSimpleRuleList (name rule) $ \ expr -> do+    case match view expr of+      Just factors -> do+        (e, es) <- split op factors+        case apply rule e of+          Just e' -> return $ build view (e' : es)+          Nothing -> fail ""+      Nothing -> fail ""++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 [] = []++forallVars :: (String -> Rule Expr) -> Rule Expr+forallVars ruleFor = makeSimpleRuleList (name (ruleFor "")) $ \ expr -> +  mapMaybe (\v -> apply (ruleFor v) expr) $ collectVars expr
+ src/Domain/Math/Power/Strategies.hs view
@@ -0,0 +1,156 @@+-----------------------------------------------------------------------------+-- 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+   ( powerStrategy+   , powerOfStrategy+   , calcPowerStrategy+   , nonNegExpStrategy+   ) where++import Common.Apply+import Common.Context+import Common.Strategy+import Common.Transformation+import Common.View+import Domain.Math.Expr+import Domain.Math.Power.Rules+import Domain.Math.Power.Views+import Domain.Math.Numeric.Rules+import Domain.Math.Numeric.Views+import Prelude hiding (repeat)++------------------------------------------------------------+-- Strategies++powerStrategy :: LabeledStrategy (Context Expr)+powerStrategy = makeStrategy "simplify" rules cleanupRules+  where +    rules = powerRules +    cleanupRules = calcPower : naturalRules ++ rationalRules++powerOfStrategy :: LabeledStrategy (Context Expr)+powerOfStrategy = makeStrategy "write as power of" rules cleanupRules+  where+   rules = powerRules +   cleanupRules = calcPower +                : simplifyRoot +                : simplifyFraction +                : naturalRules +               ++ rationalRules++nonNegExpStrategy :: LabeledStrategy (Context Expr)+nonNegExpStrategy = makeStrategy "non negative exponent" rules cleanupRules+  where+    rules = [ addExponents+            , subExponents+            , mulExponents+            , reciprocalInv hasNegExp+            , distributePower+            , distributePowerDiv+            , power2root+            , distributeRoot+            , zeroPower+            , calcPowerPlus+            , calcPowerMinus+            , myFractionTimes+            ] ++ fractionRules            +    cleanupRules = calcPower : simplifyFraction  : naturalRules++calcPowerStrategy :: LabeledStrategy (Context Expr)+calcPowerStrategy = makeStrategy "calcPower" rules cleanupRules+  where+    rules = calcPower +          : mulRootCom+          : divRoot +          : rationalRules+    cleanupRules = rationalRules ++ naturalRules++------------------------------------------------------------+-- | Help functions++makeStrategy :: String -> [Rule Expr] -> [Rule Expr] -> LabeledStrategy (Context Expr)+makeStrategy l rs cs = cleanUpStrategy f $ strategise l rs+  where+    f = applyD $ strategise l cs+    strategise l = label l . repeat . alternatives . map (somewhere . liftToContext)++powerRules =+      [ addExponents+      , subExponents+      , mulExponents+      , distributePower+      , zeroPower+      , reciprocal+      , root2power+      , distributeRoot+      , calcPower+      , calcPowerPlus+      , calcPowerMinus+      , myFractionTimes+      , pushNegOut+      ]++hasNegExp expr = +  case match strictPowerView expr of+    Just (_, (_, x)) -> case match rationalView x of+      Just x' -> x' < 0+      _       -> False+    _ -> False+++-- | Allowed numeric rules+naturalRules =+   [ calcPlusWith     "nat" natView+   , calcMinusWith    "nat" natView+   , calcTimesWith    "nat" natView+   , calcDivisionWith "nat" natView+   , doubleNegate+   , negateZero+   , plusNegateLeft+   , plusNegateRight+   , minusNegateLeft+   , minusNegateRight+   , timesNegateLeft+   , timesNegateRight   +   , divisionNegateLeft+   , divisionNegateRight  +   ]+   where+     natView = makeView f fromInteger+       where+         f (Nat n) = Just n+         f _       = Nothing+ +rationalRules =    +   [ calcPlusWith     "rational" rationalRelaxedForm+   , calcMinusWith    "rational" rationalRelaxedForm+   , calcTimesWith    "rational" rationalRelaxedForm+   , calcDivisionWith "int"      integerNormalForm+   , doubleNegate+   , negateZero+   , divisionDenominator+   , divisionNumerator+   , simplerFraction+   ]+   +fractionRules =+   [ fractionPlus, fractionPlusScale, fractionTimes+   , calcPlusWith     "int" integerNormalForm+   , calcMinusWith    "int" integerNormalForm+   , calcTimesWith    "int" integerNormalForm -- not needed?+   , calcDivisionWith "int" integerNormalForm+   , doubleNegate+   , negateZero+   , smartRule divisionDenominator  +   , smartRule divisionNumerator +   , simplerFraction+   ]
src/Domain/Math/Power/Views.hs view
@@ -1,51 +1,195 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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+-- Maintainer  :  alex.gerdes@ou.nl -- Stability   :  provisional -- Portability :  portable (depends on ghc) -- -------------------------------------------------------------------------------- For now, restricted to integers in exponent:--- no sqrt, or roots-module Domain.Math.Power.Views-   ( powerView, powerViewFor-   , powerFactorView, powerFactorViewWith, powerFactorViewForWith++module Domain.Math.Power.Views +   ( -- * Power views+     strictPowerView, strictPowerViewFor, powerConsViewFor, powerConsView+   , unitPowerView, unitPowerForView, simplePowerView, powerFactorisationView+   , powerFactorViewWith, powerViewFor', powerFactorViewForWith+   , powerViewFor, powerFactorView+     -- * Root views+   , rootView, rootConsView+     -- * View combinator+   , (<&>)+     -- * Normalising views+   , normPowerView, normPowerView', normPowerNonNegRatio+   , normPowerNonNegDouble+     -- * Other views+   , ratioView, natView    ) where -import qualified Prelude import Prelude hiding ((^), recip)+import qualified Prelude+import Control.Arrow ( (>>^) ) import Control.Monad import Common.View+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Data.Ratio import Domain.Math.Expr+import Domain.Math.Numeric.Views -------------------------------------------------------------------------- Simplified views (no side-conditions to worry about) -powerView :: View Expr (String, Int)-powerView = makeView f g- where+-- | Combinator function+(<&>) :: (MonadPlus m) => ViewM m a b -> ViewM m a b -> ViewM m a b+v <&> w = makeView f g+  where+    f x = match v x `mplus` match w x+    g   = build v+infixl <&>+++-- | Power views --------------------------------------------------------------+strictPowerView :: View Expr (Expr, (Expr, Expr))+strictPowerView  =  strictPowerConsView +                <&> (simplePowerView >>^ (,) 1) +                <&> negPowerView+  where+    strictPowerConsView = timesView >>> second simplePowerView+    negPowerView = makeView f g+      where+        f (Negate expr) = do +          (c, ax) <- match (strictPowerConsView <&> (simplePowerView >>^ (,) 1)) expr+          return (negate c, ax)+        f _ = Nothing+        g = build strictPowerView        ++strictPowerViewFor :: String -> View Expr (Expr, Expr)+strictPowerViewFor pv = makeView f g+  where+    f expr = do+      (c, (a, x)) <- match strictPowerView expr+      guard (Var pv == a)+      return (c, x)+    g (c, x) = build strictPowerView (c, (Var pv, x))++powerConsViewFor :: String -> View Expr (Expr, Rational)+powerConsViewFor pv = timesView >>> second (powerViewFor' pv)++powerConsView :: View Expr (String, (Expr, Rational))+powerConsView = makeView f g+  where+    f expr = do+      pv <- selectVar expr+      cn <- match (powerConsViewFor pv) expr+      return (pv, cn)+    g (pv, cn) = build (powerConsViewFor pv) cn+    +unitPowerForView :: String -> ViewM Maybe Expr (Expr, Rational)+unitPowerForView pv = powerConsViewFor pv <&> (powerViewFor' pv >>^ (,) 1)++unitPowerView :: ViewM Maybe Expr (String, (Expr, Rational))+unitPowerView = unitView <&> negUnitView +  where +    unitView = powerConsView <&> (powerView >>^ \(pv, n) -> (pv, (1, n))) +    negUnitView = makeView f g+      where+        f (Negate expr) = do +          (a, (c, x)) <- match unitView expr+          return (a, (negate c, x))+        f _ = Nothing+        g = build unitView      ++simplePowerView :: View Expr (Expr, Expr)+simplePowerView = makeView f g+  where+    f expr = +      case expr of+        Sym s [a, b] | s == powerSymbol -> return (a, b)+        _ -> Nothing+    g (a, b) = a .^. b   ++powerFactorisationView :: View Expr a -> View Expr (Bool, [Expr])+powerFactorisationView v = productView >>> second (makeView f id)+  where+    f es = return $ map (\x -> build productView (False, x)) $ factorise es+    factorise :: [Expr] -> [[Expr]]+    factorise es =  maybe [es] split $ findIndex isPower es+      where+        split i = let (xs, ys) = splitAt (i+1) es in xs : factorise ys+        isPower = isJust . match v++-- | Root views ---------------------------------------------------------------++rootView :: View Expr (Expr, Rational)+rootView = makeView f g+  where +    f expr = case expr of+        Sqrt e -> return (e, 2)+        Sym s [a, Nat b] | s == rootSymbol -> return (a, toRational b)+        _ -> Nothing+    g (a, b) = if b==2 then Sqrt a else root a (fromRational b)++rootConsView :: View Expr (Expr, (Expr, Rational))+rootConsView =   timesView >>> second rootView+            <&> (rootView >>^ (,) 1)+++-- | Bastiaan's power views ---------------------------------------------------++-- | AG: todo: integrate these views with the views above++natView :: View Expr Int+natView = makeView f fromIntegral+  where+    f (Nat n) = Just $ fromInteger n+    f _       = Nothing++ratioView :: View Rational (Int, Int)+ratioView = makeView f g+  where+    f x = return (fromIntegral (numerator x), fromIntegral (denominator x))+    g (n,d) = fromIntegral n % fromIntegral d++powerView :: View Expr (String, Rational)+powerView = powerViewWith rationalView++powerViewWith :: View Expr b -> View Expr (String, b)+powerViewWith v = makeView f g+ where      f expr = do       pv <- selectVar expr-      n  <- match (powerViewFor pv) expr+      n  <- match (powerViewForWith' v pv) expr       return (pv, n)-   g (pv, n) = build (powerViewFor pv) n-+   g (pv, n) = build (powerViewForWith' v pv) n+    powerViewFor :: String -> View Expr Int-powerViewFor pv = makeView f g+powerViewFor = powerViewForWith natView+powerViewFor' = powerViewForWith' rationalView++powerViewForWith :: Num a =>  View Expr a -> String -> View Expr a+powerViewForWith v pv = makeView f g  where    f expr =        case expr of-         Var s | pv == s -> Just 1+         Var s | pv == s -> match v 1          e1 :*: e2 -> liftM2 (+) (f e1) (f e2) -         Sym s [e, Nat n] -            | s == powerSymbol -> liftM (* fromInteger n) (f e)+         Sym s [e, n] | s == powerSymbol -> do+           n'<- match v n+           liftM (* n') (f e)          _ -> Nothing    -   g a = Var pv .^. fromIntegral a+   g a = Var pv .^. build v a+   +powerViewForWith' v pv = makeView f g+ where+   f expr = +      case expr of+        Var s | pv == s -> match v 1+        Sym s [Var s', n] | s' == pv && s == powerSymbol -> match v n+        _ -> Nothing+   +   g a = Var pv .^. build v a  powerFactorView :: View Expr (String, Expr, Int) powerFactorView = powerFactorViewWith identity@@ -84,94 +228,127 @@        g (a, b) = build v a .*. (Var pv .^. fromIntegral b) -------------------------------------------------------------------------- General views (that have to cope with side-conditions)-{---- x^n-genPowerView :: Num a => String -> View Expr a -> View Expr a-genPowerView pv v = makeView f g- where-   f expr = -      case expr of-         Var s | pv == s -> Just 1-         e1 :*: e2 -> liftM2 (+) (f e1) (f e2)-         e1 :/: e2 -> liftM2 (-) (f e1) (f e2)    -- introduces a condition (silently)-         Sym s [e1, e2]                           -- e2 should not be negative-            | s == powerSymbol -> -                 liftM2 (*) (f e1) (match v e2)-         _ -> Nothing-   -   g a = Var pv .^. build v a --- a*x^n-genPowerFactorView :: (Fractional a, Num b) => -                      String -> View Expr a -> View Expr b -> View Expr (a, b)-genPowerFactorView pv v1 v2 = makeView f g+-- | Normalising views ---------------------------------------------------------++normPowerNonNegRatio :: View Expr (M.Map String Rational, Rational) -- (Rational, M.Map String Rational)+normPowerNonNegRatio = makeView (liftM swap . f) (g . swap)  where-   f expr = +     swap (x,y) = (y,x)+     f expr = +        case expr of+           Sym s [a,b] +              | s==powerSymbol -> 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)+              | s==rootSymbol ->+                  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 = map f (M.toList m)+           f (s, r) = Var s .^. fromRational r+       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) = (fromIntegral (round (x * 10.0 ** n)) / 10.0 ** n, m)+    f expr =        case expr of-         Var s | pv == s -> Just (1, 1)-         e1 :*: e2 -> do -            (a1, b1) <- f e1-            (a2, b2) <- f e2-            return (a1*a2, b1+b2)-         e1 :/: e2 -> do     -- introduces a condition (silently)-            (a1, b1) <- f e1-            (a2, b2) <- f e2-            return (a1/a2, b1-b2)-         Sym s [e1, e2]      -- e2 should not be negative-            | s == powerSymbol -> do -                 (a1, b1) <- f e1-                 n <- match v2 e2-                 a <- match v1 (build v1 a1 ^ build v2 n)-                 return (a, b1*n)-         _ -> do-            guard (pv `notElem` collectVars expr)-            a <- match v1 expr -            return (a, 0)-   -   g (a, b) = build v1 a .*. (Var pv .^. build v2 b)--}+        Sym s [a,b] +          | s==powerSymbol -> do+            (x, m) <- f a+            y      <- match rationalView b+            return (x ** fromRational y, M.map (*y) m)+          | s==rootSymbol -> 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 = map f (M.toList m)+          f (s, r) = Var s .^. fromRational r+      in build productView (False, fromDouble r : xs) -{--powerView :: Integral a => String -> View Expr a -> View Expr a-powerView = undefined --- helper: also generalizes over number type in exponent (not just Int)-genPowerView :: (Num a, Num b) => String -> View Expr a -> View Expr b -> View Expr (a, b)-genPowerView = genPowerViewWith+type PowerMap = (M.Map String Rational, Rational) -genPowerViewWith :: (Num a, Num b) => String -> View Expr a -> View Expr b -> View Expr (a, b)-genPowerViewWith pv v1 v2 = makeView f g- where-   f expr =-      case expr of-         Var s | pv == s -> Just (1, 1)-         e1 :*: e2 -> do -            (a1, b1) <- f e1-            (a2, b2) <- f e2-            return (a1*a2, b1+b2)-         e1 :/: e2 -> do -            (a1, b1) <- f e1-            (a2, b2) <- f e2-            a        <- match v1 (build v1 a1 / build v1 a2)-            return (a, b1-b2) -         Sqrt e -> f (root e 2)-         Sym s [e1, e2] -            | s == rootSymbol -> do-                 (a1, b1) <- f e1-                 n <- match v2 e2-                 a <- match v1 (build v1 a1 ^ build v2 n)-                 b <- match v2 (build v2 b1 / build v2 n)-                 return (a, b)-            | s == powerSymbol -> do -                 (a1, b1) <- f e1-                 n <- match v2 e2-                 a <- match v1 (build v1 a1 ^ build v2 n)-                 return (a, b1*n)-         _ -> liftM (\a -> (a, 0)) (match v1 expr)-      -   g (a, b) = build v1 a .*. (Var pv .^. build v2 b)-   +normPowerView' :: View Expr [PowerMap]+normPowerView' = 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 -test = match (genPowerView "x" identity integralView) (sqrt (Var "x" ^ 4)) -}+normPowerView :: View Expr (String, Rational)+normPowerView = makeView f g+ where+   f expr = +        case expr of+           Sym s [x,y] +              | s==powerSymbol -> do+                   (s, r) <- f x+                   r2 <- match rationalView y+                   return (s, r*r2)+              | s==rootSymbol -> +                   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/Simplification.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -16,24 +16,26 @@    ) where  import Common.Context+import Common.Navigator import Common.Transformation import Common.Uniplate import Common.View hiding (simplify) import Control.Monad import Data.List import Data.Maybe-import Domain.Math.Data.Equation+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+import Common.Rewriting  class Simplify a where    simplify :: a -> a  instance Simplify a => Simplify (Context a) where-   simplify = fmap simplify+   simplify = change simplify  instance Simplify a => Simplify (Equation a) where    simplify = fmap simplify@@ -93,12 +95,13 @@ instance Simplify (Simplified a) where    simplify = id -instance (Simplify a, IsExpr a) => IsExpr (Simplified a) where-   toExpr (S x) = toExpr x-   fromExpr = liftM simplified . fromExpr+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
+ src/Domain/Math/SquareRoot/Tests.hs view
@@ -0,0 +1,33 @@+-----------------------------------------------------------------------------+-- 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.Utils ()++-------------------------------------------------------------------+-- Testing+ +tests :: IO ()+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)
src/Domain/Math/SquareRoot/Views.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
− src/Domain/Math/Strategy/BrokenEquations.hs 
@@ -1,111 +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 Domain.Math.Strategy.BrokenEquations where--import Prelude hiding (repeat)-import Common.Apply-import Common.Strategy-import Common.Transformation-import Common.Traversable-import Control.Monad-import Data.Ratio-import Domain.Math.Expr-import Domain.Math.Data.Equation-import Domain.Math.Data.OrList-import Domain.Math.View.Basic-import Domain.Math.ExercisesDWO-import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy)-import Domain.Math.Polynomial.QuadraticEquations (solvedList)-import Domain.Math.Polynomial.Views-import Domain.Math.Strategy.CoverUpEquations (rule1)-{- -Equations:-   (a/b) = 0       =   a=0-   (a/b) = 1       =   a=b-   (a/c) = (b/c)   =   a==b-   (a/b) = (a/c)   =   b==c--}--main = forM_ (concat brokenEquations) $ \eq -> -   let res = applyD brokenStrategy (OrList [eq])-   in if solvedList res then print "ok" else print res---- TODO: check results afterwards (possibility of division by zero)-brokenStrategy :: LabeledStrategy (OrList (Equation Expr))-brokenStrategy = label "broken" $ notBroken <*> -   try (check p <*> equationsStrategy <*> repeat inconsistencies)- where p (OrList xs) = all (`belongsTo` polyView) $ concat [[a,b] | a:==: b <- xs]--notBroken :: LabeledStrategy (OrList (Equation Expr))-notBroken = label "not broken" $ repeat $ -   alternatives [brokenZero, brokenOne, brokenSameDenom, brokenSameNum]-   |> alternatives [coverUpPlus, brokenCross]--coverUpPlus = rule1----------------------------------------------------------------------------- Equation rules--brokenZero :: Rule (OrList (Equation Expr))-brokenZero = makeSimpleRule "brokenZero" $ onceJoinM $ \(a :==: b) -> do-   n <- match rationalView b-   guard (n==0)-   (x, _) <- match divView a-   return $ OrList [x :==: 0]- `mplus` do-   n <- match rationalView a-   guard (n==0)-   (x, _) <- match divView b-   return $ OrList [x :==: 0]--brokenOne :: Rule (OrList (Equation Expr))-brokenOne = makeSimpleRule "brokenOne" $ onceJoinM $ \(a :==: b) -> do-   n <- match rationalView b-   guard (n==1)-   (x, y) <- match divView a-   return $ OrList [x :==: y]- `mplus` do-   n <- match rationalView a-   guard (n==1)-   (x, y) <- match divView b-   return $ OrList [x :==: y]--brokenSameDenom :: Rule (OrList (Equation Expr))-brokenSameDenom = makeSimpleRule "brokenSameDenom" $ onceJoinM $ \(a :==: b) -> do-   (x1, y1) <- match divView a-   (x2, y2) <- match divView b-   guard (y1==y2)-   return $ OrList [x1 :==: x2]--brokenSameNum :: Rule (OrList (Equation Expr))-brokenSameNum = makeSimpleRule "brokenSameNum" $ onceJoinM  $ \(a :==: b) -> do-   (x1, y1) <- match divView a-   (x2, y2) <- match divView b-   guard (x1==x2)-   return $ OrList [y1 :==: y2]--brokenCross :: Rule (OrList (Equation Expr))-brokenCross = makeSimpleRule "brokenCross" $ onceJoinM $ \(a :==: b) -> do-   let matchDiv e = match divView e `mplus` fmap f (match rationalView e)-       f r = (fromInteger (numerator r), fromInteger (denominator r))-   (x1, y1) <- matchDiv a-   (x2, y2) <- matchDiv b-   return $ OrList[x1 .*. y2 :==: x2 .*. y1]---- remove inconsistent equations from the or-list, such as 0==1--- TODO: move this to a different module (should not be here)-inconsistencies :: Rule (OrList (Equation Expr))-inconsistencies = makeSimpleRule "inconsistencies" $ onceJoinM $ \(a :==: b) -> do-   r1 <- match rationalView a-   r2 <- match rationalView b-   guard (r1 /= r2)-   return $ OrList []
− src/Domain/Math/Strategy/Modulus.hs 
@@ -1,81 +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 Domain.Math.Strategy.Modulus where--import Prelude hiding (repeat)-import Common.Apply-import Common.Strategy-import Common.Uniplate-import Common.Transformation-import Common.Traversable-import Control.Monad-import Domain.Math.Expr-import Domain.Math.Expr.Symbols-import Domain.Math.Data.Equation-import Domain.Math.Data.OrList-import Domain.Math.View.Basic-import Domain.Math.ExercisesDWO-import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy)-import Domain.Math.Polynomial.QuadraticEquations (solvedList)-{- -Simplifications:-   abs r = r    if r>=0-           -r   if r<0-   abs (abs e)  = abs e-   abs (-e)     = abs e-   abs (sqrt e) = sqrt e-   abs (e^n)    = e^n  if even n--Distribution:-   abs (a*b) = abs a * abs b-   abs (a/b) = abs a / abs b--Equations:-   abs a = b        =   a = b or a = -b-   abs a = abs b    =   a = b or a = -b    (special case)--}---- For level-4 exercises, I need cube-roots (to solve x^3=9)-main = forM_ (take 12 $ concat modulusEquations) $ \eq -> -   let res = applyD modulusStrategy (OrList [eq])-   in if solvedList res then print "ok" else print res--modulusStrategy :: LabeledStrategy (OrList (Equation Expr))-modulusStrategy = label "modulus" $ noAbs <*> try (check p <*> equationsStrategy <*> repeat inconsistencies)- where p (OrList xs) = all absFree $ concat [[a,b] | a:==: b <- xs]-       absFree e = null [ () | Sym s [_] <- universe e, s == absSymbol ]--noAbs :: LabeledStrategy (OrList (Equation Expr))-noAbs = label "remove modulus" $ repeat absEquation----------------------------------------------------------------------------- Equation rules--absEquation :: Rule (OrList (Equation Expr))-absEquation = makeSimpleRule "abs in equation" $ onceJoinM f- where-   f (Sym s1 [a] :==: Sym s2 [b]) | all (==absSymbol) [s1, s2] = -      Just $ OrList [a :==: b, a :==: -b]-   f (Sym s1 [a] :==: b         ) | s1 == absSymbol = -      Just $ OrList [a :==: b, a :==: -b]-   f (a          :==: Sym s2 [b]) | s2 == absSymbol = -      Just $ OrList [a :==: b, -a :==: b]-   f _ = Nothing-   --- remove inconsistent equations from the or-list, such as 0==1--- TODO: move this to a different module (should not be here)-inconsistencies :: Rule (OrList (Equation Expr))-inconsistencies = makeSimpleRule "inconsistencies" $ onceJoinM $ \(a :==: b) -> do-   r1 <- match rationalView a-   r2 <- match rationalView b-   guard (r1 /= r2)-   return $ OrList []
− src/Domain/Math/Strategy/SquareRootEquations.hs 
@@ -1,101 +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 Domain.Math.Strategy.SquareRootEquations where--import Prelude hiding (repeat)-import Common.Apply-import Common.Strategy hiding (not)-import Common.Transformation-import Common.Traversable-import Common.Uniplate (universe)-import Control.Monad-import Domain.Math.Expr-import Domain.Math.Data.Equation-import Domain.Math.Data.OrList-import Domain.Math.View.Basic-import Domain.Math.ExercisesDWO-import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy)-import Domain.Math.Polynomial.QuadraticEquations (solvedList)-{- -Strategie (p21. G&R deel 1):-1) Isoleer wortel-2) Kwadrateer-3) Controleer--Equations:-   sqrt a = b   =   a = b^2   (if a >= 0, and b>=0)--}--main = forM_ (concat sqrtEquations) $ \eq -> -   let res = applyD sqrtStrategy (OrList [eq])-   in if solvedList res then print "ok" else print res---- TODO: check results afterwards (invalid results due to squaring both sides)-sqrtStrategy :: LabeledStrategy (OrList (Equation Expr))-sqrtStrategy = label "squareroot equation" $ isolate <*> repeat squareBoth <*>-   try (check p <*> equationsStrategy <*> repeat inconsistencies)- where p (OrList xs) = all (not . varUnderSqrt) $ concat [[a,b] | a:==: b <- xs]--isolate :: LabeledStrategy (OrList (Equation Expr))-isolate = label "isolate" $ repeat $ alternatives -   [coverUpPlus, coverUpTimes, coverUpNegation]--varUnderSqrt :: Expr -> Bool-varUnderSqrt e = not $ null [ () | Sqrt a <- universe e, hasVars a ]----------------------------------------------------------------------------- Equation rules---- Isolation-coverUpPlus :: Rule (OrList (Equation Expr))-coverUpPlus  = makeSimpleRule "coverup plus" $ onceJoinM $ \(a :==: b) -> do-   guard (not $ varUnderSqrt b)-   (x, y) <- match plusView a-   case (varUnderSqrt x, varUnderSqrt y) of-      (True,  False) -> return $ OrList [x :==: b .-. y]-      (False, True ) -> return $ OrList [y :==: b .-. x]-      _ -> Nothing--coverUpNegation :: Rule (OrList (Equation Expr))-coverUpNegation = makeSimpleRule "coverup negation" $ onceJoinM f - where-   f (Negate a :==: b) | varUnderSqrt a && not (varUnderSqrt b) =-      return $ OrList [a :==: Negate b]-   f _ = Nothing-      -coverUpTimes :: Rule (OrList (Equation Expr))-coverUpTimes = makeSimpleRule "coverup times" $ onceJoinM $ \(a :==: b) -> do-   guard (not $ varUnderSqrt b)-   (x, y) <- match timesView a-   case (varUnderSqrt x, varUnderSqrt y) of-      (True,  False) -> return $ OrList [x :==: b ./. y]-      (False, True ) -> return $ OrList [y :==: b ./. x]-      _ -> Nothing------------------------------------------------------------------squareBoth :: Rule (OrList (Equation Expr))-squareBoth = makeSimpleRule "inconsistencies" $ onceJoinM f- where-    f (Sqrt a :==: Sqrt b) = return $ OrList [a :==: b]-    f (a      :==: Sqrt b) = return $ OrList [a .^. 2 :==: b]-    f (Sqrt a :==: b     ) = return $ OrList [a :==: b .^. 2]-    f _ = Nothing---- remove inconsistent equations from the or-list, such as 0==1--- TODO: move this to a different module (should not be here)-inconsistencies :: Rule (OrList (Equation Expr))-inconsistencies = makeSimpleRule "inconsistencies" $ onceJoinM $ \(a :==: b) -> do-   r1 <- match rationalView a-   r2 <- match rationalView b-   guard (r1 /= r2)-   return $ OrList []
− src/Domain/Math/Strategy/SquareRootSimplification.hs 
@@ -1,96 +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 Domain.Math.Strategy.SquareRootSimplification where--import Prelude hiding (repeat)-import Common.Apply-import Common.Strategy hiding (not)-import Common.Transformation-import Common.Uniplate (universe)-import Control.Monad-import Domain.Math.Expr-import Domain.Math.Data.Equation-import Domain.Math.Data.OrList-import Domain.Math.View.Basic-import Domain.Math.ExercisesDWO-import Domain.Math.View.SquareRoot-import Domain.Math.Polynomial.HigherDegreeEquations (equationsStrategy)-{- -Strategie (p21. G&R deel 1):-1) Isoleer wortel-2) Kwadrateer-3) Controleer--Equations:-   sqrt a = b   =   a = b^2   (if a >= 0, and b>=0)--}--main = forM_ (concat simplerSqrt) $ \e -> -   if e `belongsTo` squareRootView then print "ok" else print e---- TODO: check results afterwards (invalid results due to squaring both sides)-{--sqrtStrategy :: LabeledStrategy (OrList (Equation Expr))-sqrtStrategy = label "squareroot equation" $ isolate <*> repeat squareBoth <*>-   try (check p <*> equationsStrategy <*> repeat inconsistencies)- where p (OrList xs) = all (not . varUnderSqrt) $ concat [[a,b] | a:==: b <- xs]--}-isolate :: LabeledStrategy (OrList (Equation Expr))-isolate = undefined----------------------------------------------------------------------------- Equation rules-{---- Isolation-coverUpPlus :: Rule (OrList (Equation Expr))-coverUpPlus  = makeSimpleRuleList "coverup plus" $ forOne $ \(a :==: b) -> do-   guard (not $ varUnderSqrt b)-   (x, y) <- match plusView a-   case (varUnderSqrt x, varUnderSqrt y) of-      (True,  False) -> return [x :==: b .-. y]-      (False, True ) -> return [y :==: b .-. x]-      _ -> Nothing--coverUpNegation :: Rule (OrList (Equation Expr))-coverUpNegation = makeSimpleRuleList "coverup negation" $ forOne f - where-   f (Negate a :==: b) | varUnderSqrt a && not (varUnderSqrt b) =-      return [a :==: Negate b]-   f _ = Nothing-      -coverUpTimes :: Rule (OrList (Equation Expr))-coverUpTimes = makeSimpleRuleList "coverup times" $ forOne $ \(a :==: b) -> do-   guard (not $ varUnderSqrt b)-   (x, y) <- match timesView a-   case (varUnderSqrt x, varUnderSqrt y) of-      (True,  False) -> return [x :==: b ./. y]-      (False, True ) -> return [y :==: b ./. x]-      _ -> Nothing------------------------------------------------------------------squareBoth :: Rule (OrList (Equation Expr))-squareBoth = makeSimpleRuleList "inconsistencies" $ forOne f- where-    f (Sqrt a :==: Sqrt b) = return [a :==: b]-    f (a      :==: Sqrt b) = return [a .^. 2 :==: b]-    f (Sqrt a :==: b     ) = return [a :==: b .^. 2]-    f _ = Nothing---- remove inconsistent equations from the or-list, such as 0==1--- TODO: move this to a different module (should not be here)-inconsistencies :: Rule (OrList (Equation Expr))-inconsistencies = makeSimpleRuleList "inconsistencies" $ forOne $ \(a :==: b) -> do-   r1 <- match rationalView a-   r2 <- match rationalView b-   guard (r1 /= r2)-   return [] -}
− src/Domain/Programming.hs 
@@ -1,29 +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  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
------------------------------------------------------------------------------
-module Domain.Programming
-   ( module Domain.Programming.Expr
-   , module Domain.Programming.Prelude
-   , module Domain.Programming.Eval
-   , module Domain.Programming.Parser
-   , module Domain.Programming.Strategies
-   , module Domain.Programming.Rules
-   , module Domain.Programming.Exercises
-   ) where
-   
-import Domain.Programming.Expr
-import Domain.Programming.Prelude
-import Domain.Programming.Eval
-import Domain.Programming.Parser
-import Domain.Programming.Strategies
-import Domain.Programming.Rules
-import Domain.Programming.Exercises
-
+ src/Domain/RegularExpr/Definitions.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- 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.RegularExpr.Definitions where++import Domain.RegularExpr.Expr+import Common.Uniplate+import Common.Utils (distinct)++deterministic :: (Show a, Eq a) => RE a -> Bool+deterministic r = deterministicSimple r {-+   case (deterministicSimple r, det r) of+      (b1, b2) | b1==b2 -> b1+      _ -> error $ show r -}+       +deterministicSimple :: Eq a => RE a -> Bool+deterministicSimple regexp =+   distinct (lookahead regexp) && all deterministicSimple (children regexp)++det :: Eq a => RE a -> Bool+det regexp =+   case regexp of+      EmptySet -> True+      Epsilon  -> True+      Atom _   -> True+      Option r -> det (r :|: Epsilon)+      Star r   -> det r+      Plus r   -> det (r :*: Star r)+      r :|: s  -> lookahead r `disj` lookahead s && det r && det s+      EmptySet  :*: r -> det r+      Epsilon   :*: r -> det r+      Atom _    :*: r -> det r+      Option s  :*: r -> det ((s :|: Epsilon) :*: r)+      Star s    :*: r -> lookahead s `disj` lookahead r && det s && det r+      Plus s    :*: r -> det ((s :*: Star s) :*: r)+      (q :|: s) :*: r -> det ((q :*: r) :|: (s :*: r))+      (q :*: s) :*: r -> det (q :*: (s :*: r))+++disj xs ys = all (`notElem` xs) ys++empty :: RE a -> Bool+empty = foldRE (False, True, const (False), const True, const True, id, (&&), (||))++lookahead :: RE a -> [a]+lookahead = map fst . firsts++firsts :: RE a -> [(a, RE a)]+firsts regexp =+   case regexp of+      EmptySet -> []+      Epsilon  -> []+      Atom a   -> [(a, Epsilon)]+      Option r -> firsts r+      Star r   -> firsts (nonempty r :*: Star r)+      Plus r   -> firsts (r :*: Star r)+      r :*: s  -> [ (a, q :*: s) | (a, q) <- firsts r ] +++                  (if empty r then firsts s else [])+      r :|: s  -> firsts r ++ firsts s++nonempty :: RE a -> RE a+nonempty regexp = foldr (:|:) EmptySet [ Atom a :*: r | (a, r) <- firsts regexp ]
+ src/Domain/RegularExpr/Exercises.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------+-- 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.RegularExpr.Exercises (regexpExercise) where++import Common.Exercise+import Common.Navigator+import Common.Traversable+import Common.Rewriting hiding (difference)+import Domain.RegularExpr.Expr+import Domain.RegularExpr.Parser+import Domain.RegularExpr.Strategy+import Domain.RegularExpr.Definitions+import Control.Monad+import System.Random+import Test.QuickCheck++regexpExercise :: Exercise RegExp+regexpExercise = makeExercise+   { description    = "Rewrite a regular expression"+   , exerciseCode   = makeCode "regexp" "normalform"+   , status         = Experimental+   , parser         = parseRegExp+   , prettyPrinter  = ppRegExp+--   , equivalence    = eqRE+   , similarity     = equalWith operators -- modulo associativity+   , isReady        = deterministic+   , isSuitable     = (>1) . length . crush+   , difference     = differenceMode eqRE+   , strategy       = deterministicStrategy+   , navigation     = navigator+--   , extraRules     :: [Rule (Context a)]  -- Extra rules (possibly buggy) not appearing in strategy+   , testGenerator  = Just startFormGen -- arbitrary+   , randomExercise = simpleGenerator startFormGen -- myGen+   , examples       = generate 5 (mkStdGen 2805) (replicateM 15 startFormGen)+   }++-- myGen :: Gen RegExp+-- myGen = restrictGenerator (isSuitable regexpExercise) arbitrary++startFormGen :: Gen RegExp+startFormGen = do+   i  <- oneof $ map return [1..10]+   xs <- replicateM i $ do+      j  <- oneof $ map return [1..5]+      ys <- replicateM j $ oneof $ map (return . Atom . return) "abcd"+      return $ foldr1 (:*:) ys+   return $ foldr1 (:|:) xs   ++-- equivalence of regular expressions+eqRE :: Eq a => RE a -> RE a -> Bool+eqRE = (==)++{-+checkUntil :: Ord a => Int -> RE a -> RE a -> Bool+checkUntil n r s = empty r == empty s && (n==0 || next)+ where+   make = groupBy eqFst . sortBy cmpFst . firsts+   eqFst  (a, _) (b, _) = a==b +   cmpFst (a, _) (b, _) = compare a b+   +   as = make r+   bs = make s+   next = and ((length as == length bs) : zipWith f as bs)+   +   -- f ((a, _):+   f _ _ = False -}
+ src/Domain/RegularExpr/Expr.hs view
@@ -0,0 +1,175 @@+{-# OPTIONS -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- 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.RegularExpr.Expr where++import Common.Rewriting+import Common.Traversable+import Common.Uniplate+import Control.Monad+import Domain.Math.Expr.Symbolic+import Test.QuickCheck++--------------------------------------------------------------------+-- Data type declaration++infixl 4 :|:+infixl 5 :*:++type RegExp = RE String++data RE a = EmptySet | Epsilon | Atom a | Option (RE a) | Star (RE a)+          | Plus (RE a) | RE a :*: RE a | RE a :|: RE a+   deriving (Show, Eq, Ord)++--------------------------------------------------------------------+-- Fold++foldRE (es, eps, at, opt, st, pl, sq, ch) = rec + where+   rec regexp = +      case regexp of+         EmptySet -> es+         Epsilon  -> eps+         Atom a   -> at a+         Option r -> opt (rec r)+         Star r   -> st (rec r)+         Plus r   -> pl (rec r)+         r :*: s  -> sq (rec r) (rec s)+         r :|: s  -> ch (rec r) (rec s)++--------------------------------------------------------------------+-- General instances++instance Functor RE where+   fmap f = foldRE (EmptySet, Epsilon, Atom . f, Option, Star, Plus, (:*:), (:|:))++instance Crush RE where+   crush (Atom a) = [a]+   crush regexp   = concatMap crush (children regexp)++instance Arbitrary RegExp where+   arbitrary = sized (arbRE $ oneof $ map return ["a", "b", "c", "d"])+instance CoArbitrary RegExp where+   coarbitrary = foldRE +      (         variant 0+      ,         variant 1+      , \a ->   variant 2 . coarbitrary a+      , \a ->   variant 3 . a+      , \a ->   variant 4 . a+      , \a ->   variant 5 . a+      , \a b -> variant 6 . a . b+      , \a b -> variant 7 . a . b+      )++arbRE :: Gen a -> Int -> Gen (RE a)+arbRE g n +   | n == 0 = frequency +        [ (6, liftM Atom g)+        , (3, return Epsilon)+        , (1, return EmptySet)+        ]+   | otherwise = frequency +        [ (3, arbRE g 0)+        , (2, unop Star) -- (1, unop Option), (1, unop Plus)+        , (3, binop (:*:)), (3, binop (:|:))+        ]+ where+   rec     = arbRE g (n `div` 2)+   unop  f = liftM  f rec+   binop f = liftM2 f rec rec++--------------------------------------------------------------------+-- Pretty-printer++ppRegExp :: RegExp -> String+ppRegExp = ppWith (const id)++ppWith :: (Int -> a -> String) -> RE a -> String+ppWith f = ($ 0) . foldRE +   (const "F", const "T", flip f, unop "?", unop "*", unop "+", binop 5 "", binop 4 "|")+ where +   unop s a _ = parIf False (a 6 ++ s)+   binop i s a b n = parIf (n > i) (a i ++ s ++ b i)+   parIf b s = if b then "(" ++ s ++ ")" else s++--testje = ppWith (const id) (Star (Plus (Atom "P")) :*: (Option (Atom "Q" :*: Option (Atom "S")) :|: Atom "R"))++--------------------------------------------------------------------+-- Function for associative operators++concatOp :: Operator (RE a)+concatOp = associativeOperator (:*:) isConcat+ where+   isConcat (r :*: s) = Just (r, s)+   isConcat _         = Nothing++choiceOp :: Operator (RE a)+choiceOp = associativeOperator (:|:) isChoice+ where+   isChoice (r :|: s) = Just (r, s)+   isChoice _         = Nothing++--------------------------------------------------------------------+-- Instances for rewriting++instance Uniplate (RE a) where+   uniplate regexp = +      case regexp of+         EmptySet -> ([],     \[] -> EmptySet)+         Epsilon  -> ([],     \[] -> Epsilon)+         Atom a   -> ([],     \[] -> Atom a)+         Option r -> ([r],    \[a] -> Option a)+         Star r   -> ([r],    \[a] -> Star a)+         Plus r   -> ([r],    \[a] -> Plus a)+         r :*: s  -> ([r, s], \[a, b] -> a :*: b)+         r :|: s  -> ([r, s], \[a, b] -> a :|: b)++instance Eq a => ShallowEq (RE a) where+   shallowEq re1 re2 = +      case (re1, re2) of+         (EmptySet, EmptySet) -> True+         (Epsilon,  Epsilon ) -> True+         (Atom a,   Atom b  ) -> a==b+         (Option _, Option _) -> True+         (Star _,   Star _  ) -> True+         (Plus _,   Plus _  ) -> True+         (_ :*: _,  _ :*: _ ) -> True+         (_ :|: _,  _ :|: _ ) -> True+         _                    -> False++instance Different (RE a) where+   different = (EmptySet, Epsilon)++instance IsTerm RegExp where +   toTerm = foldRE +      ( nullary "EmptySet", nullary "Epsilon", variable, unary "Option"+      , unary "Star", unary "Plus", binary ":*:", binary ":|:"+      ) ++   fromTerm a = fromTermWith f a `mplus` liftM Atom (getVariable a)+    where+      f s []     +         | s == "EmptySet" = return EmptySet+         | s == "Epsilon"  = return Epsilon+      f s [x]    +         | s == "Option"   = return (Option x)+         | s == "Star"     = return (Star x)+         | s == "Plus"     = return (Plus x)+      f s [x, y] +         | s == ":*:"      = return (x :*: y)+         | s == ":|:"      = return (x :|: y)+      f _ _ = fail "fromExpr"++instance Rewrite RegExp where+   operators = [concatOp, choiceOp]+   associativeOps = const $ map toSymbol [":*:", ":|:"]
+ src/Domain/RegularExpr/Parser.hs view
@@ -0,0 +1,39 @@+-----------------------------------------------------------------------------+-- 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.RegularExpr.Parser (parseRegExp) where++import Domain.RegularExpr.Expr+import Text.Parsing++logicScanner :: Scanner+logicScanner = (specialSymbols "+*?|" defaultScanner)+   { keywords = ["T", "F"]+   , keywordOperators = ["+", "*", "?", "|"]+   , isIdentifierCharacter = const False+   }++parseRegExp :: String -> Either String RegExp+parseRegExp = parseWithM logicScanner pRE++pRE :: TokenParser RegExp+pRE = pOr + where+   pOr   =  pChainl ((:|:) <$ pKey "|") pSeq+   pSeq  =  foldl1 (:*:) <$> pList1 pPost+   pPost =  foldl (flip ($)) <$> pAtom <*> pList pUnop+   pUnop =  Star <$ pKey "*" <|> Plus <$ pKey "+" <|> Option <$ pKey "?"+   pAtom =  Atom <$> (pVarid <|> pConid)+        <|> Epsilon  <$ pKey "T"+        <|> EmptySet <$ pKey "F"+        <|> pSpec '(' *> pRE <* pSpec ')'++-- testje = parseRegExp "P+*((QS?)?|R)"
+ src/Domain/RegularExpr/Strategy.hs view
@@ -0,0 +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.RegularExpr.Strategy (deterministicStrategy) where++import Domain.RegularExpr.Expr+import Common.Context+import Common.Strategy+import Common.Rewriting+import Common.Transformation+import Prelude hiding (repeat, replicate)++deterministicStrategy :: LabeledStrategy (Context RegExp)+deterministicStrategy = label "deterministic and precise" $ +   repeat (somewhere+   ((liftToContext ruleLeftFactor1 <|> +    liftToContext ruleLeftFactor2 <|> +    liftToContext ruleIdempOr <|>+   -- liftToContext ruleEpsilonSeq <|>+   -- liftToContext ruleEmptySeq <|>+   -- liftToContext ruleEmptyChoice <|>+    liftToContext ruleDefOption) |>+    liftToContext ruleCommFactor))+    <*> +    repeat (somewhere (liftToContext ruleIntroOption))++ruleLeftFactor1 :: Rule RegExp+ruleLeftFactor1 = rule "LeftFactor1" $ \a x y -> +   (a :*: x) :|: (a :*: y)  :~>  a :*: (x :|: y)+   +ruleLeftFactor2 :: Rule RegExp+ruleLeftFactor2 = ruleList "LeftFactor2" $+   [ \a x -> (a :*: x) :|: a  :~>  a :*: Option x+   , \a x -> a :|: (a :*: x)  :~>  a :*: Option x+   ]++ruleIdempOr :: Rule RegExp+ruleIdempOr = rule "IdempOr" $ \a -> +   a :|: a  :~>  a+ +ruleCommFactor :: Rule RegExp+ruleCommFactor = ruleList "CommFactor"+   [ \a b _ _ -> a :|: b :|: a  :~>  a :|: a :|: b+   , \a b x _ -> (a :*: x) :|: b :|: a  :~>  (a :*: x) :|: a :|: b+   , \a b y _ -> a :|: b :|: (a :*: y)  :~>  a :|: (a :*: y) :|: b+   , \a b x y -> (a :*: x) :|: b :|: (a :*: y)  :~>  (a :*: x) :|: (a :*: y) :|: b+   ]+   ++   +ruleDefOption :: Rule RegExp+ruleDefOption = rule "DefOption" $ \a ->+   Option a  :~>  Epsilon :|: a+   +ruleIntroOption :: Rule RegExp+ruleIntroOption = ruleList "IntroOption" +   [ \a -> Epsilon :|: a  :~>  Option a+   , \a -> a :|: Epsilon  :~>  Option a+   ]+   +---+{-+ruleEpsilonSeq :: Rule RegExp+ruleEpsilonSeq = ruleList "EpsilonSeq" +   [ \a -> Epsilon :*: a  :~>  a+   , \a -> a :*: Epsilon  :~> a+   ]+   +ruleEmptySeq :: Rule RegExp+ruleEmptySeq = ruleList "EmptySeq" +   [ \a -> EmptySet :*: a  :~> EmptySet+   , \a -> a :*: EmptySet  :~> EmptySet+   ]+   +ruleEmptyChoice :: Rule RegExp+ruleEmptyChoice = ruleList "EmptyChoice" +   [ \a -> EmptySet :|: a  :~> a+   , \a -> a :|: EmptySet  :~> a+   ]+-} +-----------------+{-+ruleComm :: Rule RegExp+ruleComm = makeSimpleRuleList "Comm" $ \re -> do+   let xs = collectWithOperator choiceOp re+   i <- [0..length xs-1]+   j <- [i+2..length xs-1]+   let (as, b:bs) = splitAt i xs+       (cs, d:ds) = splitAt (j-i-1) bs+   guard (all (`notElem` (lookahead b)) (lookahead d))+   let new = as++[b,d]++cs++ds+   return (buildWithOperator choiceOp new)-}
src/Domain/RelationAlgebra.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
src/Domain/RelationAlgebra/Equivalence.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
src/Domain/RelationAlgebra/Exercises.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -21,25 +21,26 @@ import Common.Exercise
 import Common.Context
 import Data.Maybe
-import Text.Parsing (fromRanged)
 import Common.Derivation
 import Common.Rewriting (differenceMode)
 import Common.Strategy hiding (not)
 import Common.Transformation
+import Common.Navigator
 
 cnfExercise :: Exercise RelAlg
 cnfExercise = testableExercise
    { description    = "To conjunctive normal form"
    , exerciseCode   = makeCode "relationalg" "cnf"
-   , status         = Provisional
-   , parser         = either Left (Right . fromRanged) . parseRelAlg
+   , status         = Alpha
+   , parser         = parseRelAlg
    , prettyPrinter  = ppRelAlg
    , equivalence    = probablyEqual -- isEquivalent
    , extraRules     = map liftToContext (relAlgRules ++ buggyRelAlgRules)
    , strategy       = toCNF
+   , navigation     = navigator
    , difference     = differenceMode probablyEqual
    , ordering       = compare
-   , isReady        = ready (ruleset cnfExercise)
+   , isReady        = ready cnfExercise
    , randomExercise = let ok p = let n = fromMaybe maxBound (stepsRemaining 4 p)
                                  in n >= 2 && n <= 4
                       in useGenerator ok (\_ -> templateGenerator 1)
@@ -47,7 +48,7 @@ 
 stepsRemaining :: Int -> RelAlg -> Maybe Int
 stepsRemaining i = 
-   lengthMax i . derivationTree toCNF . inContext
+   lengthMax i . derivationTree toCNF . inContext cnfExercise
 
 {- cnfExerciseSimple :: Exercise RelAlg
 cnfExerciseSimple = cnfExercise
@@ -56,5 +57,6 @@    , strategy    = label "Apply rules exhaustively" $ repeat $ somewhere $ alternatives $ ruleset cnfExercise
    } -}
    
-ready :: [Rule (Context a)] -> a -> Bool
-ready rs = null . applyAll (alternatives $ filter (not . isBuggyRule) rs) . inContext+ready :: Exercise a -> a -> Bool
+ready ex = null . applyAll (alternatives $ filter (not . isBuggyRule) (ruleset ex)) 
+         . inContext ex
src/Domain/RelationAlgebra/Formula.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -11,13 +11,13 @@ -----------------------------------------------------------------------------
 module Domain.RelationAlgebra.Formula where
 
+import Domain.Math.Expr.Symbolic
+import Common.Exercise (generate)
 import Common.Uniplate (Uniplate(..))
 import Common.Rewriting
 import Common.Utils
 import Control.Monad
-import Data.Char
 import Data.List
-import Data.Maybe
 import qualified Data.Set as S
 import System.Random (StdGen, mkStdGen, split)
 import Test.QuickCheck
@@ -47,7 +47,6 @@ 
 -------------------------------------
 
-
 isAtom :: RelAlg -> Bool
 isAtom  r = 
     case r of
@@ -170,11 +169,6 @@          Inv s     -> ([s], \[a] -> Inv a)
          _         -> ([], \[] -> term)
 
-instance MetaVar RelAlg where
-   isMetaVar (Var a) = isMetaVar a
-   isMetaVar _       = Nothing
-   metaVar           = Var . metaVar
-
 instance ShallowEq RelAlg where
    shallowEq expr1 expr2 = 
       case (expr1, expr2) of
@@ -187,4 +181,29 @@          (Inv _   , Inv _   ) -> True
          (V       , V       ) -> True
          (I       , I       ) -> True
-         _                    -> False+         _                    -> False
+         
+instance Different RelAlg where
+   different = (V, I)
+   
+instance IsTerm RelAlg where
+   toTerm = foldRelAlg 
+      ( variable, binary ".", binary "+", binary "&&", binary "||"
+      , unary "~", unary "-", nullary "V", nullary "I"
+      )
+
+   fromTerm a = 
+      fromTermWith f a `mplus` liftM Var (getVariable a)
+    where
+      f s []
+         | s == "V"  = return V
+         | s == "I"  = return I
+      f s [x]
+         | s == "~"  = return (Not x)
+         | s == "-"  = return (Inv x)
+      f s [x, y]
+         | s == "."  = return (x :.:  y)
+         | s == "+"  = return (x :+:  y)
+         | s == "&&" = return (x :&&: y)
+         | s == "||" = return (x :||: y)
+      f _ _ = fail "fromTerm"
src/Domain/RelationAlgebra/Generator.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -14,12 +14,13 @@ import Domain.RelationAlgebra.Formula
 import Common.Rewriting
 import Control.Monad
-import Test.QuickCheck 
+import Test.QuickCheck
 
 instance Rewrite RelAlg
 
 instance Arbitrary RelAlg where
-   arbitrary = sized arbRelAlg
+   arbitrary = sized (arbRelAlg . min 8)
+instance CoArbitrary RelAlg where
    coarbitrary term =
       case term of
          Var x    -> variant 0 . coarbitrary x
src/Domain/RelationAlgebra/Parser.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -13,12 +13,12 @@ 
 import Domain.RelationAlgebra.Formula
 import Text.Parsing
-import Data.Char
 
 myScanner :: Scanner
-myScanner = minusAsSpecial $ makeCharsSpecial "~" defaultScanner
+myScanner = defaultScanner
    { keywords         = ["V", "E", "I"]
-   , keywordOperators = concatMap (map fst . snd) operatorTable
+   , keywordOperators = invSym : notSym : concatMap (map fst . snd) operatorTable
+   , specialCharacters = "-~" ++ specialCharacters defaultScanner
    }
 
 operatorTable :: OperatorTable RelAlg
@@ -38,37 +38,38 @@ -----------------------------------------------------------
 --- Parser
 
-parseRelAlg  :: String -> Either SyntaxError (Ranged RelAlg)
+parseRelAlg  :: String -> Either String RelAlg
 parseRelAlg = analyseAndParse pRelAlg . scanWith myScanner
 
-pRelAlg :: Parser Token (Ranged RelAlg)
+pRelAlg :: Parser Token RelAlg
 pRelAlg = pOperators operatorTable pTerm
 
 -- Two postfix operators
-pTerm :: Parser Token (Ranged RelAlg)
+pTerm :: Parser Token RelAlg
 pTerm = foldl (flip ($)) <$> pAtom <*> pList pUnOp
  where
-   pUnOp  =  unaryOp  Inv <$> pKey invSym 
-         <|> unaryOp  Not <$> pKey notSym
+   pUnOp  =  Inv <$ pKey invSym 
+         <|> Not <$ pKey notSym
 
-pAtom :: Parser Token (Ranged RelAlg)
-pAtom  =  (\(s, r) -> toRanged (Var s) r) <$> pVarid
+pAtom :: Parser Token RelAlg
+pAtom  =  Var <$> pVarid
       <|> pParens pRelAlg
-      <|> toRanged V     <$> pKey "V"
-      <|> toRanged empty <$> pKey "E"
-      <|> toRanged I     <$> pKey "I"
+      <|> const V     <$> pKey "V"
+      <|> const empty <$> pKey "E"
+      <|> const I     <$> pKey "I"
 
 -----------------------------------------------------------
 --- Helper-function for parentheses analyses
 
-analyseAndParse :: Parser Token a -> [Token] -> Either SyntaxError a
+analyseAndParse :: Parser Token a -> [Token] -> Either String a
 analyseAndParse p ts =
    case checkParentheses ts of
-      Just err -> Left err
-      Nothing  -> case parse p ts of
-                     (_, m:_) -> Left (fromMessage m)
-                     (a, _)   -> Right a
-                                        
+      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"
+                               
 -----------------------------------------------------------
 --- Pretty-Printer
src/Domain/RelationAlgebra/Rules.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
src/Domain/RelationAlgebra/Strategies.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
+ src/Main.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------
+-- 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)
+--
+-- Main module for feedback services
+--
+-----------------------------------------------------------------------------
+module Main (main) where
+
+import Common.Utils (useFixedStdGen)
+import Control.Monad
+import Control.Monad.Trans
+import Data.IORef
+import Data.Time
+import Documentation.Make
+import Main.ExerciseList
+import Main.LoggingDatabase
+import Main.Options
+import Network.CGI
+import Service.ModeJSON (processJSON)
+import Service.ModeXML  (processXML)
+import Service.Request
+
+main :: IO ()
+main = do
+   startTime <- getCurrentTime
+   flags     <- serviceOptions
+   logRef    <- newIORef (return ())
+   
+   case withInputFile flags of      
+      -- from file
+      Just file -> do  
+         when (FixRNG `elem` flags) 
+            useFixedStdGen -- use a predictable "random" number generator
+         input    <- readFile file
+         (req, txt, _) <- process input
+         when (Logging True `elem` flags) $ 
+            writeIORef logRef $ -- save logging action for later
+               logMessage req input txt "local" startTime
+         putStrLn txt
+
+      -- documentation mode
+      _ | documentationMode flags -> 
+             useIDEAS $ 
+         mapM_ makeDocumentation (docItems flags)
+
+      -- cgi binary
+      Nothing -> runCGI $ do
+         addr  <- remoteAddr           -- the IP address of the remote host making the request          
+         raw   <- getInput "input"     -- read input
+         input <- case raw of
+                     Nothing -> fail "Invalid request: environment variable \"input\" is empty"
+                     Just s  -> return s
+         (req, txt, ctp) <- lift $ process input
+         lift $ writeIORef logRef $ -- save logging action for later
+            logMessage req input txt addr startTime
+         setHeader "Content-type" ctp
+         output txt
+   
+   -- log request to database
+   when (withLogging flags) $
+      join (readIORef logRef)
+   
+process :: String -> IO (Request, String, String)
+process input = useIDEAS $ 
+   case discoverDataFormat input of
+      Just XML  -> processXML input
+      Just JSON -> processJSON input
+      _ -> fail "Invalid input"
+ src/Main/ExerciseList.hs view
@@ -0,0 +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 Main.ExerciseList (packages, useIDEAS) where++import Common.Utils (Some(..), fromShowString)+import Common.Rewriting+import Domain.Math.Expr+import Service.ExercisePackage+import Service.FeedbackText+import Service.DomainReasoner+import qualified Domain.LinearAlgebra as LA+import qualified Domain.Logic as Logic+import qualified Domain.Logic.FeedbackText as Logic+import qualified Domain.RelationAlgebra as RA+import qualified Domain.Math.DerivativeExercise as Math+import qualified Domain.Math.Numeric.Exercises as Math+import qualified Domain.Math.Equation.CoverUpExercise as Math+import qualified Domain.Math.Polynomial.Exercises as Math+import qualified Domain.Math.Polynomial.IneqExercises as Math+import qualified Domain.RegularExpr.Exercises as RE+import qualified Domain.Math.Power.Exercises as Math+import Main.Options+import Service.ServiceList++packages :: [Some ExercisePackage]+packages =+   [ -- logic and relation-algebra+     Some (package Logic.dnfExercise)+        { withOpenMath    = True+        , toOpenMath      = termToOMOBJ . toTerm . fmap (Var . fromShowString)+        , fromOpenMath    = (>>= fromTerm) . omobjToTerm+        , getExerciseText = Just logicText+        }+   , Some (package Logic.dnfUnicodeExercise)+        { withOpenMath    = True+        , toOpenMath      = termToOMOBJ . toTerm . fmap (Var . fromShowString)+        , fromOpenMath    = (>>= fromTerm) . omobjToTerm+        , getExerciseText = Just logicText+        }+   , 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.quadraticNoABCExercise+   , someTermPackage Math.quadraticWithApproximation+   , someTermPackage Math.derivativeExercise+   , someTermPackage Math.simplifyPowerExercise+   , someTermPackage Math.powerOfExercise     +   , someTermPackage Math.nonNegExpExercise+   , someTermPackage Math.calcPowerExercise+     -- 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+   }+   +useIDEAS :: DomainReasoner a -> IO a+useIDEAS action = runDomainReasoner $ do+   setVersion     shortVersion+   setFullVersion fullVersion+   addPackages    packages+   addServices    serviceList+   addPkgService  exerciselistS+   action
+ src/Main/LoggingDatabase.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- 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)
+--
+-- Facilities to create a log database
+--
+-----------------------------------------------------------------------------
+module Main.LoggingDatabase (logMessage, logEnabled) where
+
+import Data.Time
+import Service.Request
+#ifdef DB
+import Data.Maybe
+import Database.HDBC
+import Database.HDBC.Sqlite3 (connectSqlite3)
+
+logEnabled :: Bool
+logEnabled = True
+
+-- | Log a message to the database (a Sqlite database).
+logMessage :: Request -> String -> String -> String -> UTCTime -> IO ()
+logMessage req input output ipaddress begin = do
+     -- make a connection with the database
+     conn <- connectSqlite3 "service.db"
+
+     -- check if the database exists, if not make one
+     --tables <- getTables conn
+     --if not (elem "log" tables) then run conn createStmt [] else return 0
+
+     -- calculate duration
+     end <- getCurrentTime
+     let diff = diffUTCTime end begin 
+
+     -- insert data into database
+     run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" 
+             [ toSql $ service req
+             , toSql $ maybe "unknown" show (exerciseID req)
+             , toSql $ fromMaybe "unknown" (source req)
+             , toSql $ show (dataformat req)
+             , toSql $ maybe "unknown" show (encoding req)
+             , toSql $ input
+             , toSql $ output
+             , toSql $ ipaddress
+             , toSql $ begin
+             , toSql $ diff
+             ]
+     commit conn
+
+     -- close the connection to the database
+     disconnect conn
+  `catch` \err -> do putStrLn $ "Error in logging to database: " ++ show err
+
+{-
+-- | Log table schema
+createStmt =  "CREATE TABLE log ( service      VARCHAR(250)"
+           ++                  ", exerciseID   VARCHAR(250)"
+           ++                  ", source       VARCHAR(250)"
+           ++                  ", dataformat   VARCHAR(250)"
+           ++                  ", encoding     VARCHAR(250)"
+           ++                  ", input        VARCHAR(250)"
+           ++                  ", output       VARCHAR(250)"
+           ++                  ", ipaddress    VARCHAR(20)"
+           ++                  ", time         TIME"
+           ++                  ", responsetime TIME)"
+-}
+#else
+logMessage :: Request -> String -> String -> String -> UTCTime -> IO ()
+logMessage _ _ _ _ _ = return ()
+
+logEnabled :: Bool
+logEnabled = False
+#endif
+
+ src/Main/Options.hs view
@@ -0,0 +1,91 @@+-----------------------------------------------------------------------------
+-- 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)
+--
+-- Options and command-line flags for services
+--
+-----------------------------------------------------------------------------
+module Main.Options where
+
+import Data.Maybe
+import Documentation.Make
+import Main.LoggingDatabase (logEnabled)
+import Main.Revision
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+
+data Flag = Version | Help | Logging Bool | InputFile String 
+          | FixRNG | DocItem DocItem
+   deriving Eq
+
+header :: String
+header = 
+   "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++
+   "Copyright 2010, Open Universiteit Nederland\n" ++
+   versionText ++
+   "\n\nUsage: ideas [OPTION]     (by default, CGI protocol)\n" ++
+   "\nOptions:"
+
+versionText :: String
+versionText = 
+  "version " ++ version ++ ", revision " ++ show revision ++
+  ", logging " ++ (if logEnabled then "enabled" else "disabled")
+
+fullVersion :: String
+fullVersion = "version " ++ version ++ " (revision " 
+           ++ show revision ++ ", " ++ lastChanged ++ ")"
+
+shortVersion :: String
+shortVersion = version ++ " (" ++ show revision ++ ")"
+
+options :: [OptDescr Flag]
+options =
+     [ Option []  ["version"]    (NoArg Version)           "show version number"
+     , Option "?" ["help"]       (NoArg Help)              "show options"
+     , Option "l" ["logging"]    (NoArg $ Logging True)    "enable logging"
+     , Option []  ["no-logging"] (NoArg $ Logging False)   "disable logging (default on local machine)"
+     , Option "f" ["file"]       (ReqArg InputFile "FILE") "use input FILE as request"
+     , Option ""  ["fixed-rng"]  (NoArg FixRNG)            "use a fixed random-number generator"
+     , Option ""  ["make-pages"] (docItemDescr (Pages      . fromMaybe "docs")) "generate pages for exercises and services"
+     , Option ""  ["make-rules"] (docItemDescr (LatexRules . fromMaybe "docs")) "generate latex code for rewrite rules"
+     , Option ""  ["self-check"] (docItemDescr (SelfCheck  . fromMaybe "test")) "perform a self-check"
+     ]
+
+docItemDescr :: (Maybe String -> DocItem) -> ArgDescr Flag
+docItemDescr f = OptArg (DocItem . f) "DIR"
+
+serviceOptions :: IO [Flag]
+serviceOptions = do
+   args <- getArgs
+   case getOpt Permute options args of
+      (flags, [], [])
+         | flags == [Version] -> do 
+              putStrLn ("IDEAS, " ++ versionText)
+              exitSuccess
+         | all (`notElem` flags) [Version, Help] ->
+              return flags
+      (_, _, errs) -> do
+         putStrLn (concat errs ++ usageInfo header options)
+         exitFailure 
+
+docItems :: [Flag] -> [DocItem]
+docItems flags = [ x | DocItem x <- flags ]
+
+documentationMode :: [Flag] -> Bool
+documentationMode = not . null . docItems
+
+withLogging :: [Flag] -> Bool
+withLogging flags = and [ b | Logging b <- flags ]
+   
+withInputFile :: [Flag] -> Maybe String
+withInputFile flags = 
+   case [ file | InputFile file <- flags ] of
+      [hd] -> Just hd
+      _    -> Nothing
+ src/Main/Revision.hs view
@@ -0,0 +1,5 @@+-- Automatically generated by Makefile.  Do not change.+module Main.Revision where+version = "0.6"+revision = 3065+lastChanged = "ma, 19 apr 2010"
+ src/Service/Diagnose.hs view
@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------+-- 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(..), RuleID, diagnose, restartIfNeeded+   ) where ++import Common.Apply+import Common.Context+import Common.Exercise+import Common.Strategy (emptyPrefix)+import Common.Transformation+import Common.Utils (safeHead)+import Data.Maybe+import Service.TypedAbstractService++----------------------------------------------------------------+-- Result types for diagnose service++type RuleID a = Rule (Context a)++data Diagnosis a+   = Buggy          (RuleID a)+   | NotEquivalent  +   | Similar        Bool (State a)+   | Expected       Bool (State a) (RuleID a)+   | Detour         Bool (State a) (RuleID a)+   | Correct        Bool (State a)++----------------------------------------------------------------+-- The diagnose service++diagnose :: State a -> a -> Diagnosis a+diagnose state new+   -- Is the submitted term equivalent?+   | not (equivalence ex (term state) new) =+        -- 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 (term 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 (state { prefix=Nothing, context=inContext ex new })+        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+   ex = exercise state+   +   expected = do+      xs <- allfirsts (restartIfNeeded state)+      let p (_, _, ns) = similarity ex new (term ns)+      safeHead (filter p xs)++   discovered searchForBuggy = safeHead+      [ r+      | r <- ruleset ex+      , isBuggyRule r == searchForBuggy+      , ca <- applyAll r (inContext ex sub1)+      -- , let s = prettyPrinter (exercise state) (fromContext a)+      --, if s=="2*x+2 == 5" then True else error s+      , a <- fromContext ca+      , similarity ex sub2 a+      ]+    where +      mode = not searchForBuggy+      diff = difference ex mode (term state) new+      (sub1, sub2) = fromMaybe (term state, new) diff+      +----------------------------------------------------------------+-- 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 s +   | isNothing (prefix s) && canBeRestarted ex = +        case fromContext (context s) of +           Just a -> s+              { prefix  = Just (emptyPrefix (strategy ex))+              , context = inContext ex a+              } +           Nothing -> s+   | otherwise = s+ where+   ex = exercise s
+ src/Service/DomainReasoner.hs view
@@ -0,0 +1,135 @@+{-# OPTIONS -XMultiParamTypeClasses -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+-- 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+   , liftEither, liftIO, catchError +     -- * Update functions+   , addPackages, addPackage, addPkgService+   , addServices, addService+   , setVersion, setFullVersion+     -- * Accessor functions+   , getPackages, getExercises, getServices+   , getVersion, getFullVersion+   , findPackage, findService+   ) where++import Common.Exercise+import Common.Utils (Some(..))+import Control.Monad.Error+import Control.Monad.State+import Service.ServiceList+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]+   , version     :: String+   , fullVersion :: Maybe String+   }+   +noContent :: Content+noContent = Content [] (const []) [] 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++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 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 . map const++addService :: Service -> DomainReasoner ()+addService s = addServices [s]++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++findPackage :: ExerciseCode -> DomainReasoner (Some ExercisePackage)+findPackage code = do+   pkgs <- getPackages +   let p (Some pkg) = exerciseCode (exercise pkg) == code+   case filter p pkgs of+      [this] -> return this+      _      -> fail $ "Package " ++ show code ++ " not found"+      +findService :: String -> DomainReasoner Service+findService txt = do+   srvs <- getServices+   case filter ((==txt) . serviceName) srvs of+      [hd] -> return hd+      []   -> fail $ "No service " ++ txt+      _    -> fail $ "Ambiguous service " ++ txt
− src/Service/ExerciseList.hs 
@@ -1,95 +0,0 @@-{-# LANGUAGE ExistentialQuantification, Rank2Types #-}--------------------------------------------------------------------------------- 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 Service.ExerciseList -   ( exerciseList, findExercises, getExercise-   , openMathExercises, findOpenMathExercises, getOpenMathExercise-   , OpenMathExercise(..)-   , resolveExerciseCode-   ) where--import Common.Utils (Some(..))-import Common.Exercise-import Data.Char-import Domain.Math.Expr-import qualified Domain.LinearAlgebra as LA-import qualified Domain.Logic as Logic-import qualified Domain.RelationAlgebra as RA-import qualified Domain.Math.DerivativeExercise as Math-import qualified Domain.Math.Numeric.Exercises as Math-import qualified Domain.Math.Equation.CoverUpExercise as Math-import qualified Domain.Math.Polynomial.Exercises as Math---- List with all known exercises-exerciseList :: [Some Exercise]-exerciseList = -   [ -- logic and relation-algebra-     Some Logic.dnfExercise-   , Some Logic.dnfUnicodeExercise-   , Some RA.cnfExercise-   ] ++-   [ Some e | OMEX e <- openMathExercises ]---------------------------------------------------------------------------------- All mathematical exercises are supported by the OpenMath standard, and --- require an extra type constraint--data OpenMathExercise = forall a . IsExpr a => OMEX (Exercise a)-   -openMathExercises :: [OpenMathExercise]-openMathExercises = -   [ -- basic math-     OMEX Math.naturalExercise, OMEX Math.integerExercise-   , OMEX Math.rationalExercise, OMEX Math.fractionExercise-   , OMEX Math.coverUpExercise-   , OMEX Math.linearExercise-   , OMEX Math.quadraticExercise-   , OMEX Math.higherDegreeExercise-   , OMEX Math.derivativeExercise-     -- linear algebra-   , OMEX LA.gramSchmidtExercise-   , OMEX LA.linearSystemExercise-   , OMEX LA.gaussianElimExercise-   , OMEX LA.systemWithMatrixExercise-   ]-   --------------------------------------------------------------------------------- Utility functions for finding an exercise--resolveExerciseCode :: Monad m => String -> m ExerciseCode-resolveExerciseCode txt = -   case findExercises (\ex -> show (exerciseCode ex) ~= txt) of-      [Some ex] -> return (exerciseCode ex)-      _         -> fail $ "Failed to resolve the exercise code " ++ show txt- where-   s ~= t = f s == f t -   f = map toLower . filter isAlphaNum--findExercises :: (forall a . Exercise a -> Bool) -> [Some Exercise]-findExercises p = [ Some e | Some e <- exerciseList, p e ]--getExercise :: Monad m => ExerciseCode -> m (Some Exercise)-getExercise code = -   case findExercises ((==code) . exerciseCode) of-      [hd] -> return hd-      []   -> fail $ "No exercise with code "   ++ show code-      _    -> fail $ "Ambiguous exercise code " ++ show code-      -findOpenMathExercises :: (forall a . Exercise a -> Bool) -> [OpenMathExercise]-findOpenMathExercises p = [ OMEX e | OMEX e <- openMathExercises, p e ]--getOpenMathExercise :: Monad m => ExerciseCode -> m OpenMathExercise-getOpenMathExercise code = -   case findOpenMathExercises ((==code) . exerciseCode) of-      [hd] -> return hd-      []   -> fail $ "No exercise with code "   ++ show code-      _    -> fail $ "Ambiguous exercise code " ++ show code
+ src/Service/ExercisePackage.hs view
@@ -0,0 +1,102 @@+{-# 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+   ) where++import Common.Utils (Some(..))+import Common.Exercise+import Control.Monad+import Common.Rewriting.Term+import Data.Char+import Data.List+import Service.FeedbackText (ExerciseText)+import Text.OpenMath.Object+import Text.OpenMath.Symbol+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)+   }++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   -> case s of+                    S (Just a) b -> OMS (makeSymbol a b)+                    S Nothing  b -> OMS (extraSymbol b)+      Meta i  -> OMV ("$" ++ show i)+      Num n   -> OMI n+      Float d -> OMF d+      App _ _ -> 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 (Con (S (dictionary s) (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
src/Service/FeedbackText.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -10,112 +10,112 @@ -- ----------------------------------------------------------------------------- module Service.FeedbackText -   ( feedbackLogic-   , onefirsttext, submittext, derivationtext+   ( ExerciseText(..)+   , onefirsttext, submittext, derivationtext, submitHelper    ) where  import Control.Arrow-import Control.Monad+import Common.Context import Common.Exercise-import Common.Utils (safeHead, fst3, commaList)+import Common.Transformation+import Common.Utils import Data.Maybe-import Domain.Logic.Formula (SLogic)-import Domain.Logic.FeedbackText-import Domain.Logic.Exercises (dnfExercise, dnfUnicodeExercise)+import Service.Diagnose (restartIfNeeded)+import Service.Submit import Service.TypedAbstractService-import Common.Context-import Common.Transformation (name, Rule)-import Text.Parsing (errorToPositions)-import Data.Char --- Quick hack for determining subterms-coerceLogic :: Exercise a -> a -> Maybe SLogic-coerceLogic ex a-   | exerciseCode ex == exerciseCode dnfExercise =-        either (const Nothing) Just $ parser dnfExercise (prettyPrinter ex a)-   | exerciseCode ex == exerciseCode dnfUnicodeExercise =-        either (const Nothing) Just $ parser dnfUnicodeExercise (prettyPrinter ex a)-   | otherwise = Nothing+------------------------------------------------------------+-- Exercise Text data type -youRewroteInto :: State a -> a -> Maybe String-youRewroteInto = rewriteIntoText False "You rewrote "+-- 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+   } -useToRewrite :: Rule (Context a) -> State a -> a -> Maybe String-useToRewrite rule old = rewriteIntoText True txt old- where-   txt = "Use " ++ showRule (exerciseCode $ exercise old) rule-         ++ " to rewrite "+------------------------------------------------------------+-- Services -rewriteIntoText :: Bool -> String -> State a -> a -> Maybe String-rewriteIntoText mode txt old a = do-   let ex | exerciseCode (exercise old) == exerciseCode dnfUnicodeExercise =-               dnfUnicodeExercise-          | otherwise = dnfExercise-   p <- coerceLogic (exercise old) (fromContext $ context old)-   q <- coerceLogic (exercise old) a-   (p1, q1) <- difference ex mode p q-   return $ txt ++ prettyPrinter ex p1 -         ++ " into " ++ prettyPrinter ex q1 ++ ". "+derivationtext :: Monad m => ExerciseText a -> State a -> Maybe String -> m [(String, Context a)]+derivationtext exText st _event = do+   xs <- derivation Nothing st+   return (map (first (showRule exText)) xs) +onefirsttext :: ExerciseText a -> State a -> Maybe String -> (Bool, String, State a)+onefirsttext exText state event =+   case allfirsts state of+      Just ((r, _, s):_) ->+         let msg = case fromContext (context s) >>= useToRewrite exText r state of+                      Just txt | event /= Just "hint button" -> txt+                      _ -> "Use " ++ showRule exText r+         in (True, msg, s)+      _ -> (False, "Sorry, no hint available", state)+      +submittext :: ExerciseText a -> State a -> String -> Maybe String -> (Bool, String, State a)+submittext exText state txt _event = +   case parser (exercise state) txt 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)-feedbackLogic :: State a -> a -> Result a -> (String, Bool)-feedbackLogic old a result =+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 (ready old) rs+                           feedbackBuggy exText (ready old) rs                          , False)       NotEquivalent   -> ( fromMaybe ""  (youRewroteInto old a) ++-                           feedbackNotEquivalent (ready old)+                           feedbackNotEquivalent exText (ready old)                          , False)       Ok rs _-         | null rs    -> (feedbackSame, False)-         | otherwise  -> feedbackOk rs-      Detour rs _     -> feedbackDetour (ready old) (expected old) 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 (ready old)+                           feedbackUnknown exText (ready old)                          , False)  where-   expected = fmap fst3 . safeHead . allfirsts+   expected s = do+      xs <- allfirsts s+      fmap fst3 (safeHead xs) -showRule :: ExerciseCode -> Rule a -> String-showRule code r -   | code `elem` map exerciseCode [dnfExercise, dnfUnicodeExercise] =-        fromMaybe txt (ruleText r)-   | otherwise = txt- where-   txt = "rule " ++ name r+------------------------------------------------------------+-- Helper functions -getCode :: State a -> ExerciseCode-getCode = exerciseCode . exercise+showRule :: ExerciseText a -> Rule (Context a) -> String+showRule exText r = +   case ruleText exText r of+      Just s  -> s+      Nothing -> "rule " ++ name r -derivationtext :: State a -> Maybe String -> [(String, Context a)]-derivationtext st _event = -   map (first (showRule (getCode st))) (derivation st)+useToRewrite :: ExerciseText a -> Rule (Context a) -> State a -> a -> Maybe String+useToRewrite exText rule old = rewriteIntoText True txt old+ where+   txt = "Use " ++ showRule exText rule+         ++ " to rewrite " -onefirsttext :: State a -> Maybe String -> (Bool, String, State a)-onefirsttext state event =-   case allfirsts state of-      (r, _, s):_ ->-         let msg = case useToRewrite r state (fromContext $ context s) of-                      Just txt | event /= Just "hint button" -> txt-                      _ -> "Use " ++ showRule (getCode state) r-         in (True, msg, s)-      _ -> (False, "Sorry, no hint available", state)+youRewroteInto :: State a -> a -> Maybe String+youRewroteInto = rewriteIntoText False "You rewrote " -submittext :: State a -> String -> Maybe String -> (Bool, String, State a)-submittext state txt _event = -   case parser (exercise state) txt of-      Left err -> -         let msg = "Syntax error" ++ pos ++ ": " ++ show err-             pos = case map show (errorToPositions err) of-                      [] -> ""-                      xs -> " at " ++ commaList xs-         in (False, msg, state)-      Right a  -> -         let result = submit state a-             (txt, b) = feedbackLogic state a result-         in case getResultState result of-               Just new | b -> (True, txt, resetStateIfNeeded new)-               _ -> (False, txt, state)+rewriteIntoText :: Bool -> String -> State a -> a -> Maybe String+rewriteIntoText mode txt old a = do+   let ex = exercise old+   p <- fromContext (context old)+   (p1, a1) <- difference ex mode p a +   return $ txt ++ prettyPrinter ex p1 +         ++ " into " ++ prettyPrinter ex a1 ++ ". "
− src/Service/LoggingDatabase.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
--- 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  :  alex.gerdes@ou.nl
--- Stability   :  provisional
--- Portability :  portable (depends on ghc)
---
--- Facilities to create a log database
---
------------------------------------------------------------------------------
-module Service.LoggingDatabase (logMessage, logEnabled) where
-
-import Data.Time
-import Service.Request
-#ifdef DB
-import Data.Maybe
-import Database.HDBC
-import Database.HDBC.Sqlite3 (connectSqlite3)
-
-logEnabled :: Bool
-logEnabled = True
-
--- | Log a message to the database (a Sqlite database).
-logMessage :: Request -> String -> String -> String -> UTCTime -> IO ()
-logMessage req input output ipaddress begin = do
-     -- make a connection with the database
-     conn <- connectSqlite3 "service.db"
-
-     -- check if the database exists, if not make one
-     --tables <- getTables conn
-     --if not (elem "log" tables) then run conn createStmt [] else return 0
-
-     -- calculate duration
-     end <- getCurrentTime
-     let diff = diffUTCTime end begin 
-
-     -- insert data into database
-     run conn "INSERT INTO log VALUES (?,?,?,?,?,?,?,?,?,?)" 
-             [ toSql $ service req
-             , toSql $ maybe "unknown" show (exerciseID req)
-             , toSql $ fromMaybe "unknown" (source req)
-             , toSql $ show (dataformat req)
-             , toSql $ maybe "unknown" show (encoding req)
-             , toSql $ input
-             , toSql $ output
-             , toSql $ ipaddress
-             , toSql $ begin
-             , toSql $ diff
-             ]
-     commit conn
-
-     -- close the connection to the database
-     disconnect conn
-  `catch` \err -> do putStrLn $ "Error in logging to database: " ++ show err
-
-{-
--- | Log table schema
-createStmt =  "CREATE TABLE log ( service      VARCHAR(250)"
-           ++                  ", exerciseID   VARCHAR(250)"
-           ++                  ", source       VARCHAR(250)"
-           ++                  ", dataformat   VARCHAR(250)"
-           ++                  ", encoding     VARCHAR(250)"
-           ++                  ", input        VARCHAR(250)"
-           ++                  ", output       VARCHAR(250)"
-           ++                  ", ipaddress    VARCHAR(20)"
-           ++                  ", time         TIME"
-           ++                  ", responsetime TIME)"
--}
-#else
-logMessage :: Request -> String -> String -> String -> UTCTime -> IO ()
-logMessage _ _ _ _ _ = return ()
-
-logEnabled :: Bool
-logEnabled = False
-#endif
-
− src/Service/Main.hs 
@@ -1,81 +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)
---
--- Main module for feedback services
---
------------------------------------------------------------------------------
-module Main (main) where
-
--- import Common.Logging
-import Common.Utils (useFixedStdGen)
-import Service.Options
-import Service.ModeXML  (processXML)
-import Service.ModeJSON (processJSON)
-import Service.Request
-import Service.LoggingDatabase
-import Network.CGI
-import Control.Monad.Trans
-import Control.Monad
-import Data.Maybe
-import Data.Char
-import Data.IORef
-import Data.Time
-
-main :: IO ()
-main = do
-   startTime <- getCurrentTime
-   flags     <- serviceOptions
-   logRef    <- newIORef (return ())
-   
-   case withInputFile flags of
-      -- from file
-      Just file -> do  
-         useFixedStdGen                 -- use a predictable "random" number generator
-         input    <- readFile file
-         (req, txt, _) <- process input
-         when (Logging True `elem` flags) $ 
-            writeIORef logRef $ -- save logging action for later
-               logMessage req input txt "local" startTime
-         putStrLn txt
-         
-         
-      -- cgi binary
-      Nothing -> runCGI $ do
-         addr  <- remoteAddr           -- the IP address of the remote host making the request          
-         raw   <- getInput "input"     -- read input
-         input <- case raw of
-                     Nothing -> fail "Invalid request: environment variable \"input\" is empty"
-                     Just s  -> return s
-         (req, txt, ctp) <- lift $ process input
-         lift $ 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 =
-   case discoverDataFormat input of
-      Just XML  -> processXML  input
-      Just JSON -> processJSON input
-      _         -> fail "Invalid input"
-
--- Convert escaped characters ('%')   
-{-
-convert :: String -> String
-convert [] = []
-convert ('%':c1:c2:cs) =
-   case stringToHex [c1, c2] of
-      Just i  -> chr i : convert cs
-      Nothing -> '%' : convert (c1:c2:cs)
-convert (c:cs) = c : convert cs -}
src/Service/ModeJSON.hs view
@@ -1,5 +1,6 @@+{-# OPTIONS -XGADTs #-}
 -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -14,40 +15,51 @@ module Service.ModeJSON (processJSON, jsonTuple) where
 
 import Common.Context
-import Common.Utils (Some(..), distinct)
+import Common.Utils (Some(..), distinct, readM)
 import Common.Exercise
 import Common.Strategy (makePrefix)
 import Common.Transformation hiding (ruleList, defaultArgument)
 import Text.JSON
 import Service.Request
-import Service.Types (Evaluator(..), Type, encodeDefault, decodeDefault, Encoder(..), Decoder(..))
+import Service.Types (TypedValue(..), Evaluator(..), Type, encodeDefault, decodeDefault, Encoder(..), Decoder(..), decoderExercise)
 import qualified Service.Types as Tp
 import qualified Service.TypedAbstractService as TAS
+import Service.Submit
 import Service.ServiceList hiding (Service)
-import qualified Service.ExerciseList as List
+import Service.ExercisePackage 
+import Service.DomainReasoner
 import Control.Monad
 import Data.Maybe
 import Data.Char
 
 -- TODO: Clean-up code
 extractCode :: JSON -> ExerciseCode
-extractCode = fromMaybe noCode . List.resolveExerciseCode . f
+extractCode = fromMaybe noCode . readCode . f
  where 
    f (String s) = s
    f (Array [String _, String _, a@(Array _)]) = f a
    f (Array (String s:tl)) | any (\c -> not (isAlphaNum c || isSpace c || c `elem` ".-")) s = f (Array tl)
    f (Array (hd:_)) = f hd
    f _ = ""
-      
-processJSON :: String -> IO (Request, String, String)
+
+processJSON :: String -> DomainReasoner (Request, String, String)
 processJSON input = do
-   txt <- jsonRPC input myHandler
-   case fmap jsonRequest (parseJSON input) of
-      Just (Right req) -> return (req, txt, "application/json")
-      Just (Left err)  -> fail err
-      _                -> fail "no parse"
+   json <- parseJSON input
+   req  <- jsonRequest json
+   vers <- getVersion
+   resp <- jsonRPC json myHandler
+   let out = show $ (if null vers then id else addVersion vers) (toJSON resp)
+   return (req, out, "application/json")
 
-jsonRequest :: JSON -> Either String Request
+addVersion :: String -> JSON -> JSON
+addVersion version json = 
+   case json of
+      Object xs -> Object (xs ++ [info])
+      _         -> json
+ where
+   info = ("version", String version)
+
+jsonRequest :: Monad m => JSON -> m Request
 jsonRequest json = do
    srv  <- case lookupM "method" json of
               Just (String s) -> return s
@@ -69,24 +81,19 @@       , encoding   = enc
       }
 
-myHandler :: JSON_RPC_Handler
-myHandler fun arg 
-   | code == noCode && fun /= "exerciselist" =
-        fail "invalid exercise code"
-   | otherwise = 
-        case jsonConverter code of
-           Some conv -> do
-              service <- getService fun
-              either fail return (evalService conv service arg)
- where 
-   code = extractCode arg
+myHandler :: JSON_RPC_Handler DomainReasoner
+myHandler fun arg = do
+   pkg <- if fun == "exerciselist" 
+          then return (Some (package emptyExercise))
+          else findPackage (extractCode arg)
+   srv <- findService fun
+   case jsonConverter pkg of
+      Some conv -> do
+         either fail return (evalService conv srv arg)
 
-jsonConverter :: ExerciseCode -> Some (Evaluator (Either String) JSON JSON)
-jsonConverter code =
-   let f a = Some (Evaluator (jsonEncoder a) (jsonDecoder a))
-   in case List.getExercise code of
-         Just (Some a) -> f a
-         Nothing       -> f emptyExercise
+jsonConverter :: Some ExercisePackage -> Some (Evaluator (Either String) JSON JSON)
+jsonConverter (Some pkg) =
+   Some (Evaluator (jsonEncoder (exercise pkg)) (jsonDecoder pkg))
 
 jsonEncoder :: Monad m => Exercise a -> Encoder m JSON a
 jsonEncoder ex = Encoder
@@ -96,33 +103,33 @@    }
  where
    encode :: Monad m => Encoder m JSON a -> Type a t -> t -> m JSON
-   encode enc serviceType =
-      case serviceType of
-         Tp.List t   -> liftM Array . mapM (encode enc t)
-         Tp.Tag s t  -> liftM (\a -> Object [(s, a)]) . encode enc t 
-         Tp.Int      -> return . toJSON
-         Tp.Bool     -> return . toJSON
-         Tp.String   -> return . toJSON
-         Tp.State    -> encode enc stateType . fromState
-         Tp.Result   -> encodeResult enc
-         _           -> encodeDefault enc serviceType
-
-fromState :: TAS.State a -> (String, String, Context a, String)
-fromState st = 
-   ( show (exerciseCode (TAS.exercise st))
-   , maybe "NoPrefix" show (TAS.prefix st)
-   , inContext (TAS.term st)
-   , showContext (TAS.context st)
-   )
-
-stateType :: Type a (String, String, Context a, String)
-stateType = Tp.Quadruple Tp.String Tp.String Tp.Term Tp.String
-
-jsonDecoder :: MonadPlus m => Exercise a -> Decoder m JSON a
-jsonDecoder ex = Decoder
-   { decodeType      = decode (jsonDecoder ex)
-   , decodeTerm      = reader ex
-   , decoderExercise = ex
+   encode enc serviceType a
+      | length xs > 1 =
+           liftM jsonTuple (mapM (\(b ::: t) -> encode enc t b) xs)
+      | otherwise = 
+           case serviceType of
+              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)
+              Tp.State     -> encodeState (encodeTerm enc) a
+              Tp.Result    -> encodeResult enc 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 (fst p ::: t1) ++ tupleList (snd p ::: t2)
+   tupleList tv = [tv]
+         
+jsonDecoder :: MonadPlus m => ExercisePackage a -> Decoder m JSON a
+jsonDecoder pkg = Decoder
+   { decodeType     = decode (jsonDecoder pkg)
+   , decodeTerm     = reader (exercise pkg)
+   , decoderPackage = pkg
    }
  where
    reader :: Monad m => Exercise a -> JSON -> m a
@@ -133,11 +140,11 @@    decode dec serviceType =
       case serviceType of
          Tp.State    -> useFirst $ decodeState (decoderExercise dec) (decodeTerm dec)
-         Tp.Location -> useFirst fromJSON
-         Tp.Term     -> useFirst $ liftM inContext . decodeTerm dec
+         Tp.Location -> useFirst decodeLocation
+         Tp.Term     -> useFirst $ decodeTerm dec
          Tp.Rule     -> useFirst $ \x -> fromJSON x >>= getRule (decoderExercise dec)
          Tp.Exercise -> \json -> case json of
-                                    (Array (String s:rest)) -> return (decoderExercise dec, Array rest)
+                                    (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)
@@ -152,47 +159,61 @@       a <- f x
       return (a, Array xs)
    useFirst _ _ = fail "expecting an argument"
-         
-instance InJSON Location where
-   toJSON              = toJSON . show
-   fromJSON (String s) = case reads s of
-                            [(loc, rest)] | all isSpace rest -> return loc
-                            _ -> fail "invalid string"
-   fromJSON _          = fail "expecting a string"
 
+decodeLocation :: Monad m => JSON -> m [Int]
+decodeLocation (String s) = readM s
+decodeLocation _          = fail "expecting a string for a location"
+
 --------------------------
 
+encodeState :: Monad m => (a -> m JSON) -> TAS.State a -> m JSON
+encodeState f st = do 
+   theTerm <- f (TAS.term st)
+   return $ Array
+      [ String (show (exerciseCode (TAS.exercise st)))
+      , String (maybe "NoPrefix" show (TAS.prefix st))
+      , theTerm
+      , encodeContext (getEnvironment (TAS.context st))
+      ]
+
+encodeContext :: Environment -> JSON
+encodeContext env = Object (map f (keysEnv env))
+ where
+   f k = (k, String $ fromMaybe "" $ lookupEnv k env)
+
 decodeState :: Monad m => Exercise a -> (JSON -> m a) -> JSON -> m (TAS.State a)
 decodeState ex f (Array [a]) = decodeState ex f a
-decodeState ex f (Array [String code, String p, ce, String ctx]) = do
+decodeState ex f (Array [String _code, String p, ce, jsonContext]) = do
    a    <- f ce 
-   unit <- maybe (fail "invalid context") return (parseContext ctx) 
+   env  <- decodeContext jsonContext
    return TAS.State 
       { TAS.exercise = ex
-      , TAS.prefix   = fmap (`makePrefix` strategy ex) (readPrefix p) 
-      , TAS.context  = fmap (const a) unit
+      , TAS.prefix   = readM p >>= (`makePrefix` strategy ex)
+      , TAS.context  = makeContext ex env a
       }
 decodeState _ _ s = fail $ "invalid state" ++ show s
 
-readPrefix :: String -> Maybe [Int]
-readPrefix input =
-   case reads input of
-      [(is, rest)] | all isSpace rest -> return is
-      _ -> Nothing
+decodeContext :: Monad m => JSON -> m Environment
+decodeContext (String "") = decodeContext (Object []) -- Being backwards compatible (for now)
+decodeContext (Object xs) = foldM add emptyEnv xs
+ where 
+   add env (k, String s) = return (storeEnv k s env)       
+   add _ _ = fail "invalid item in context"
+decodeContext json = fail $ "invalid context: " ++ show json
    
-encodeResult :: Monad m => Encoder m JSON a -> TAS.Result a -> m JSON
+encodeResult :: Monad m => Encoder m JSON a -> Result a -> m JSON
 encodeResult enc result =
    case result of
       -- TAS.SyntaxError _ -> [("result", String "SyntaxError")]
-      TAS.Buggy rs      -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . name) rs)]
-      TAS.NotEquivalent -> return $ Object [("result", String "NotEquivalent")]   
-      TAS.Ok rs st      -> do
+      Buggy rs      -> return $ Object [("result", String "Buggy"), ("rules", Array $ map (String . name) rs)]
+      NotEquivalent -> return $ Object [("result", String "NotEquivalent")]   
+      Ok rs st      -> do
          json <- encodeType enc Tp.State st
          return $ Object [("result", String "Ok"), ("rules", Array $ map (String . name) rs), ("state", json)]
-      TAS.Detour rs st  -> do
+      Detour rs st  -> do
          json <- encodeType enc Tp.State st
          return $ Object [("result", String "Detour"), ("rules", Array $ map (String . name) rs), ("state", json)]
-      TAS.Unknown st    -> do
+      Unknown st    -> do
          json <- encodeType enc Tp.State st
          return $ Object [("result", String "Unknown"), ("state", json)]
src/Service/ModeXML.hs view
@@ -1,5 +1,6 @@+{-# OPTIONS -XGADTs #-}
 -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -11,39 +12,49 @@ -- Services using XML notation
 --
 -----------------------------------------------------------------------------
-module Service.ModeXML (processXML) where
+module Service.ModeXML 
+   ( processXML, xmlRequest, openMathConverterTp, stringFormatConverterTp
+   , resultOk, resultError, addVersion
+   ) where
 
+import Common.Navigator
 import Common.Context
 import Common.Exercise
 import Common.Strategy hiding (not, fail)
-import Common.Transformation hiding (name, defaultArgument)
-import Common.Utils (Some(..))
+import Common.Utils (Some(..), readM)
 import Control.Monad
 import Data.Char
+import Data.List
 import Data.Maybe
-import Service.ExerciseList
+import Service.ExercisePackage
 import Service.ProblemDecomposition
 import Service.Request
-import Service.Revision (version)
+import Service.RulesInfo (rulesInfoXML)
 import Service.ServiceList 
+import Service.StrategyInfo
 import Service.TypedAbstractService hiding (exercise)
-import Service.Types (Evaluator(..), Type, encodeDefault, decodeDefault, Encoder(..), Decoder(..))
-import Domain.Math.Expr
+import Service.Diagnose
+import Service.Types hiding (State)
 import Text.OpenMath.Object
-import Text.OpenMath.Reply (replyToXML)
-import Text.OpenMath.Request (xmlToRequest)
 import Text.XML
 import qualified Common.Transformation as Rule
 import qualified Service.Types as Tp
+import Service.DomainReasoner
 
+processXML :: String -> DomainReasoner (Request, String, String)
+processXML input = do
+   xml  <- liftEither (parseXML input)
+   req  <- liftEither (xmlRequest xml)
+   resp <- xmlReply req xml
+              `catchError` \msg -> return (resultError msg)
+   vers <- getVersion
+   let out = showXML (if null vers then resp else addVersion vers resp)
+   return (req, out, "application/xml")
 
-processXML :: String -> IO (Request, String, String)
-processXML input = 
-   either fail return $ do
-      xml <- parseXML input
-      req <- xmlRequest xml
-      out <- xmlRequestHandler xml
-      return (req, showXML out, "application/xml") 
+addVersion :: String -> XML -> XML
+addVersion s xml = 
+   let info = [ "version" := s ]
+   in xml { attributes = attributes xml ++ info }
 
 xmlRequest :: XML -> Either String Request
 xmlRequest xml = do   
@@ -62,157 +73,259 @@       , encoding   = enc
       }
 
-xmlReply :: Request -> XML -> Either String XML
+xmlReply :: Request -> XML -> DomainReasoner XML
 xmlReply request xml 
    | service request == "mathdox" = do
         code <- maybe (fail "unknown exercise code") return (exerciseID request)
-        OMEX ex <- getOpenMathExercise code
-        (st, sloc, answer) <- xmlToRequest xml ex
-        return (replyToXML (problemDecomposition st sloc answer))
-   | otherwise =
-   case encoding request of
-      Just StringEncoding -> do 
-         code <- maybe (fail "unknown exercise code") return (exerciseID request)
-         ex <- getExercise code
-         case stringFormatConverter ex of
-            Some conv -> do
-               srv <- getService (service request)
-               res <- evalService conv srv xml 
-               return (resultOk res)
-      _ -> do 
-         code <- maybe (fail "unknown exercise code") return (exerciseID request)
-         ex <- getOpenMathExercise code
-         case openMathConverter ex of
-            Some conv -> do
-               srv <- getService (service request)
-               res <- evalService conv srv xml 
-               return (resultOk res)
+        Some pkg <- findPackage code
+        (st, sloc, answer) <- liftEither $ xmlToRequest xml (fromOpenMath pkg) (exercise pkg)
+        return (replyToXML (toOpenMath pkg) (problemDecomposition st sloc answer))
 
-xmlRequestHandler :: Monad m => XML -> m XML
-xmlRequestHandler xml =
-   case xmlRequest xml of 
-      Left err -> return (resultError err)
-      Right request ->  
-         case xmlReply request xml of
-            Left err     -> return (resultError err)
-            Right result -> return result
+xmlReply request xml = do
+   srv <- findService (service request)
+   pkg <- 
+      case exerciseID request of
+         Just code -> findPackage code
+         Nothing   
+            | service request == "exerciselist" ->
+                 return (Some (package emptyExercise))
+            | otherwise -> 
+                 fail "unknown exercise code"
+   Some conv <- return $ 
+      case encoding request of
+         Just StringEncoding -> stringFormatConverter pkg
+         _                   -> openMathConverter pkg
+   res <- liftEither $ evalService conv srv xml
+   return (resultOk res)
 
 extractExerciseCode :: Monad m => XML -> m ExerciseCode
 extractExerciseCode xml =
    case liftM (break (== '.')) (findAttribute "exerciseid" xml) of
       Just (as, _:bs) -> return (makeCode as bs)
-      Just (as, _)    -> resolveExerciseCode as
+      Just (as, _)    -> maybe (fail "invalid code") return (readCode as)
       -- being backwards compatible with early MathDox
-      Nothing ->
-         case fmap getData (findChild "strategy" xml) of
-            Just name -> 
-               let s ~= t = f s == f t 
-                   f = map toLower . filter isAlphaNum
-               in case findOpenMathExercises (\ex -> name ~= description ex) of 
-                     [OMEX a] -> return (exerciseCode a)
-                     _ -> fail $ "Unknown strategy name " ++ show name 
+      Nothing -> do
+         let getName = map toLower . filter isAlphaNum . getData
+             linalg  = return . makeCode "linalg"
+         case fmap getName (findChild "strategy" xml) of
+            Just name
+               | name == "gaussianelimination"         -> linalg "gaussianelim"
+               | name == "gramschmidt"                 -> linalg "gramschmidt"
+               | name == "solvelinearsystem"           -> linalg "linsystem"
+               | name == "solvelinearsystemwithmatrix" -> linalg "systemwithmatrix"
             _ -> fail "no exerciseid attribute, nor a known strategy element" 
 
 resultOk :: XMLBuilder -> XML
 resultOk body = makeXML "reply" $ do 
-   "result"  .=. "ok"
-   "version" .=. version
+   "result" .=. "ok"
    body
 
 resultError :: String -> XML
 resultError txt = makeXML "reply" $ do 
-   "result"  .=. "error"
-   "version" .=. version
+   "result" .=. "error"
    element "message" (text txt)
 
 ------------------------------------------------------------
 -- Mixing abstract syntax (OpenMath format) and concrete syntax (string)
 
-stringFormatConverter :: Some Exercise -> Some (Evaluator (Either String) XML XMLBuilder)
-stringFormatConverter (Some ex) = 
-   Some $ Evaluator (xmlEncoder f ex) (xmlDecoder g ex)
+stringFormatConverter :: Some ExercisePackage -> Some (Evaluator (Either String) XML XMLBuilder)
+stringFormatConverter (Some pkg) = Some (stringFormatConverterTp pkg)
+
+stringFormatConverterTp :: ExercisePackage a -> Evaluator (Either String) XML XMLBuilder a
+stringFormatConverterTp pkg = 
+   Evaluator (xmlEncoder False f ex) (xmlDecoder False g pkg)
  where
-   f = return . element "expr" . text . prettyPrinter ex
+   ex = exercise pkg
+   f  = return . element "expr" . text . prettyPrinter ex
    g xml = do
       xml <- findChild "expr" xml -- quick fix
       -- guard (name xml == "expr")
       let input = getData xml
       either (fail . show) return (parser ex input)
+
+openMathConverter :: Some ExercisePackage -> Some (Evaluator (Either String) XML XMLBuilder)
+openMathConverter (Some pkg) = Some (openMathConverterTp pkg)
         
-openMathConverter :: OpenMathExercise -> Some (Evaluator (Either String) XML XMLBuilder)
-openMathConverter (OMEX ex) = 
-   Some $ Evaluator (xmlEncoder f ex) (xmlDecoder g ex)
+openMathConverterTp :: ExercisePackage a -> Evaluator (Either String) XML XMLBuilder a
+openMathConverterTp pkg =
+   Evaluator (xmlEncoder True f ex) (xmlDecoder True g pkg)
  where
-   f = return . builder . toXML . toOMOBJ . toExpr
-   g xml = do 
+   ex = exercise pkg
+   f = return . builder . toXML . toOpenMath pkg
+   g xml = do
       xob   <- findChild "OMOBJ" xml
       omobj <- xml2omobj xob
-      case fromExpr (fromOMOBJ omobj) of
+      case fromOpenMath pkg omobj of
          Just a  -> return a
          Nothing -> fail "Unknown OpenMath object"
-   
-xmlEncoder :: Monad m => (a -> m XMLBuilder) -> Exercise a -> Encoder m XMLBuilder a
-xmlEncoder f ex = Encoder
-   { encodeType  = encode (xmlEncoder f ex)
+
+xmlEncoder :: Monad m => Bool -> (a -> m XMLBuilder) -> Exercise a -> Encoder m XMLBuilder a
+xmlEncoder b f ex = Encoder
+   { encodeType  = encode (xmlEncoder b f ex) ex
    , encodeTerm  = f
    , encodeTuple = sequence_
    }
  where
-   encode :: Monad m => Encoder m XMLBuilder a -> Type a t -> t -> m XMLBuilder
-   encode enc serviceType =
+   encode :: Monad m => Encoder m XMLBuilder a -> Exercise a -> Type a t -> t -> m XMLBuilder
+   encode enc ex serviceType =
       case serviceType of
-         Tp.List t1  -> \xs -> do
-            bs <- mapM (encode enc t1) xs
-            let b = mapM_ (element "elem") bs
-            return (element "list" b)
-         Tp.Elem t1  -> liftM (element "elem") . encode enc t1
-         Tp.Tag s t1 -> liftM (element s) . encode enc t1  -- quick fix
-         Tp.Rule     -> return . ("ruleid" .=.) . Rule.name
-         Tp.Term     -> encodeTerm enc . fromContext
-         Tp.Location -> return . text . show
-         Tp.Bool     -> return . text . show
-         Tp.Int      -> return . text . show
-         Tp.State    -> encodeState (encodeTerm enc)
-         _           -> encodeDefault enc serviceType
+         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 (encode enc ex t1) xs
+                  let elems = mapM_ (element "elem") bs
+                  return (element "list" elems)
+         Tp.Elem t1   -> liftM (element "elem") . encode enc ex t1
+         Tp.Tag s t1  -> liftM (element s) . encode enc ex t1  -- quick fix
+         Tp.Strategy  -> return . builder . strategyToXML
+         Tp.Rule      -> return . ("ruleid" .=.) . Rule.name
+         Tp.RulesInfo -> \_ -> rulesInfoXML ex (encodeTerm enc)
+         Tp.Term      -> encodeTerm enc
+         Tp.Diagnosis -> encodeDiagnosis b (encodeTerm enc)
+         Tp.Context   -> encodeContext   b (encodeTerm enc)
+         Tp.Location  -> return . {-element "location" .-} text . show
+         Tp.Bool      -> return . text . map toLower . show
+         Tp.String    -> return . text
+         Tp.Int       -> return . text . show
+         Tp.State     -> encodeState b (encodeTerm enc)
+         _            -> encodeDefault enc serviceType
 
-xmlDecoder :: MonadPlus m => (XML -> m a) -> Exercise a -> Decoder m XML a
-xmlDecoder f ex = Decoder
-   { decodeType      = decode (xmlDecoder f ex)
-   , decodeTerm      = f
-   , decoderExercise = ex
+xmlDecoder :: MonadPlus m => Bool -> (XML -> m a) -> ExercisePackage a -> Decoder m XML a
+xmlDecoder b f pkg = Decoder
+   { decodeType     = decode (xmlDecoder b f pkg)
+   , decodeTerm     = f
+   , decoderPackage = pkg
    }
  where
    decode :: MonadPlus m => Decoder m XML a -> Type a t -> XML -> m (t, XML)
    decode dec serviceType = 
       case serviceType of
-         Tp.State    -> decodeState (decoderExercise dec) (decodeTerm dec)
-         Tp.Location -> leave $ liftM (read . getData) . findChild "location"
-         Tp.Rule     -> leave $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . getData) . findChild "ruleid"
-         Tp.Exercise -> leave $ const (return (decoderExercise dec))
-         Tp.Term     -> \xml -> decodeTerm dec xml >>= \a -> return (inContext a, xml)
-         _           -> decodeDefault dec serviceType
+         Tp.State       -> decodeState b (decoderExercise dec) (decodeTerm dec)
+         Tp.Location    -> leave $ liftM (read . getData) . findChild "location"
+         Tp.Rule        -> leave $ fromMaybe (fail "unknown rule") . liftM (getRule (decoderExercise dec) . getData) . findChild "ruleid"
+         Tp.Term        -> \xml -> decodeTerm dec xml >>= \a -> return (a, xml)
+         Tp.StrategyCfg -> decodeConfiguration
+         _              -> decodeDefault dec serviceType
          
    leave :: Monad m => (XML -> m a) -> XML -> m (a, XML)
    leave f xml = liftM (\a -> (a, xml)) (f xml)
          
-decodeState :: Monad m => Exercise a -> (XML -> m a) -> XML -> m (State a, XML)
-decodeState ex f top = do
+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 tag Bool)   = Just $ \b -> [(tag, map toLower (show b))]
+allAreTagged (Tag tag String) = Just $ \s -> [(tag, s)]
+allAreTagged _ = Nothing
+         
+decodeState :: Monad m => Bool -> Exercise a -> (XML -> m a) -> XML -> m (State a, XML)
+decodeState b ex f top = do
    xml <- findChild "state" top
    unless (name xml == "state") (fail "expected a state tag")
-   let sp = maybe "[]" getData (findChild "prefix" xml)
-       sc = maybe ""   getData (findChild "context" xml)
-   --x    <- findChild "OMOBJ" xml
+   mpr <- case maybe "" getData (findChild "prefix" xml) of
+             prefixText
+                | all isSpace prefixText ->
+                     return (Just (emptyPrefix (strategy ex)))
+                | prefixText ~= "no prefix" -> 
+                     return Nothing 
+                | otherwise -> do
+                     a  <- readM prefixText
+                     pr <- makePrefix a (strategy ex)
+                     return (Just pr)
    expr <- f xml
-   contxt <- maybe (fail $ "invalid context" ++ show sc) return (parseContext sc)
-   let state  = State ex (Just (makePrefix (read sp) $ strategy ex)) term
-       term   = fmap (const expr) contxt
+   env  <- decodeEnvironment b xml
+   let state  = State ex mpr term
+       term   = makeContext ex env expr
    return (state, top)
+ where
+   a ~= b = g a == g b
+   g = map toLower . filter (not . isSpace)
 
-encodeState :: Monad m => (a -> m XMLBuilder) -> State a -> m XMLBuilder
-encodeState f state = do
-   b <- f (term state)
-   return $ element "state" $ do
-      element "prefix"  (text $ maybe "[]" show (prefix state))
-      element "context" (text $ showContext (context state))
-      b
-   +decodeEnvironment :: Monad m => Bool -> XML -> m Environment
+decodeEnvironment b xml =
+   case findChild "context" xml of 
+      Just this -> foldM add emptyEnv (children this)
+      Nothing   -> return emptyEnv
+ where
+   add env item = do 
+      unless (name item == "item") $ 
+         fail $ "expecting item tag, found " ++ name item
+      name  <- findAttribute "name"  item
+      case findChild "OMOBJ" item of
+         -- OpenMath object found inside item tag
+         Just this | b -> do
+            case xml2omobj this >>= omobjToTerm of
+               Left err -> fail err
+               Right term -> 
+                  return (storeEnv name term env)
+         -- Simple value in attribute
+         _ -> do
+            value <- findAttribute "value" item
+            return (storeEnv name value env)
+
+decodeConfiguration :: MonadPlus m => XML -> m (StrategyConfiguration, XML)
+decodeConfiguration xml =
+   case findChild "configuration" xml of
+      Just this -> mapM decodeAction (children this) >>= \xs -> return (xs, xml)
+      Nothing   -> fail "no strategy configuration" 
+ where
+   decodeAction item = do 
+      guard (null (children item))
+      action <- 
+         case find (\a -> map toLower (show a) == name item) configActions of
+            Just a  -> return a
+            Nothing -> fail $ "unknown action " ++ show (name item)
+      cfgloc <- findAttribute "name" item
+      return $ (ByName cfgloc, action)
+
+
+encodeState :: Monad m => Bool -> (a -> m XMLBuilder) -> State a -> m XMLBuilder
+encodeState b f state = f (term state) >>= \body -> return $
+   element "state" $ do
+      element "prefix"  (text $ maybe "no prefix" show (prefix state))
+      let env = getEnvironment (context state)
+      encodeEnvironment b (location (context state)) env
+      body
+
+encodeEnvironment :: Bool -> Location -> Environment -> XMLBuilder
+encodeEnvironment b loc env0
+   | nullEnv env = return ()
+   | otherwise   = element "context" $ do
+        forM_ (keysEnv env) $ \k -> do
+           element "item" $ do 
+              "name"  .=. k
+              case lookupEnv k env of 
+                 Just term | b -> builder  (omobj2xml (termToOMOBJ 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" .=. Rule.name r
+      NotEquivalent  -> return $ tag "notequiv"
+      Similar  b s   -> ok "similar"  b s Nothing
+      Expected b s r -> ok "expected" b s (Just r)
+      Detour   b s r -> ok "detour"   b s (Just 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" .=.) . Rule.name) mr
+         body
+  
+encodeContext :: Monad m => Bool -> (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))
− src/Service/Options.hs 
@@ -1,57 +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)
---
--- Options and command-line flags for services
---
------------------------------------------------------------------------------
-module Service.Options where
-
-import System.Environment
-import System.Exit
-import System.Console.GetOpt
-import Service.Revision (version, revision)
-import Service.LoggingDatabase (logEnabled)
-
-data Flag = Verbose | Version | Logging Bool | InputFile String 
- deriving (Show, Eq)
-
-options :: [OptDescr Flag]
-options =
-     [ Option "?"     ["version"]    (NoArg Version)           "show version number"
-     , 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") "input FILE"
-     ]
-
-header :: String
-header = "Usage: service [OPTION]   (" ++ versionText ++ ", logging " ++ 
-         (if logEnabled then "enabled" else "disabled") ++ ")"
-
-versionText :: String
-versionText = "version " ++ version ++ ", revision " ++ show revision
-
-serviceOptions :: IO [Flag]
-serviceOptions = do
-   args <- getArgs
-   case getOpt Permute options args of
-      (flags, [], []) | Version `notElem` flags ->
-         return flags
-      (_, _, errs) -> do
-         putStrLn (concat errs ++ usageInfo header options)
-         exitFailure 
-         
-withLogging :: [Flag] -> Bool
-withLogging flags = and [ b | Logging b <- flags ]
-   
-withInputFile :: [Flag] -> Maybe String
-withInputFile flags = 
-   case [ file | InputFile file <- flags ] of
-      [hd] -> Just hd
-      _    -> Nothing
src/Service/ProblemDecomposition.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -9,63 +9,71 @@ -- Portability :  portable (depends on ghc)
 --
 -----------------------------------------------------------------------------
-module Service.ProblemDecomposition (problemDecomposition) where
+module Service.ProblemDecomposition 
+   ( problemDecomposition
+   , Reply, replyToXML, xmlToRequest
+   ) where
 
 import Common.Apply
 import Common.Context
 import Common.Exercise
 import Common.Derivation
-import Common.Strategy hiding (not, repeat)
-import Common.Transformation
+import Common.Strategy hiding (not, repeat, fail)
+import Common.Transformation 
 import Common.Utils
 import Data.Char
-import Data.List
 import Data.Maybe
-import Text.OpenMath.Reply
 import Service.TypedAbstractService (State(..), stepsremaining)
+import Text.XML hiding (name)
+import qualified Text.XML as XML
+import Control.Monad
+import Text.OpenMath.Object
 
 replyError :: String -> String -> Reply a
 replyError kind = Error . ReplyError kind
 
 problemDecomposition :: State a -> StrategyLocation -> Maybe a -> Reply a
-problemDecomposition st@(State ex mpr requestedTerm) sloc answer 
+problemDecomposition (State ex mpr requestedTerm) sloc answer 
    | isNothing $ subStrategy sloc (strategy ex) =
         replyError "request error" "invalid location for strategy"
    | otherwise =
    let pr = fromMaybe (emptyPrefix $ strategy ex) mpr in
-         case (runPrefixLocation sloc pr requestedTerm, maybe Nothing (Just . inContext) answer) of            
+         case (runPrefixLocation sloc pr requestedTerm, maybe Nothing (Just . inContext ex) answer) of            
             ([], _) -> replyError "strategy error" "not able to compute an expected answer"
             (answers, Just answeredTerm)
                | not (null witnesses) ->
                     Ok ReplyOk
                        { repOk_Code     = ex
-                       , repOk_Location = nextTask sloc $ nextMajorForPrefix newPrefix (fst $ head witnesses)
+                       , repOk_Location = nextTaskLocation sloc $ nextMajorForPrefix newPrefix (fst $ head witnesses)
                        , repOk_Context  = show newPrefix ++ ";" ++ 
-                                          showContext (fst $ head witnesses)
-                       , repOk_Steps    = stepsremaining $ State ex (Just newPrefix) (fst $ head witnesses)
+                                          show (getEnvironment $ fst $ head witnesses)
+                       , repOk_Steps    = fromMaybe 0 $ stepsremaining $ State ex (Just newPrefix) (fst $ head witnesses)
                        }
                   where 
-                    witnesses   = filter (similarity ex (fromContext answeredTerm) . fromContext . fst) $ take 1 answers
-                    newPrefix   = snd (head witnesses)
-                      
+                    witnesses   = filter (similarityCtx ex answeredTerm . fst) $ take 1 answers
+                    newPrefix   = snd (head witnesses)            
             ((expected, prefix):_, maybeAnswer) ->
                     Incorrect ReplyIncorrect
                        { repInc_Code       = ex
-                       , repInc_Location   = subTask sloc loc
-                       , repInc_Expected   = fromContext expected
+                       , repInc_Location   = subTaskLocation sloc loc
+                       , repInc_Expected   = fromJust (fromContext expected)
                        , repInc_Derivation = derivation
                        , repInc_Arguments  = args
-                       , repInc_Steps      = stepsremaining $ State ex (Just pr) requestedTerm
-                       , repInc_Equivalent = maybe False (equivalence ex (fromContext expected) . fromContext) maybeAnswer
-                       }  
+                       , repInc_Steps      = fromMaybe 0 $ stepsremaining $ State ex (Just pr) requestedTerm
+                       , repInc_Equivalent = maybe False (equivalenceContext ex expected) maybeAnswer
+                       }
              where
                (loc, args) = firstMajorInPrefix pr prefix requestedTerm
                derivation  = 
                   let len      = length $ prefixToSteps pr
                       rules    = stepsToRules $ drop len $ prefixToSteps prefix
-                      f (s, a) = (s, fromContext a)
+                      f (s, a) = (s, fromJust (fromContext a))
                   in map f (makeDerivation requestedTerm rules)
 
+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 :: StrategyLocation -> Prefix a -> a -> [(a, Prefix a)]
@@ -74,8 +82,7 @@    cutOnStep (stop . lastStepInPrefix) . prefixTree p0
  where
    f d = (last (terms d), if isEmpty d then p0 else last (steps d))
-   stop (Just (End is))    = is==loc
-   stop (Just (Step is _)) = is==loc
+   stop (Just (End is _)) = is==loc
    stop _ = False
  
    check result@(a, p)
@@ -85,26 +92,17 @@     where
       rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p
 
--- old (current) and actual (next major rule) location
-subTask :: [Int] -> [Int] -> [Int]
-subTask (i:is) (j:js)
-   | i == j    = i : subTask is js
-   | otherwise = []
-subTask _ js   = take 1 js
-
--- old (current) and actual (next major rule) location
-nextTask :: [Int] -> [Int] -> [Int]
-nextTask (i:is) (j:js)
-   | i == j    = i : nextTask is js
-   | otherwise = [j] 
-nextTask _ _   = [] 
-
-firstMajorInPrefix :: Prefix a -> Prefix a -> a -> ([Int], Args)
-firstMajorInPrefix p0 prefix a = fromMaybe ([], []) $ do
+firstMajorInPrefix :: Prefix a -> Prefix a -> a -> (StrategyLocation, Args)
+firstMajorInPrefix p0 prefix a = fromMaybe (topLocation, []) $ do
    let steps = prefixToSteps prefix
        newSteps = drop (length $ prefixToSteps p0) steps
-   is    <- safeHead [ is | Step is r <- newSteps, isMajorRule r ]
+   is <- firstLocation newSteps
    return (is, argumentsForSteps a newSteps)
+ where
+   firstLocation :: [Step a] -> Maybe StrategyLocation
+   firstLocation [] = Nothing
+   firstLocation (Begin is _:Step r:_) | isMajorRule r = Just is
+   firstLocation (_:rest) = firstLocation rest
  
 argumentsForSteps :: a -> [Step a] -> Args
 argumentsForSteps a = flip rec a . stepsToRules
@@ -116,15 +114,17 @@                          in maybe [] (zip ds) (expectedArguments r a)
       | otherwise      = []
  
-nextMajorForPrefix :: Prefix a -> a -> [Int]
-nextMajorForPrefix p0 a = fromMaybe [] $ do
+nextMajorForPrefix :: Prefix a -> a -> StrategyLocation
+nextMajorForPrefix p0 a = fromMaybe topLocation $ do
    (_, p1)  <- safeHead $ runPrefixMajor p0 a
    let steps = prefixToSteps p1
-   lastStep <- safeHead (reverse steps)
-   case lastStep of
-      Step is r | not (isMinorRule r) -> return is
-      _ -> Nothing
-
+   rec (reverse steps)
+ where
+   rec [] = Nothing
+   rec (Begin is _:_) = Just is
+   rec (End is _:_)   = Just is
+   rec (_:rest)       = rec rest 
+  
 makeDerivation :: a -> [Rule a] -> [(String, a)]
 makeDerivation _ []     = []
 makeDerivation a (r:rs) = 
@@ -137,5 +137,154 @@    map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree p0
  where
    f d = (last (terms d), if isEmpty d then p0 else last (steps d))
-   stop (Just (Step _ r)) = isMajorRule r
-   stop _ = False+   stop (Just (Step r)) = isMajorRule r
+   stop _ = False
+
+------------------------------------------------------------------------
+-- Requests
+
+extractString :: String -> XML -> Either String String
+extractString s = liftM getData . findChild s
+
+xmlToRequest :: XML -> (OMOBJ -> Maybe a) -> Exercise a -> Either String (State a, StrategyLocation, Maybe a)
+xmlToRequest xml fromOpenMath ex = do
+   unless (XML.name xml == "request") $
+      fail "XML document is not a request" 
+   loc     <- optional (extractLocation "location" xml)
+   term    <- extractExpr "term" xml
+   context <- optional (extractString "context" xml)
+   answer  <- optional (extractExpr "answer" xml)
+   t  <- maybe (fail "invalid omobj") return (fromOpenMath term)
+   mt <- case answer of
+            Nothing -> return Nothing 
+            Just o  -> return $ fromOpenMath o
+   return
+      ( State
+           { exercise = ex
+           , prefix   = case context of
+                           Just s  -> Just $ getPrefix2 s (strategy ex)
+                           Nothing -> Just $ emptyPrefix (strategy ex)
+           , context  = case context of 
+                           Just s  -> putInContext2 ex s t
+                           Nothing -> inContext ex t
+           }
+      , fromMaybe topLocation loc
+      , mt
+      )
+
+-----------------------------------------------------------
+putInContext2 :: Exercise a -> String -> a -> Context a
+putInContext2 ex s = fromMaybe (inContext ex) $ do
+   (_, s2) <- splitAtElem ';' s
+   env     <- parseContext s2
+   return (makeContext ex env)
+
+getPrefix2 :: String -> LabeledStrategy (Context a) -> Prefix (Context a)
+getPrefix2 s ls = fromMaybe (emptyPrefix ls) $ do
+   (s1, _) <- splitAtElem ';' s
+   is <- readM s1
+   makePrefix is ls
+
+optional :: Either String a -> Either String (Maybe a)
+optional = Right . either (const Nothing) Just
+
+extractLocation :: String -> XML -> Either String StrategyLocation
+extractLocation s xml = do
+   c <- findChild s xml
+   case parseStrategyLocation (getData c) of
+      Just loc -> return loc
+      _        -> fail "invalid location"
+
+extractExpr :: String -> XML -> Either String OMOBJ
+extractExpr n xml =
+   case findChild n xml of 
+      Just expr -> 
+         case children expr of 
+            [this] -> xml2omobj this
+            _ -> fail $ "error in " ++ show (n, xml)
+      _ -> fail $ "error in " ++ show (n, xml)
+
+-- Legacy code: remove!
+parseContext :: String -> Maybe Environment
+parseContext s
+   | all isSpace s = 
+        return emptyEnv
+   | otherwise = do
+        pairs <- mapM (splitAtElem '=') (splitsWithElem ',' s)
+        let env = foldr (uncurry storeEnv) emptyEnv pairs
+        return env
+        
+------------------------------------------------------------------------
+-- Data types for replies
+
+-- There are three possible replies: ok, incorrect, or an error in the protocol (e.g., a parse error)
+data Reply a = Ok (ReplyOk a) | Incorrect (ReplyIncorrect a) | Error ReplyError
+
+data ReplyOk a = ReplyOk
+   { repOk_Code     :: Exercise a
+   , repOk_Location :: StrategyLocation
+   , repOk_Context  :: String
+   , repOk_Steps    :: Int
+   }
+   
+data ReplyIncorrect a = ReplyIncorrect
+   { repInc_Code       :: Exercise a
+   , repInc_Location   :: StrategyLocation
+   , repInc_Expected   :: a
+   , repInc_Derivation :: [(String, a)]
+   , repInc_Arguments  :: Args
+   , repInc_Steps      :: Int
+   , repInc_Equivalent :: Bool
+   }
+ 
+data ReplyError = ReplyError
+   { repErr_Kind    :: String
+   , repErr_Message :: String
+   }
+
+type Args = [(String, String)]
+
+------------------------------------------------------------------------
+-- Conversion functions to XML
+
+replyToXML :: (a -> OMOBJ) -> Reply a -> XML
+replyToXML toOpenMath reply =
+   case reply of
+      Ok r        -> replyOkToXML r
+      Incorrect r -> replyIncorrectToXML toOpenMath r 
+      Error r     -> replyErrorToXML r
+
+replyOkToXML :: ReplyOk a -> XML
+replyOkToXML r = makeReply "ok" $ do
+   element "strategy" (text $ show $ exerciseCode $ repOk_Code r)
+   element "location" (text $ show $ repOk_Location r)
+   element "context"  (text $ repOk_Context r)
+   element "steps"    (text $ show $ repOk_Steps r)
+
+replyIncorrectToXML :: (a -> OMOBJ) -> ReplyIncorrect a -> XML
+replyIncorrectToXML toOpenMath r = makeReply "incorrect" $ do
+   element "strategy"   (text $ show $ exerciseCode $ repInc_Code r)
+   element "location"   (text $ show $ repInc_Location r)
+   element "expected"   (builder $ omobj2xml $ toOpenMath $ repInc_Expected r)
+   element "steps"      (text $ show $ repInc_Steps r)
+   element "equivalent" (text $ show $ repInc_Equivalent r)
+   
+   unless (null $ repInc_Arguments r) $
+       let f (x, y) = element "elem" $ do 
+              "descr" .=. x 
+              text y
+       in element "arguments" $ mapM_ f (repInc_Arguments r)
+
+   unless (null $  repInc_Derivation r) $
+      let f (x,y) = element "elem" $ do 
+             "ruleid" .=. x 
+             builder (omobj2xml (toOpenMath y))
+      in element "derivation" $ mapM_ f (repInc_Derivation r)
+
+replyErrorToXML :: ReplyError -> XML
+replyErrorToXML r = makeReply (repErr_Kind r) (text $ repErr_Message r)
+   
+makeReply :: String -> XMLBuilder -> XML
+makeReply kind body = makeXML "reply" $ do
+   "result" .=. kind
+   body
src/Service/Request.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
− src/Service/Revision.hs 
@@ -1,4 +0,0 @@-module Service.Revision where-version = "0.5.8"-revision = 2376-lastChanged = "Fri, 23 Oct 2009"
+ src/Service/RulesInfo.hs view
@@ -0,0 +1,88 @@+-----------------------------------------------------------------------------+-- 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 +   ( RulesInfo, mkRulesInfo, rulesInfoXML+   , rewriteRuleToFMP, collectExamples+   ) where++import Common.Utils (Some(..))+import Common.Context+import Common.Derivation+import Common.Exercise hiding (getRule)+import Common.Rewriting+import Common.Strategy (derivationTree)+import Common.Transformation+import Data.Char+import Control.Monad+import Text.OpenMath.Object+import Text.OpenMath.FMP+import Text.XML hiding (name)+import Service.ExercisePackage (termToOMOBJ)+import qualified Data.Map as M++data RulesInfo a = I++mkRulesInfo :: RulesInfo a+mkRulesInfo = I++rulesInfoXML :: Monad m => Exercise a -> (a -> m XMLBuilder) -> m XMLBuilder+rulesInfoXML ex enc = combine $ forM (ruleset ex) $ \r -> do+   +   let pairs = M.findWithDefault [] (name r) exampleMap+   examples <- forM (take 3 pairs) $ \(a, b) ->+                  liftM2 (,) (enc a) (enc b)+                     +   return $ element "rule" $ do+      "name"        .=. name r+      "buggy"       .=. f (isBuggyRule r)+      "rewriterule" .=. f (isRewriteRule r)+      -- More information+      let descr = ruleDescription r+          -- to do: rules should carry descriptions +          txt   = if null descr then (name r) else descr +      unless (null txt) $+         element "description" $ text txt+      forM_ (ruleGroups r) $ \s -> +         element "group" $ text s+      forM_ (ruleSiblings r) $ \s -> +         element "sibling" $ text 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_ examples $ \(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 (rulePair r 0)+              +collectExamples :: Exercise a -> M.Map String [(a, 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 (a, r, b) = M.insertWith (++) (name r) (liftM2 (,) (fromContext a) (fromContext b))+             in f (derivation tree)
− src/Service/SearchSpace.hs 
@@ -1,150 +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 Service.SearchSpace 
-   ( searchSpace, searchSpaceWith, SearchSpaceConfig(..), defaultConfig
-   ) where
-
-import Common.Apply
-import Common.Rewriting.TreeDiff
-import Common.Transformation
-import Common.Strategy hiding ((<||>), (<|>))
-import Service.Progress
-import qualified Data.Set as S
-
-data SearchSpaceConfig = SSC 
-   { costStrategy :: Rational
-   , costRule     :: String -> Rational
-   }
-   
-defaultConfig :: SearchSpaceConfig
-defaultConfig = SSC 
-   { costStrategy = 1
-   , costRule     = const 1
-   }
-
-type Diffs a = a -> [(a, TreeDiff)] 
-
-searchSpace :: (a -> a -> Ordering) -> Diffs a -> Maybe (Prefix a) -> [Rule a] -> a -> Progress Rational (a, Maybe (Prefix a), [Rule a])
-searchSpace = searchSpaceWith defaultConfig
-
-searchSpaceWith :: SearchSpaceConfig -> (a -> a -> Ordering) -> Diffs a -> Maybe (Prefix a) -> [Rule a] -> a -> Progress Rational (a, Maybe (Prefix a), [Rule a])
-searchSpaceWith config ordering diffs mp rules q = rec (empty ordering) (success (q, [], mp))
- where
-   rec history worklist =
-      case extractFirst worklist of
-         Nothing -> 
-            emptyProgress
-         Just (cost, (p, rs, mStrat), _, rest)
-            | member p history ->
-                 addScore cost failure <||> rec history rest
-            | otherwise -> 
-                 let new = newStrategy <|> newRule
-                     newRule = mapProgress (\(a, r) -> (a, r:rs, Nothing)) (stepP p)
-                     newStrategy = 
-                        case mStrat of
-                           Nothing -> emptyProgress
-                           Just p1 -> addScore (costStrategy config) $ fromMaybeList $
-                              flip map (runPrefixMajor p1 p) $ \(x, y) -> 
-                                 case lastRuleInPrefix y of
-                                    Just r | isMajorRule r && stepsToRules (prefixToSteps p1) /= stepsToRules (prefixToSteps y) -> 
-                                       Just (x, r:rs, Just y)
-                                    _ -> Nothing
-                     newHistory  = insert p history
-                     newWorklist = addScore cost new <|> rest
-                 in addScore cost (success (p, mStrat, rs)) <||> rec newHistory newWorklist
-
-   stepP a0 = do
-      (r, a) <- scoreList 
-         [ (cost , (r, a)) 
-         | (a, td) <- diffs a0
-         , r <- rules 
-         , let cost = costRule config (name r) * scoreTreeDiff td
-         ]
-      fromMaybeList $ 
-         case applyAll r a of
-            [] -> [ Nothing ]
-            bs -> [ Just (b, r) | b <- bs]
-
-scoreTreeDiff :: TreeDiff -> Rational
-scoreTreeDiff td =
-   case td of
-      Equal -> 1000 
-      _ -> 1
-      {- Equal     -> 20
-      Inside    -> 10
-      Different -> 1
-      Top       -> 2 -}
-
--- History and X are a work-around, since we don't have an Ord instance for our type
-data History a = History (a -> a -> Ordering) (S.Set (X a))
-
-newtype X a = X (a -> a -> Ordering, a)
-
-instance Eq (X a) where
-   X (f, a) == X (_, b) = f a b == EQ
-
-instance Ord (X a) where
-   X (f, a) `compare` X (_, b) = f a b
-
-empty :: (a -> a -> Ordering) -> History a 
-empty f = History f S.empty
-
-member :: a -> History a -> Bool
-member a (History f s) = S.member (X (f, a)) s
-
-insert :: a -> History a -> History a
-insert a (History f s) = History f (S.insert (X (f, a)) s)
-
-------------------------------------------------------
--- Example for logic domain
-{- 
-buggyRules     = map liftRuleToContext [buggyDeMorganOr, buggyDeMorganAnd, buggyAndOverOr, buggyOrOverAnd]
-expensiveRules = map liftRuleToContext [ruleDefEquiv, ruleAndOverOr, ruleOrOverAnd]
-
-buggyDeMorganOr :: LogicRule
-buggyDeMorganOr = buggyRule $ makeRule "Buggy DeMorganOr" $
-   (Not (x :||: y))  |-  (Not x :||: Not y)
-
-buggyDeMorganAnd :: LogicRule
-buggyDeMorganAnd = buggyRule $ makeRule "Buggy DeMorganAnd" $
-   (Not (x :&&: y))  |-  (Not x :&&: Not y)
-   
-buggyAndOverOr :: LogicRule
-buggyAndOverOr = buggyRule $ makeRuleList "Buggy AndOverOr"
-   [ (x :&&: (y :||: z))  |-  ((x :||: y) :&&: (x :||: z))
-   , ((x :||: y) :&&: z)  |-  ((x :||: z) :&&: (y :||: z))
-   ]
-
-buggyOrOverAnd :: LogicRule
-buggyOrOverAnd = buggyRule $ makeRuleList "Buggy OrOverAnd"
-   [ (x :||: (y :&&: z))  |-  ((x :&&: y) :||: (x :&&: z))
-   , ((x :&&: y) :||: z)  |-  ((x :&&: z) :||: (y :&&: z))
-   ]
-
-ex = (T :->: Var "p") :&&: (Var "q" :||: T)
-
-q = putStrLn $ unlines $ map f $ successes $ maxDepth 20 $ stepsP (inContext ex)
- where f (a, rs) = ppLogic (fromContext a) ++ "  " ++ show rs
-
-w = map (\(a,b) -> (a, length b)) $ successesForScore $ maxDepth 25 $ stepsP (inContext ex)
-
-ruleScore :: Rule (Context Logic) -> Int
-ruleScore r
-   | name r `elem` map name buggyRules     = fromInteger costBUGGY
-   | name r `elem` map name expensiveRules = fromInteger costEXPENSIVE
-   | otherwise                             = fromInteger costRULE
-
-stepsP :: Context Logic -> Progress Int (Context Logic, [Rule (Context Logic)])
-stepsP = searchSpace (emptyPrefix toDNF) rules
- where
-   list  = map liftRuleToContext logicRules ++ buggyRules
-   rules = zip (map ruleScore list) list -}
src/Service/ServiceList.hs view
@@ -1,5 +1,6 @@+{-# OPTIONS -XRankNTypes #-} -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -9,123 +10,219 @@ -- Portability :  portable (depends on ghc) -- ------------------------------------------------------------------------------module Service.ServiceList (serviceList, Service(..), getService, evalService) where+module Service.ServiceList +   ( serviceList, exerciselistS+   , Service(..), evalService+   ) where -import Common.Context+import Common.Exercise hiding (Exercise)+import Common.Strategy (toStrategy) import Common.Transformation-import qualified Common.Exercise as E import Common.Utils (Some(..))-import Common.Exercise hiding (Exercise)-import Control.Monad.Error-import qualified Service.ExerciseList as S-import qualified Service.TypedAbstractService as S-import Service.FeedbackText-import Service.Types  import Data.List (sortBy)+import Service.FeedbackText hiding (ExerciseText)+import Service.ProblemDecomposition+import Service.ExercisePackage+import Service.RulesInfo+import Service.Types +import qualified Common.Exercise as E+import qualified Service.Diagnose as S+import qualified Service.Submit as S+import qualified Service.TypedAbstractService as S -data Service a = Service -   { serviceName :: String-   , typedValue  :: TypedValue a+data Service = Service +   { serviceName        :: String+   , serviceDescription :: String+   , serviceDeprecated  :: Bool+   , serviceFunction    :: forall a . TypedValue a    }  ------------------------------------------------------ -- Querying a service -serviceList :: [Service a]+serviceList :: [Service] serviceList =    [ derivationS, allfirstsS, onefirstS, readyS    , stepsremainingS, applicableS, applyS, generateS-   , submitS+   , submitS, diagnoseS    , onefirsttextS, findbuggyrulesS    , submittextS, derivationtextS-   , exerciselistS, rulelistS+   , problemdecompositionS+   , rulelistS, rulesinfoS, strategyinfoS    ] -getService :: Monad m => String -> m (Service a)-getService txt =-   case filter ((==txt) . serviceName) serviceList of-      [hd] -> return hd-      []   -> fail $ "No service " ++ txt-      _    -> fail $ "Ambiguous service " ++ txt+makeService :: String -> String -> (forall a . TypedValue a) -> Service+makeService name descr f = Service name descr False f -evalService :: Monad m => Evaluator m inp out a -> Service a -> inp -> m out-evalService f = eval f . typedValue+deprecate :: Service -> Service+deprecate s = s { serviceDeprecated = True }++evalService :: Monad m => Evaluator m inp out a -> Service -> inp -> m out+evalService f = eval f . serviceFunction     ------------------------------------------------------ -- Basic services -derivationS :: Service a-derivationS = Service "derivation" $ -   S.derivation ::: State :-> List (Pair Rule Term)+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." $ +   S.derivation ::: Maybe StrategyCfg :-> State :-> Error (List (tuple2 Rule Context)) -allfirstsS :: Service a-allfirstsS = Service "allfirsts" $ -   S.allfirsts ::: State :-> List (Triple Rule Location State)+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." $ +   S.allfirsts ::: State :-> Error (List (tuple3 Rule Location State))         -onefirstS :: Service a-onefirstS = Service "onefirst" $ -   S.onefirst ::: State :-> Elem (Triple Rule Location State)+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." $ +   S.onefirst ::: State :-> Elem (Error (tuple3 Rule Location State))   -readyS :: Service a-readyS = Service "ready" $ +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." $     S.ready ::: State :-> Bool -stepsremainingS :: Service a-stepsremainingS = Service "stepsremaining" $-   S.stepsremaining ::: State :-> Int+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." $+   S.stepsremaining ::: State :-> Error Int -applicableS :: Service a-applicableS = Service "applicable" $ +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." $     S.applicable ::: Location :-> State :-> List Rule -applyS :: Service a-applyS = Service "apply" $ -   S.apply ::: Rule :-> Location :-> State :-> State+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." $ +   S.apply ::: Rule :-> Location :-> State :-> Error State -generateS :: Service a-generateS = Service "generate" $ S.generate ::: -   Exercise :-> Optional 5 Int :-> IO State+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." $ +   S.generate ::: Exercise :-> Optional 5 Int :-> IO State -findbuggyrulesS :: Service a-findbuggyrulesS = Service "findbuggyrules" $ +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." $     S.findbuggyrules ::: State :-> Term :-> List Rule -submitS :: Service a-submitS = Service "submit" $ (\a -> S.submit a . fromContext) :::-   State :-> Term :-> Result+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." $ +   S.submit ::: State :-> Term :-> Result +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)." $+   S.diagnose ::: State :-> Term :-> Diagnosis+ ------------------------------------------------------ -- Services with a feedback component -onefirsttextS :: Service a-onefirsttextS = Service "onefirsttext" $ -   onefirsttext ::: State :-> Maybe String :-> Elem (Triple Bool String State)+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 ::: ExerciseText :-> State :-> Maybe String :-> Elem (tuple3 Bool String State) -submittextS :: Service a-submittextS = Service "submittext" $ -   submittext ::: State :-> String :-> Maybe String :-> Elem (Triple Bool String State)+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 ::: ExerciseText :-> State :-> String :-> Maybe String :-> Elem (tuple3 Bool String State) -derivationtextS :: Service a-derivationtextS = Service "derivationtext" $ -   derivationtext ::: State :-> Maybe String :-> List (Pair String Term)-   +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 ::: ExerciseText :-> State :-> Maybe String :-> Error (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 ::: State :-> StrategyLoc :-> Maybe Term :-> DecompositionReply++------------------------------------------------------ -- Reflective services    -exerciselistS :: Service a-exerciselistS = Service "exerciselist" $-   allExercises ::: List (Quadruple (Tag "domain" String) (Tag "identifier" String) (Tag "description" String) (Tag "status" String))+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 (tuple4 (Tag "domain" String) (Tag "identifier" String) (Tag "description" String) (Tag "status" String)) -rulelistS :: Service a-rulelistS = Service "rulelist" $ -   allRules ::: Exercise :-> List (Triple (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool))+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 :-> List (tuple3 (Tag "name" String) (Tag "buggy" Bool) (Tag "rewriterule" Bool))       -allExercises :: [(String, String, String, String)]-allExercises  = map make $ sortBy cmp S.exerciseList+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." $+   mkRulesInfo ::: RulesInfo++strategyinfoS :: Service+strategyinfoS = makeService "strategyinfo"+   "Returns the representation of the strategy of a particular exercise." $ +   (toStrategy . strategy) ::: Exercise :-> Strategy +   +allExercises :: [Some ExercisePackage] -> [(String, String, String, String)]+allExercises = map make . sortBy cmp  where    cmp e1 e2  = f e1 `compare` f e2-   f (Some e) = (domain (exerciseCode e), identifier (exerciseCode e))-   make (Some ex) = (domain (exerciseCode ex), identifier (exerciseCode ex), description ex, show (status ex))+   f (Some pkg) = exerciseCode (exercise pkg)+   make (Some pkg) = +      let ex   = exercise pkg+          code = exerciseCode ex +      in (domain code, identifier code, description ex, show (status ex))  allRules :: E.Exercise a -> [(String, Bool, Bool)] allRules = map make . ruleset
+ src/Service/StrategyInfo.hs view
@@ -0,0 +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.Strategy.Core (Core(..), noLabels)+import Common.Strategy.Abstract+import Text.XML+import Common.Transformation hiding (name)+import Common.Utils (readInt)++instance InXML (LabeledStrategy a) where+   toXML       = toXML . toStrategy+   fromXML xml = fromXML xml >>= toLabeledStrategy++instance InXML (Strategy a) where+   toXML   = strategyToXML+   fromXML = xmlToStrategy unknownRule++-----------------------------------------------------------------------+-- Strategy to XML++strategyToXML :: IsStrategy f => f a -> XML+strategyToXML = coreToXML . toCore . toStrategy++infoToXML :: LabelInfo -> XMLBuilder+infoToXML info = do+   "name" .=. labelName 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 :: (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 a -> element "label"    (f l >> rec a)+         Rec n a   -> element "rec"      (("var" .=. show n) >> rec a)+         Not a     -> element "not"      (recNot a)+         Rule l r  -> element "rule"     (maybe ("name" .=. show r) f l)+         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 (labelName info) of+               Just r  -> return r+               Nothing -> fail $ "Unknown rule: " ++ show (labelName 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"++unknownRule :: Monad m => String -> m (Rule a)+unknownRule s = +   let n = "#Unknown rule:" ++ s+   in return (makeSimpleRule n (const Nothing))++readStrategy :: Monad m => (XML -> m l) -> (l -> m (Rule a)) -> XML -> m (Core l a)+readStrategy f g xml = do+   xs <- mapM (readStrategy f g) (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 <- f xml+      return (Label info x)+   buildRule = do+      info <- f xml+      rule <- g info+      return (Rule (Just info) rule)+   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)++   nullary a _ [] = return a+   nullary _ s _  = fail $ "Strategy combinator " ++ s ++ "expects 0 args"+ +   unary f _ [x] = return (f x)+   unary _ 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",     unary Many)+      , ("repeat",   unary Repeat)+      , ("label",    join2 unary buildLabel)+      , ("rec",      join2 unary buildRec)+      , ("not",      unary (Not . noLabels))+      , ("rule",     join2 nullary buildRule)+      , ("var",      join2 nullary buildVar)+      , ("succeed",  nullary Succeed)+      , ("fail",     nullary Fail) +      ]
+ src/Service/Submit.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+-- 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) where++import Common.Transformation+import Common.Context+import qualified Service.Diagnose as Diagnose+import Service.Diagnose (Diagnosis, diagnose)+import Service.TypedAbstractService++-- 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 diagnose =+   case diagnose 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 new = fromDiagnose (diagnose state new)+   +getResultState :: Result a -> Maybe (State a)+getResultState result =+   case result of+      Ok _ st     -> return st+      Detour _ st -> return st+      Unknown st  -> return st+      _           -> Nothing
src/Service/TypedAbstractService.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -13,37 +13,30 @@    ( -- * Exercise state
      State(..), emptyState, term
      -- * Services
-   , stepsremaining, findbuggyrules, submit, ready, allfirsts
-   , derivation, onefirst, applicable, apply, generate, generateWith
-     -- * Result data type
-   , Result(..), getResultState, resetStateIfNeeded
+   , stepsremaining, findbuggyrules, ready, allfirsts, derivation
+   , onefirst, applicable, apply, generate, generateWith
    ) where
 
 import qualified Common.Apply as Apply
 import Common.Context 
 import Common.Derivation hiding (derivation)
-import Common.Exercise (Exercise(..), ruleset, randomTermWith)
-import Common.Strategy hiding (not)
+import Common.Exercise (Exercise(..), ruleset, randomTermWith, inContext)
+import Common.Strategy hiding (not, fail)
 import Common.Transformation (Rule, name, isMajorRule, isBuggyRule)
 import Common.Utils (safeHead)
+import Common.Navigator
 import Data.Maybe
 import System.Random
+import Control.Monad
 
 data State a = State 
-   { exercise :: Exercise a
-   , prefix   :: Maybe (Prefix (Context a))
-   , context  :: Context a
+   { exercise     :: Exercise a
+   , prefix       :: Maybe (Prefix (Context a))
+   , context      :: Context a
    }
 
 term :: State a -> a
-term = fromContext . context
-
--- 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
+term = fromMaybe (error "invalid term") . fromContext . context
 
 -----------------------------------------------------------
 
@@ -51,7 +44,7 @@ emptyState ex a = State
    { exercise = ex
    , prefix   = Just (emptyPrefix (strategy ex))
-   , context  = inContext a
+   , context  = inContext ex a
    }
       
 -- result must be in the IO monad to access a standard random number generator
@@ -62,134 +55,98 @@ 
 generateWith :: StdGen -> Exercise a -> Int -> State a
 generateWith rng ex level = emptyState ex (randomTermWith rng level ex)
-   
-derivation :: State a -> [(Rule (Context a), Context a)]
-derivation state =
-   case allfirsts state of 
-      [] -> []
-      (r, _, next):_ -> (r, context next) : derivation next 
 
+derivation :: Monad m => Maybe StrategyConfiguration -> State a -> m [(Rule (Context a), Context a)]
+derivation mcfg state =
+   case (prefix state, mcfg) of 
+      (Nothing, _) -> fail "Prefix is required"
+      -- configuration is only allowed beforehand: hence, the prefix 
+      -- should be empty (or else, the configuration is ignored). This
+      -- restriction should probably be relaxed later on.
+      (Just p, Just cfg) | null (prefixToSteps p) -> 
+         let new = configure cfg $ strategy $ exercise state
+         in rec state 
+               { prefix   = Just (emptyPrefix new)
+               , exercise = (exercise state) {strategy=new}
+               } 
+      _ -> rec state
+ where
+   rec :: Monad m => State a -> m [(Rule (Context a), Context a)]
+   rec state = do
+      xs <- allfirsts state
+      case xs of 
+         [] -> return []
+         (r, _, next):_ -> liftM ((r, context next):) (rec next)
+
 -- Note that we have to inspect the last step of the prefix afterwards, because
 -- the remaining part of the derivation could consist of minor rules only.
-allfirsts :: State a -> [(Rule (Context a), Location, State a)]
+allfirsts :: Monad m => State a -> m [(Rule (Context a), Location, State a)]
 allfirsts state = 
    case prefix state of
       Nothing -> 
-         error "allfirsts: no prefix"
+         fail "Prefix is required"
       Just p0 ->
          let tree = cutOnStep (stop . lastStepInPrefix) (prefixTree p0 (context state))
-         in mapMaybe make (derivations tree)
+         in return (mapMaybe make (derivations tree))
  where
-   stop (Just (Step _ r)) = isMajorRule r
+   stop (Just (Step r)) = isMajorRule r
    stop _ = False
    
    make d = do
       prefixEnd <- safeHead (reverse (steps d))
       termEnd   <- safeHead (reverse (terms d))
       case lastStepInPrefix prefixEnd of
-         Just (Step _ r) | isMajorRule r -> return
+         Just (Step r) | isMajorRule r -> return
             ( r
             , location termEnd
             , state { context = termEnd
-                    , prefix = Just prefixEnd
+                    , prefix  = Just prefixEnd
                     }
             )
          _ -> Nothing
 
-onefirst :: State a -> (Rule (Context a), Location, State a)
-onefirst = fromMaybe (error "onefirst") . safeHead . allfirsts
+onefirst :: Monad m => State a -> m (Rule (Context a), Location, State a)
+onefirst state = 
+   case allfirsts state of
+      Right (hd:_) -> return hd
+      Right []     -> fail "No step possible"
+      Left msg     -> fail msg
 
 applicable :: Location -> State a -> [Rule (Context a)]
 applicable loc state =
    let check r = not (isBuggyRule r) && Apply.applicable r (setLocation loc (context state))
    in filter check (ruleset (exercise state))
 
+-- local helper
+setLocation :: Location -> Context a -> Context a 
+setLocation loc c0 = fromMaybe c0 $ do
+   navigateTo loc c0
+
 -- Two possible scenarios: either I have a prefix and I can return a new one (i.e., still following the 
 -- strategy), or I return a new term without a prefix. A final scenario is that the rule cannot be applied
 -- to the current term at the given location, in which case the request is invalid.
-apply :: Rule (Context a) -> Location -> State a -> State a
+apply :: Monad m => Rule (Context a) -> Location -> State a -> m (State a)
 apply r loc state = maybe applyOff applyOn (prefix state)
  where
    applyOn _ = -- scenario 1: on-strategy
-      fromMaybe applyOff $ safeHead
-      [ s1 | (r1, loc1, s1) <- allfirsts state, name r == name r1, loc==loc1 ]
+      maybe applyOff return $ safeHead
+      [ s1 | (r1, loc1, s1) <- fromMaybe [] $ allfirsts state, name r == name r1, loc==loc1 ]
       
    applyOff  = -- scenario 2: off-strategy
       case Apply.apply r (setLocation loc (context state)) of
-         Just new -> state { context=new }
-         Nothing  -> error "apply"
+         Just new -> return state { context=new, prefix=Nothing }
+         Nothing  -> fail ("Cannot apply " ++ show r)
        
 ready :: State a -> Bool
 ready state = isReady (exercise state) (term state)
 
-stepsremaining :: State a -> Int
-stepsremaining = length . derivation
+stepsremaining :: Monad m => State a -> m Int
+stepsremaining = liftM length . derivation Nothing
 
-findbuggyrules :: State a -> Context a -> [Rule (Context a)]
+findbuggyrules :: State a -> a -> [Rule (Context a)]
 findbuggyrules state a =
    let ex      = exercise state
-       isA     = similarity ex (fromContext a) . fromContext  
+       isA     = maybe False (similarity ex a) . fromContext
        buggies = filter isBuggyRule (ruleset ex)
        check r = any isA (Apply.applyAll r (context state))
-   in filter check buggies
-
--- make sure that new has a prefix (because of possible detour)
--- when resetting the prefix, also make sure that the context is refreshed
-resetStateIfNeeded :: State a -> State a
-resetStateIfNeeded s 
-   | isJust (prefix s) = s
-   | otherwise = s
-        { prefix  = Just (emptyPrefix (strategy (exercise s)))
-        , context = inContext (fromContext (context s))
-        } 
-
-submit :: State a -> a -> Result a
-submit state new
-   -- Is the submitted term equivalent?
-   | not (equivalence (exercise state) (term state) new) =
-        -- 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 (exercise state) (term state) new =
-        -- If yes, report this
-        Ok [] state
-   -- Was the submitted term expected by the strategy
-   | isJust expected =
-        -- If yes, return new state and rule
-        let (r, _, ns) = fromJust expected  
-        in Ok [r] ns
-   -- Is the rule used discoverable by trying all known rules?
-   | otherwise =
-        case discovered False of
-           Just r ->  -- If yes, report the found rule as a detour
-              Detour [r] state { prefix=Nothing, context=inContext new }
-           Nothing -> -- If not, we give up
-              Unknown state { prefix=Nothing, context=inContext new }
- where
-   expected = 
-      let p (_, _, ns) = similarity (exercise state) new (term ns)
-      in safeHead (filter p (allfirsts state))
-
-   discovered searchForBuggy = safeHead
-      [ r
-      | r <- ruleset (exercise state)
-      , isBuggyRule r == searchForBuggy
-      , a <- Apply.applyAll r (inContext sub1)
-      , similarity (exercise state) sub2 (fromContext a)
-      ]
-    where 
-      mode = not searchForBuggy
-      diff = difference (exercise state) mode (term state) new
-      (sub1, sub2) = fromMaybe (term state, new) diff 
-
-getResultState :: Result a -> Maybe (State a)
-getResultState result =
-   case result of
-      Ok _ st     -> return st
-      Detour _ st -> return st
-      Unknown st  -> return st
-      _           -> Nothing+   in filter check buggies
+ src/Service/TypedExample.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS -XGADTs #-}+-----------------------------------------------------------------------------+-- 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.ServiceList+import Service.Types+import Common.Exercise+import Text.XML+   +typedExample :: ExercisePackage a -> Service -> [TypedValue a] -> DomainReasoner (XML, XML, Bool)+typedExample pkg service args = do+   -- Construct a request in xml+   xmlRequest <- +      case makeArgType args of+         Nothing -> return $  +            stdReply (serviceName service) enc (exercise pkg) (return ())+         Just (reqTuple ::: reqTp) ->+            case encodeType (encoder evaluator) reqTp reqTuple of+               Left err  -> fail err+               Right xml -> return $ +                  stdReply (serviceName service) enc (exercise pkg) xml+   -- Construct a reply in xml+   xmlReply <- return $+      case foldl dynamicApply (serviceFunction service) args of+         reply ::: replyTp ->+            case encodeType (encoder evaluator) replyTp reply of+               Left err  -> resultError err+               Right xml -> resultOk xml+   -- Check request/reply pair+   vers <- getVersion+   xmlTest <- do+      (_, txt, _) <- processXML (show xmlRequest)+      let p   = filter (not . isSpace)+          out = showXML (if null vers then xmlReply else addVersion vers xmlReply)+      return (p txt == p out)+     `catchError` +      const (return False)+   return (xmlRequest, xmlReply, 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" .=. show (exerciseCode 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)"++equal :: Type a t1 -> Type a t2 -> Maybe (t1 -> t2)+equal t1 t2 = +   case (t1, t2) of+      (Maybe a, Maybe b) -> fmap fmap (equal a b)+      (StrategyCfg, StrategyCfg) -> Just id+      (State, State) -> Just id+      (Location, Location) -> Just id+      (Exercise, Exercise) -> Just id+      _ -> Nothing
src/Service/Types.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, Rank2Types #-} -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -12,83 +12,120 @@ ----------------------------------------------------------------------------- module Service.Types where -import Common.Context (Context, Location, fromContext)+import Common.Context (Context, fromContext) import Common.Exercise (Exercise)+import Common.Navigator (Location) import Common.Transformation (Rule, name)+import Common.Strategy (Strategy, StrategyLocation, StrategyConfiguration) import Common.Utils (commaList) import Control.Arrow import Control.Monad import Data.Maybe-import Service.TypedAbstractService (State, Result)+import Service.ExercisePackage (ExercisePackage, exercise, getExerciseText)+import Service.TypedAbstractService (State)+import Service.Submit (Result)+import Service.Diagnose (Diagnosis)+import Service.FeedbackText (ExerciseText)+import Service.RulesInfo import System.IO.Unsafe+import qualified Service.ProblemDecomposition as Decomposition  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)))+ 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)-   -- Tuple types-   Pair      :: Type a t1 -> Type a t2 -> Type a (t1, t2)-   Triple    :: Type a t1 -> Type a t2 -> Type a t3 -> Type a (t1, t2, t3)-   Quadruple :: Type a t1 -> Type a t2 -> Type a t3 -> Type a t4 -> Type a (t1, t2, t3, t4)+   (:->)        :: Type a t1 -> Type a t2 -> Type a (t1 -> t2)    -- Special annotations-   Tag       :: String -> Type a t1 -> Type a t1-   Optional  :: t1 -> Type a t1 -> Type a t1-   Maybe     :: Type a t1 -> Type a (Maybe t1)+   Tag          :: String -> Type a t1 -> Type a t1+   Optional     :: t1 -> Type a t1 -> Type a t1+   Maybe        :: Type a t1 -> Type a (Maybe t1)+   Error        :: Type a t -> Type a (Either String t)    -- Type constructors-   List      :: Type a t -> Type a [t]-   Elem      :: Type a t -> Type a t -- quick fix-   IO        :: Type a t -> Type a (IO t)+   List         :: Type a t -> Type a [t]+   Pair         :: Type a t1 -> Type a t2 -> Type a (t1, t2)+   Elem         :: Type a t -> Type a t -- quick fix+   IO           :: Type a t -> Type a (IO t)    -- Exercise-specific types-   State     :: Type a (State a)-   Exercise  :: Type a (Exercise a)-   Rule      :: Type a (Rule (Context a))-   Term      :: Type a (Context a)-   Result    :: Type a (Result a)+   State        :: Type a (State a)+   Exercise     :: Type a (Exercise a)+   Strategy     :: Type a (Strategy (Context a))+   ExerciseText :: Type a (ExerciseText a)+   Rule         :: Type a (Rule (Context a))+   RulesInfo    :: Type a (RulesInfo a)+   Term         :: Type a a+   Context      :: Type a (Context a)+   Result       :: Type a (Result a)+   Diagnosis    :: Type a (Diagnosis a)+   Location     :: Type a Location+   StrategyLoc  :: Type a StrategyLocation+   StrategyCfg  :: Type a StrategyConfiguration+   DecompositionReply :: Type a (Decomposition.Reply a)    -- Basic types-   Bool      :: Type a Bool-   Int       :: Type a Int-   String    :: Type a String-   Location  :: Type a Location+   Bool         :: Type a Bool+   Int          :: Type a Int+   String       :: Type a String  instance Show (Type a t) where-   show (t1 :-> t2)       = show t1 ++ " -> " ++ show t2 -   show (Pair t1 t2)      = "(" ++ commaList [show t1, show t2] ++ ")"-   show (Triple t1 t2 t3) = "(" ++ commaList [show t1, show t2, show t3] ++ ")"-   show (Quadruple t1 t2 t3 t4) = "(" ++ commaList [show t1, show t2, show t3, show t4] ++ ")"-   show (Tag _ t)         = show t-   show (Optional _ t)    = "(" ++ show t ++ ")?"-   show (Maybe t)         = "(" ++ show t ++ ")?"-   show (List t)          = "[" ++ show t ++ "]"-   show (Elem t)          = show t-   show (IO t)            = show t-   show t                 = fromMaybe "unknown" (groundType t)-+   show (Iso _ _ t)    = show t+   show (t1 :-> t2)    = show t1 ++ " -> " ++ show t2 +   show t@(Pair _ _)   = showTuple t+   show (Tag _ t)      = show t+   show (Optional _ t) = "(" ++ show t ++ ")?"+   show (Maybe t)      = "(" ++ show t ++ ")?"+   show (Error t)      = show t+   show (List t)       = "[" ++ show t ++ "]"+   show (Elem t)       = show t+   show (IO t)         = show t+   show t              = fromMaybe "unknown" (groundType t)+   +showTuple :: Type a t -> String+showTuple t = "(" ++ commaList (collect t) ++ ")"+ 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 -      State    -> Just "State"-      Exercise -> Just "Exercise"-      Rule     -> Just "Rule"-      Term     -> Just "Term"-      Result   -> Just "Result"-      Bool     -> Just "Bool"-      Int      -> Just "Int"-      String   -> Just "String"-      Location -> Just "Location"-      _        -> Nothing--{- eqType :: Type a1 t1 -> Type a2 t2 -> Bool-eqType (t1 :-> t2)       (t3 :-> t4)       = eqType t1 t3 && eqType t2 t4-eqType (Pair t1 t2)      (Pair t3 t4)      = eqType t1 t3 && eqType t2 t4-eqType (Triple t1 t2 t3) (Triple t4 t5 t6) = eqType t1 t4 && eqType t2 t5 && eqType t3 t6-eqType (List t1)         (List t2)         = eqType t1 t2-eqType (Elem t1)         (Elem t2)         = eqType t1 t2-eqType (IO t1)           (IO t2)           = eqType t1 t2 -eqType t1 t2 = maybe False ((groundType t1 ==) . Just) (groundType t2) -}+      State        -> Just "State"+      Exercise     -> Just "Exercise"+      Strategy     -> Just "Strategy"+      ExerciseText -> Just "ExerciseText"+      Rule         -> Just "Rule"+      RulesInfo    -> Just "RulesInfo"+      Term         -> Just "Term"+      Context      -> Just "Context"+      Result       -> Just "Result"+      Diagnosis    -> Just "Diagnosis"+      Bool         -> Just "Bool"+      Int          -> Just "Int"+      String       -> Just "String"+      Location     -> Just "Location"+      StrategyLoc  -> Just "StrategyLocation"+      StrategyCfg  -> Just "StrategyConfiguration"+      _            -> Nothing  data Evaluator m inp out a = Evaluator     { encoder :: Encoder m out a@@ -102,11 +139,14 @@    }  data Decoder m s a = Decoder -   { decodeType :: forall t . Type a t -> s -> m (t, s)-   , decodeTerm :: s -> m a-   , decoderExercise :: Exercise a+   { decodeType     :: forall t . Type a t -> s -> m (t, s)+   , decodeTerm     :: s -> m a+   , decoderPackage :: ExercisePackage a    } +decoderExercise :: Decoder m s a -> Exercise a+decoderExercise = exercise . decoderPackage+ eval :: Monad m => Evaluator m inp out a -> TypedValue a -> inp -> m out eval f (tv ::: tp) s =     case tp of @@ -119,59 +159,48 @@ decodeDefault :: MonadPlus m => Decoder m s a -> Type a t -> s -> m (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)-      Triple t1 t2 t3 -> do-         (a, s1) <- decodeType dec t1 s-         (b, s2) <- decodeType dec t2 s1-         (c, s3) <- decodeType dec t3 s2-         return ((a, b, c), s3)-      Quadruple t1 t2 t3 t4 -> do-         (a, s1) <- decodeType dec t1 s-         (b, s2) <- decodeType dec t2 s1-         (c, s3) <- decodeType dec t3 s2-         (d, s4) <- decodeType dec t4 s3-         return ((a, b, c, d), s4)       Tag _ t1 ->          decodeType dec t1 s       Optional a t1 ->           decodeType dec t1 s `mplus` return (a, s)       Maybe t1 ->           liftM (first Just) (decodeType dec t1 s) `mplus` return (Nothing, s)+      Error t -> +         liftM (first Right) (decodeType dec t s)+      Exercise -> do+         return (exercise (decoderPackage dec), s)+      ExerciseText -> do+         exText <- case getExerciseText (decoderPackage dec) of +                      Just a  -> return a+                      Nothing -> fail "No support for exercise texts"+         return (exText, s)       _ ->          fail $ "No support for argument type: " ++ show tp  encodeDefault :: Monad m => Encoder m s a -> Type a t -> t -> m 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])-      Triple t1 t2 t3 -> do-         let (a, b, c) = tv-         x <- encodeType enc t1 a-         y <- encodeType enc t2 b-         z <- encodeType enc t3 c-         return (encodeTuple enc [x, y, z])-      Quadruple t1 t2 t3 t4 -> do-         let (a, b, c, d) = tv-         x <- encodeType enc t1 a-         y <- encodeType enc t2 b-         z <- encodeType enc t3 c-         u <- encodeType enc t4 d-         return (encodeTuple enc [x, y, z, u])       Tag _ t1      -> encodeType enc t1 tv       Elem t1       -> encodeType enc t1 tv       Optional _ t1 -> encodeType enc t1 tv       Maybe t1      -> case tv of                           Just a  -> encodeType enc t1 a                           Nothing -> return (encodeTuple enc [])+      Error t       -> either fail (encodeType enc t) tv       IO t1         -> encodeType enc t1 (unsafePerformIO tv)       Rule          -> encodeType enc String (name tv)-      Term          -> encodeTerm enc (fromContext tv)+      Term          -> encodeTerm enc tv+      Context       -> fromContext tv >>= encodeType enc Term       Location      -> encodeType enc String (show tv)-      _             -> fail "No support for result type"+      _             -> fail ("No support for result type: " ++ show tp)
src/Text/HTML.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -13,12 +13,14 @@ ----------------------------------------------------------------------------- module Text.HTML     ( HTML, HTMLBuilder, showHTML-   , htmlPage, errorPage, link, h1, h2, preText, ul, table, text, image, space-   , bold, italic, para, ttText, hr, br, pre, center+   , htmlPage, errorPage, link, h1, h2, h3, h4, preText, ul, table, noBorderTable+   , text, image, space, tt, spaces+   , bold, italic, para, ttText, hr, br, pre, center, bullet    ) where  import Text.XML hiding (text) import qualified Text.XML as XML+import Control.Monad  type HTML = XML @@ -58,6 +60,13 @@ h2 :: String -> HTMLBuilder h2 = element "h2" . text +h3 :: String -> HTMLBuilder+h3 = element "h3" . text++h4 :: String -> HTMLBuilder+h4 = element "h4" . text++ bold, italic :: HTMLBuilder -> HTMLBuilder bold   = element "b"  italic = element "i"@@ -91,19 +100,20 @@    "border" .=. "1"    mapM_ (element "tr" . mapM_ (element "td")) rows -space :: HTMLBuilder-space = XML.text "&nbsp;"+noBorderTable :: [[HTMLBuilder]] -> HTMLBuilder+noBorderTable rows = element "table" $ do+   "border"      .=. "0"+   mapM_ (element "tr" . mapM_ (element "td")) rows +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 . escape--escape :: String -> String-escape = concatMap f - where-   f '<'  = "&lt;"-   f '>'  = "&gt;"-   f '\n' = "<br>"-   f c   = [c] +text = XML.text
src/Text/JSON.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -17,30 +17,16 @@    , InJSON(..)                           -- type class"
    , lookupM
    , parseJSON, showCompact, showPretty   -- parser and pretty-printers
-   , jsonRPC, JSON_RPC_Handler
+   , jsonRPC, JSON_RPC_Handler, testMe
    ) where
 
 import Text.Parsing
 import qualified Text.UTF8 as UTF8
-import Common.Utils (indent)
-import Data.Char
 import Data.List (intersperse)
 import Data.Maybe
-import Control.Monad
-import Service.Revision (version, revision)
+import Control.Monad.Error
+import Test.QuickCheck
 
--- temporary test
-{-
-main :: IO ()
-main = do
-   input <- readFile "ex.json"
-   print (scan input)
-   putStrLn input
-   let Just json = parseJSON input
-   print json
-   print (parseJSON $ show json)
--}
-   
 data JSON 
    = Number  Number        -- integer, real, or floating point
    | String  String        -- double-quoted Unicode with backslash escapement
@@ -48,10 +34,11 @@    | Array   [JSON]        -- ordered sequence (comma-separated, square brackets)
    | Object  [(Key, JSON)] -- collection of key/value pairs (comma-separated, curly brackets
    | Null
+ deriving Eq
 
 type Key = String
           
-data Number = I Integer | F Float
+data Number = I Integer | D Double deriving Eq
 
 instance Show JSON where
    show = showPretty
@@ -89,7 +76,7 @@          
 instance Show Number where
    show (I n) = show n
-   show (F f) = show f
+   show (D d) = show d
 
 class InJSON a where
    toJSON       :: a -> JSON
@@ -110,9 +97,9 @@    fromJSON (Number (I n)) = return n
    fromJSON _              = fail "expecting a number"
 
-instance InJSON Float where 
-   toJSON = Number . F
-   fromJSON (Number (F n)) = return n
+instance InJSON Double where 
+   toJSON = Number . D
+   fromJSON (Number (D n)) = return n
    fromJSON _              = fail "expecting a number"
    
 instance InJSON Char where
@@ -147,15 +134,20 @@    fromJSON (Array [a, b, c, d]) = liftM4 (,,,) (fromJSON a) (fromJSON b) (fromJSON c) (fromJSON d)
    fromJSON _                    = fail "expecting an array with 4 elements"
     
-parseJSON :: String -> Maybe JSON
+parseJSON :: Monad m => String -> m JSON
 parseJSON input = 
-   case parse json (scanWith (makeCharsSpecial ":" defaultScanner) input) of 
-      (result, []) -> Just result
-      _            -> Nothing
+   case parseWith jsonScanner json input of
+      Left err -> fail (show err)
+      Right a  -> return a
  where
+   jsonScanner = specialSymbols ":" defaultScanner
+      { keywords   = ["true", "false", "null"]
+      , unaryMinus = True
+      }
+ 
    json :: TokenParser JSON
    json =  (Number . I) <$> pInteger
-       <|> (Number . F) <$> pFraction
+       <|> (Number . D) <$> pReal
        <|> (String . fromMaybe [] . UTF8.decodeM) <$> pString
        <|> Boolean True <$ pKey "true"
        <|> Boolean False <$ pKey "false"
@@ -210,7 +202,6 @@       [ ("result", responseResult resp)
       , ("error" , responseError resp)
       , ("id"    , responseId resp)
-      , ("version", String $ version ++ " (" ++ show revision ++ ")")
       ]
    fromJSON obj = do
       rj <- lookupM "result" obj
@@ -236,17 +227,76 @@ lookupM x (Object xs) = maybe (fail $ "field " ++ x ++ " not found") return (lookup x xs)
 lookupM _ _ = fail "expecting a JSON object"
 
+indent :: Int -> String -> String
+indent n = unlines . map (\s -> replicate n ' ' ++ s) . lines
+
 --------------------------------------------------------
 -- JSON-RPC over HTTP
 
-type JSON_RPC_Handler = String -> JSON -> IO JSON
+type JSON_RPC_Handler m = String -> JSON -> m JSON
 
-jsonRPC :: String -> JSON_RPC_Handler -> IO String
+jsonRPC :: (MonadError a m, InJSON a) 
+        => JSON -> JSON_RPC_Handler m -> m JSON_RPC_Response
 jsonRPC input handler = 
-         case parseJSON input >>= fromJSON of 
-            Nothing   -> fail "Invalid request"
-            Just req -> do 
-               json <- handler (requestMethod req) (requestParams req)
-               return $ show $ okResponse json (requestId req)
-             `catch` \e ->
-               return $ show $ errorResponse (String (show e)) (requestId req)
+   case fromJSON input of 
+      Nothing  -> return (errorResponse (String "Invalid request") Null)
+      Just req -> do
+         json <- handler (requestMethod req) (requestParams req)
+         return (okResponse json (requestId req))
+       `catchError` \msg ->
+          return (errorResponse (toJSON msg) (requestId req))
+
+--------------------------------------------------------
+-- Testing parser/pretty-printer
+
+instance Arbitrary JSON where
+   arbitrary = sized arbJSON
+
+instance CoArbitrary JSON where
+   coarbitrary json = 
+      case json of
+         Number a  -> variant 0 . coarbitrary a
+         String s  -> variant 1 . coarbitrary s
+         Boolean b -> variant 2 . coarbitrary b
+         Array xs  -> variant 3 . coarbitrary xs
+         Object xs -> variant 4 . coarbitrary xs
+         Null      -> variant 5
+
+instance Arbitrary Number where
+   arbitrary = oneof [liftM I arbitrary, liftM (D . fromInteger) arbitrary]
+instance CoArbitrary Number where
+   coarbitrary (I n) = variant 0 . coarbitrary n
+   coarbitrary (D d) = variant 1 . coarbitrary d
+
+arbJSON :: Int -> Gen JSON
+arbJSON n 
+   | n == 0 = oneof 
+        [ liftM Number arbitrary, liftM String myStringGen
+        , liftM Boolean arbitrary, return Null
+        ]
+   | otherwise = oneof
+        [ arbJSON 0
+        , do i  <- choose (0, 6)
+             xs <- replicateM i rec
+             return (Array xs)
+        , do i  <- choose (0, 6)
+             xs <- replicateM i myStringGen
+             ys <- replicateM i rec
+             return (Object (zip xs ys))
+        ]
+ where
+   rec = arbJSON (n `div` 2)
+   
+myStringGen :: Gen String
+myStringGen = do 
+   n <- choose (1, 10)
+   replicateM n $ oneof $ map return $ 
+      ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9']
+   
+testMe :: IO ()
+testMe = do 
+   putStrLn "** JSON encoding"
+   quickCheck prop
+ where
+   prop :: JSON -> Bool
+   prop a = parseJSON (show a) == Just a
src/Text/OpenMath/ContentDictionary.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -18,6 +18,7 @@    ) where
 
 import Text.OpenMath.Object (OMOBJ, xml2omobj)
+import Text.Scanning (scanInt, Pos(..))
 import Text.XML
 import Data.Char
 import Data.List
@@ -108,21 +109,22 @@       _ -> fail ("invalid date (YYYY-MM-DD): " ++ txt)
 
 extractInt :: String -> XML -> Either String Int
-extractInt s xml = do
+extractInt s xml = do 
    txt <- extractText s xml
-   case reads txt of 
-      [(n, xs)] | all isSpace xs -> 
-         return n
-      _ -> fail ("invalid number" ++ txt)
+   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
-   case reads (map toUpper hd ++ map toLower tl) of
-      [(st, xs)] | all isSpace xs -> 
-         return st
-      _ -> fail ("invalid status: " ++ 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
@@ -145,7 +147,8 @@ type VersionNumber = (Int, Int) -- major and minor part
 type Date = (Int, Int, Int) -- YYYY-MM-DD
 
-data ContentDictionaryStatus = Official | Experimental | Private | Obsolete deriving (Read,Show)
+data ContentDictionaryStatus = Official | Experimental | Private | Obsolete 
+   deriving Show
 
 data Definition = Definition 
    { symbolName          :: String
@@ -154,4 +157,5 @@    , commentedProperties :: [String]
    , formalProperties    :: [OMOBJ]
    , examples            :: [[XML]]
-   } deriving Show+   } 
+ deriving Show
+ src/Text/OpenMath/Dictionary/Quant1.hs view
@@ -0,0 +1,23 @@+-- Automatically generated from content dictionary quant1.ocd.  Do not change.
+module Text.OpenMath.Dictionary.Quant1 where
+
+import Text.OpenMath.Symbol
+
+-- | List of symbols defined in quant1 dictionary
+quant1List :: [Symbol]
+quant1List = [forallSymbol, existsSymbol]
+
+{-| This symbol represents the universal ("for all") quantifier which takes
+two arguments. It must be placed within an OMBIND element. The first argument
+is the bound variables (placed within an OMBVAR element), and the second is an
+expression. -}
+forallSymbol :: Symbol
+forallSymbol = makeSymbol "quant1" "forall"
+
+{-| This symbol represents the existential ("there exists") quantifier which
+takes two arguments. It must be placed within an OMBIND element. The first
+argument is the bound variables (placed within an OMBVAR element), and the
+second is an expression. -}
+existsSymbol :: Symbol
+existsSymbol = makeSymbol "quant1" "exists"
+
+ src/Text/OpenMath/FMP.hs view
@@ -0,0 +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+   }
src/Text/OpenMath/MakeSymbols.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Text/OpenMath/Object.hs view
@@ -1,5 +1,6 @@+{-# OPTIONS -XDeriveDataTypeable #-}
 -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -10,27 +11,38 @@ --
 -----------------------------------------------------------------------------
 module Text.OpenMath.Object 
-   ( OMOBJ(..), xml2omobj, omobj2xml
+   ( OMOBJ(..), getOMVs, xml2omobj, omobj2xml
    ) where
 
-import Text.XML
 import Data.Char (isSpace)
+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 Float 
+           | OMF Double 
            | OMV String 
            | OMS Symbol 
            | OMA [OMOBJ] 
            | OMBIND OMOBJ [String] OMOBJ
-   deriving (Show, Eq)
+   deriving (Show, Eq, Typeable)
 
 instance InXML OMOBJ where
    toXML   = omobj2xml
    fromXML = either fail return . xml2omobj
 
+getOMVs :: OMOBJ -> [String]
+getOMVs = nub . rec
+ where
+   rec (OMA xs)       = concatMap rec xs
+   rec (OMBIND q _ b) = rec q ++ rec b
+   rec (OMV s)        = [s]
+   rec _              = []
+
 ----------------------------------------------------------
 -- conversion functions: XML <-> OMOBJ
    
@@ -53,15 +65,17 @@             return (OMS (Symbol mcd name))
 
          [Left s] | name xml == "OMI" ->
-            case reads s of
-               [(i, xs)] | all isSpace xs -> return (OMI i)
-               _ -> fail "invalid integer in OMI"
+            case scanInt (Pos 0 0) s of
+               Just (i, _, rest) | all isSpace rest
+                  -> return (OMI (toInteger i))
+               _  -> fail "invalid integer in OMI"
          
          [] | name xml == "OMF" -> do
             s <- findAttribute "dec" xml 
-            case reads s of
-               [(fp, xs)] | all isSpace xs -> return (OMF fp)
-               _ -> fail "invalid floating-point in OMF"
+            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"
                     
          [] | name xml == "OMV" -> do
             s <- findAttribute "name" xml
@@ -81,7 +95,7 @@                f this = fail $ "expected tag OMV in OMBVAR, but found " ++ show this
            in mapM (f . rec) (children xml)
       | otherwise = 
-           fail ("expected tag OMVAR, but found " ++ show tag)
+           fail ("expected tag OMVAR, but found " ++ show (name xml))
    
 omobj2xml :: OMOBJ -> XML
 omobj2xml object = makeXML "OMOBJ" $ do
− src/Text/OpenMath/Reply.hs 
@@ -1,102 +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 Text.OpenMath.Reply 
-   ( Reply(..), replyToXML, replyInXML
-   , ReplyOk(..), ReplyIncorrect(..), ReplyError(..), Args
-   ) where
-
-import Control.Monad
-import Common.Exercise
-import Common.Strategy hiding (not)
-import Domain.Math.Expr
-import Text.OpenMath.Object
-import Text.XML
-import Service.Revision
-
-------------------------------------------------------------------------
--- Data types for replies
-
--- There are three possible replies: ok, incorrect, or an error in the protocol (e.g., a parse error)
-data Reply a = Ok (ReplyOk a) | Incorrect (ReplyIncorrect a) | Error ReplyError
-
-data ReplyOk a = ReplyOk
-   { repOk_Code     :: Exercise a
-   , repOk_Location :: StrategyLocation
-   , repOk_Context  :: String
-   , repOk_Steps    :: Int
-   }
-   
-data ReplyIncorrect a = ReplyIncorrect
-   { repInc_Code       :: Exercise a
-   , repInc_Location   :: StrategyLocation
-   , repInc_Expected   :: a
-   , repInc_Derivation :: [(String, a)]
-   , repInc_Arguments  :: Args
-   , repInc_Steps      :: Int
-   , repInc_Equivalent :: Bool
-   }
- 
-data ReplyError = ReplyError
-   { repErr_Kind    :: String
-   , repErr_Message :: String
-   }
-
-type Args = [(String, String)]
-
-------------------------------------------------------------------------
--- Conversion functions to XML
- 
-replyInXML :: IsExpr a => Reply a -> String
-replyInXML = showXML . replyToXML
-
-replyToXML :: IsExpr a => Reply a -> XML
-replyToXML reply =
-   case reply of
-      Ok r        -> replyOkToXML r
-      Incorrect r -> replyIncorrectToXML r 
-      Error r     -> replyErrorToXML r
-
-replyOkToXML :: ReplyOk a -> XML
-replyOkToXML r = makeReply "ok" $ do
-   element "strategy" (text $ show $ exerciseCode $ repOk_Code r)
-   element "location" (text $ show $ repOk_Location r)
-   element "context"  (text $ repOk_Context r)
-   element "steps"    (text $ show $ repOk_Steps r)
-
-replyIncorrectToXML :: IsExpr a => ReplyIncorrect a -> XML
-replyIncorrectToXML r = makeReply "incorrect" $ do
-   element "strategy"   (text $ show $ exerciseCode $ repInc_Code r)
-   element "location"   (text $ show $ repInc_Location r)
-   element "expected"   (builder $ omobj2xml $ toOMOBJ $ toExpr $ repInc_Expected r)
-   element "steps"      (text $ show $ repInc_Steps r)
-   element "equivalent" (text $ show $ repInc_Equivalent r)
-   
-   unless (null $ repInc_Arguments r) $
-       let f (x, y) = element "elem" $ do 
-              "descr" .=. x 
-              text y
-       in element "arguments" $ mapM_ f (repInc_Arguments r)
-
-   unless (null $  repInc_Derivation r) $
-      let f (x,y) = element "elem" $ do 
-             "ruleid" .=. x 
-             builder (omobj2xml (toOMOBJ (toExpr y)))
-      in element "derivation" $ mapM_ f (repInc_Derivation r)
-
-replyErrorToXML :: ReplyError -> XML
-replyErrorToXML r = makeReply (repErr_Kind r) (text $ repErr_Message r)
-   
-makeReply :: String -> XMLBuilder -> XML
-makeReply kind body = makeXML "reply" $ do
-   "result"  .=. kind
-   "version" .=. version
-   body
− src/Text/OpenMath/Request.hs 
@@ -1,86 +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 Text.OpenMath.Request (xmlToRequest) where
-
-import Service.TypedAbstractService
-import Text.XML
-import Control.Monad
-import Common.Context
-import Common.Exercise
-import Common.Strategy hiding (fail)
-import Common.Utils (splitAtElem)
-import Text.OpenMath.Object
-import Data.Char
-import Data.Maybe
-import Domain.Math.Expr
-
-extractString :: String -> XML -> Either String String
-extractString s = liftM getData . findChild s
-
-xmlToRequest :: IsExpr a => XML -> Exercise a -> Either String (State a, StrategyLocation, Maybe a)
-xmlToRequest xml ex = do
-   unless (name xml == "request") $
-      fail "XML document is not a request" 
-   loc     <- optional (extractLocation "location" xml)
-   term    <- extractExpr "term" xml
-   context <- optional (extractString "context" xml)
-   answer  <- optional (extractExpr "answer" xml)
-   t  <- fromExpr $ fromOMOBJ term
-   mt <- case answer of
-            Nothing -> return Nothing 
-            Just o  -> return $ fromExpr $ fromOMOBJ o
-   return
-      ( State
-           { exercise = ex
-           , prefix   = case context of
-                           Just s  -> Just $ getPrefix2 s (strategy ex)
-                           Nothing -> Just $ emptyPrefix (strategy ex)
-           , context  = case context of 
-                           Just s  -> putInContext2 s t
-                           Nothing -> inContext t
-           }
-      , fromMaybe [] loc
-      , mt
-      )
-
------------------------------------------------------------
-putInContext2 :: String -> a -> Context a
-putInContext2 s = fromMaybe inContext $ do
-   (_, s2) <- splitAtElem ';' s
-   c       <- parseContext s2
-   return (flip fmap c . const)
-
-getPrefix2 :: String -> LabeledStrategy (Context a) -> Prefix (Context a)
-getPrefix2 s ls = fromMaybe (emptyPrefix ls) $ do
-   (s1, _) <- splitAtElem ';' s
-   case reads s1 of
-      [(is, xs)] | all isSpace xs -> return (makePrefix is ls)
-      _ -> Nothing 
-
-optional :: Either String a -> Either String (Maybe a)
-optional = Right . either (const Nothing) Just
-
-extractLocation :: String -> XML -> Either String StrategyLocation
-extractLocation s xml = do
-   c <- findChild s xml
-   case reads (getData c) of
-      [(n, xs)] | all isSpace xs -> return n
-      _                          -> fail "invalid location"
-
-extractExpr :: String -> XML -> Either String OMOBJ
-extractExpr n xml =
-   case findChild n xml of 
-      Just expr -> 
-         case children expr of 
-            [this] -> xml2omobj this
-            _ -> fail $ "error in " ++ show (n, xml)
-      _ -> fail $ "error in " ++ show (n, xml)
src/Text/OpenMath/Symbol.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -19,7 +19,13 @@  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
src/Text/Parsing.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
 -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -9,121 +9,32 @@ -- Stability   :  provisional
 -- Portability :  portable (depends on ghc)
 --
--- A simplified interface to the UU.Parsing and UU.Scanner libraries. This module
--- provides some additional functionality to determine valid sub-expressions.
+-- A simplified interface to the UU.Parsing library.
 --
 -----------------------------------------------------------------------------
 module Text.Parsing 
    ( -- * Scaning
-     Scanner(..), defaultScanner, makeCharsSpecial, newlinesAsSpecial, minusAsSpecial, scan, scanWith, UU.Token
+     module Text.Scanning
      -- * Parsing
-   , Parser, CharParser, TokenParser, parse, Message
+   , 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
    , pChainl, pChainr, pChoice, pFail
-     -- * Subexpressions
-   , Ranged, Range(..), Pos(..), toRanged, fromRanged, subExpressionAt
-   , pKey, pSpec, pVarid, pConid, unaryOp, binaryOp, pParens, indicesToRange
-   , pInteger, pFraction, pString, pBracks, pCurly, pCommas, pLines
     -- * Operator table (parser)
    , OperatorTable, Associativity(..), pOperators
-    -- * Analyzing parentheses
-   , SyntaxError(..), fromMessage, errorToPositions
-   , checkParentheses, showTokenPos, tokenNoPosition
-   , toPosition, tokenText
    ) where
 
-import qualified UU.Parsing as UU
-import qualified UU.Scanner as UU
-import qualified UU.Scanner.GenToken as UU
-import Control.Arrow
-import Common.Utils
-import Data.Char
-import Data.List
 import Data.Maybe
+import Text.Scanning
+import qualified UU.Parsing as UU
 
 ----------------------------------------------------------
--- Scaning
-
--- | Data type to configure a scanner
-data Scanner = Scanner
-   { fileName           :: Maybe String
-   , keywords           :: [String]
-   , keywordOperators   :: [String]
-   , specialCharacters  :: String
-   , operatorCharacters :: String
-   }
-
--- | A default scanner configuration (using Haskell's special characters)
-defaultScanner :: Scanner
-defaultScanner = Scanner
-   { fileName           = Nothing
-   , keywords           = []
-   , keywordOperators   = []
-   , specialCharacters  = "(),;[]`{}"              -- Haskell's special characters 
-   , operatorCharacters = "!#$%&*+./<=>?@\\^|-~"   -- The non-special characters      
-   }
-
--- | Add characters to the list of special characters (and remove these from the list of operator characters)
-makeCharsSpecial :: String -> Scanner -> Scanner
-makeCharsSpecial cs scanner = scanner
-   { specialCharacters  = specialCharacters scanner `union` cs
-   , operatorCharacters = operatorCharacters scanner \\ cs
-   }
-
--- Newline characters are mapped to "special" tokens
--- The current solution to deal with newlines is a hack: all characters '\n' in the input
--- are first mapped to '\001', and later the tokens are adapted
-newlinesAsSpecial :: Scanner -> Scanner
-newlinesAsSpecial = makeCharsSpecial [specialNewlinesChar]
-
-specialNewlinesChar :: Char
-specialNewlinesChar = chr 1
-
--- Minus characters are mapped to "special" tokens
--- The current solution to deal with minus is a hack: all characters '-' in the input
--- are first mapped to '\002', and later the tokens are adapted 
--- (since the scanner considers -- to be comment)
-minusAsSpecial :: Scanner -> Scanner
-minusAsSpecial = makeCharsSpecial [specialMinusChar]
-
-specialMinusChar :: Char
-specialMinusChar = chr 2
-
--- | Scan an input string with the default scanner configuration
-scan :: String -> [UU.Token]
-scan = scanWith defaultScanner
-
--- | Scan an input string with the given scanner configuration
-scanWith :: Scanner -> String -> [UU.Token]
-scanWith scanner = post . uuScan . pre
- where
-   -- very special characters
-   special = or [specialNewlines, specialMinus]
-   specialNewlines = specialNewlinesChar `elem` specialCharacters scanner
-   specialMinus    = specialMinusChar    `elem` specialCharacters scanner
-   
-   pre    = if special then map changeChar  else id
-   post   = if special then map changeToken else id
-   pos    = UU.initPos $ fromMaybe "" (fileName scanner)
-   uuScan = UU.scan (keywords scanner) (keywordOperators scanner) 
-               (specialCharacters scanner) (operatorCharacters scanner) pos
-   
-   changeChar :: Char -> Char
-   changeChar c
-      | c == '\n' && specialNewlines = specialNewlinesChar
-      | c == '-'  && specialMinus    = specialMinusChar
-      | otherwise                    = c
-   
-   changeToken :: UU.Token -> UU.Token
-   changeToken t =
-      case t of
-         UU.Reserved [c] pos 
-            | c == specialNewlinesChar && specialNewlines -> UU.Reserved "\n" pos
-            | c == specialMinusChar    && specialMinus    -> UU.Reserved "-"  pos
-         _ -> t
-                      
-----------------------------------------------------------
 -- Parsing
 
 -- | Abstract data type for a parser, where @s@ is the symbol type, and @a@ is 
@@ -135,8 +46,10 @@ type CharParser  = Parser Char
 
 -- | A parser with tokens as symbol type
-type TokenParser = Parser UU.Token
+type TokenParser = Parser Token
 
+instance UU.Symbol Token
+
 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)
@@ -156,19 +69,97 @@    getzerop            = fmap P . UU.getzerop . unP
    getonep             = fmap P . UU.getonep  . unP 
 
-type Message s = (UU.Expecting s, Maybe s)
-
--- Parsing an input string always returns a result and a list of error messages
-parse :: UU.Symbol s => Parser s a -> [s] -> (a, [Message s])
-parse (P p) input = (result, map f messages)
+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 
  where
    steps    = UU.parse p input
-   result   = fstPair (UU.evalSteps steps)
    messages = UU.getMsgs steps
-   fstPair (UU.Pair a _) = a
-   f (UU.Msg a b _) = (a, b)
+   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   = makeTokN isTokenReal   TokenReal
+pKey    = makeTokA TokenKeyword 
+pSpec   = makeTokA TokenSpecial
+
+-- helpers
+makeTokS f con = makeTok f "" (con minString) (con maxString)
+makeTokT f con = makeTok f ("","") (con minString minString) (con maxString maxString)
+makeTokN f con = makeTok f 0 (con minBound) (con maxBound)
+makeTokA con a = makeTok (const Nothing) a (con a) (con a)
+
+makeTok f a con1 con2 = 
+   (fromMaybe a . 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
+
+minDouble, maxDouble :: Double
+minDouble = -(10^500) -- -Infinity
+maxDouble = 10^500    -- Infinity
+
+instance Bounded Double where
+   minBound = minDouble
+   maxBound = maxDouble
+
+----------------------------------------------------------
+-- 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)) []
+
+-- | 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 
+ 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 <|>
@@ -210,131 +201,6 @@ pFail = UU.pFail
 
 ----------------------------------------------------------
--- Subexpressions
-
--- | Abstract data type for expressions that ''know'' about the ranges of their 
--- subexpressions
-data Ranged a = Ranged 
-   { fromRanged :: a           -- ^ Forget about the subexpressions
-   , getRange   :: Range
-   , special    :: Bool
-   , children   :: [Ranged a]
-   } 
-
-instance Show a => Show (Ranged a) where
-   show = show . fromRanged
-
--- | Data type for ranges
-data Range = Range
-   { beginPos :: Pos
-   , endPos   :: Pos
-   }
- deriving (Show, Eq, Ord)
-
--- | Data type for positions
-data Pos = Pos
-   { line   :: Int
-   , column :: Int
-   }
- deriving (Show, Eq, Ord)
-
--- | A value without subexpressions
-toRanged :: a -> Range -> Ranged a
-toRanged a r = Ranged a r False []
-
--- | Given a selection (range) and a ranged term, return the location of the selected 
--- subexpression (or Nothing to indicate that the selection is invalid)
-subExpressionAt :: Range -> Ranged a -> Maybe [Int]
-subExpressionAt r ra
-   | r == getRange ra = return []
-   | otherwise = 
-        let f i | special ra = id
-                | otherwise  = (i:)
-        in safeHead $ catMaybes
-              [ fmap (f i) (subExpressionAt r c) | (i, c) <- zip [0..] (children ra) ]
-
-pKey :: String -> TokenParser Range
-pKey  s = toRange 1 <$> UU.pKeyPos  s
-
-pSpec :: Char -> TokenParser Range
-pSpec c = toRange 1 <$> UU.pSpecPos c
-
-pVarid, pConid :: TokenParser (String, Range)
-pVarid = second (toRange 1) <$> UU.pVaridPos
-pConid = second (toRange 1) <$> UU.pConidPos
-   
-unaryOp :: (a -> a) -> Range -> Ranged a -> Ranged a
-unaryOp f r1 r2 = Ranged (f $ fromRanged r2) (r1 & getRange r2) False [r2]
-
-binaryOp :: (a -> a -> a) -> Ranged a -> Ranged a -> Ranged a       
-binaryOp f r1 r2 = Ranged (f (fromRanged r1) (fromRanged r2)) (getRange r1 & getRange r2) False [r1, r2]
-
-pParens :: TokenParser (Ranged a) -> TokenParser (Ranged a)
-pParens p = (\p1 r p2 -> Ranged (fromRanged r) (toRange 1 p1 & toRange 1 p2) True [r]) <$> UU.pOParenPos <*> p <*> UU.pCParenPos
-
--- TODO: fix inconsistency with pParens
-pBracks :: TokenParser a -> TokenParser a
-pBracks  = UU.pBracks
-
--- | 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 
- where
-   pOne | allowEmptyLine = optional (Just <$> p) Nothing
-        | otherwise      = Just <$> p
-   pn = (:) <$> pOne <*> pList (pSpec '\n' *> pOne)
-
--- TODO: fix inconsistency with pParens
-pCurly :: TokenParser a -> TokenParser a
-pCurly   = UU.pCurly
-
-pInteger :: TokenParser Integer
-pInteger = (maybe 0 fromIntegral . readInt) <$> UU.pInteger
-
-pFraction :: TokenParser Float
-pFraction = read <$> UU.pFraction
-
-pString :: TokenParser String
-pString = UU.pString
-
-pCommas :: TokenParser a -> TokenParser [a]
-pCommas = UU.pCommas
-
--- | Helper function to translate two indices on a string to a range: the positions of a range are line-based
-indicesToRange :: String -> Int -> Int -> Range
-indicesToRange s i j = Range (indexToPos s a) (indexToPos s b) 
- where (a, b) = trimIndexPair s i j
-
--- local helper functions
-(&) :: Range -> Range -> Range
-Range p1 p2 & Range p3 p4 = Range (p1 `min` p3) (p2 `max` p4)
-
-toPos :: UU.Pos -> Pos
-toPos p = Pos (UU.line p) (UU.column p)
-
-toRange :: Int -> UU.Pos -> Range
-toRange n p = Range (toPos p) (toPos (UU.advc n p))
-
-indexToPos :: String -> Int -> Pos
-indexToPos = rec . zip [1..] . lines
- where
-   rec [] _ = Pos 0 0
-   rec ((lnr, x):rest) i
-      | i <= len  = Pos lnr (i+1)
-      | otherwise = rec rest (i-len-1)
-    where
-      len = length x
-
-trimIndexPair :: String -> Int -> Int -> (Int, Int)
-trimIndexPair s i j 
-   | j < i     = trimIndexPair s j i
-   | otherwise = (i + f sub, j - f (reverse sub))
- where 
-    sub = take (j-i) (drop i s)
-    f   = length . takeWhile isSpace
-
-----------------------------------------------------------
 -- Operator table (parser)
 
 -- | Type for an operator table. Operators with a low priority should appear in the front of the list.
@@ -345,7 +211,7 @@ data Associativity = LeftAssociative | RightAssociative | NonAssociative | NoMix
 
 -- | Construct a parser using an operator table
-pOperators :: OperatorTable a -> TokenParser (Ranged a) -> TokenParser (Ranged a)
+pOperators :: OperatorTable a -> TokenParser a -> TokenParser a
 pOperators table p = foldr op p table 
  where op (a, ops) q = 
           case a of
@@ -355,7 +221,7 @@              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) = binaryOp g <$ pKey s
+       f (s, g) = g <$ pKey s
 
 
 -- local helper function
@@ -364,85 +230,4 @@                   LeftAssociative  -> pChainl p q
                   RightAssociative -> pChainr p q
                   NonAssociative   -> flip ($) <$> q <*> p <*> q
-                  NoMix            -> pChainr p q
-
------------------------------------------------------------
---- Syntax errors
-
-data SyntaxError 
-   = Unexpected UU.Token
-   | ParNotClosed UU.Token 
-   | ParNoOpen UU.Token 
-   | ParMismatch UU.Token UU.Token
-   | ErrorMessage String
-
-instance Show SyntaxError where
-   show err = 
-      case err of
-         Unexpected t      -> "Unexpected " ++ show (tokenNoPosition t) 
-         ParNotClosed t    -> "Opening parenthesis " ++ show (tokenNoPosition t) ++ " is not closed"
-         ParNoOpen t       -> "Closing parenthesis " ++ show (tokenNoPosition t) ++ " has no matching symbol"
-         ParMismatch t1 t2 -> "Opening parenthesis " ++ show (tokenNoPosition t1) ++ " is closed with " ++ show (tokenNoPosition t2)
-         ErrorMessage msg  -> msg
-
-fromMessage :: Message UU.Token -> SyntaxError
-fromMessage (_, Just t) = Unexpected t
-fromMessage _           = ErrorMessage "Syntax error"
-
-errorToPositions :: SyntaxError -> [(Int, Int)]
-errorToPositions err = 
-   case err of
-      Unexpected t      -> [toPosition t]
-      ParNotClosed t    -> [toPosition t]
-      ParNoOpen t       -> [toPosition t]
-      ParMismatch t1 t2 -> [toPosition t1, toPosition t2]
-      ErrorMessage _    -> []
-
------------------------------------------------------------
---- Analyzing parentheses
-
-tokenText :: UU.Token -> String
-tokenText (UU.Reserved s _)   = "symbol " ++ s
-tokenText (UU.ValToken s v _) = show s ++ " " ++ v
-
-showTokenPos :: UU.Token -> String
-showTokenPos (UU.Reserved _ p)   = showPosition p
-showTokenPos (UU.ValToken _ _ p) = showPosition p
-
-toPosition :: UU.Token -> (Int, Int)
-toPosition (UU.Reserved _ p)   = (UU.line p, UU.column p)
-toPosition (UU.ValToken _ _ p) = (UU.line p, UU.column p)
-
-showPosition :: UU.Position a => a -> String
-showPosition p = show (UU.line p, UU.column p)
-
-tokenNoPosition :: UU.Token -> UU.Token
-tokenNoPosition (UU.Reserved a _)   = UU.Reserved a UU.noPos
-tokenNoPosition (UU.ValToken a b _) = UU.ValToken a b UU.noPos
-
-checkParentheses :: [UU.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 :: UU.Token -> Bool
-isOpening (UU.Reserved ("(") _) = True
-isOpening _ = False
-isClosing (UU.Reserved (")") _) = True
-isClosing _ = False
-            
-match :: UU.Token -> UU.Token -> Bool
-match (UU.Reserved ("(") _) (UU.Reserved (")") _) = True
-match _ _ = False
+                  NoMix            -> pChainr p q
+ src/Text/Scanning.hs view
@@ -0,0 +1,363 @@+-----------------------------------------------------------------------------+-- 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++----------------------------------------------------------+-- * 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 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"+      | isNumber 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++   isNumber :: String -> Bool+   isNumber ('-':x:_) = isDigit x && unaryMinus scanner+   isNumber (x:_)     = isDigit x+   isNumber _         = False++scanIdentifier :: Scanner -> String -> Maybe (Maybe String, String, String)+scanIdentifier scanner (x:rest) | isAlpha x = +   case break (not . isIdentifierCharacter scanner) rest of+      (xs, '.':y:rest2) | qualifiedIdentifiers scanner && isAlpha y -> +         let (ys, zs) = break (not . 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 == 'e' || s == 'E' = 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) = break (not . 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,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Text/XML.hs view
@@ -1,5 +1,5 @@ -----------------------------------------------------------------------------
--- Copyright 2009, Open Universiteit Nederland. This file is distributed 
+-- 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.
 -----------------------------------------------------------------------------
@@ -14,18 +14,15 @@ -----------------------------------------------------------------------------
 module Text.XML
    ( XML, Attr, AttrList, InXML(..), Element(..)
-   , XMLBuilder, makeXML, text, element, tag, attribute
+   , XMLBuilder, makeXML, text, unescaped, element, tag, attribute
    , parseXML, showXML, compactXML, (.=.), findAttribute
-   , children, Attribute(..), builder, findChild, getData {-, extract, extractText -}
-   , {- isText, isTag, mkTag mkText , findChild-}
+   , children, Attribute(..), builder, findChild, getData
    ) where
 
-import Common.Utils (trim)
-import Control.Monad.State
 import Control.Monad.Error ()
-import Data.Char
-import Data.List
+import Control.Monad.State
 import Data.Monoid
+import Text.XML.Document (trim)
 import Text.XML.Interface hiding (parseXML)
 import qualified Text.XML.Interface as I
 
@@ -112,8 +109,13 @@    in Element s (bsAttributes bs []) (bsElements bs [])
 
 text :: String -> XMLBuilder
-text = XMLBuilder . modify . appendElemBS . Left
+text = unescaped . escape
 
+-- Should be used with care: the argument String is not escaped, and
+-- therefore may contain xml tags or xml entities
+unescaped :: String -> XMLBuilder
+unescaped = XMLBuilder . modify . appendElemBS . Left
+
 element :: String -> XMLBuilder -> XMLBuilder
 element s = XMLBuilder . modify . appendElemBS . Right . makeXML s
 
@@ -128,6 +130,14 @@ 
 builder :: Element -> XMLBuilder
 builder = XMLBuilder . modify . appendElemBS . Right
+
+escape :: String -> String
+escape = concatMap f
+ where
+   f '<' = "&lt;"
+   f '>' = "&gt;"
+   f '&' = "&amp;"
+   f c   = [c]
 
 ----------------------------------------------------------------
 -- XML utility functions
src/Text/XML/Document.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -243,6 +243,9 @@  parenthesize :: String -> String parenthesize s = "(" ++ s ++ ")"++trim :: String -> String+trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse  ---------------------------------------------------
src/Text/XML/Interface.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -13,6 +13,7 @@ ----------------------------------------------------------------------------- module Text.XML.Interface where +import Control.Arrow import Text.XML.Document (Name) import Text.XML.Unicode (decoding) import Text.XML.Parser (document, extParsedEnt)@@ -65,14 +66,17 @@    refToContent (D.EntityRef s) =        case lookup s entities of          Just c  -> c-         Nothing -> [] -- error+         Nothing -> undefined -- [] -- error     entities :: [(String, Content)]    entities = -      [ (n, toContent (snd ext)) | (n, ext) <- D.externals doc ]+      [ (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) = Left (s++t) : merge rest+   merge (Left s:Left t:rest) = merge (Left (s++t) : rest)    merge (x:xs) = x:merge xs    merge []     = []
src/Text/XML/ParseLib.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Text/XML/Parser.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------
src/Text/XML/TestSuite.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------@@ -15,7 +15,7 @@ module Main (main) where  import Text.XML.Interface-import Common.Utils (trim)+import Text.XML.Document (trim) import Control.Monad.Error import Data.List import Data.Maybe
src/Text/XML/Unicode.hs view
@@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- Copyright 2009, Open Universiteit Nederland. This file is distributed +-- 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. -----------------------------------------------------------------------------